1 /* OpenMP directive matching and resolving.
2 Copyright (C) 2005-2018 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
->grainsize
);
80 gfc_free_expr (c
->hint
);
81 gfc_free_expr (c
->num_tasks
);
82 gfc_free_expr (c
->priority
);
83 for (i
= 0; i
< OMP_IF_LAST
; i
++)
84 gfc_free_expr (c
->if_exprs
[i
]);
85 gfc_free_expr (c
->async_expr
);
86 gfc_free_expr (c
->gang_num_expr
);
87 gfc_free_expr (c
->gang_static_expr
);
88 gfc_free_expr (c
->worker_expr
);
89 gfc_free_expr (c
->vector_expr
);
90 gfc_free_expr (c
->num_gangs_expr
);
91 gfc_free_expr (c
->num_workers_expr
);
92 gfc_free_expr (c
->vector_length_expr
);
93 for (i
= 0; i
< OMP_LIST_NUM
; i
++)
94 gfc_free_omp_namelist (c
->lists
[i
]);
95 gfc_free_expr_list (c
->wait_list
);
96 gfc_free_expr_list (c
->tile_list
);
97 free (CONST_CAST (char *, c
->critical_name
));
101 /* Free oacc_declare structures. */
104 gfc_free_oacc_declare_clauses (struct gfc_oacc_declare
*oc
)
106 struct gfc_oacc_declare
*decl
= oc
;
110 struct gfc_oacc_declare
*next
;
113 gfc_free_omp_clauses (decl
->clauses
);
120 /* Free expression list. */
122 gfc_free_expr_list (gfc_expr_list
*list
)
126 for (; list
; list
= n
)
133 /* Free an !$omp declare simd construct list. */
136 gfc_free_omp_declare_simd (gfc_omp_declare_simd
*ods
)
140 gfc_free_omp_clauses (ods
->clauses
);
146 gfc_free_omp_declare_simd_list (gfc_omp_declare_simd
*list
)
150 gfc_omp_declare_simd
*current
= list
;
152 gfc_free_omp_declare_simd (current
);
156 /* Free an !$omp declare reduction. */
159 gfc_free_omp_udr (gfc_omp_udr
*omp_udr
)
163 gfc_free_omp_udr (omp_udr
->next
);
164 gfc_free_namespace (omp_udr
->combiner_ns
);
165 if (omp_udr
->initializer_ns
)
166 gfc_free_namespace (omp_udr
->initializer_ns
);
173 gfc_find_omp_udr (gfc_namespace
*ns
, const char *name
, gfc_typespec
*ts
)
181 gfc_omp_udr
*omp_udr
;
183 st
= gfc_find_symtree (ns
->omp_udr_root
, name
);
186 for (omp_udr
= st
->n
.omp_udr
; omp_udr
; omp_udr
= omp_udr
->next
)
189 else if (gfc_compare_types (&omp_udr
->ts
, ts
))
191 if (ts
->type
== BT_CHARACTER
)
193 if (omp_udr
->ts
.u
.cl
->length
== NULL
)
195 if (ts
->u
.cl
->length
== NULL
)
197 if (gfc_compare_expr (omp_udr
->ts
.u
.cl
->length
,
206 /* Don't escape an interface block. */
207 if (ns
&& !ns
->has_import_set
208 && ns
->proc_name
&& ns
->proc_name
->attr
.if_source
== IFSRC_IFBODY
)
219 /* Match a variable/common block list and construct a namelist from it. */
222 gfc_match_omp_variable_list (const char *str
, gfc_omp_namelist
**list
,
223 bool allow_common
, bool *end_colon
= NULL
,
224 gfc_omp_namelist
***headp
= NULL
,
225 bool allow_sections
= false)
227 gfc_omp_namelist
*head
, *tail
, *p
;
228 locus old_loc
, cur_loc
;
229 char n
[GFC_MAX_SYMBOL_LEN
+1];
236 old_loc
= gfc_current_locus
;
244 cur_loc
= gfc_current_locus
;
245 m
= gfc_match_symbol (&sym
, 1);
251 if (allow_sections
&& gfc_peek_ascii_char () == '(')
253 gfc_current_locus
= cur_loc
;
254 m
= gfc_match_variable (&expr
, 0);
265 gfc_set_sym_referenced (sym
);
266 p
= gfc_get_omp_namelist ();
276 tail
->where
= cur_loc
;
287 m
= gfc_match (" / %n /", n
);
288 if (m
== MATCH_ERROR
)
293 st
= gfc_find_symtree (gfc_current_ns
->common_root
, n
);
296 gfc_error ("COMMON block /%s/ not found at %C", n
);
299 for (sym
= st
->n
.common
->head
; sym
; sym
= sym
->common_next
)
301 gfc_set_sym_referenced (sym
);
302 p
= gfc_get_omp_namelist ();
311 tail
->where
= cur_loc
;
315 if (end_colon
&& gfc_match_char (':') == MATCH_YES
)
320 if (gfc_match_char (')') == MATCH_YES
)
322 if (gfc_match_char (',') != MATCH_YES
)
327 list
= &(*list
)->next
;
335 gfc_error ("Syntax error in OpenMP variable list at %C");
338 gfc_free_omp_namelist (head
);
339 gfc_current_locus
= old_loc
;
343 /* Match a variable/procedure/common block list and construct a namelist
347 gfc_match_omp_to_link (const char *str
, gfc_omp_namelist
**list
)
349 gfc_omp_namelist
*head
, *tail
, *p
;
350 locus old_loc
, cur_loc
;
351 char n
[GFC_MAX_SYMBOL_LEN
+1];
358 old_loc
= gfc_current_locus
;
366 cur_loc
= gfc_current_locus
;
367 m
= gfc_match_symbol (&sym
, 1);
371 p
= gfc_get_omp_namelist ();
380 tail
->where
= cur_loc
;
388 m
= gfc_match (" / %n /", n
);
389 if (m
== MATCH_ERROR
)
394 st
= gfc_find_symtree (gfc_current_ns
->common_root
, n
);
397 gfc_error ("COMMON block /%s/ not found at %C", n
);
400 p
= gfc_get_omp_namelist ();
408 tail
->u
.common
= st
->n
.common
;
409 tail
->where
= cur_loc
;
412 if (gfc_match_char (')') == MATCH_YES
)
414 if (gfc_match_char (',') != MATCH_YES
)
419 list
= &(*list
)->next
;
425 gfc_error ("Syntax error in OpenMP variable list at %C");
428 gfc_free_omp_namelist (head
);
429 gfc_current_locus
= old_loc
;
433 /* Match depend(sink : ...) construct a namelist from it. */
436 gfc_match_omp_depend_sink (gfc_omp_namelist
**list
)
438 gfc_omp_namelist
*head
, *tail
, *p
;
439 locus old_loc
, cur_loc
;
444 old_loc
= gfc_current_locus
;
448 cur_loc
= gfc_current_locus
;
449 switch (gfc_match_symbol (&sym
, 1))
452 gfc_set_sym_referenced (sym
);
453 p
= gfc_get_omp_namelist ();
457 head
->u
.depend_op
= OMP_DEPEND_SINK_FIRST
;
463 tail
->u
.depend_op
= OMP_DEPEND_SINK
;
467 tail
->where
= cur_loc
;
468 if (gfc_match_char ('+') == MATCH_YES
)
470 if (gfc_match_literal_constant (&tail
->expr
, 0) != MATCH_YES
)
473 else if (gfc_match_char ('-') == MATCH_YES
)
475 if (gfc_match_literal_constant (&tail
->expr
, 0) != MATCH_YES
)
477 tail
->expr
= gfc_uminus (tail
->expr
);
486 if (gfc_match_char (')') == MATCH_YES
)
488 if (gfc_match_char (',') != MATCH_YES
)
493 list
= &(*list
)->next
;
499 gfc_error ("Syntax error in OpenMP DEPEND SINK list at %C");
502 gfc_free_omp_namelist (head
);
503 gfc_current_locus
= old_loc
;
508 match_oacc_expr_list (const char *str
, gfc_expr_list
**list
,
511 gfc_expr_list
*head
, *tail
, *p
;
518 old_loc
= gfc_current_locus
;
526 m
= gfc_match_expr (&expr
);
527 if (m
== MATCH_YES
|| allow_asterisk
)
529 p
= gfc_get_expr_list ();
539 else if (gfc_match (" *") != MATCH_YES
)
543 if (m
== MATCH_ERROR
)
548 if (gfc_match_char (')') == MATCH_YES
)
550 if (gfc_match_char (',') != MATCH_YES
)
555 list
= &(*list
)->next
;
561 gfc_error ("Syntax error in OpenACC expression list at %C");
564 gfc_free_expr_list (head
);
565 gfc_current_locus
= old_loc
;
570 match_oacc_clause_gwv (gfc_omp_clauses
*cp
, unsigned gwv
)
572 match ret
= MATCH_YES
;
574 if (gfc_match (" ( ") != MATCH_YES
)
577 if (gwv
== GOMP_DIM_GANG
)
579 /* The gang clause accepts two optional arguments, num and static.
580 The num argument may either be explicit (num: <val>) or
581 implicit without (<val> without num:). */
583 while (ret
== MATCH_YES
)
585 if (gfc_match (" static :") == MATCH_YES
)
590 cp
->gang_static
= true;
591 if (gfc_match_char ('*') == MATCH_YES
)
592 cp
->gang_static_expr
= NULL
;
593 else if (gfc_match (" %e ", &cp
->gang_static_expr
) != MATCH_YES
)
598 if (cp
->gang_num_expr
)
601 /* The 'num' argument is optional. */
602 gfc_match (" num :");
604 if (gfc_match (" %e ", &cp
->gang_num_expr
) != MATCH_YES
)
608 ret
= gfc_match (" , ");
611 else if (gwv
== GOMP_DIM_WORKER
)
613 /* The 'num' argument is optional. */
614 gfc_match (" num :");
616 if (gfc_match (" %e ", &cp
->worker_expr
) != MATCH_YES
)
619 else if (gwv
== GOMP_DIM_VECTOR
)
621 /* The 'length' argument is optional. */
622 gfc_match (" length :");
624 if (gfc_match (" %e ", &cp
->vector_expr
) != MATCH_YES
)
628 gfc_fatal_error ("Unexpected OpenACC parallelism.");
630 return gfc_match (" )");
634 gfc_match_oacc_clause_link (const char *str
, gfc_omp_namelist
**list
)
636 gfc_omp_namelist
*head
= NULL
;
637 gfc_omp_namelist
*tail
, *p
;
639 char n
[GFC_MAX_SYMBOL_LEN
+1];
644 old_loc
= gfc_current_locus
;
650 m
= gfc_match (" (");
654 m
= gfc_match_symbol (&sym
, 0);
658 if (sym
->attr
.in_common
)
660 gfc_error_now ("Variable at %C is an element of a COMMON block");
663 gfc_set_sym_referenced (sym
);
664 p
= gfc_get_omp_namelist ();
674 tail
->where
= gfc_current_locus
;
683 m
= gfc_match (" / %n /", n
);
684 if (m
== MATCH_ERROR
)
686 if (m
== MATCH_NO
|| n
[0] == '\0')
689 st
= gfc_find_symtree (gfc_current_ns
->common_root
, n
);
692 gfc_error ("COMMON block /%s/ not found at %C", n
);
696 for (sym
= st
->n
.common
->head
; sym
; sym
= sym
->common_next
)
698 gfc_set_sym_referenced (sym
);
699 p
= gfc_get_omp_namelist ();
708 tail
->where
= gfc_current_locus
;
712 if (gfc_match_char (')') == MATCH_YES
)
714 if (gfc_match_char (',') != MATCH_YES
)
718 if (gfc_match_omp_eos () != MATCH_YES
)
720 gfc_error ("Unexpected junk after !$ACC DECLARE at %C");
725 list
= &(*list
)->next
;
730 gfc_error ("Syntax error in !$ACC DECLARE list at %C");
733 gfc_current_locus
= old_loc
;
737 /* OpenMP 4.5 clauses. */
741 OMP_CLAUSE_FIRSTPRIVATE
,
742 OMP_CLAUSE_LASTPRIVATE
,
743 OMP_CLAUSE_COPYPRIVATE
,
746 OMP_CLAUSE_REDUCTION
,
748 OMP_CLAUSE_NUM_THREADS
,
755 OMP_CLAUSE_MERGEABLE
,
760 OMP_CLAUSE_NOTINBRANCH
,
761 OMP_CLAUSE_PROC_BIND
,
769 OMP_CLAUSE_NUM_TEAMS
,
770 OMP_CLAUSE_THREAD_LIMIT
,
771 OMP_CLAUSE_DIST_SCHEDULE
,
772 OMP_CLAUSE_DEFAULTMAP
,
773 OMP_CLAUSE_GRAINSIZE
,
775 OMP_CLAUSE_IS_DEVICE_PTR
,
778 OMP_CLAUSE_NUM_TASKS
,
782 OMP_CLAUSE_USE_DEVICE_PTR
,
784 /* This must come last. */
788 /* OpenACC 2.0 specific clauses. */
792 OMP_CLAUSE_NUM_GANGS
,
793 OMP_CLAUSE_NUM_WORKERS
,
794 OMP_CLAUSE_VECTOR_LENGTH
,
799 OMP_CLAUSE_PRESENT_OR_COPY
,
800 OMP_CLAUSE_PRESENT_OR_COPYIN
,
801 OMP_CLAUSE_PRESENT_OR_COPYOUT
,
802 OMP_CLAUSE_PRESENT_OR_CREATE
,
803 OMP_CLAUSE_DEVICEPTR
,
808 OMP_CLAUSE_INDEPENDENT
,
809 OMP_CLAUSE_USE_DEVICE
,
810 OMP_CLAUSE_DEVICE_RESIDENT
,
811 OMP_CLAUSE_HOST_SELF
,
816 /* This must come last. */
822 /* Customized bitset for up to 128-bits.
823 The two enums above provide bit numbers to use, and which of the
824 two enums it is determines which of the two mask fields is used.
825 Supported operations are defining a mask, like:
826 #define XXX_CLAUSES \
827 (omp_mask (OMP_CLAUSE_XXX) | OMP_CLAUSE_YYY | OMP_CLAUSE_ZZZ)
828 oring such bitsets together or removing selected bits:
829 (XXX_CLAUSES | YYY_CLAUSES) & ~(omp_mask (OMP_CLAUSE_VVV))
830 and testing individual bits:
831 if (mask & OMP_CLAUSE_UUU) */
834 const uint64_t mask1
;
835 const uint64_t mask2
;
837 inline omp_mask (omp_mask1
);
838 inline omp_mask (omp_mask2
);
839 inline omp_mask (uint64_t, uint64_t);
840 inline omp_mask
operator| (omp_mask1
) const;
841 inline omp_mask
operator| (omp_mask2
) const;
842 inline omp_mask
operator| (omp_mask
) const;
843 inline omp_mask
operator& (const omp_inv_mask
&) const;
844 inline bool operator& (omp_mask1
) const;
845 inline bool operator& (omp_mask2
) const;
846 inline omp_inv_mask
operator~ () const;
849 struct omp_inv_mask
: public omp_mask
{
850 inline omp_inv_mask (const omp_mask
&);
853 omp_mask::omp_mask () : mask1 (0), mask2 (0)
857 omp_mask::omp_mask (omp_mask1 m
) : mask1 (((uint64_t) 1) << m
), mask2 (0)
861 omp_mask::omp_mask (omp_mask2 m
) : mask1 (0), mask2 (((uint64_t) 1) << m
)
865 omp_mask::omp_mask (uint64_t m1
, uint64_t m2
) : mask1 (m1
), mask2 (m2
)
870 omp_mask::operator| (omp_mask1 m
) const
872 return omp_mask (mask1
| (((uint64_t) 1) << m
), mask2
);
876 omp_mask::operator| (omp_mask2 m
) const
878 return omp_mask (mask1
, mask2
| (((uint64_t) 1) << m
));
882 omp_mask::operator| (omp_mask m
) const
884 return omp_mask (mask1
| m
.mask1
, mask2
| m
.mask2
);
888 omp_mask::operator& (const omp_inv_mask
&m
) const
890 return omp_mask (mask1
& ~m
.mask1
, mask2
& ~m
.mask2
);
894 omp_mask::operator& (omp_mask1 m
) const
896 return (mask1
& (((uint64_t) 1) << m
)) != 0;
900 omp_mask::operator& (omp_mask2 m
) const
902 return (mask2
& (((uint64_t) 1) << m
)) != 0;
906 omp_mask::operator~ () const
908 return omp_inv_mask (*this);
911 omp_inv_mask::omp_inv_mask (const omp_mask
&m
) : omp_mask (m
)
915 /* Helper function for OpenACC and OpenMP clauses involving memory
919 gfc_match_omp_map_clause (gfc_omp_namelist
**list
, gfc_omp_map_op map_op
)
921 gfc_omp_namelist
**head
= NULL
;
922 if (gfc_match_omp_variable_list ("", list
, false, NULL
, &head
, true)
926 for (n
= *head
; n
; n
= n
->next
)
927 n
->u
.map_op
= map_op
;
934 /* Match OpenMP and OpenACC directive clauses. MASK is a bitmask of
935 clauses that are allowed for a particular directive. */
938 gfc_match_omp_clauses (gfc_omp_clauses
**cp
, const omp_mask mask
,
939 bool first
= true, bool needs_space
= true,
940 bool openacc
= false)
942 gfc_omp_clauses
*c
= gfc_get_omp_clauses ();
945 gcc_checking_assert (OMP_MASK1_LAST
<= 64 && OMP_MASK2_LAST
<= 64);
949 if ((first
|| gfc_match_char (',') != MATCH_YES
)
950 && (needs_space
&& gfc_match_space () != MATCH_YES
))
954 gfc_gobble_whitespace ();
956 gfc_omp_namelist
**head
;
957 old_loc
= gfc_current_locus
;
958 char pc
= gfc_peek_ascii_char ();
964 if ((mask
& OMP_CLAUSE_ALIGNED
)
965 && gfc_match_omp_variable_list ("aligned (",
966 &c
->lists
[OMP_LIST_ALIGNED
],
970 gfc_expr
*alignment
= NULL
;
973 if (end_colon
&& gfc_match (" %e )", &alignment
) != MATCH_YES
)
975 gfc_free_omp_namelist (*head
);
976 gfc_current_locus
= old_loc
;
980 for (n
= *head
; n
; n
= n
->next
)
981 if (n
->next
&& alignment
)
982 n
->expr
= gfc_copy_expr (alignment
);
987 if ((mask
& OMP_CLAUSE_ASYNC
)
989 && gfc_match ("async") == MATCH_YES
)
992 match m
= gfc_match (" ( %e )", &c
->async_expr
);
993 if (m
== MATCH_ERROR
)
995 gfc_current_locus
= old_loc
;
998 else if (m
== MATCH_NO
)
1001 = gfc_get_constant_expr (BT_INTEGER
,
1002 gfc_default_integer_kind
,
1003 &gfc_current_locus
);
1004 mpz_set_si (c
->async_expr
->value
.integer
, GOMP_ASYNC_NOVAL
);
1009 if ((mask
& OMP_CLAUSE_AUTO
)
1011 && gfc_match ("auto") == MATCH_YES
)
1019 if ((mask
& OMP_CLAUSE_COLLAPSE
)
1022 gfc_expr
*cexpr
= NULL
;
1023 match m
= gfc_match ("collapse ( %e )", &cexpr
);
1028 if (gfc_extract_int (cexpr
, &collapse
, -1))
1030 else if (collapse
<= 0)
1032 gfc_error_now ("COLLAPSE clause argument not"
1033 " constant positive integer at %C");
1036 c
->collapse
= collapse
;
1037 gfc_free_expr (cexpr
);
1041 if ((mask
& OMP_CLAUSE_COPY
)
1042 && gfc_match ("copy ( ") == MATCH_YES
1043 && gfc_match_omp_map_clause (&c
->lists
[OMP_LIST_MAP
],
1044 OMP_MAP_FORCE_TOFROM
))
1046 if (mask
& OMP_CLAUSE_COPYIN
)
1050 if (gfc_match ("copyin ( ") == MATCH_YES
1051 && gfc_match_omp_map_clause (&c
->lists
[OMP_LIST_MAP
],
1055 else if (gfc_match_omp_variable_list ("copyin (",
1056 &c
->lists
[OMP_LIST_COPYIN
],
1060 if ((mask
& OMP_CLAUSE_COPYOUT
)
1061 && gfc_match ("copyout ( ") == MATCH_YES
1062 && gfc_match_omp_map_clause (&c
->lists
[OMP_LIST_MAP
],
1063 OMP_MAP_FORCE_FROM
))
1065 if ((mask
& OMP_CLAUSE_COPYPRIVATE
)
1066 && gfc_match_omp_variable_list ("copyprivate (",
1067 &c
->lists
[OMP_LIST_COPYPRIVATE
],
1070 if ((mask
& OMP_CLAUSE_CREATE
)
1071 && gfc_match ("create ( ") == MATCH_YES
1072 && gfc_match_omp_map_clause (&c
->lists
[OMP_LIST_MAP
],
1073 OMP_MAP_FORCE_ALLOC
))
1077 if ((mask
& OMP_CLAUSE_DEFAULT
)
1078 && c
->default_sharing
== OMP_DEFAULT_UNKNOWN
)
1080 if (gfc_match ("default ( none )") == MATCH_YES
)
1081 c
->default_sharing
= OMP_DEFAULT_NONE
;
1084 if (gfc_match ("default ( present )") == MATCH_YES
)
1085 c
->default_sharing
= OMP_DEFAULT_PRESENT
;
1089 if (gfc_match ("default ( firstprivate )") == MATCH_YES
)
1090 c
->default_sharing
= OMP_DEFAULT_FIRSTPRIVATE
;
1091 else if (gfc_match ("default ( private )") == MATCH_YES
)
1092 c
->default_sharing
= OMP_DEFAULT_PRIVATE
;
1093 else if (gfc_match ("default ( shared )") == MATCH_YES
)
1094 c
->default_sharing
= OMP_DEFAULT_SHARED
;
1096 if (c
->default_sharing
!= OMP_DEFAULT_UNKNOWN
)
1099 if ((mask
& OMP_CLAUSE_DEFAULTMAP
)
1101 && gfc_match ("defaultmap ( tofrom : scalar )") == MATCH_YES
)
1103 c
->defaultmap
= true;
1106 if ((mask
& OMP_CLAUSE_DELETE
)
1107 && gfc_match ("delete ( ") == MATCH_YES
1108 && gfc_match_omp_map_clause (&c
->lists
[OMP_LIST_MAP
],
1111 if ((mask
& OMP_CLAUSE_DEPEND
)
1112 && gfc_match ("depend ( ") == MATCH_YES
)
1114 match m
= MATCH_YES
;
1115 gfc_omp_depend_op depend_op
= OMP_DEPEND_OUT
;
1116 if (gfc_match ("inout") == MATCH_YES
)
1117 depend_op
= OMP_DEPEND_INOUT
;
1118 else if (gfc_match ("in") == MATCH_YES
)
1119 depend_op
= OMP_DEPEND_IN
;
1120 else if (gfc_match ("out") == MATCH_YES
)
1121 depend_op
= OMP_DEPEND_OUT
;
1122 else if (!c
->depend_source
1123 && gfc_match ("source )") == MATCH_YES
)
1125 c
->depend_source
= true;
1128 else if (gfc_match ("sink : ") == MATCH_YES
)
1130 if (gfc_match_omp_depend_sink (&c
->lists
[OMP_LIST_DEPEND
])
1139 && gfc_match_omp_variable_list (" : ",
1140 &c
->lists
[OMP_LIST_DEPEND
],
1144 gfc_omp_namelist
*n
;
1145 for (n
= *head
; n
; n
= n
->next
)
1146 n
->u
.depend_op
= depend_op
;
1150 gfc_current_locus
= old_loc
;
1152 if ((mask
& OMP_CLAUSE_DEVICE
)
1154 && c
->device
== NULL
1155 && gfc_match ("device ( %e )", &c
->device
) == MATCH_YES
)
1157 if ((mask
& OMP_CLAUSE_DEVICE
)
1159 && gfc_match ("device ( ") == MATCH_YES
1160 && gfc_match_omp_map_clause (&c
->lists
[OMP_LIST_MAP
],
1163 if ((mask
& OMP_CLAUSE_DEVICEPTR
)
1164 && gfc_match ("deviceptr ( ") == MATCH_YES
)
1166 gfc_omp_namelist
**list
= &c
->lists
[OMP_LIST_MAP
];
1167 gfc_omp_namelist
**head
= NULL
;
1168 if (gfc_match_omp_variable_list ("", list
, true, NULL
,
1169 &head
, false) == MATCH_YES
)
1171 gfc_omp_namelist
*n
;
1172 for (n
= *head
; n
; n
= n
->next
)
1173 n
->u
.map_op
= OMP_MAP_FORCE_DEVICEPTR
;
1177 if ((mask
& OMP_CLAUSE_DEVICE_RESIDENT
)
1178 && gfc_match_omp_variable_list
1179 ("device_resident (",
1180 &c
->lists
[OMP_LIST_DEVICE_RESIDENT
], true) == MATCH_YES
)
1182 if ((mask
& OMP_CLAUSE_DIST_SCHEDULE
)
1183 && c
->dist_sched_kind
== OMP_SCHED_NONE
1184 && gfc_match ("dist_schedule ( static") == MATCH_YES
)
1187 c
->dist_sched_kind
= OMP_SCHED_STATIC
;
1188 m
= gfc_match (" , %e )", &c
->dist_chunk_size
);
1190 m
= gfc_match_char (')');
1193 c
->dist_sched_kind
= OMP_SCHED_NONE
;
1194 gfc_current_locus
= old_loc
;
1201 if ((mask
& OMP_CLAUSE_FINAL
)
1202 && c
->final_expr
== NULL
1203 && gfc_match ("final ( %e )", &c
->final_expr
) == MATCH_YES
)
1205 if ((mask
& OMP_CLAUSE_FIRSTPRIVATE
)
1206 && gfc_match_omp_variable_list ("firstprivate (",
1207 &c
->lists
[OMP_LIST_FIRSTPRIVATE
],
1210 if ((mask
& OMP_CLAUSE_FROM
)
1211 && gfc_match_omp_variable_list ("from (",
1212 &c
->lists
[OMP_LIST_FROM
], false,
1213 NULL
, &head
, true) == MATCH_YES
)
1217 if ((mask
& OMP_CLAUSE_GANG
)
1219 && gfc_match ("gang") == MATCH_YES
)
1222 match m
= match_oacc_clause_gwv (c
, GOMP_DIM_GANG
);
1223 if (m
== MATCH_ERROR
)
1225 gfc_current_locus
= old_loc
;
1228 else if (m
== MATCH_NO
)
1232 if ((mask
& OMP_CLAUSE_GRAINSIZE
)
1233 && c
->grainsize
== NULL
1234 && gfc_match ("grainsize ( %e )", &c
->grainsize
) == MATCH_YES
)
1238 if ((mask
& OMP_CLAUSE_HINT
)
1240 && gfc_match ("hint ( %e )", &c
->hint
) == MATCH_YES
)
1242 if ((mask
& OMP_CLAUSE_HOST_SELF
)
1243 && gfc_match ("host ( ") == MATCH_YES
1244 && gfc_match_omp_map_clause (&c
->lists
[OMP_LIST_MAP
],
1245 OMP_MAP_FORCE_FROM
))
1249 if ((mask
& OMP_CLAUSE_IF
)
1250 && c
->if_expr
== NULL
1251 && gfc_match ("if ( ") == MATCH_YES
)
1253 if (gfc_match ("%e )", &c
->if_expr
) == MATCH_YES
)
1257 /* This should match the enum gfc_omp_if_kind order. */
1258 static const char *ifs
[OMP_IF_LAST
] = {
1263 " target data : %e )",
1264 " target update : %e )",
1265 " target enter data : %e )",
1266 " target exit data : %e )" };
1268 for (i
= 0; i
< OMP_IF_LAST
; i
++)
1269 if (c
->if_exprs
[i
] == NULL
1270 && gfc_match (ifs
[i
], &c
->if_exprs
[i
]) == MATCH_YES
)
1272 if (i
< OMP_IF_LAST
)
1275 gfc_current_locus
= old_loc
;
1277 if ((mask
& OMP_CLAUSE_INBRANCH
)
1280 && gfc_match ("inbranch") == MATCH_YES
)
1282 c
->inbranch
= needs_space
= true;
1285 if ((mask
& OMP_CLAUSE_INDEPENDENT
)
1287 && gfc_match ("independent") == MATCH_YES
)
1289 c
->independent
= true;
1293 if ((mask
& OMP_CLAUSE_IS_DEVICE_PTR
)
1294 && gfc_match_omp_variable_list
1296 &c
->lists
[OMP_LIST_IS_DEVICE_PTR
], false) == MATCH_YES
)
1300 if ((mask
& OMP_CLAUSE_LASTPRIVATE
)
1301 && gfc_match_omp_variable_list ("lastprivate (",
1302 &c
->lists
[OMP_LIST_LASTPRIVATE
],
1307 if ((mask
& OMP_CLAUSE_LINEAR
)
1308 && gfc_match ("linear (") == MATCH_YES
)
1310 gfc_omp_linear_op linear_op
= OMP_LINEAR_DEFAULT
;
1311 gfc_expr
*step
= NULL
;
1313 if (gfc_match_omp_variable_list (" ref (",
1314 &c
->lists
[OMP_LIST_LINEAR
],
1317 linear_op
= OMP_LINEAR_REF
;
1318 else if (gfc_match_omp_variable_list (" val (",
1319 &c
->lists
[OMP_LIST_LINEAR
],
1322 linear_op
= OMP_LINEAR_VAL
;
1323 else if (gfc_match_omp_variable_list (" uval (",
1324 &c
->lists
[OMP_LIST_LINEAR
],
1327 linear_op
= OMP_LINEAR_UVAL
;
1328 else if (gfc_match_omp_variable_list ("",
1329 &c
->lists
[OMP_LIST_LINEAR
],
1330 false, &end_colon
, &head
)
1332 linear_op
= OMP_LINEAR_DEFAULT
;
1335 gfc_current_locus
= old_loc
;
1338 if (linear_op
!= OMP_LINEAR_DEFAULT
)
1340 if (gfc_match (" :") == MATCH_YES
)
1342 else if (gfc_match (" )") != MATCH_YES
)
1344 gfc_free_omp_namelist (*head
);
1345 gfc_current_locus
= old_loc
;
1350 if (end_colon
&& gfc_match (" %e )", &step
) != MATCH_YES
)
1352 gfc_free_omp_namelist (*head
);
1353 gfc_current_locus
= old_loc
;
1357 else if (!end_colon
)
1359 step
= gfc_get_constant_expr (BT_INTEGER
,
1360 gfc_default_integer_kind
,
1362 mpz_set_si (step
->value
.integer
, 1);
1364 (*head
)->expr
= step
;
1365 if (linear_op
!= OMP_LINEAR_DEFAULT
)
1366 for (gfc_omp_namelist
*n
= *head
; n
; n
= n
->next
)
1367 n
->u
.linear_op
= linear_op
;
1370 if ((mask
& OMP_CLAUSE_LINK
)
1372 && (gfc_match_oacc_clause_link ("link (",
1373 &c
->lists
[OMP_LIST_LINK
])
1376 else if ((mask
& OMP_CLAUSE_LINK
)
1378 && (gfc_match_omp_to_link ("link (",
1379 &c
->lists
[OMP_LIST_LINK
])
1384 if ((mask
& OMP_CLAUSE_MAP
)
1385 && gfc_match ("map ( ") == MATCH_YES
)
1387 locus old_loc2
= gfc_current_locus
;
1388 bool always
= false;
1389 gfc_omp_map_op map_op
= OMP_MAP_TOFROM
;
1390 if (gfc_match ("always , ") == MATCH_YES
)
1392 if (gfc_match ("alloc : ") == MATCH_YES
)
1393 map_op
= OMP_MAP_ALLOC
;
1394 else if (gfc_match ("tofrom : ") == MATCH_YES
)
1395 map_op
= always
? OMP_MAP_ALWAYS_TOFROM
: OMP_MAP_TOFROM
;
1396 else if (gfc_match ("to : ") == MATCH_YES
)
1397 map_op
= always
? OMP_MAP_ALWAYS_TO
: OMP_MAP_TO
;
1398 else if (gfc_match ("from : ") == MATCH_YES
)
1399 map_op
= always
? OMP_MAP_ALWAYS_FROM
: OMP_MAP_FROM
;
1400 else if (gfc_match ("release : ") == MATCH_YES
)
1401 map_op
= OMP_MAP_RELEASE
;
1402 else if (gfc_match ("delete : ") == MATCH_YES
)
1403 map_op
= OMP_MAP_DELETE
;
1406 gfc_current_locus
= old_loc2
;
1410 if (gfc_match_omp_variable_list ("", &c
->lists
[OMP_LIST_MAP
],
1414 gfc_omp_namelist
*n
;
1415 for (n
= *head
; n
; n
= n
->next
)
1416 n
->u
.map_op
= map_op
;
1420 gfc_current_locus
= old_loc
;
1422 if ((mask
& OMP_CLAUSE_MERGEABLE
) && !c
->mergeable
1423 && gfc_match ("mergeable") == MATCH_YES
)
1425 c
->mergeable
= needs_space
= true;
1430 if ((mask
& OMP_CLAUSE_NOGROUP
)
1432 && gfc_match ("nogroup") == MATCH_YES
)
1434 c
->nogroup
= needs_space
= true;
1437 if ((mask
& OMP_CLAUSE_NOTINBRANCH
)
1440 && gfc_match ("notinbranch") == MATCH_YES
)
1442 c
->notinbranch
= needs_space
= true;
1445 if ((mask
& OMP_CLAUSE_NOWAIT
)
1447 && gfc_match ("nowait") == MATCH_YES
)
1449 c
->nowait
= needs_space
= true;
1452 if ((mask
& OMP_CLAUSE_NUM_GANGS
)
1453 && c
->num_gangs_expr
== NULL
1454 && gfc_match ("num_gangs ( %e )",
1455 &c
->num_gangs_expr
) == MATCH_YES
)
1457 if ((mask
& OMP_CLAUSE_NUM_TASKS
)
1458 && c
->num_tasks
== NULL
1459 && gfc_match ("num_tasks ( %e )", &c
->num_tasks
) == MATCH_YES
)
1461 if ((mask
& OMP_CLAUSE_NUM_TEAMS
)
1462 && c
->num_teams
== NULL
1463 && gfc_match ("num_teams ( %e )", &c
->num_teams
) == MATCH_YES
)
1465 if ((mask
& OMP_CLAUSE_NUM_THREADS
)
1466 && c
->num_threads
== NULL
1467 && (gfc_match ("num_threads ( %e )", &c
->num_threads
)
1470 if ((mask
& OMP_CLAUSE_NUM_WORKERS
)
1471 && c
->num_workers_expr
== NULL
1472 && gfc_match ("num_workers ( %e )",
1473 &c
->num_workers_expr
) == MATCH_YES
)
1477 if ((mask
& OMP_CLAUSE_ORDERED
)
1479 && gfc_match ("ordered") == MATCH_YES
)
1481 gfc_expr
*cexpr
= NULL
;
1482 match m
= gfc_match (" ( %e )", &cexpr
);
1488 if (gfc_extract_int (cexpr
, &ordered
, -1))
1490 else if (ordered
<= 0)
1492 gfc_error_now ("ORDERED clause argument not"
1493 " constant positive integer at %C");
1496 c
->orderedc
= ordered
;
1497 gfc_free_expr (cexpr
);
1506 if ((mask
& OMP_CLAUSE_PRESENT_OR_COPY
)
1507 && gfc_match ("pcopy ( ") == MATCH_YES
1508 && gfc_match_omp_map_clause (&c
->lists
[OMP_LIST_MAP
],
1511 if ((mask
& OMP_CLAUSE_PRESENT_OR_COPYIN
)
1512 && gfc_match ("pcopyin ( ") == MATCH_YES
1513 && gfc_match_omp_map_clause (&c
->lists
[OMP_LIST_MAP
],
1516 if ((mask
& OMP_CLAUSE_PRESENT_OR_COPYOUT
)
1517 && gfc_match ("pcopyout ( ") == MATCH_YES
1518 && gfc_match_omp_map_clause (&c
->lists
[OMP_LIST_MAP
],
1521 if ((mask
& OMP_CLAUSE_PRESENT_OR_CREATE
)
1522 && gfc_match ("pcreate ( ") == MATCH_YES
1523 && gfc_match_omp_map_clause (&c
->lists
[OMP_LIST_MAP
],
1526 if ((mask
& OMP_CLAUSE_PRESENT
)
1527 && gfc_match ("present ( ") == MATCH_YES
1528 && gfc_match_omp_map_clause (&c
->lists
[OMP_LIST_MAP
],
1529 OMP_MAP_FORCE_PRESENT
))
1531 if ((mask
& OMP_CLAUSE_PRESENT_OR_COPY
)
1532 && gfc_match ("present_or_copy ( ") == MATCH_YES
1533 && gfc_match_omp_map_clause (&c
->lists
[OMP_LIST_MAP
],
1536 if ((mask
& OMP_CLAUSE_PRESENT_OR_COPYIN
)
1537 && gfc_match ("present_or_copyin ( ") == MATCH_YES
1538 && gfc_match_omp_map_clause (&c
->lists
[OMP_LIST_MAP
],
1541 if ((mask
& OMP_CLAUSE_PRESENT_OR_COPYOUT
)
1542 && gfc_match ("present_or_copyout ( ") == MATCH_YES
1543 && gfc_match_omp_map_clause (&c
->lists
[OMP_LIST_MAP
],
1546 if ((mask
& OMP_CLAUSE_PRESENT_OR_CREATE
)
1547 && gfc_match ("present_or_create ( ") == MATCH_YES
1548 && gfc_match_omp_map_clause (&c
->lists
[OMP_LIST_MAP
],
1551 if ((mask
& OMP_CLAUSE_PRIORITY
)
1552 && c
->priority
== NULL
1553 && gfc_match ("priority ( %e )", &c
->priority
) == MATCH_YES
)
1555 if ((mask
& OMP_CLAUSE_PRIVATE
)
1556 && gfc_match_omp_variable_list ("private (",
1557 &c
->lists
[OMP_LIST_PRIVATE
],
1560 if ((mask
& OMP_CLAUSE_PROC_BIND
)
1561 && c
->proc_bind
== OMP_PROC_BIND_UNKNOWN
)
1563 if (gfc_match ("proc_bind ( master )") == MATCH_YES
)
1564 c
->proc_bind
= OMP_PROC_BIND_MASTER
;
1565 else if (gfc_match ("proc_bind ( spread )") == MATCH_YES
)
1566 c
->proc_bind
= OMP_PROC_BIND_SPREAD
;
1567 else if (gfc_match ("proc_bind ( close )") == MATCH_YES
)
1568 c
->proc_bind
= OMP_PROC_BIND_CLOSE
;
1569 if (c
->proc_bind
!= OMP_PROC_BIND_UNKNOWN
)
1574 if ((mask
& OMP_CLAUSE_REDUCTION
)
1575 && gfc_match ("reduction ( ") == MATCH_YES
)
1577 gfc_omp_reduction_op rop
= OMP_REDUCTION_NONE
;
1578 char buffer
[GFC_MAX_SYMBOL_LEN
+ 3];
1579 if (gfc_match_char ('+') == MATCH_YES
)
1580 rop
= OMP_REDUCTION_PLUS
;
1581 else if (gfc_match_char ('*') == MATCH_YES
)
1582 rop
= OMP_REDUCTION_TIMES
;
1583 else if (gfc_match_char ('-') == MATCH_YES
)
1584 rop
= OMP_REDUCTION_MINUS
;
1585 else if (gfc_match (".and.") == MATCH_YES
)
1586 rop
= OMP_REDUCTION_AND
;
1587 else if (gfc_match (".or.") == MATCH_YES
)
1588 rop
= OMP_REDUCTION_OR
;
1589 else if (gfc_match (".eqv.") == MATCH_YES
)
1590 rop
= OMP_REDUCTION_EQV
;
1591 else if (gfc_match (".neqv.") == MATCH_YES
)
1592 rop
= OMP_REDUCTION_NEQV
;
1593 if (rop
!= OMP_REDUCTION_NONE
)
1594 snprintf (buffer
, sizeof buffer
, "operator %s",
1595 gfc_op2string ((gfc_intrinsic_op
) rop
));
1596 else if (gfc_match_defined_op_name (buffer
+ 1, 1) == MATCH_YES
)
1599 strcat (buffer
, ".");
1601 else if (gfc_match_name (buffer
) == MATCH_YES
)
1604 const char *n
= buffer
;
1606 gfc_find_symbol (buffer
, NULL
, 1, &sym
);
1609 if (sym
->attr
.intrinsic
)
1611 else if ((sym
->attr
.flavor
!= FL_UNKNOWN
1612 && sym
->attr
.flavor
!= FL_PROCEDURE
)
1613 || sym
->attr
.external
1614 || sym
->attr
.generic
1618 || sym
->attr
.subroutine
1619 || sym
->attr
.pointer
1621 || sym
->attr
.cray_pointer
1622 || sym
->attr
.cray_pointee
1623 || (sym
->attr
.proc
!= PROC_UNKNOWN
1624 && sym
->attr
.proc
!= PROC_INTRINSIC
)
1625 || sym
->attr
.if_source
!= IFSRC_UNKNOWN
1626 || sym
== sym
->ns
->proc_name
)
1635 rop
= OMP_REDUCTION_NONE
;
1636 else if (strcmp (n
, "max") == 0)
1637 rop
= OMP_REDUCTION_MAX
;
1638 else if (strcmp (n
, "min") == 0)
1639 rop
= OMP_REDUCTION_MIN
;
1640 else if (strcmp (n
, "iand") == 0)
1641 rop
= OMP_REDUCTION_IAND
;
1642 else if (strcmp (n
, "ior") == 0)
1643 rop
= OMP_REDUCTION_IOR
;
1644 else if (strcmp (n
, "ieor") == 0)
1645 rop
= OMP_REDUCTION_IEOR
;
1646 if (rop
!= OMP_REDUCTION_NONE
1648 && ! sym
->attr
.intrinsic
1649 && ! sym
->attr
.use_assoc
1650 && ((sym
->attr
.flavor
== FL_UNKNOWN
1651 && !gfc_add_flavor (&sym
->attr
, FL_PROCEDURE
,
1653 || !gfc_add_intrinsic (&sym
->attr
, NULL
)))
1654 rop
= OMP_REDUCTION_NONE
;
1660 ? gfc_find_omp_udr (gfc_current_ns
, buffer
, NULL
) : NULL
);
1661 gfc_omp_namelist
**head
= NULL
;
1662 if (rop
== OMP_REDUCTION_NONE
&& udr
)
1663 rop
= OMP_REDUCTION_USER
;
1665 if (gfc_match_omp_variable_list (" :",
1666 &c
->lists
[OMP_LIST_REDUCTION
],
1668 openacc
) == MATCH_YES
)
1670 gfc_omp_namelist
*n
;
1671 if (rop
== OMP_REDUCTION_NONE
)
1675 gfc_error_now ("!$OMP DECLARE REDUCTION %s not found "
1676 "at %L", buffer
, &old_loc
);
1677 gfc_free_omp_namelist (n
);
1680 for (n
= *head
; n
; n
= n
->next
)
1682 n
->u
.reduction_op
= rop
;
1685 n
->udr
= gfc_get_omp_namelist_udr ();
1692 gfc_current_locus
= old_loc
;
1696 if ((mask
& OMP_CLAUSE_SAFELEN
)
1697 && c
->safelen_expr
== NULL
1698 && gfc_match ("safelen ( %e )", &c
->safelen_expr
) == MATCH_YES
)
1700 if ((mask
& OMP_CLAUSE_SCHEDULE
)
1701 && c
->sched_kind
== OMP_SCHED_NONE
1702 && gfc_match ("schedule ( ") == MATCH_YES
)
1705 locus old_loc2
= gfc_current_locus
;
1709 && gfc_match ("simd") == MATCH_YES
)
1711 c
->sched_simd
= true;
1714 else if (!c
->sched_monotonic
1715 && !c
->sched_nonmonotonic
1716 && gfc_match ("monotonic") == MATCH_YES
)
1718 c
->sched_monotonic
= true;
1721 else if (!c
->sched_monotonic
1722 && !c
->sched_nonmonotonic
1723 && gfc_match ("nonmonotonic") == MATCH_YES
)
1725 c
->sched_nonmonotonic
= true;
1731 gfc_current_locus
= old_loc2
;
1735 && gfc_match (" , ") == MATCH_YES
)
1737 else if (gfc_match (" : ") == MATCH_YES
)
1739 gfc_current_locus
= old_loc2
;
1743 if (gfc_match ("static") == MATCH_YES
)
1744 c
->sched_kind
= OMP_SCHED_STATIC
;
1745 else if (gfc_match ("dynamic") == MATCH_YES
)
1746 c
->sched_kind
= OMP_SCHED_DYNAMIC
;
1747 else if (gfc_match ("guided") == MATCH_YES
)
1748 c
->sched_kind
= OMP_SCHED_GUIDED
;
1749 else if (gfc_match ("runtime") == MATCH_YES
)
1750 c
->sched_kind
= OMP_SCHED_RUNTIME
;
1751 else if (gfc_match ("auto") == MATCH_YES
)
1752 c
->sched_kind
= OMP_SCHED_AUTO
;
1753 if (c
->sched_kind
!= OMP_SCHED_NONE
)
1756 if (c
->sched_kind
!= OMP_SCHED_RUNTIME
1757 && c
->sched_kind
!= OMP_SCHED_AUTO
)
1758 m
= gfc_match (" , %e )", &c
->chunk_size
);
1760 m
= gfc_match_char (')');
1762 c
->sched_kind
= OMP_SCHED_NONE
;
1764 if (c
->sched_kind
!= OMP_SCHED_NONE
)
1767 gfc_current_locus
= old_loc
;
1769 if ((mask
& OMP_CLAUSE_HOST_SELF
)
1770 && gfc_match ("self ( ") == MATCH_YES
1771 && gfc_match_omp_map_clause (&c
->lists
[OMP_LIST_MAP
],
1772 OMP_MAP_FORCE_FROM
))
1774 if ((mask
& OMP_CLAUSE_SEQ
)
1776 && gfc_match ("seq") == MATCH_YES
)
1782 if ((mask
& OMP_CLAUSE_SHARED
)
1783 && gfc_match_omp_variable_list ("shared (",
1784 &c
->lists
[OMP_LIST_SHARED
],
1787 if ((mask
& OMP_CLAUSE_SIMDLEN
)
1788 && c
->simdlen_expr
== NULL
1789 && gfc_match ("simdlen ( %e )", &c
->simdlen_expr
) == MATCH_YES
)
1791 if ((mask
& OMP_CLAUSE_SIMD
)
1793 && gfc_match ("simd") == MATCH_YES
)
1795 c
->simd
= needs_space
= true;
1800 if ((mask
& OMP_CLAUSE_THREAD_LIMIT
)
1801 && c
->thread_limit
== NULL
1802 && gfc_match ("thread_limit ( %e )",
1803 &c
->thread_limit
) == MATCH_YES
)
1805 if ((mask
& OMP_CLAUSE_THREADS
)
1807 && gfc_match ("threads") == MATCH_YES
)
1809 c
->threads
= needs_space
= true;
1812 if ((mask
& OMP_CLAUSE_TILE
)
1814 && match_oacc_expr_list ("tile (", &c
->tile_list
,
1817 if ((mask
& OMP_CLAUSE_TO
) && (mask
& OMP_CLAUSE_LINK
))
1819 if (gfc_match_omp_to_link ("to (", &c
->lists
[OMP_LIST_TO
])
1823 else if ((mask
& OMP_CLAUSE_TO
)
1824 && gfc_match_omp_variable_list ("to (",
1825 &c
->lists
[OMP_LIST_TO
], false,
1826 NULL
, &head
, true) == MATCH_YES
)
1830 if ((mask
& OMP_CLAUSE_UNIFORM
)
1831 && gfc_match_omp_variable_list ("uniform (",
1832 &c
->lists
[OMP_LIST_UNIFORM
],
1833 false) == MATCH_YES
)
1835 if ((mask
& OMP_CLAUSE_UNTIED
)
1837 && gfc_match ("untied") == MATCH_YES
)
1839 c
->untied
= needs_space
= true;
1842 if ((mask
& OMP_CLAUSE_USE_DEVICE
)
1843 && gfc_match_omp_variable_list ("use_device (",
1844 &c
->lists
[OMP_LIST_USE_DEVICE
],
1847 if ((mask
& OMP_CLAUSE_USE_DEVICE_PTR
)
1848 && gfc_match_omp_variable_list
1849 ("use_device_ptr (",
1850 &c
->lists
[OMP_LIST_USE_DEVICE_PTR
], false) == MATCH_YES
)
1854 /* VECTOR_LENGTH must be matched before VECTOR, because the latter
1855 doesn't unconditionally match '('. */
1856 if ((mask
& OMP_CLAUSE_VECTOR_LENGTH
)
1857 && c
->vector_length_expr
== NULL
1858 && (gfc_match ("vector_length ( %e )", &c
->vector_length_expr
)
1861 if ((mask
& OMP_CLAUSE_VECTOR
)
1863 && gfc_match ("vector") == MATCH_YES
)
1866 match m
= match_oacc_clause_gwv (c
, GOMP_DIM_VECTOR
);
1867 if (m
== MATCH_ERROR
)
1869 gfc_current_locus
= old_loc
;
1878 if ((mask
& OMP_CLAUSE_WAIT
)
1880 && gfc_match ("wait") == MATCH_YES
)
1883 match m
= match_oacc_expr_list (" (", &c
->wait_list
, false);
1884 if (m
== MATCH_ERROR
)
1886 gfc_current_locus
= old_loc
;
1889 else if (m
== MATCH_NO
)
1893 if ((mask
& OMP_CLAUSE_WORKER
)
1895 && gfc_match ("worker") == MATCH_YES
)
1898 match m
= match_oacc_clause_gwv (c
, GOMP_DIM_WORKER
);
1899 if (m
== MATCH_ERROR
)
1901 gfc_current_locus
= old_loc
;
1904 else if (m
== MATCH_NO
)
1913 if (gfc_match_omp_eos () != MATCH_YES
)
1915 gfc_free_omp_clauses (c
);
1924 #define OACC_PARALLEL_CLAUSES \
1925 (omp_mask (OMP_CLAUSE_IF) | OMP_CLAUSE_ASYNC | OMP_CLAUSE_NUM_GANGS \
1926 | OMP_CLAUSE_NUM_WORKERS | OMP_CLAUSE_VECTOR_LENGTH | OMP_CLAUSE_REDUCTION \
1927 | OMP_CLAUSE_COPY | OMP_CLAUSE_COPYIN | OMP_CLAUSE_COPYOUT \
1928 | OMP_CLAUSE_CREATE | OMP_CLAUSE_PRESENT | OMP_CLAUSE_PRESENT_OR_COPY \
1929 | OMP_CLAUSE_PRESENT_OR_COPYIN | OMP_CLAUSE_PRESENT_OR_COPYOUT \
1930 | OMP_CLAUSE_PRESENT_OR_CREATE | OMP_CLAUSE_DEVICEPTR | OMP_CLAUSE_PRIVATE \
1931 | OMP_CLAUSE_FIRSTPRIVATE | OMP_CLAUSE_DEFAULT | OMP_CLAUSE_WAIT)
1932 #define OACC_KERNELS_CLAUSES \
1933 (omp_mask (OMP_CLAUSE_IF) | OMP_CLAUSE_ASYNC | OMP_CLAUSE_NUM_GANGS \
1934 | OMP_CLAUSE_NUM_WORKERS | OMP_CLAUSE_VECTOR_LENGTH | OMP_CLAUSE_DEVICEPTR \
1935 | OMP_CLAUSE_COPY | OMP_CLAUSE_COPYIN | OMP_CLAUSE_COPYOUT \
1936 | OMP_CLAUSE_CREATE | OMP_CLAUSE_PRESENT | OMP_CLAUSE_PRESENT_OR_COPY \
1937 | OMP_CLAUSE_PRESENT_OR_COPYIN | OMP_CLAUSE_PRESENT_OR_COPYOUT \
1938 | OMP_CLAUSE_PRESENT_OR_CREATE | OMP_CLAUSE_DEFAULT | OMP_CLAUSE_WAIT)
1939 #define OACC_DATA_CLAUSES \
1940 (omp_mask (OMP_CLAUSE_IF) | OMP_CLAUSE_DEVICEPTR | OMP_CLAUSE_COPY \
1941 | OMP_CLAUSE_COPYIN | OMP_CLAUSE_COPYOUT | OMP_CLAUSE_CREATE \
1942 | OMP_CLAUSE_PRESENT | OMP_CLAUSE_PRESENT_OR_COPY \
1943 | OMP_CLAUSE_PRESENT_OR_COPYIN | OMP_CLAUSE_PRESENT_OR_COPYOUT \
1944 | OMP_CLAUSE_PRESENT_OR_CREATE)
1945 #define OACC_LOOP_CLAUSES \
1946 (omp_mask (OMP_CLAUSE_COLLAPSE) | OMP_CLAUSE_GANG | OMP_CLAUSE_WORKER \
1947 | OMP_CLAUSE_VECTOR | OMP_CLAUSE_SEQ | OMP_CLAUSE_INDEPENDENT \
1948 | OMP_CLAUSE_PRIVATE | OMP_CLAUSE_REDUCTION | OMP_CLAUSE_AUTO \
1950 #define OACC_PARALLEL_LOOP_CLAUSES \
1951 (OACC_LOOP_CLAUSES | OACC_PARALLEL_CLAUSES)
1952 #define OACC_KERNELS_LOOP_CLAUSES \
1953 (OACC_LOOP_CLAUSES | OACC_KERNELS_CLAUSES)
1954 #define OACC_HOST_DATA_CLAUSES omp_mask (OMP_CLAUSE_USE_DEVICE)
1955 #define OACC_DECLARE_CLAUSES \
1956 (omp_mask (OMP_CLAUSE_COPY) | OMP_CLAUSE_COPYIN | OMP_CLAUSE_COPYOUT \
1957 | OMP_CLAUSE_CREATE | OMP_CLAUSE_DEVICEPTR | OMP_CLAUSE_DEVICE_RESIDENT \
1958 | OMP_CLAUSE_PRESENT | OMP_CLAUSE_PRESENT_OR_COPY \
1959 | OMP_CLAUSE_PRESENT_OR_COPYIN | OMP_CLAUSE_PRESENT_OR_COPYOUT \
1960 | OMP_CLAUSE_PRESENT_OR_CREATE | OMP_CLAUSE_LINK)
1961 #define OACC_UPDATE_CLAUSES \
1962 (omp_mask (OMP_CLAUSE_IF) | OMP_CLAUSE_ASYNC | OMP_CLAUSE_HOST_SELF \
1963 | OMP_CLAUSE_DEVICE | OMP_CLAUSE_WAIT)
1964 #define OACC_ENTER_DATA_CLAUSES \
1965 (omp_mask (OMP_CLAUSE_IF) | OMP_CLAUSE_ASYNC | OMP_CLAUSE_WAIT \
1966 | OMP_CLAUSE_COPYIN | OMP_CLAUSE_CREATE | OMP_CLAUSE_PRESENT_OR_COPYIN \
1967 | OMP_CLAUSE_PRESENT_OR_CREATE)
1968 #define OACC_EXIT_DATA_CLAUSES \
1969 (omp_mask (OMP_CLAUSE_IF) | OMP_CLAUSE_ASYNC | OMP_CLAUSE_WAIT \
1970 | OMP_CLAUSE_COPYOUT | OMP_CLAUSE_DELETE)
1971 #define OACC_WAIT_CLAUSES \
1972 omp_mask (OMP_CLAUSE_ASYNC)
1973 #define OACC_ROUTINE_CLAUSES \
1974 (omp_mask (OMP_CLAUSE_GANG) | OMP_CLAUSE_WORKER | OMP_CLAUSE_VECTOR \
1979 match_acc (gfc_exec_op op
, const omp_mask mask
)
1982 if (gfc_match_omp_clauses (&c
, mask
, false, false, true) != MATCH_YES
)
1985 new_st
.ext
.omp_clauses
= c
;
1990 gfc_match_oacc_parallel_loop (void)
1992 return match_acc (EXEC_OACC_PARALLEL_LOOP
, OACC_PARALLEL_LOOP_CLAUSES
);
1997 gfc_match_oacc_parallel (void)
1999 return match_acc (EXEC_OACC_PARALLEL
, OACC_PARALLEL_CLAUSES
);
2004 gfc_match_oacc_kernels_loop (void)
2006 return match_acc (EXEC_OACC_KERNELS_LOOP
, OACC_KERNELS_LOOP_CLAUSES
);
2011 gfc_match_oacc_kernels (void)
2013 return match_acc (EXEC_OACC_KERNELS
, OACC_KERNELS_CLAUSES
);
2018 gfc_match_oacc_data (void)
2020 return match_acc (EXEC_OACC_DATA
, OACC_DATA_CLAUSES
);
2025 gfc_match_oacc_host_data (void)
2027 return match_acc (EXEC_OACC_HOST_DATA
, OACC_HOST_DATA_CLAUSES
);
2032 gfc_match_oacc_loop (void)
2034 return match_acc (EXEC_OACC_LOOP
, OACC_LOOP_CLAUSES
);
2039 gfc_match_oacc_declare (void)
2042 gfc_omp_namelist
*n
;
2043 gfc_namespace
*ns
= gfc_current_ns
;
2044 gfc_oacc_declare
*new_oc
;
2045 bool module_var
= false;
2046 locus where
= gfc_current_locus
;
2048 if (gfc_match_omp_clauses (&c
, OACC_DECLARE_CLAUSES
, false, false, true)
2052 for (n
= c
->lists
[OMP_LIST_DEVICE_RESIDENT
]; n
!= NULL
; n
= n
->next
)
2053 n
->sym
->attr
.oacc_declare_device_resident
= 1;
2055 for (n
= c
->lists
[OMP_LIST_LINK
]; n
!= NULL
; n
= n
->next
)
2056 n
->sym
->attr
.oacc_declare_link
= 1;
2058 for (n
= c
->lists
[OMP_LIST_MAP
]; n
!= NULL
; n
= n
->next
)
2060 gfc_symbol
*s
= n
->sym
;
2062 if (s
->ns
->proc_name
&& s
->ns
->proc_name
->attr
.proc
== PROC_MODULE
)
2064 if (n
->u
.map_op
!= OMP_MAP_FORCE_ALLOC
2065 && n
->u
.map_op
!= OMP_MAP_FORCE_TO
)
2067 gfc_error ("Invalid clause in module with !$ACC DECLARE at %L",
2075 if (s
->attr
.use_assoc
)
2077 gfc_error ("Variable is USE-associated with !$ACC DECLARE at %L",
2082 if ((s
->attr
.dimension
|| s
->attr
.codimension
)
2083 && s
->attr
.dummy
&& s
->as
->type
!= AS_EXPLICIT
)
2085 gfc_error ("Assumed-size dummy array with !$ACC DECLARE at %L",
2090 switch (n
->u
.map_op
)
2092 case OMP_MAP_FORCE_ALLOC
:
2093 s
->attr
.oacc_declare_create
= 1;
2096 case OMP_MAP_FORCE_TO
:
2097 s
->attr
.oacc_declare_copyin
= 1;
2100 case OMP_MAP_FORCE_DEVICEPTR
:
2101 s
->attr
.oacc_declare_deviceptr
= 1;
2109 new_oc
= gfc_get_oacc_declare ();
2110 new_oc
->next
= ns
->oacc_declare
;
2111 new_oc
->module_var
= module_var
;
2112 new_oc
->clauses
= c
;
2113 new_oc
->loc
= gfc_current_locus
;
2114 ns
->oacc_declare
= new_oc
;
2121 gfc_match_oacc_update (void)
2124 locus here
= gfc_current_locus
;
2126 if (gfc_match_omp_clauses (&c
, OACC_UPDATE_CLAUSES
, false, false, true)
2130 if (!c
->lists
[OMP_LIST_MAP
])
2132 gfc_error ("%<acc update%> must contain at least one "
2133 "%<device%> or %<host%> or %<self%> clause at %L", &here
);
2137 new_st
.op
= EXEC_OACC_UPDATE
;
2138 new_st
.ext
.omp_clauses
= c
;
2144 gfc_match_oacc_enter_data (void)
2146 return match_acc (EXEC_OACC_ENTER_DATA
, OACC_ENTER_DATA_CLAUSES
);
2151 gfc_match_oacc_exit_data (void)
2153 return match_acc (EXEC_OACC_EXIT_DATA
, OACC_EXIT_DATA_CLAUSES
);
2158 gfc_match_oacc_wait (void)
2160 gfc_omp_clauses
*c
= gfc_get_omp_clauses ();
2161 gfc_expr_list
*wait_list
= NULL
, *el
;
2165 m
= match_oacc_expr_list (" (", &wait_list
, true);
2166 if (m
== MATCH_ERROR
)
2168 else if (m
== MATCH_YES
)
2171 if (gfc_match_omp_clauses (&c
, OACC_WAIT_CLAUSES
, space
, space
, true)
2176 for (el
= wait_list
; el
; el
= el
->next
)
2178 if (el
->expr
== NULL
)
2180 gfc_error ("Invalid argument to !$ACC WAIT at %L",
2181 &wait_list
->expr
->where
);
2185 if (!gfc_resolve_expr (el
->expr
)
2186 || el
->expr
->ts
.type
!= BT_INTEGER
|| el
->expr
->rank
!= 0)
2188 gfc_error ("WAIT clause at %L requires a scalar INTEGER expression",
2194 c
->wait_list
= wait_list
;
2195 new_st
.op
= EXEC_OACC_WAIT
;
2196 new_st
.ext
.omp_clauses
= c
;
2202 gfc_match_oacc_cache (void)
2204 gfc_omp_clauses
*c
= gfc_get_omp_clauses ();
2205 /* The OpenACC cache directive explicitly only allows "array elements or
2206 subarrays", which we're currently not checking here. Either check this
2207 after the call of gfc_match_omp_variable_list, or add something like a
2208 only_sections variant next to its allow_sections parameter. */
2209 match m
= gfc_match_omp_variable_list (" (",
2210 &c
->lists
[OMP_LIST_CACHE
], true,
2214 gfc_free_omp_clauses(c
);
2218 if (gfc_current_state() != COMP_DO
2219 && gfc_current_state() != COMP_DO_CONCURRENT
)
2221 gfc_error ("ACC CACHE directive must be inside of loop %C");
2222 gfc_free_omp_clauses(c
);
2226 new_st
.op
= EXEC_OACC_CACHE
;
2227 new_st
.ext
.omp_clauses
= c
;
2231 /* Determine the loop level for a routine. */
2234 gfc_oacc_routine_dims (gfc_omp_clauses
*clauses
)
2243 level
= GOMP_DIM_GANG
, mask
|= GOMP_DIM_MASK (level
);
2244 if (clauses
->worker
)
2245 level
= GOMP_DIM_WORKER
, mask
|= GOMP_DIM_MASK (level
);
2246 if (clauses
->vector
)
2247 level
= GOMP_DIM_VECTOR
, mask
|= GOMP_DIM_MASK (level
);
2249 level
= GOMP_DIM_MAX
, mask
|= GOMP_DIM_MASK (level
);
2251 if (mask
!= (mask
& -mask
))
2252 gfc_error ("Multiple loop axes specified for routine");
2256 level
= GOMP_DIM_MAX
;
2262 gfc_match_oacc_routine (void)
2265 gfc_symbol
*sym
= NULL
;
2267 gfc_omp_clauses
*c
= NULL
;
2268 gfc_oacc_routine_name
*n
= NULL
;
2270 old_loc
= gfc_current_locus
;
2272 m
= gfc_match (" (");
2274 if (gfc_current_ns
->proc_name
2275 && gfc_current_ns
->proc_name
->attr
.if_source
== IFSRC_IFBODY
2278 gfc_error ("Only the !$ACC ROUTINE form without "
2279 "list is allowed in interface block at %C");
2285 char buffer
[GFC_MAX_SYMBOL_LEN
+ 1];
2288 m
= gfc_match_name (buffer
);
2291 st
= gfc_find_symtree (gfc_current_ns
->sym_root
, buffer
);
2295 if (gfc_current_ns
->proc_name
!= NULL
2296 && strcmp (sym
->name
, gfc_current_ns
->proc_name
->name
) == 0)
2302 && !sym
->attr
.external
2303 && !sym
->attr
.function
2304 && !sym
->attr
.subroutine
))
2306 gfc_error ("Syntax error in !$ACC ROUTINE ( NAME ) at %C, "
2307 "invalid function name %s",
2308 (sym
) ? sym
->name
: buffer
);
2309 gfc_current_locus
= old_loc
;
2315 gfc_error ("Syntax error in !$ACC ROUTINE ( NAME ) at %C");
2316 gfc_current_locus
= old_loc
;
2320 if (gfc_match_char (')') != MATCH_YES
)
2322 gfc_error ("Syntax error in !$ACC ROUTINE ( NAME ) at %C, expecting"
2324 gfc_current_locus
= old_loc
;
2329 if (gfc_match_omp_eos () != MATCH_YES
2330 && (gfc_match_omp_clauses (&c
, OACC_ROUTINE_CLAUSES
, false, false, true)
2336 n
= gfc_get_oacc_routine_name ();
2340 if (gfc_current_ns
->oacc_routine_names
!= NULL
)
2341 n
->next
= gfc_current_ns
->oacc_routine_names
;
2343 gfc_current_ns
->oacc_routine_names
= n
;
2345 else if (gfc_current_ns
->proc_name
)
2347 if (!gfc_add_omp_declare_target (&gfc_current_ns
->proc_name
->attr
,
2348 gfc_current_ns
->proc_name
->name
,
2351 gfc_current_ns
->proc_name
->attr
.oacc_function
2352 = gfc_oacc_routine_dims (c
) + 1;
2357 else if (gfc_current_ns
->oacc_routine
)
2358 gfc_current_ns
->oacc_routine_clauses
= c
;
2360 new_st
.op
= EXEC_OACC_ROUTINE
;
2361 new_st
.ext
.omp_clauses
= c
;
2365 gfc_current_locus
= old_loc
;
2370 #define OMP_PARALLEL_CLAUSES \
2371 (omp_mask (OMP_CLAUSE_PRIVATE) | OMP_CLAUSE_FIRSTPRIVATE \
2372 | OMP_CLAUSE_SHARED | OMP_CLAUSE_COPYIN | OMP_CLAUSE_REDUCTION \
2373 | OMP_CLAUSE_IF | OMP_CLAUSE_NUM_THREADS | OMP_CLAUSE_DEFAULT \
2374 | OMP_CLAUSE_PROC_BIND)
2375 #define OMP_DECLARE_SIMD_CLAUSES \
2376 (omp_mask (OMP_CLAUSE_SIMDLEN) | OMP_CLAUSE_LINEAR \
2377 | OMP_CLAUSE_UNIFORM | OMP_CLAUSE_ALIGNED | OMP_CLAUSE_INBRANCH \
2378 | OMP_CLAUSE_NOTINBRANCH)
2379 #define OMP_DO_CLAUSES \
2380 (omp_mask (OMP_CLAUSE_PRIVATE) | OMP_CLAUSE_FIRSTPRIVATE \
2381 | OMP_CLAUSE_LASTPRIVATE | OMP_CLAUSE_REDUCTION \
2382 | OMP_CLAUSE_SCHEDULE | OMP_CLAUSE_ORDERED | OMP_CLAUSE_COLLAPSE \
2383 | OMP_CLAUSE_LINEAR)
2384 #define OMP_SECTIONS_CLAUSES \
2385 (omp_mask (OMP_CLAUSE_PRIVATE) | OMP_CLAUSE_FIRSTPRIVATE \
2386 | OMP_CLAUSE_LASTPRIVATE | OMP_CLAUSE_REDUCTION)
2387 #define OMP_SIMD_CLAUSES \
2388 (omp_mask (OMP_CLAUSE_PRIVATE) | OMP_CLAUSE_LASTPRIVATE \
2389 | OMP_CLAUSE_REDUCTION | OMP_CLAUSE_COLLAPSE | OMP_CLAUSE_SAFELEN \
2390 | OMP_CLAUSE_LINEAR | OMP_CLAUSE_ALIGNED | OMP_CLAUSE_SIMDLEN)
2391 #define OMP_TASK_CLAUSES \
2392 (omp_mask (OMP_CLAUSE_PRIVATE) | OMP_CLAUSE_FIRSTPRIVATE \
2393 | OMP_CLAUSE_SHARED | OMP_CLAUSE_IF | OMP_CLAUSE_DEFAULT \
2394 | OMP_CLAUSE_UNTIED | OMP_CLAUSE_FINAL | OMP_CLAUSE_MERGEABLE \
2395 | OMP_CLAUSE_DEPEND | OMP_CLAUSE_PRIORITY)
2396 #define OMP_TASKLOOP_CLAUSES \
2397 (omp_mask (OMP_CLAUSE_PRIVATE) | OMP_CLAUSE_FIRSTPRIVATE \
2398 | OMP_CLAUSE_LASTPRIVATE | OMP_CLAUSE_SHARED | OMP_CLAUSE_IF \
2399 | OMP_CLAUSE_DEFAULT | OMP_CLAUSE_UNTIED | OMP_CLAUSE_FINAL \
2400 | OMP_CLAUSE_MERGEABLE | OMP_CLAUSE_PRIORITY | OMP_CLAUSE_GRAINSIZE \
2401 | OMP_CLAUSE_NUM_TASKS | OMP_CLAUSE_COLLAPSE | OMP_CLAUSE_NOGROUP)
2402 #define OMP_TARGET_CLAUSES \
2403 (omp_mask (OMP_CLAUSE_DEVICE) | OMP_CLAUSE_MAP | OMP_CLAUSE_IF \
2404 | OMP_CLAUSE_DEPEND | OMP_CLAUSE_NOWAIT | OMP_CLAUSE_PRIVATE \
2405 | OMP_CLAUSE_FIRSTPRIVATE | OMP_CLAUSE_DEFAULTMAP \
2406 | OMP_CLAUSE_IS_DEVICE_PTR)
2407 #define OMP_TARGET_DATA_CLAUSES \
2408 (omp_mask (OMP_CLAUSE_DEVICE) | OMP_CLAUSE_MAP | OMP_CLAUSE_IF \
2409 | OMP_CLAUSE_USE_DEVICE_PTR)
2410 #define OMP_TARGET_ENTER_DATA_CLAUSES \
2411 (omp_mask (OMP_CLAUSE_DEVICE) | OMP_CLAUSE_MAP | OMP_CLAUSE_IF \
2412 | OMP_CLAUSE_DEPEND | OMP_CLAUSE_NOWAIT)
2413 #define OMP_TARGET_EXIT_DATA_CLAUSES \
2414 (omp_mask (OMP_CLAUSE_DEVICE) | OMP_CLAUSE_MAP | OMP_CLAUSE_IF \
2415 | OMP_CLAUSE_DEPEND | OMP_CLAUSE_NOWAIT)
2416 #define OMP_TARGET_UPDATE_CLAUSES \
2417 (omp_mask (OMP_CLAUSE_DEVICE) | OMP_CLAUSE_IF | OMP_CLAUSE_TO \
2418 | OMP_CLAUSE_FROM | OMP_CLAUSE_DEPEND | OMP_CLAUSE_NOWAIT)
2419 #define OMP_TEAMS_CLAUSES \
2420 (omp_mask (OMP_CLAUSE_NUM_TEAMS) | OMP_CLAUSE_THREAD_LIMIT \
2421 | OMP_CLAUSE_DEFAULT | OMP_CLAUSE_PRIVATE | OMP_CLAUSE_FIRSTPRIVATE \
2422 | OMP_CLAUSE_SHARED | OMP_CLAUSE_REDUCTION)
2423 #define OMP_DISTRIBUTE_CLAUSES \
2424 (omp_mask (OMP_CLAUSE_PRIVATE) | OMP_CLAUSE_FIRSTPRIVATE \
2425 | OMP_CLAUSE_COLLAPSE | OMP_CLAUSE_DIST_SCHEDULE)
2426 #define OMP_SINGLE_CLAUSES \
2427 (omp_mask (OMP_CLAUSE_PRIVATE) | OMP_CLAUSE_FIRSTPRIVATE)
2428 #define OMP_ORDERED_CLAUSES \
2429 (omp_mask (OMP_CLAUSE_THREADS) | OMP_CLAUSE_SIMD)
2430 #define OMP_DECLARE_TARGET_CLAUSES \
2431 (omp_mask (OMP_CLAUSE_TO) | OMP_CLAUSE_LINK)
2435 match_omp (gfc_exec_op op
, const omp_mask mask
)
2438 if (gfc_match_omp_clauses (&c
, mask
) != MATCH_YES
)
2441 new_st
.ext
.omp_clauses
= c
;
2447 gfc_match_omp_critical (void)
2449 char n
[GFC_MAX_SYMBOL_LEN
+1];
2450 gfc_omp_clauses
*c
= NULL
;
2452 if (gfc_match (" ( %n )", n
) != MATCH_YES
)
2455 if (gfc_match_omp_eos () != MATCH_YES
)
2457 gfc_error ("Unexpected junk after $OMP CRITICAL statement at %C");
2461 else if (gfc_match_omp_clauses (&c
, omp_mask (OMP_CLAUSE_HINT
)) != MATCH_YES
)
2464 new_st
.op
= EXEC_OMP_CRITICAL
;
2465 new_st
.ext
.omp_clauses
= c
;
2467 c
->critical_name
= xstrdup (n
);
2473 gfc_match_omp_end_critical (void)
2475 char n
[GFC_MAX_SYMBOL_LEN
+1];
2477 if (gfc_match (" ( %n )", n
) != MATCH_YES
)
2479 if (gfc_match_omp_eos () != MATCH_YES
)
2481 gfc_error ("Unexpected junk after $OMP CRITICAL statement at %C");
2485 new_st
.op
= EXEC_OMP_END_CRITICAL
;
2486 new_st
.ext
.omp_name
= n
[0] ? xstrdup (n
) : NULL
;
2492 gfc_match_omp_distribute (void)
2494 return match_omp (EXEC_OMP_DISTRIBUTE
, OMP_DISTRIBUTE_CLAUSES
);
2499 gfc_match_omp_distribute_parallel_do (void)
2501 return match_omp (EXEC_OMP_DISTRIBUTE_PARALLEL_DO
,
2502 (OMP_DISTRIBUTE_CLAUSES
| OMP_PARALLEL_CLAUSES
2504 & ~(omp_mask (OMP_CLAUSE_ORDERED
))
2505 & ~(omp_mask (OMP_CLAUSE_LINEAR
)));
2510 gfc_match_omp_distribute_parallel_do_simd (void)
2512 return match_omp (EXEC_OMP_DISTRIBUTE_PARALLEL_DO_SIMD
,
2513 (OMP_DISTRIBUTE_CLAUSES
| OMP_PARALLEL_CLAUSES
2514 | OMP_DO_CLAUSES
| OMP_SIMD_CLAUSES
)
2515 & ~(omp_mask (OMP_CLAUSE_ORDERED
)));
2520 gfc_match_omp_distribute_simd (void)
2522 return match_omp (EXEC_OMP_DISTRIBUTE_SIMD
,
2523 OMP_DISTRIBUTE_CLAUSES
| OMP_SIMD_CLAUSES
);
2528 gfc_match_omp_do (void)
2530 return match_omp (EXEC_OMP_DO
, OMP_DO_CLAUSES
);
2535 gfc_match_omp_do_simd (void)
2537 return match_omp (EXEC_OMP_DO_SIMD
, OMP_DO_CLAUSES
| OMP_SIMD_CLAUSES
);
2542 gfc_match_omp_flush (void)
2544 gfc_omp_namelist
*list
= NULL
;
2545 gfc_match_omp_variable_list (" (", &list
, true);
2546 if (gfc_match_omp_eos () != MATCH_YES
)
2548 gfc_error ("Unexpected junk after $OMP FLUSH statement at %C");
2549 gfc_free_omp_namelist (list
);
2552 new_st
.op
= EXEC_OMP_FLUSH
;
2553 new_st
.ext
.omp_namelist
= list
;
2559 gfc_match_omp_declare_simd (void)
2561 locus where
= gfc_current_locus
;
2562 gfc_symbol
*proc_name
;
2564 gfc_omp_declare_simd
*ods
;
2565 bool needs_space
= false;
2567 switch (gfc_match (" ( %s ) ", &proc_name
))
2569 case MATCH_YES
: break;
2570 case MATCH_NO
: proc_name
= NULL
; needs_space
= true; break;
2571 case MATCH_ERROR
: return MATCH_ERROR
;
2574 if (gfc_match_omp_clauses (&c
, OMP_DECLARE_SIMD_CLAUSES
, true,
2575 needs_space
) != MATCH_YES
)
2578 if (gfc_current_ns
->is_block_data
)
2580 gfc_free_omp_clauses (c
);
2584 ods
= gfc_get_omp_declare_simd ();
2586 ods
->proc_name
= proc_name
;
2588 ods
->next
= gfc_current_ns
->omp_declare_simd
;
2589 gfc_current_ns
->omp_declare_simd
= ods
;
2595 match_udr_expr (gfc_symtree
*omp_sym1
, gfc_symtree
*omp_sym2
)
2598 locus old_loc
= gfc_current_locus
;
2599 char sname
[GFC_MAX_SYMBOL_LEN
+ 1];
2601 gfc_namespace
*ns
= gfc_current_ns
;
2602 gfc_expr
*lvalue
= NULL
, *rvalue
= NULL
;
2604 gfc_actual_arglist
*arglist
;
2606 m
= gfc_match (" %v =", &lvalue
);
2608 gfc_current_locus
= old_loc
;
2611 m
= gfc_match (" %e )", &rvalue
);
2614 ns
->code
= gfc_get_code (EXEC_ASSIGN
);
2615 ns
->code
->expr1
= lvalue
;
2616 ns
->code
->expr2
= rvalue
;
2617 ns
->code
->loc
= old_loc
;
2621 gfc_current_locus
= old_loc
;
2622 gfc_free_expr (lvalue
);
2625 m
= gfc_match (" %n", sname
);
2629 if (strcmp (sname
, omp_sym1
->name
) == 0
2630 || strcmp (sname
, omp_sym2
->name
) == 0)
2633 gfc_current_ns
= ns
->parent
;
2634 if (gfc_get_ha_sym_tree (sname
, &st
))
2638 if (sym
->attr
.flavor
!= FL_PROCEDURE
2639 && sym
->attr
.flavor
!= FL_UNKNOWN
)
2642 if (!sym
->attr
.generic
2643 && !sym
->attr
.subroutine
2644 && !sym
->attr
.function
)
2646 if (!(sym
->attr
.external
&& !sym
->attr
.referenced
))
2648 /* ...create a symbol in this scope... */
2649 if (sym
->ns
!= gfc_current_ns
2650 && gfc_get_sym_tree (sname
, NULL
, &st
, false) == 1)
2653 if (sym
!= st
->n
.sym
)
2657 /* ...and then to try to make the symbol into a subroutine. */
2658 if (!gfc_add_subroutine (&sym
->attr
, sym
->name
, NULL
))
2662 gfc_set_sym_referenced (sym
);
2663 gfc_gobble_whitespace ();
2664 if (gfc_peek_ascii_char () != '(')
2667 gfc_current_ns
= ns
;
2668 m
= gfc_match_actual_arglist (1, &arglist
);
2672 if (gfc_match_char (')') != MATCH_YES
)
2675 ns
->code
= gfc_get_code (EXEC_CALL
);
2676 ns
->code
->symtree
= st
;
2677 ns
->code
->ext
.actual
= arglist
;
2678 ns
->code
->loc
= old_loc
;
2683 gfc_omp_udr_predef (gfc_omp_reduction_op rop
, const char *name
,
2684 gfc_typespec
*ts
, const char **n
)
2686 if (!gfc_numeric_ts (ts
) && ts
->type
!= BT_LOGICAL
)
2691 case OMP_REDUCTION_PLUS
:
2692 case OMP_REDUCTION_MINUS
:
2693 case OMP_REDUCTION_TIMES
:
2694 return ts
->type
!= BT_LOGICAL
;
2695 case OMP_REDUCTION_AND
:
2696 case OMP_REDUCTION_OR
:
2697 case OMP_REDUCTION_EQV
:
2698 case OMP_REDUCTION_NEQV
:
2699 return ts
->type
== BT_LOGICAL
;
2700 case OMP_REDUCTION_USER
:
2701 if (name
[0] != '.' && (ts
->type
== BT_INTEGER
|| ts
->type
== BT_REAL
))
2705 gfc_find_symbol (name
, NULL
, 1, &sym
);
2708 if (sym
->attr
.intrinsic
)
2710 else if ((sym
->attr
.flavor
!= FL_UNKNOWN
2711 && sym
->attr
.flavor
!= FL_PROCEDURE
)
2712 || sym
->attr
.external
2713 || sym
->attr
.generic
2717 || sym
->attr
.subroutine
2718 || sym
->attr
.pointer
2720 || sym
->attr
.cray_pointer
2721 || sym
->attr
.cray_pointee
2722 || (sym
->attr
.proc
!= PROC_UNKNOWN
2723 && sym
->attr
.proc
!= PROC_INTRINSIC
)
2724 || sym
->attr
.if_source
!= IFSRC_UNKNOWN
2725 || sym
== sym
->ns
->proc_name
)
2733 && (strcmp (*n
, "max") == 0 || strcmp (*n
, "min") == 0))
2736 && ts
->type
== BT_INTEGER
2737 && (strcmp (*n
, "iand") == 0
2738 || strcmp (*n
, "ior") == 0
2739 || strcmp (*n
, "ieor") == 0))
2750 gfc_omp_udr_find (gfc_symtree
*st
, gfc_typespec
*ts
)
2752 gfc_omp_udr
*omp_udr
;
2757 for (omp_udr
= st
->n
.omp_udr
; omp_udr
; omp_udr
= omp_udr
->next
)
2758 if (omp_udr
->ts
.type
== ts
->type
2759 || ((omp_udr
->ts
.type
== BT_DERIVED
|| omp_udr
->ts
.type
== BT_CLASS
)
2760 && (ts
->type
== BT_DERIVED
|| ts
->type
== BT_CLASS
)))
2762 if (omp_udr
->ts
.type
== BT_DERIVED
|| omp_udr
->ts
.type
== BT_CLASS
)
2764 if (strcmp (omp_udr
->ts
.u
.derived
->name
, ts
->u
.derived
->name
) == 0)
2767 else if (omp_udr
->ts
.kind
== ts
->kind
)
2769 if (omp_udr
->ts
.type
== BT_CHARACTER
)
2771 if (omp_udr
->ts
.u
.cl
->length
== NULL
2772 || ts
->u
.cl
->length
== NULL
)
2774 if (omp_udr
->ts
.u
.cl
->length
->expr_type
!= EXPR_CONSTANT
)
2776 if (ts
->u
.cl
->length
->expr_type
!= EXPR_CONSTANT
)
2778 if (omp_udr
->ts
.u
.cl
->length
->ts
.type
!= BT_INTEGER
)
2780 if (ts
->u
.cl
->length
->ts
.type
!= BT_INTEGER
)
2782 if (gfc_compare_expr (omp_udr
->ts
.u
.cl
->length
,
2783 ts
->u
.cl
->length
, INTRINSIC_EQ
) != 0)
2793 gfc_match_omp_declare_reduction (void)
2796 gfc_intrinsic_op op
;
2797 char name
[GFC_MAX_SYMBOL_LEN
+ 3];
2798 auto_vec
<gfc_typespec
, 5> tss
;
2802 locus where
= gfc_current_locus
;
2803 locus end_loc
= gfc_current_locus
;
2804 bool end_loc_set
= false;
2805 gfc_omp_reduction_op rop
= OMP_REDUCTION_NONE
;
2807 if (gfc_match_char ('(') != MATCH_YES
)
2810 m
= gfc_match (" %o : ", &op
);
2811 if (m
== MATCH_ERROR
)
2815 snprintf (name
, sizeof name
, "operator %s", gfc_op2string (op
));
2816 rop
= (gfc_omp_reduction_op
) op
;
2820 m
= gfc_match_defined_op_name (name
+ 1, 1);
2821 if (m
== MATCH_ERROR
)
2827 if (gfc_match (" : ") != MATCH_YES
)
2832 if (gfc_match (" %n : ", name
) != MATCH_YES
)
2835 rop
= OMP_REDUCTION_USER
;
2838 m
= gfc_match_type_spec (&ts
);
2841 /* Treat len=: the same as len=*. */
2842 if (ts
.type
== BT_CHARACTER
)
2843 ts
.deferred
= false;
2846 while (gfc_match_char (',') == MATCH_YES
)
2848 m
= gfc_match_type_spec (&ts
);
2853 if (gfc_match_char (':') != MATCH_YES
)
2856 st
= gfc_find_symtree (gfc_current_ns
->omp_udr_root
, name
);
2857 for (i
= 0; i
< tss
.length (); i
++)
2859 gfc_symtree
*omp_out
, *omp_in
;
2860 gfc_symtree
*omp_priv
= NULL
, *omp_orig
= NULL
;
2861 gfc_namespace
*combiner_ns
, *initializer_ns
= NULL
;
2862 gfc_omp_udr
*prev_udr
, *omp_udr
;
2863 const char *predef_name
= NULL
;
2865 omp_udr
= gfc_get_omp_udr ();
2866 omp_udr
->name
= gfc_get_string ("%s", name
);
2868 omp_udr
->ts
= tss
[i
];
2869 omp_udr
->where
= where
;
2871 gfc_current_ns
= combiner_ns
= gfc_get_namespace (gfc_current_ns
, 1);
2872 combiner_ns
->proc_name
= combiner_ns
->parent
->proc_name
;
2874 gfc_get_sym_tree ("omp_out", combiner_ns
, &omp_out
, false);
2875 gfc_get_sym_tree ("omp_in", combiner_ns
, &omp_in
, false);
2876 combiner_ns
->omp_udr_ns
= 1;
2877 omp_out
->n
.sym
->ts
= tss
[i
];
2878 omp_in
->n
.sym
->ts
= tss
[i
];
2879 omp_out
->n
.sym
->attr
.omp_udr_artificial_var
= 1;
2880 omp_in
->n
.sym
->attr
.omp_udr_artificial_var
= 1;
2881 omp_out
->n
.sym
->attr
.flavor
= FL_VARIABLE
;
2882 omp_in
->n
.sym
->attr
.flavor
= FL_VARIABLE
;
2883 gfc_commit_symbols ();
2884 omp_udr
->combiner_ns
= combiner_ns
;
2885 omp_udr
->omp_out
= omp_out
->n
.sym
;
2886 omp_udr
->omp_in
= omp_in
->n
.sym
;
2888 locus old_loc
= gfc_current_locus
;
2890 if (!match_udr_expr (omp_out
, omp_in
))
2893 gfc_current_locus
= old_loc
;
2894 gfc_current_ns
= combiner_ns
->parent
;
2895 gfc_undo_symbols ();
2896 gfc_free_omp_udr (omp_udr
);
2900 if (gfc_match (" initializer ( ") == MATCH_YES
)
2902 gfc_current_ns
= combiner_ns
->parent
;
2903 initializer_ns
= gfc_get_namespace (gfc_current_ns
, 1);
2904 gfc_current_ns
= initializer_ns
;
2905 initializer_ns
->proc_name
= initializer_ns
->parent
->proc_name
;
2907 gfc_get_sym_tree ("omp_priv", initializer_ns
, &omp_priv
, false);
2908 gfc_get_sym_tree ("omp_orig", initializer_ns
, &omp_orig
, false);
2909 initializer_ns
->omp_udr_ns
= 1;
2910 omp_priv
->n
.sym
->ts
= tss
[i
];
2911 omp_orig
->n
.sym
->ts
= tss
[i
];
2912 omp_priv
->n
.sym
->attr
.omp_udr_artificial_var
= 1;
2913 omp_orig
->n
.sym
->attr
.omp_udr_artificial_var
= 1;
2914 omp_priv
->n
.sym
->attr
.flavor
= FL_VARIABLE
;
2915 omp_orig
->n
.sym
->attr
.flavor
= FL_VARIABLE
;
2916 gfc_commit_symbols ();
2917 omp_udr
->initializer_ns
= initializer_ns
;
2918 omp_udr
->omp_priv
= omp_priv
->n
.sym
;
2919 omp_udr
->omp_orig
= omp_orig
->n
.sym
;
2921 if (!match_udr_expr (omp_priv
, omp_orig
))
2925 gfc_current_ns
= combiner_ns
->parent
;
2929 end_loc
= gfc_current_locus
;
2931 gfc_current_locus
= old_loc
;
2933 prev_udr
= gfc_omp_udr_find (st
, &tss
[i
]);
2934 if (gfc_omp_udr_predef (rop
, name
, &tss
[i
], &predef_name
)
2935 /* Don't error on !$omp declare reduction (min : integer : ...)
2936 just yet, there could be integer :: min afterwards,
2937 making it valid. When the UDR is resolved, we'll get
2939 && (rop
!= OMP_REDUCTION_USER
|| name
[0] == '.'))
2942 gfc_error_now ("Redefinition of predefined %s "
2943 "!$OMP DECLARE REDUCTION at %L",
2944 predef_name
, &where
);
2946 gfc_error_now ("Redefinition of predefined "
2947 "!$OMP DECLARE REDUCTION at %L", &where
);
2951 gfc_error_now ("Redefinition of !$OMP DECLARE REDUCTION at %L",
2953 gfc_error_now ("Previous !$OMP DECLARE REDUCTION at %L",
2958 omp_udr
->next
= st
->n
.omp_udr
;
2959 st
->n
.omp_udr
= omp_udr
;
2963 st
= gfc_new_symtree (&gfc_current_ns
->omp_udr_root
, name
);
2964 st
->n
.omp_udr
= omp_udr
;
2970 gfc_current_locus
= end_loc
;
2971 if (gfc_match_omp_eos () != MATCH_YES
)
2973 gfc_error ("Unexpected junk after !$OMP DECLARE REDUCTION at %C");
2974 gfc_current_locus
= where
;
2986 gfc_match_omp_declare_target (void)
2990 gfc_omp_clauses
*c
= NULL
;
2992 gfc_omp_namelist
*n
;
2995 old_loc
= gfc_current_locus
;
2997 if (gfc_current_ns
->proc_name
2998 && gfc_match_omp_eos () == MATCH_YES
)
3000 if (!gfc_add_omp_declare_target (&gfc_current_ns
->proc_name
->attr
,
3001 gfc_current_ns
->proc_name
->name
,
3007 if (gfc_current_ns
->proc_name
3008 && gfc_current_ns
->proc_name
->attr
.if_source
== IFSRC_IFBODY
)
3010 gfc_error ("Only the !$OMP DECLARE TARGET form without "
3011 "clauses is allowed in interface block at %C");
3015 m
= gfc_match (" (");
3018 c
= gfc_get_omp_clauses ();
3019 gfc_current_locus
= old_loc
;
3020 m
= gfc_match_omp_to_link (" (", &c
->lists
[OMP_LIST_TO
]);
3023 if (gfc_match_omp_eos () != MATCH_YES
)
3025 gfc_error ("Unexpected junk after !$OMP DECLARE TARGET at %C");
3029 else if (gfc_match_omp_clauses (&c
, OMP_DECLARE_TARGET_CLAUSES
) != MATCH_YES
)
3032 gfc_buffer_error (false);
3034 for (list
= OMP_LIST_TO
; list
!= OMP_LIST_NUM
;
3035 list
= (list
== OMP_LIST_TO
? OMP_LIST_LINK
: OMP_LIST_NUM
))
3036 for (n
= c
->lists
[list
]; n
; n
= n
->next
)
3039 else if (n
->u
.common
->head
)
3040 n
->u
.common
->head
->mark
= 0;
3042 for (list
= OMP_LIST_TO
; list
!= OMP_LIST_NUM
;
3043 list
= (list
== OMP_LIST_TO
? OMP_LIST_LINK
: OMP_LIST_NUM
))
3044 for (n
= c
->lists
[list
]; n
; n
= n
->next
)
3047 if (n
->sym
->attr
.in_common
)
3048 gfc_error_now ("OMP DECLARE TARGET variable at %L is an "
3049 "element of a COMMON block", &n
->where
);
3050 else if (n
->sym
->attr
.omp_declare_target
3051 && n
->sym
->attr
.omp_declare_target_link
3052 && list
!= OMP_LIST_LINK
)
3053 gfc_error_now ("OMP DECLARE TARGET variable at %L previously "
3054 "mentioned in LINK clause and later in TO clause",
3056 else if (n
->sym
->attr
.omp_declare_target
3057 && !n
->sym
->attr
.omp_declare_target_link
3058 && list
== OMP_LIST_LINK
)
3059 gfc_error_now ("OMP DECLARE TARGET variable at %L previously "
3060 "mentioned in TO clause and later in LINK clause",
3062 else if (n
->sym
->mark
)
3063 gfc_error_now ("Variable at %L mentioned multiple times in "
3064 "clauses of the same OMP DECLARE TARGET directive",
3066 else if (gfc_add_omp_declare_target (&n
->sym
->attr
, n
->sym
->name
,
3067 &n
->sym
->declared_at
))
3069 if (list
== OMP_LIST_LINK
)
3070 gfc_add_omp_declare_target_link (&n
->sym
->attr
, n
->sym
->name
,
3071 &n
->sym
->declared_at
);
3075 else if (n
->u
.common
->omp_declare_target
3076 && n
->u
.common
->omp_declare_target_link
3077 && list
!= OMP_LIST_LINK
)
3078 gfc_error_now ("OMP DECLARE TARGET COMMON at %L previously "
3079 "mentioned in LINK clause and later in TO clause",
3081 else if (n
->u
.common
->omp_declare_target
3082 && !n
->u
.common
->omp_declare_target_link
3083 && list
== OMP_LIST_LINK
)
3084 gfc_error_now ("OMP DECLARE TARGET COMMON at %L previously "
3085 "mentioned in TO clause and later in LINK clause",
3087 else if (n
->u
.common
->head
&& n
->u
.common
->head
->mark
)
3088 gfc_error_now ("COMMON at %L mentioned multiple times in "
3089 "clauses of the same OMP DECLARE TARGET directive",
3093 n
->u
.common
->omp_declare_target
= 1;
3094 n
->u
.common
->omp_declare_target_link
= (list
== OMP_LIST_LINK
);
3095 for (s
= n
->u
.common
->head
; s
; s
= s
->common_next
)
3098 if (gfc_add_omp_declare_target (&s
->attr
, s
->name
,
3101 if (list
== OMP_LIST_LINK
)
3102 gfc_add_omp_declare_target_link (&s
->attr
, s
->name
,
3108 gfc_buffer_error (true);
3111 gfc_free_omp_clauses (c
);
3115 gfc_error ("Syntax error in !$OMP DECLARE TARGET list at %C");
3118 gfc_current_locus
= old_loc
;
3120 gfc_free_omp_clauses (c
);
3126 gfc_match_omp_threadprivate (void)
3129 char n
[GFC_MAX_SYMBOL_LEN
+1];
3134 old_loc
= gfc_current_locus
;
3136 m
= gfc_match (" (");
3142 m
= gfc_match_symbol (&sym
, 0);
3146 if (sym
->attr
.in_common
)
3147 gfc_error_now ("Threadprivate variable at %C is an element of "
3149 else if (!gfc_add_threadprivate (&sym
->attr
, sym
->name
, &sym
->declared_at
))
3158 m
= gfc_match (" / %n /", n
);
3159 if (m
== MATCH_ERROR
)
3161 if (m
== MATCH_NO
|| n
[0] == '\0')
3164 st
= gfc_find_symtree (gfc_current_ns
->common_root
, n
);
3167 gfc_error ("COMMON block /%s/ not found at %C", n
);
3170 st
->n
.common
->threadprivate
= 1;
3171 for (sym
= st
->n
.common
->head
; sym
; sym
= sym
->common_next
)
3172 if (!gfc_add_threadprivate (&sym
->attr
, sym
->name
, &sym
->declared_at
))
3176 if (gfc_match_char (')') == MATCH_YES
)
3178 if (gfc_match_char (',') != MATCH_YES
)
3182 if (gfc_match_omp_eos () != MATCH_YES
)
3184 gfc_error ("Unexpected junk after OMP THREADPRIVATE at %C");
3191 gfc_error ("Syntax error in !$OMP THREADPRIVATE list at %C");
3194 gfc_current_locus
= old_loc
;
3200 gfc_match_omp_parallel (void)
3202 return match_omp (EXEC_OMP_PARALLEL
, OMP_PARALLEL_CLAUSES
);
3207 gfc_match_omp_parallel_do (void)
3209 return match_omp (EXEC_OMP_PARALLEL_DO
,
3210 OMP_PARALLEL_CLAUSES
| OMP_DO_CLAUSES
);
3215 gfc_match_omp_parallel_do_simd (void)
3217 return match_omp (EXEC_OMP_PARALLEL_DO_SIMD
,
3218 OMP_PARALLEL_CLAUSES
| OMP_DO_CLAUSES
| OMP_SIMD_CLAUSES
);
3223 gfc_match_omp_parallel_sections (void)
3225 return match_omp (EXEC_OMP_PARALLEL_SECTIONS
,
3226 OMP_PARALLEL_CLAUSES
| OMP_SECTIONS_CLAUSES
);
3231 gfc_match_omp_parallel_workshare (void)
3233 return match_omp (EXEC_OMP_PARALLEL_WORKSHARE
, OMP_PARALLEL_CLAUSES
);
3238 gfc_match_omp_sections (void)
3240 return match_omp (EXEC_OMP_SECTIONS
, OMP_SECTIONS_CLAUSES
);
3245 gfc_match_omp_simd (void)
3247 return match_omp (EXEC_OMP_SIMD
, OMP_SIMD_CLAUSES
);
3252 gfc_match_omp_single (void)
3254 return match_omp (EXEC_OMP_SINGLE
, OMP_SINGLE_CLAUSES
);
3259 gfc_match_omp_target (void)
3261 return match_omp (EXEC_OMP_TARGET
, OMP_TARGET_CLAUSES
);
3266 gfc_match_omp_target_data (void)
3268 return match_omp (EXEC_OMP_TARGET_DATA
, OMP_TARGET_DATA_CLAUSES
);
3273 gfc_match_omp_target_enter_data (void)
3275 return match_omp (EXEC_OMP_TARGET_ENTER_DATA
, OMP_TARGET_ENTER_DATA_CLAUSES
);
3280 gfc_match_omp_target_exit_data (void)
3282 return match_omp (EXEC_OMP_TARGET_EXIT_DATA
, OMP_TARGET_EXIT_DATA_CLAUSES
);
3287 gfc_match_omp_target_parallel (void)
3289 return match_omp (EXEC_OMP_TARGET_PARALLEL
,
3290 (OMP_TARGET_CLAUSES
| OMP_PARALLEL_CLAUSES
)
3291 & ~(omp_mask (OMP_CLAUSE_COPYIN
)));
3296 gfc_match_omp_target_parallel_do (void)
3298 return match_omp (EXEC_OMP_TARGET_PARALLEL_DO
,
3299 (OMP_TARGET_CLAUSES
| OMP_PARALLEL_CLAUSES
3300 | OMP_DO_CLAUSES
) & ~(omp_mask (OMP_CLAUSE_COPYIN
)));
3305 gfc_match_omp_target_parallel_do_simd (void)
3307 return match_omp (EXEC_OMP_TARGET_PARALLEL_DO_SIMD
,
3308 (OMP_TARGET_CLAUSES
| OMP_PARALLEL_CLAUSES
| OMP_DO_CLAUSES
3309 | OMP_SIMD_CLAUSES
) & ~(omp_mask (OMP_CLAUSE_COPYIN
)));
3314 gfc_match_omp_target_simd (void)
3316 return match_omp (EXEC_OMP_TARGET_SIMD
,
3317 OMP_TARGET_CLAUSES
| OMP_SIMD_CLAUSES
);
3322 gfc_match_omp_target_teams (void)
3324 return match_omp (EXEC_OMP_TARGET_TEAMS
,
3325 OMP_TARGET_CLAUSES
| OMP_TEAMS_CLAUSES
);
3330 gfc_match_omp_target_teams_distribute (void)
3332 return match_omp (EXEC_OMP_TARGET_TEAMS_DISTRIBUTE
,
3333 OMP_TARGET_CLAUSES
| OMP_TEAMS_CLAUSES
3334 | OMP_DISTRIBUTE_CLAUSES
);
3339 gfc_match_omp_target_teams_distribute_parallel_do (void)
3341 return match_omp (EXEC_OMP_TARGET_TEAMS_DISTRIBUTE_PARALLEL_DO
,
3342 (OMP_TARGET_CLAUSES
| OMP_TEAMS_CLAUSES
3343 | OMP_DISTRIBUTE_CLAUSES
| OMP_PARALLEL_CLAUSES
3345 & ~(omp_mask (OMP_CLAUSE_ORDERED
))
3346 & ~(omp_mask (OMP_CLAUSE_LINEAR
)));
3351 gfc_match_omp_target_teams_distribute_parallel_do_simd (void)
3353 return match_omp (EXEC_OMP_TARGET_TEAMS_DISTRIBUTE_PARALLEL_DO_SIMD
,
3354 (OMP_TARGET_CLAUSES
| OMP_TEAMS_CLAUSES
3355 | OMP_DISTRIBUTE_CLAUSES
| OMP_PARALLEL_CLAUSES
3356 | OMP_DO_CLAUSES
| OMP_SIMD_CLAUSES
)
3357 & ~(omp_mask (OMP_CLAUSE_ORDERED
)));
3362 gfc_match_omp_target_teams_distribute_simd (void)
3364 return match_omp (EXEC_OMP_TARGET_TEAMS_DISTRIBUTE_SIMD
,
3365 OMP_TARGET_CLAUSES
| OMP_TEAMS_CLAUSES
3366 | OMP_DISTRIBUTE_CLAUSES
| OMP_SIMD_CLAUSES
);
3371 gfc_match_omp_target_update (void)
3373 return match_omp (EXEC_OMP_TARGET_UPDATE
, OMP_TARGET_UPDATE_CLAUSES
);
3378 gfc_match_omp_task (void)
3380 return match_omp (EXEC_OMP_TASK
, OMP_TASK_CLAUSES
);
3385 gfc_match_omp_taskloop (void)
3387 return match_omp (EXEC_OMP_TASKLOOP
, OMP_TASKLOOP_CLAUSES
);
3392 gfc_match_omp_taskloop_simd (void)
3394 return match_omp (EXEC_OMP_TASKLOOP_SIMD
,
3395 (OMP_TASKLOOP_CLAUSES
| OMP_SIMD_CLAUSES
)
3396 & ~(omp_mask (OMP_CLAUSE_REDUCTION
)));
3401 gfc_match_omp_taskwait (void)
3403 if (gfc_match_omp_eos () != MATCH_YES
)
3405 gfc_error ("Unexpected junk after TASKWAIT clause at %C");
3408 new_st
.op
= EXEC_OMP_TASKWAIT
;
3409 new_st
.ext
.omp_clauses
= NULL
;
3415 gfc_match_omp_taskyield (void)
3417 if (gfc_match_omp_eos () != MATCH_YES
)
3419 gfc_error ("Unexpected junk after TASKYIELD clause at %C");
3422 new_st
.op
= EXEC_OMP_TASKYIELD
;
3423 new_st
.ext
.omp_clauses
= NULL
;
3429 gfc_match_omp_teams (void)
3431 return match_omp (EXEC_OMP_TEAMS
, OMP_TEAMS_CLAUSES
);
3436 gfc_match_omp_teams_distribute (void)
3438 return match_omp (EXEC_OMP_TEAMS_DISTRIBUTE
,
3439 OMP_TEAMS_CLAUSES
| OMP_DISTRIBUTE_CLAUSES
);
3444 gfc_match_omp_teams_distribute_parallel_do (void)
3446 return match_omp (EXEC_OMP_TEAMS_DISTRIBUTE_PARALLEL_DO
,
3447 (OMP_TEAMS_CLAUSES
| OMP_DISTRIBUTE_CLAUSES
3448 | OMP_PARALLEL_CLAUSES
| OMP_DO_CLAUSES
)
3449 & ~(omp_mask (OMP_CLAUSE_ORDERED
))
3450 & ~(omp_mask (OMP_CLAUSE_LINEAR
)));
3455 gfc_match_omp_teams_distribute_parallel_do_simd (void)
3457 return match_omp (EXEC_OMP_TEAMS_DISTRIBUTE_PARALLEL_DO_SIMD
,
3458 (OMP_TEAMS_CLAUSES
| OMP_DISTRIBUTE_CLAUSES
3459 | OMP_PARALLEL_CLAUSES
| OMP_DO_CLAUSES
3460 | OMP_SIMD_CLAUSES
) & ~(omp_mask (OMP_CLAUSE_ORDERED
)));
3465 gfc_match_omp_teams_distribute_simd (void)
3467 return match_omp (EXEC_OMP_TEAMS_DISTRIBUTE_SIMD
,
3468 OMP_TEAMS_CLAUSES
| OMP_DISTRIBUTE_CLAUSES
3469 | OMP_SIMD_CLAUSES
);
3474 gfc_match_omp_workshare (void)
3476 if (gfc_match_omp_eos () != MATCH_YES
)
3478 gfc_error ("Unexpected junk after $OMP WORKSHARE statement at %C");
3481 new_st
.op
= EXEC_OMP_WORKSHARE
;
3482 new_st
.ext
.omp_clauses
= gfc_get_omp_clauses ();
3488 gfc_match_omp_master (void)
3490 if (gfc_match_omp_eos () != MATCH_YES
)
3492 gfc_error ("Unexpected junk after $OMP MASTER statement at %C");
3495 new_st
.op
= EXEC_OMP_MASTER
;
3496 new_st
.ext
.omp_clauses
= NULL
;
3502 gfc_match_omp_ordered (void)
3504 return match_omp (EXEC_OMP_ORDERED
, OMP_ORDERED_CLAUSES
);
3509 gfc_match_omp_ordered_depend (void)
3511 return match_omp (EXEC_OMP_ORDERED
, omp_mask (OMP_CLAUSE_DEPEND
));
3516 gfc_match_omp_oacc_atomic (bool omp_p
)
3518 gfc_omp_atomic_op op
= GFC_OMP_ATOMIC_UPDATE
;
3520 if (gfc_match ("% seq_cst") == MATCH_YES
)
3522 locus old_loc
= gfc_current_locus
;
3523 if (seq_cst
&& gfc_match_char (',') == MATCH_YES
)
3526 || gfc_match_space () == MATCH_YES
)
3528 gfc_gobble_whitespace ();
3529 if (gfc_match ("update") == MATCH_YES
)
3530 op
= GFC_OMP_ATOMIC_UPDATE
;
3531 else if (gfc_match ("read") == MATCH_YES
)
3532 op
= GFC_OMP_ATOMIC_READ
;
3533 else if (gfc_match ("write") == MATCH_YES
)
3534 op
= GFC_OMP_ATOMIC_WRITE
;
3535 else if (gfc_match ("capture") == MATCH_YES
)
3536 op
= GFC_OMP_ATOMIC_CAPTURE
;
3540 gfc_current_locus
= old_loc
;
3544 && (gfc_match (", seq_cst") == MATCH_YES
3545 || gfc_match ("% seq_cst") == MATCH_YES
))
3549 if (gfc_match_omp_eos () != MATCH_YES
)
3551 gfc_error ("Unexpected junk after $OMP ATOMIC statement at %C");
3554 new_st
.op
= (omp_p
? EXEC_OMP_ATOMIC
: EXEC_OACC_ATOMIC
);
3556 op
= (gfc_omp_atomic_op
) (op
| GFC_OMP_ATOMIC_SEQ_CST
);
3557 new_st
.ext
.omp_atomic
= op
;
3562 gfc_match_oacc_atomic (void)
3564 return gfc_match_omp_oacc_atomic (false);
3568 gfc_match_omp_atomic (void)
3570 return gfc_match_omp_oacc_atomic (true);
3574 gfc_match_omp_barrier (void)
3576 if (gfc_match_omp_eos () != MATCH_YES
)
3578 gfc_error ("Unexpected junk after $OMP BARRIER statement at %C");
3581 new_st
.op
= EXEC_OMP_BARRIER
;
3582 new_st
.ext
.omp_clauses
= NULL
;
3588 gfc_match_omp_taskgroup (void)
3590 if (gfc_match_omp_eos () != MATCH_YES
)
3592 gfc_error ("Unexpected junk after $OMP TASKGROUP statement at %C");
3595 new_st
.op
= EXEC_OMP_TASKGROUP
;
3600 static enum gfc_omp_cancel_kind
3601 gfc_match_omp_cancel_kind (void)
3603 if (gfc_match_space () != MATCH_YES
)
3604 return OMP_CANCEL_UNKNOWN
;
3605 if (gfc_match ("parallel") == MATCH_YES
)
3606 return OMP_CANCEL_PARALLEL
;
3607 if (gfc_match ("sections") == MATCH_YES
)
3608 return OMP_CANCEL_SECTIONS
;
3609 if (gfc_match ("do") == MATCH_YES
)
3610 return OMP_CANCEL_DO
;
3611 if (gfc_match ("taskgroup") == MATCH_YES
)
3612 return OMP_CANCEL_TASKGROUP
;
3613 return OMP_CANCEL_UNKNOWN
;
3618 gfc_match_omp_cancel (void)
3621 enum gfc_omp_cancel_kind kind
= gfc_match_omp_cancel_kind ();
3622 if (kind
== OMP_CANCEL_UNKNOWN
)
3624 if (gfc_match_omp_clauses (&c
, omp_mask (OMP_CLAUSE_IF
), false) != MATCH_YES
)
3627 new_st
.op
= EXEC_OMP_CANCEL
;
3628 new_st
.ext
.omp_clauses
= c
;
3634 gfc_match_omp_cancellation_point (void)
3637 enum gfc_omp_cancel_kind kind
= gfc_match_omp_cancel_kind ();
3638 if (kind
== OMP_CANCEL_UNKNOWN
)
3640 if (gfc_match_omp_eos () != MATCH_YES
)
3642 gfc_error ("Unexpected junk after $OMP CANCELLATION POINT statement "
3646 c
= gfc_get_omp_clauses ();
3648 new_st
.op
= EXEC_OMP_CANCELLATION_POINT
;
3649 new_st
.ext
.omp_clauses
= c
;
3655 gfc_match_omp_end_nowait (void)
3657 bool nowait
= false;
3658 if (gfc_match ("% nowait") == MATCH_YES
)
3660 if (gfc_match_omp_eos () != MATCH_YES
)
3662 gfc_error ("Unexpected junk after NOWAIT clause at %C");
3665 new_st
.op
= EXEC_OMP_END_NOWAIT
;
3666 new_st
.ext
.omp_bool
= nowait
;
3672 gfc_match_omp_end_single (void)
3675 if (gfc_match ("% nowait") == MATCH_YES
)
3677 new_st
.op
= EXEC_OMP_END_NOWAIT
;
3678 new_st
.ext
.omp_bool
= true;
3681 if (gfc_match_omp_clauses (&c
, omp_mask (OMP_CLAUSE_COPYPRIVATE
))
3684 new_st
.op
= EXEC_OMP_END_SINGLE
;
3685 new_st
.ext
.omp_clauses
= c
;
3691 oacc_is_loop (gfc_code
*code
)
3693 return code
->op
== EXEC_OACC_PARALLEL_LOOP
3694 || code
->op
== EXEC_OACC_KERNELS_LOOP
3695 || code
->op
== EXEC_OACC_LOOP
;
3699 resolve_scalar_int_expr (gfc_expr
*expr
, const char *clause
)
3701 if (!gfc_resolve_expr (expr
)
3702 || expr
->ts
.type
!= BT_INTEGER
3704 gfc_error ("%s clause at %L requires a scalar INTEGER expression",
3705 clause
, &expr
->where
);
3709 resolve_positive_int_expr (gfc_expr
*expr
, const char *clause
)
3711 resolve_scalar_int_expr (expr
, clause
);
3712 if (expr
->expr_type
== EXPR_CONSTANT
3713 && expr
->ts
.type
== BT_INTEGER
3714 && mpz_sgn (expr
->value
.integer
) <= 0)
3715 gfc_warning (0, "INTEGER expression of %s clause at %L must be positive",
3716 clause
, &expr
->where
);
3720 resolve_nonnegative_int_expr (gfc_expr
*expr
, const char *clause
)
3722 resolve_scalar_int_expr (expr
, clause
);
3723 if (expr
->expr_type
== EXPR_CONSTANT
3724 && expr
->ts
.type
== BT_INTEGER
3725 && mpz_sgn (expr
->value
.integer
) < 0)
3726 gfc_warning (0, "INTEGER expression of %s clause at %L must be "
3727 "non-negative", clause
, &expr
->where
);
3730 /* Emits error when symbol is pointer, cray pointer or cray pointee
3731 of derived of polymorphic type. */
3734 check_symbol_not_pointer (gfc_symbol
*sym
, locus loc
, const char *name
)
3736 if (sym
->ts
.type
== BT_DERIVED
&& sym
->attr
.pointer
)
3737 gfc_error ("POINTER object %qs of derived type in %s clause at %L",
3738 sym
->name
, name
, &loc
);
3739 if (sym
->ts
.type
== BT_DERIVED
&& sym
->attr
.cray_pointer
)
3740 gfc_error ("Cray pointer object %qs of derived type in %s clause at %L",
3741 sym
->name
, name
, &loc
);
3742 if (sym
->ts
.type
== BT_DERIVED
&& sym
->attr
.cray_pointee
)
3743 gfc_error ("Cray pointee object %qs of derived type in %s clause at %L",
3744 sym
->name
, name
, &loc
);
3746 if ((sym
->ts
.type
== BT_ASSUMED
&& sym
->attr
.pointer
)
3747 || (sym
->ts
.type
== BT_CLASS
&& CLASS_DATA (sym
)
3748 && CLASS_DATA (sym
)->attr
.pointer
))
3749 gfc_error ("POINTER object %qs of polymorphic type in %s clause at %L",
3750 sym
->name
, name
, &loc
);
3751 if ((sym
->ts
.type
== BT_ASSUMED
&& sym
->attr
.cray_pointer
)
3752 || (sym
->ts
.type
== BT_CLASS
&& CLASS_DATA (sym
)
3753 && CLASS_DATA (sym
)->attr
.cray_pointer
))
3754 gfc_error ("Cray pointer object %qs of polymorphic type in %s clause at %L",
3755 sym
->name
, name
, &loc
);
3756 if ((sym
->ts
.type
== BT_ASSUMED
&& sym
->attr
.cray_pointee
)
3757 || (sym
->ts
.type
== BT_CLASS
&& CLASS_DATA (sym
)
3758 && CLASS_DATA (sym
)->attr
.cray_pointee
))
3759 gfc_error ("Cray pointee object %qs of polymorphic type in %s clause at %L",
3760 sym
->name
, name
, &loc
);
3763 /* Emits error when symbol represents assumed size/rank array. */
3766 check_array_not_assumed (gfc_symbol
*sym
, locus loc
, const char *name
)
3768 if (sym
->as
&& sym
->as
->type
== AS_ASSUMED_SIZE
)
3769 gfc_error ("Assumed size array %qs in %s clause at %L",
3770 sym
->name
, name
, &loc
);
3771 if (sym
->as
&& sym
->as
->type
== AS_ASSUMED_RANK
)
3772 gfc_error ("Assumed rank array %qs in %s clause at %L",
3773 sym
->name
, name
, &loc
);
3774 if (sym
->as
&& sym
->as
->type
== AS_DEFERRED
&& sym
->attr
.pointer
3775 && !sym
->attr
.contiguous
)
3776 gfc_error ("Noncontiguous deferred shape array %qs in %s clause at %L",
3777 sym
->name
, name
, &loc
);
3781 resolve_oacc_data_clauses (gfc_symbol
*sym
, locus loc
, const char *name
)
3783 if (sym
->ts
.type
== BT_DERIVED
&& sym
->attr
.allocatable
)
3784 gfc_error ("ALLOCATABLE object %qs of derived type in %s clause at %L",
3785 sym
->name
, name
, &loc
);
3786 if ((sym
->ts
.type
== BT_ASSUMED
&& sym
->attr
.allocatable
)
3787 || (sym
->ts
.type
== BT_CLASS
&& CLASS_DATA (sym
)
3788 && CLASS_DATA (sym
)->attr
.allocatable
))
3789 gfc_error ("ALLOCATABLE object %qs of polymorphic type "
3790 "in %s clause at %L", sym
->name
, name
, &loc
);
3791 check_symbol_not_pointer (sym
, loc
, name
);
3792 check_array_not_assumed (sym
, loc
, name
);
3796 resolve_oacc_deviceptr_clause (gfc_symbol
*sym
, locus loc
, const char *name
)
3798 if (sym
->attr
.pointer
3799 || (sym
->ts
.type
== BT_CLASS
&& CLASS_DATA (sym
)
3800 && CLASS_DATA (sym
)->attr
.class_pointer
))
3801 gfc_error ("POINTER object %qs in %s clause at %L",
3802 sym
->name
, name
, &loc
);
3803 if (sym
->attr
.cray_pointer
3804 || (sym
->ts
.type
== BT_CLASS
&& CLASS_DATA (sym
)
3805 && CLASS_DATA (sym
)->attr
.cray_pointer
))
3806 gfc_error ("Cray pointer object %qs in %s clause at %L",
3807 sym
->name
, name
, &loc
);
3808 if (sym
->attr
.cray_pointee
3809 || (sym
->ts
.type
== BT_CLASS
&& CLASS_DATA (sym
)
3810 && CLASS_DATA (sym
)->attr
.cray_pointee
))
3811 gfc_error ("Cray pointee object %qs in %s clause at %L",
3812 sym
->name
, name
, &loc
);
3813 if (sym
->attr
.allocatable
3814 || (sym
->ts
.type
== BT_CLASS
&& CLASS_DATA (sym
)
3815 && CLASS_DATA (sym
)->attr
.allocatable
))
3816 gfc_error ("ALLOCATABLE object %qs in %s clause at %L",
3817 sym
->name
, name
, &loc
);
3818 if (sym
->attr
.value
)
3819 gfc_error ("VALUE object %qs in %s clause at %L",
3820 sym
->name
, name
, &loc
);
3821 check_array_not_assumed (sym
, loc
, name
);
3825 struct resolve_omp_udr_callback_data
3827 gfc_symbol
*sym1
, *sym2
;
3832 resolve_omp_udr_callback (gfc_expr
**e
, int *, void *data
)
3834 struct resolve_omp_udr_callback_data
*rcd
3835 = (struct resolve_omp_udr_callback_data
*) data
;
3836 if ((*e
)->expr_type
== EXPR_VARIABLE
3837 && ((*e
)->symtree
->n
.sym
== rcd
->sym1
3838 || (*e
)->symtree
->n
.sym
== rcd
->sym2
))
3840 gfc_ref
*ref
= gfc_get_ref ();
3841 ref
->type
= REF_ARRAY
;
3842 ref
->u
.ar
.where
= (*e
)->where
;
3843 ref
->u
.ar
.as
= (*e
)->symtree
->n
.sym
->as
;
3844 ref
->u
.ar
.type
= AR_FULL
;
3845 ref
->u
.ar
.dimen
= 0;
3846 ref
->next
= (*e
)->ref
;
3854 resolve_omp_udr_callback2 (gfc_expr
**e
, int *, void *)
3856 if ((*e
)->expr_type
== EXPR_FUNCTION
3857 && (*e
)->value
.function
.isym
== NULL
)
3859 gfc_symbol
*sym
= (*e
)->symtree
->n
.sym
;
3860 if (!sym
->attr
.intrinsic
3861 && sym
->attr
.if_source
== IFSRC_UNKNOWN
)
3862 gfc_error ("Implicitly declared function %s used in "
3863 "!$OMP DECLARE REDUCTION at %L", sym
->name
, &(*e
)->where
);
3870 resolve_omp_udr_clause (gfc_omp_namelist
*n
, gfc_namespace
*ns
,
3871 gfc_symbol
*sym1
, gfc_symbol
*sym2
)
3874 gfc_symbol sym1_copy
, sym2_copy
;
3876 if (ns
->code
->op
== EXEC_ASSIGN
)
3878 copy
= gfc_get_code (EXEC_ASSIGN
);
3879 copy
->expr1
= gfc_copy_expr (ns
->code
->expr1
);
3880 copy
->expr2
= gfc_copy_expr (ns
->code
->expr2
);
3884 copy
= gfc_get_code (EXEC_CALL
);
3885 copy
->symtree
= ns
->code
->symtree
;
3886 copy
->ext
.actual
= gfc_copy_actual_arglist (ns
->code
->ext
.actual
);
3888 copy
->loc
= ns
->code
->loc
;
3893 sym1
->name
= sym1_copy
.name
;
3894 sym2
->name
= sym2_copy
.name
;
3895 ns
->proc_name
= ns
->parent
->proc_name
;
3896 if (n
->sym
->attr
.dimension
)
3898 struct resolve_omp_udr_callback_data rcd
;
3901 gfc_code_walker (©
, gfc_dummy_code_callback
,
3902 resolve_omp_udr_callback
, &rcd
);
3904 gfc_resolve_code (copy
, gfc_current_ns
);
3905 if (copy
->op
== EXEC_CALL
&& copy
->resolved_isym
== NULL
)
3907 gfc_symbol
*sym
= copy
->resolved_sym
;
3909 && !sym
->attr
.intrinsic
3910 && sym
->attr
.if_source
== IFSRC_UNKNOWN
)
3911 gfc_error ("Implicitly declared subroutine %s used in "
3912 "!$OMP DECLARE REDUCTION at %L", sym
->name
,
3915 gfc_code_walker (©
, gfc_dummy_code_callback
,
3916 resolve_omp_udr_callback2
, NULL
);
3922 /* OpenMP directive resolving routines. */
3925 resolve_omp_clauses (gfc_code
*code
, gfc_omp_clauses
*omp_clauses
,
3926 gfc_namespace
*ns
, bool openacc
= false)
3928 gfc_omp_namelist
*n
;
3932 bool if_without_mod
= false;
3933 gfc_omp_linear_op linear_op
= OMP_LINEAR_DEFAULT
;
3934 static const char *clause_names
[]
3935 = { "PRIVATE", "FIRSTPRIVATE", "LASTPRIVATE", "COPYPRIVATE", "SHARED",
3936 "COPYIN", "UNIFORM", "ALIGNED", "LINEAR", "DEPEND", "MAP",
3937 "TO", "FROM", "REDUCTION", "DEVICE_RESIDENT", "LINK", "USE_DEVICE",
3938 "CACHE", "IS_DEVICE_PTR", "USE_DEVICE_PTR" };
3940 if (omp_clauses
== NULL
)
3943 if (omp_clauses
->orderedc
&& omp_clauses
->orderedc
< omp_clauses
->collapse
)
3944 gfc_error ("ORDERED clause parameter is less than COLLAPSE at %L",
3947 if (omp_clauses
->if_expr
)
3949 gfc_expr
*expr
= omp_clauses
->if_expr
;
3950 if (!gfc_resolve_expr (expr
)
3951 || expr
->ts
.type
!= BT_LOGICAL
|| expr
->rank
!= 0)
3952 gfc_error ("IF clause at %L requires a scalar LOGICAL expression",
3954 if_without_mod
= true;
3956 for (ifc
= 0; ifc
< OMP_IF_LAST
; ifc
++)
3957 if (omp_clauses
->if_exprs
[ifc
])
3959 gfc_expr
*expr
= omp_clauses
->if_exprs
[ifc
];
3961 if (!gfc_resolve_expr (expr
)
3962 || expr
->ts
.type
!= BT_LOGICAL
|| expr
->rank
!= 0)
3963 gfc_error ("IF clause at %L requires a scalar LOGICAL expression",
3965 else if (if_without_mod
)
3967 gfc_error ("IF clause without modifier at %L used together with "
3968 "IF clauses with modifiers",
3969 &omp_clauses
->if_expr
->where
);
3970 if_without_mod
= false;
3975 case EXEC_OMP_PARALLEL
:
3976 case EXEC_OMP_PARALLEL_DO
:
3977 case EXEC_OMP_PARALLEL_SECTIONS
:
3978 case EXEC_OMP_PARALLEL_WORKSHARE
:
3979 case EXEC_OMP_PARALLEL_DO_SIMD
:
3980 case EXEC_OMP_DISTRIBUTE_PARALLEL_DO
:
3981 case EXEC_OMP_DISTRIBUTE_PARALLEL_DO_SIMD
:
3982 case EXEC_OMP_TEAMS_DISTRIBUTE_PARALLEL_DO
:
3983 case EXEC_OMP_TEAMS_DISTRIBUTE_PARALLEL_DO_SIMD
:
3984 ok
= ifc
== OMP_IF_PARALLEL
;
3988 ok
= ifc
== OMP_IF_TASK
;
3991 case EXEC_OMP_TASKLOOP
:
3992 case EXEC_OMP_TASKLOOP_SIMD
:
3993 ok
= ifc
== OMP_IF_TASKLOOP
;
3996 case EXEC_OMP_TARGET
:
3997 case EXEC_OMP_TARGET_TEAMS
:
3998 case EXEC_OMP_TARGET_TEAMS_DISTRIBUTE
:
3999 case EXEC_OMP_TARGET_TEAMS_DISTRIBUTE_SIMD
:
4000 case EXEC_OMP_TARGET_SIMD
:
4001 ok
= ifc
== OMP_IF_TARGET
;
4004 case EXEC_OMP_TARGET_DATA
:
4005 ok
= ifc
== OMP_IF_TARGET_DATA
;
4008 case EXEC_OMP_TARGET_UPDATE
:
4009 ok
= ifc
== OMP_IF_TARGET_UPDATE
;
4012 case EXEC_OMP_TARGET_ENTER_DATA
:
4013 ok
= ifc
== OMP_IF_TARGET_ENTER_DATA
;
4016 case EXEC_OMP_TARGET_EXIT_DATA
:
4017 ok
= ifc
== OMP_IF_TARGET_EXIT_DATA
;
4020 case EXEC_OMP_TARGET_TEAMS_DISTRIBUTE_PARALLEL_DO
:
4021 case EXEC_OMP_TARGET_TEAMS_DISTRIBUTE_PARALLEL_DO_SIMD
:
4022 case EXEC_OMP_TARGET_PARALLEL
:
4023 case EXEC_OMP_TARGET_PARALLEL_DO
:
4024 case EXEC_OMP_TARGET_PARALLEL_DO_SIMD
:
4025 ok
= ifc
== OMP_IF_TARGET
|| ifc
== OMP_IF_PARALLEL
;
4034 static const char *ifs
[] = {
4041 "TARGET ENTER DATA",
4044 gfc_error ("IF clause modifier %s at %L not appropriate for "
4045 "the current OpenMP construct", ifs
[ifc
], &expr
->where
);
4049 if (omp_clauses
->final_expr
)
4051 gfc_expr
*expr
= omp_clauses
->final_expr
;
4052 if (!gfc_resolve_expr (expr
)
4053 || expr
->ts
.type
!= BT_LOGICAL
|| expr
->rank
!= 0)
4054 gfc_error ("FINAL clause at %L requires a scalar LOGICAL expression",
4057 if (omp_clauses
->num_threads
)
4058 resolve_positive_int_expr (omp_clauses
->num_threads
, "NUM_THREADS");
4059 if (omp_clauses
->chunk_size
)
4061 gfc_expr
*expr
= omp_clauses
->chunk_size
;
4062 if (!gfc_resolve_expr (expr
)
4063 || expr
->ts
.type
!= BT_INTEGER
|| expr
->rank
!= 0)
4064 gfc_error ("SCHEDULE clause's chunk_size at %L requires "
4065 "a scalar INTEGER expression", &expr
->where
);
4066 else if (expr
->expr_type
== EXPR_CONSTANT
4067 && expr
->ts
.type
== BT_INTEGER
4068 && mpz_sgn (expr
->value
.integer
) <= 0)
4069 gfc_warning (0, "INTEGER expression of SCHEDULE clause's chunk_size "
4070 "at %L must be positive", &expr
->where
);
4073 /* Check that no symbol appears on multiple clauses, except that
4074 a symbol can appear on both firstprivate and lastprivate. */
4075 for (list
= 0; list
< OMP_LIST_NUM
; list
++)
4076 for (n
= omp_clauses
->lists
[list
]; n
; n
= n
->next
)
4079 if (n
->sym
->attr
.flavor
== FL_VARIABLE
4080 || n
->sym
->attr
.proc_pointer
4081 || (!code
&& (!n
->sym
->attr
.dummy
|| n
->sym
->ns
!= ns
)))
4083 if (!code
&& (!n
->sym
->attr
.dummy
|| n
->sym
->ns
!= ns
))
4084 gfc_error ("Variable %qs is not a dummy argument at %L",
4085 n
->sym
->name
, &n
->where
);
4088 if (n
->sym
->attr
.flavor
== FL_PROCEDURE
4089 && n
->sym
->result
== n
->sym
4090 && n
->sym
->attr
.function
)
4092 if (gfc_current_ns
->proc_name
== n
->sym
4093 || (gfc_current_ns
->parent
4094 && gfc_current_ns
->parent
->proc_name
== n
->sym
))
4096 if (gfc_current_ns
->proc_name
->attr
.entry_master
)
4098 gfc_entry_list
*el
= gfc_current_ns
->entries
;
4099 for (; el
; el
= el
->next
)
4100 if (el
->sym
== n
->sym
)
4105 if (gfc_current_ns
->parent
4106 && gfc_current_ns
->parent
->proc_name
->attr
.entry_master
)
4108 gfc_entry_list
*el
= gfc_current_ns
->parent
->entries
;
4109 for (; el
; el
= el
->next
)
4110 if (el
->sym
== n
->sym
)
4116 gfc_error ("Object %qs is not a variable at %L", n
->sym
->name
,
4120 for (list
= 0; list
< OMP_LIST_NUM
; list
++)
4121 if (list
!= OMP_LIST_FIRSTPRIVATE
4122 && list
!= OMP_LIST_LASTPRIVATE
4123 && list
!= OMP_LIST_ALIGNED
4124 && list
!= OMP_LIST_DEPEND
4125 && (list
!= OMP_LIST_MAP
|| openacc
)
4126 && list
!= OMP_LIST_FROM
4127 && list
!= OMP_LIST_TO
4128 && (list
!= OMP_LIST_REDUCTION
|| !openacc
))
4129 for (n
= omp_clauses
->lists
[list
]; n
; n
= n
->next
)
4132 gfc_error ("Symbol %qs present on multiple clauses at %L",
4133 n
->sym
->name
, &n
->where
);
4138 gcc_assert (OMP_LIST_LASTPRIVATE
== OMP_LIST_FIRSTPRIVATE
+ 1);
4139 for (list
= OMP_LIST_FIRSTPRIVATE
; list
<= OMP_LIST_LASTPRIVATE
; list
++)
4140 for (n
= omp_clauses
->lists
[list
]; n
; n
= n
->next
)
4143 gfc_error ("Symbol %qs present on multiple clauses at %L",
4144 n
->sym
->name
, &n
->where
);
4148 for (n
= omp_clauses
->lists
[OMP_LIST_FIRSTPRIVATE
]; n
; n
= n
->next
)
4151 gfc_error ("Symbol %qs present on multiple clauses at %L",
4152 n
->sym
->name
, &n
->where
);
4156 for (n
= omp_clauses
->lists
[OMP_LIST_LASTPRIVATE
]; n
; n
= n
->next
)
4159 for (n
= omp_clauses
->lists
[OMP_LIST_LASTPRIVATE
]; n
; n
= n
->next
)
4162 gfc_error ("Symbol %qs present on multiple clauses at %L",
4163 n
->sym
->name
, &n
->where
);
4168 for (n
= omp_clauses
->lists
[OMP_LIST_ALIGNED
]; n
; n
= n
->next
)
4171 for (n
= omp_clauses
->lists
[OMP_LIST_ALIGNED
]; n
; n
= n
->next
)
4174 gfc_error ("Symbol %qs present on multiple clauses at %L",
4175 n
->sym
->name
, &n
->where
);
4180 /* OpenACC reductions. */
4183 for (n
= omp_clauses
->lists
[OMP_LIST_REDUCTION
]; n
; n
= n
->next
)
4186 for (n
= omp_clauses
->lists
[OMP_LIST_REDUCTION
]; n
; n
= n
->next
)
4189 gfc_error ("Symbol %qs present on multiple clauses at %L",
4190 n
->sym
->name
, &n
->where
);
4194 /* OpenACC does not support reductions on arrays. */
4196 gfc_error ("Array %qs is not permitted in reduction at %L",
4197 n
->sym
->name
, &n
->where
);
4201 for (n
= omp_clauses
->lists
[OMP_LIST_TO
]; n
; n
= n
->next
)
4203 for (n
= omp_clauses
->lists
[OMP_LIST_FROM
]; n
; n
= n
->next
)
4204 if (n
->expr
== NULL
)
4206 for (n
= omp_clauses
->lists
[OMP_LIST_TO
]; n
; n
= n
->next
)
4208 if (n
->expr
== NULL
&& n
->sym
->mark
)
4209 gfc_error ("Symbol %qs present on both FROM and TO clauses at %L",
4210 n
->sym
->name
, &n
->where
);
4215 for (list
= 0; list
< OMP_LIST_NUM
; list
++)
4216 if ((n
= omp_clauses
->lists
[list
]) != NULL
)
4220 if (list
< OMP_LIST_NUM
)
4221 name
= clause_names
[list
];
4227 case OMP_LIST_COPYIN
:
4228 for (; n
!= NULL
; n
= n
->next
)
4230 if (!n
->sym
->attr
.threadprivate
)
4231 gfc_error ("Non-THREADPRIVATE object %qs in COPYIN clause"
4232 " at %L", n
->sym
->name
, &n
->where
);
4235 case OMP_LIST_COPYPRIVATE
:
4236 for (; n
!= NULL
; n
= n
->next
)
4238 if (n
->sym
->as
&& n
->sym
->as
->type
== AS_ASSUMED_SIZE
)
4239 gfc_error ("Assumed size array %qs in COPYPRIVATE clause "
4240 "at %L", n
->sym
->name
, &n
->where
);
4241 if (n
->sym
->attr
.pointer
&& n
->sym
->attr
.intent
== INTENT_IN
)
4242 gfc_error ("INTENT(IN) POINTER %qs in COPYPRIVATE clause "
4243 "at %L", n
->sym
->name
, &n
->where
);
4246 case OMP_LIST_SHARED
:
4247 for (; n
!= NULL
; n
= n
->next
)
4249 if (n
->sym
->attr
.threadprivate
)
4250 gfc_error ("THREADPRIVATE object %qs in SHARED clause at "
4251 "%L", n
->sym
->name
, &n
->where
);
4252 if (n
->sym
->attr
.cray_pointee
)
4253 gfc_error ("Cray pointee %qs in SHARED clause at %L",
4254 n
->sym
->name
, &n
->where
);
4255 if (n
->sym
->attr
.associate_var
)
4256 gfc_error ("ASSOCIATE name %qs in SHARED clause at %L",
4257 n
->sym
->name
, &n
->where
);
4260 case OMP_LIST_ALIGNED
:
4261 for (; n
!= NULL
; n
= n
->next
)
4263 if (!n
->sym
->attr
.pointer
4264 && !n
->sym
->attr
.allocatable
4265 && !n
->sym
->attr
.cray_pointer
4266 && (n
->sym
->ts
.type
!= BT_DERIVED
4267 || (n
->sym
->ts
.u
.derived
->from_intmod
4268 != INTMOD_ISO_C_BINDING
)
4269 || (n
->sym
->ts
.u
.derived
->intmod_sym_id
4270 != ISOCBINDING_PTR
)))
4271 gfc_error ("%qs in ALIGNED clause must be POINTER, "
4272 "ALLOCATABLE, Cray pointer or C_PTR at %L",
4273 n
->sym
->name
, &n
->where
);
4276 gfc_expr
*expr
= n
->expr
;
4278 if (!gfc_resolve_expr (expr
)
4279 || expr
->ts
.type
!= BT_INTEGER
4281 || gfc_extract_int (expr
, &alignment
)
4283 gfc_error ("%qs in ALIGNED clause at %L requires a scalar "
4284 "positive constant integer alignment "
4285 "expression", n
->sym
->name
, &n
->where
);
4289 case OMP_LIST_DEPEND
:
4293 case OMP_LIST_CACHE
:
4294 for (; n
!= NULL
; n
= n
->next
)
4296 if (list
== OMP_LIST_DEPEND
)
4298 if (n
->u
.depend_op
== OMP_DEPEND_SINK_FIRST
4299 || n
->u
.depend_op
== OMP_DEPEND_SINK
)
4301 if (code
->op
!= EXEC_OMP_ORDERED
)
4302 gfc_error ("SINK dependence type only allowed "
4303 "on ORDERED directive at %L", &n
->where
);
4304 else if (omp_clauses
->depend_source
)
4306 gfc_error ("DEPEND SINK used together with "
4307 "DEPEND SOURCE on the same construct "
4308 "at %L", &n
->where
);
4309 omp_clauses
->depend_source
= false;
4313 if (!gfc_resolve_expr (n
->expr
)
4314 || n
->expr
->ts
.type
!= BT_INTEGER
4315 || n
->expr
->rank
!= 0)
4316 gfc_error ("SINK addend not a constant integer "
4317 "at %L", &n
->where
);
4321 else if (code
->op
== EXEC_OMP_ORDERED
)
4322 gfc_error ("Only SOURCE or SINK dependence types "
4323 "are allowed on ORDERED directive at %L",
4328 if (!gfc_resolve_expr (n
->expr
)
4329 || n
->expr
->expr_type
!= EXPR_VARIABLE
4330 || n
->expr
->ref
== NULL
4331 || n
->expr
->ref
->next
4332 || n
->expr
->ref
->type
!= REF_ARRAY
)
4333 gfc_error ("%qs in %s clause at %L is not a proper "
4334 "array section", n
->sym
->name
, name
,
4336 else if (n
->expr
->ref
->u
.ar
.codimen
)
4337 gfc_error ("Coarrays not supported in %s clause at %L",
4342 gfc_array_ref
*ar
= &n
->expr
->ref
->u
.ar
;
4343 for (i
= 0; i
< ar
->dimen
; i
++)
4346 gfc_error ("Stride should not be specified for "
4347 "array section in %s clause at %L",
4351 else if (ar
->dimen_type
[i
] != DIMEN_ELEMENT
4352 && ar
->dimen_type
[i
] != DIMEN_RANGE
)
4354 gfc_error ("%qs in %s clause at %L is not a "
4355 "proper array section",
4356 n
->sym
->name
, name
, &n
->where
);
4359 else if (list
== OMP_LIST_DEPEND
4361 && ar
->start
[i
]->expr_type
== EXPR_CONSTANT
4363 && ar
->end
[i
]->expr_type
== EXPR_CONSTANT
4364 && mpz_cmp (ar
->start
[i
]->value
.integer
,
4365 ar
->end
[i
]->value
.integer
) > 0)
4367 gfc_error ("%qs in DEPEND clause at %L is a "
4368 "zero size array section",
4369 n
->sym
->name
, &n
->where
);
4376 if (list
== OMP_LIST_MAP
4377 && n
->u
.map_op
== OMP_MAP_FORCE_DEVICEPTR
)
4378 resolve_oacc_deviceptr_clause (n
->sym
, n
->where
, name
);
4380 resolve_oacc_data_clauses (n
->sym
, n
->where
, name
);
4382 else if (list
!= OMP_LIST_DEPEND
4384 && n
->sym
->as
->type
== AS_ASSUMED_SIZE
)
4385 gfc_error ("Assumed size array %qs in %s clause at %L",
4386 n
->sym
->name
, name
, &n
->where
);
4387 if (list
== OMP_LIST_MAP
&& !openacc
)
4390 case EXEC_OMP_TARGET
:
4391 case EXEC_OMP_TARGET_DATA
:
4392 switch (n
->u
.map_op
)
4395 case OMP_MAP_ALWAYS_TO
:
4397 case OMP_MAP_ALWAYS_FROM
:
4398 case OMP_MAP_TOFROM
:
4399 case OMP_MAP_ALWAYS_TOFROM
:
4403 gfc_error ("TARGET%s with map-type other than TO, "
4404 "FROM, TOFROM, or ALLOC on MAP clause "
4406 code
->op
== EXEC_OMP_TARGET
4407 ? "" : " DATA", &n
->where
);
4411 case EXEC_OMP_TARGET_ENTER_DATA
:
4412 switch (n
->u
.map_op
)
4415 case OMP_MAP_ALWAYS_TO
:
4419 gfc_error ("TARGET ENTER DATA with map-type other "
4420 "than TO, or ALLOC on MAP clause at %L",
4425 case EXEC_OMP_TARGET_EXIT_DATA
:
4426 switch (n
->u
.map_op
)
4429 case OMP_MAP_ALWAYS_FROM
:
4430 case OMP_MAP_RELEASE
:
4431 case OMP_MAP_DELETE
:
4434 gfc_error ("TARGET EXIT DATA with map-type other "
4435 "than FROM, RELEASE, or DELETE on MAP "
4436 "clause at %L", &n
->where
);
4445 if (list
!= OMP_LIST_DEPEND
)
4446 for (n
= omp_clauses
->lists
[list
]; n
!= NULL
; n
= n
->next
)
4448 n
->sym
->attr
.referenced
= 1;
4449 if (n
->sym
->attr
.threadprivate
)
4450 gfc_error ("THREADPRIVATE object %qs in %s clause at %L",
4451 n
->sym
->name
, name
, &n
->where
);
4452 if (n
->sym
->attr
.cray_pointee
)
4453 gfc_error ("Cray pointee %qs in %s clause at %L",
4454 n
->sym
->name
, name
, &n
->where
);
4457 case OMP_LIST_IS_DEVICE_PTR
:
4458 case OMP_LIST_USE_DEVICE_PTR
:
4459 /* FIXME: Handle these. */
4462 for (; n
!= NULL
; n
= n
->next
)
4465 if (n
->sym
->attr
.threadprivate
)
4466 gfc_error ("THREADPRIVATE object %qs in %s clause at %L",
4467 n
->sym
->name
, name
, &n
->where
);
4468 if (n
->sym
->attr
.cray_pointee
)
4469 gfc_error ("Cray pointee %qs in %s clause at %L",
4470 n
->sym
->name
, name
, &n
->where
);
4471 if (n
->sym
->attr
.associate_var
)
4472 gfc_error ("ASSOCIATE name %qs in %s clause at %L",
4473 n
->sym
->name
, name
, &n
->where
);
4474 if (list
!= OMP_LIST_PRIVATE
)
4476 if (n
->sym
->attr
.proc_pointer
&& list
== OMP_LIST_REDUCTION
)
4477 gfc_error ("Procedure pointer %qs in %s clause at %L",
4478 n
->sym
->name
, name
, &n
->where
);
4479 if (n
->sym
->attr
.pointer
&& list
== OMP_LIST_REDUCTION
)
4480 gfc_error ("POINTER object %qs in %s clause at %L",
4481 n
->sym
->name
, name
, &n
->where
);
4482 if (n
->sym
->attr
.cray_pointer
&& list
== OMP_LIST_REDUCTION
)
4483 gfc_error ("Cray pointer %qs in %s clause at %L",
4484 n
->sym
->name
, name
, &n
->where
);
4487 && (oacc_is_loop (code
) || code
->op
== EXEC_OACC_PARALLEL
))
4488 check_array_not_assumed (n
->sym
, n
->where
, name
);
4489 else if (n
->sym
->as
&& n
->sym
->as
->type
== AS_ASSUMED_SIZE
)
4490 gfc_error ("Assumed size array %qs in %s clause at %L",
4491 n
->sym
->name
, name
, &n
->where
);
4492 if (n
->sym
->attr
.in_namelist
&& list
!= OMP_LIST_REDUCTION
)
4493 gfc_error ("Variable %qs in %s clause is used in "
4494 "NAMELIST statement at %L",
4495 n
->sym
->name
, name
, &n
->where
);
4496 if (n
->sym
->attr
.pointer
&& n
->sym
->attr
.intent
== INTENT_IN
)
4499 case OMP_LIST_PRIVATE
:
4500 case OMP_LIST_LASTPRIVATE
:
4501 case OMP_LIST_LINEAR
:
4502 /* case OMP_LIST_REDUCTION: */
4503 gfc_error ("INTENT(IN) POINTER %qs in %s clause at %L",
4504 n
->sym
->name
, name
, &n
->where
);
4512 case OMP_LIST_REDUCTION
:
4513 switch (n
->u
.reduction_op
)
4515 case OMP_REDUCTION_PLUS
:
4516 case OMP_REDUCTION_TIMES
:
4517 case OMP_REDUCTION_MINUS
:
4518 if (!gfc_numeric_ts (&n
->sym
->ts
))
4521 case OMP_REDUCTION_AND
:
4522 case OMP_REDUCTION_OR
:
4523 case OMP_REDUCTION_EQV
:
4524 case OMP_REDUCTION_NEQV
:
4525 if (n
->sym
->ts
.type
!= BT_LOGICAL
)
4528 case OMP_REDUCTION_MAX
:
4529 case OMP_REDUCTION_MIN
:
4530 if (n
->sym
->ts
.type
!= BT_INTEGER
4531 && n
->sym
->ts
.type
!= BT_REAL
)
4534 case OMP_REDUCTION_IAND
:
4535 case OMP_REDUCTION_IOR
:
4536 case OMP_REDUCTION_IEOR
:
4537 if (n
->sym
->ts
.type
!= BT_INTEGER
)
4540 case OMP_REDUCTION_USER
:
4550 const char *udr_name
= NULL
;
4553 udr_name
= n
->udr
->udr
->name
;
4555 = gfc_find_omp_udr (NULL
, udr_name
,
4557 if (n
->udr
->udr
== NULL
)
4565 if (udr_name
== NULL
)
4566 switch (n
->u
.reduction_op
)
4568 case OMP_REDUCTION_PLUS
:
4569 case OMP_REDUCTION_TIMES
:
4570 case OMP_REDUCTION_MINUS
:
4571 case OMP_REDUCTION_AND
:
4572 case OMP_REDUCTION_OR
:
4573 case OMP_REDUCTION_EQV
:
4574 case OMP_REDUCTION_NEQV
:
4575 udr_name
= gfc_op2string ((gfc_intrinsic_op
)
4578 case OMP_REDUCTION_MAX
:
4581 case OMP_REDUCTION_MIN
:
4584 case OMP_REDUCTION_IAND
:
4587 case OMP_REDUCTION_IOR
:
4590 case OMP_REDUCTION_IEOR
:
4596 gfc_error ("!$OMP DECLARE REDUCTION %s not found "
4597 "for type %s at %L", udr_name
,
4598 gfc_typename (&n
->sym
->ts
), &n
->where
);
4602 gfc_omp_udr
*udr
= n
->udr
->udr
;
4603 n
->u
.reduction_op
= OMP_REDUCTION_USER
;
4605 = resolve_omp_udr_clause (n
, udr
->combiner_ns
,
4608 if (udr
->initializer_ns
)
4610 = resolve_omp_udr_clause (n
,
4611 udr
->initializer_ns
,
4617 case OMP_LIST_LINEAR
:
4619 && n
->u
.linear_op
!= OMP_LINEAR_DEFAULT
4620 && n
->u
.linear_op
!= linear_op
)
4622 gfc_error ("LINEAR clause modifier used on DO or SIMD"
4623 " construct at %L", &n
->where
);
4624 linear_op
= n
->u
.linear_op
;
4626 else if (omp_clauses
->orderedc
)
4627 gfc_error ("LINEAR clause specified together with "
4628 "ORDERED clause with argument at %L",
4630 else if (n
->u
.linear_op
!= OMP_LINEAR_REF
4631 && n
->sym
->ts
.type
!= BT_INTEGER
)
4632 gfc_error ("LINEAR variable %qs must be INTEGER "
4633 "at %L", n
->sym
->name
, &n
->where
);
4634 else if ((n
->u
.linear_op
== OMP_LINEAR_REF
4635 || n
->u
.linear_op
== OMP_LINEAR_UVAL
)
4636 && n
->sym
->attr
.value
)
4637 gfc_error ("LINEAR dummy argument %qs with VALUE "
4638 "attribute with %s modifier at %L",
4640 n
->u
.linear_op
== OMP_LINEAR_REF
4641 ? "REF" : "UVAL", &n
->where
);
4644 gfc_expr
*expr
= n
->expr
;
4645 if (!gfc_resolve_expr (expr
)
4646 || expr
->ts
.type
!= BT_INTEGER
4648 gfc_error ("%qs in LINEAR clause at %L requires "
4649 "a scalar integer linear-step expression",
4650 n
->sym
->name
, &n
->where
);
4651 else if (!code
&& expr
->expr_type
!= EXPR_CONSTANT
)
4653 if (expr
->expr_type
== EXPR_VARIABLE
4654 && expr
->symtree
->n
.sym
->attr
.dummy
4655 && expr
->symtree
->n
.sym
->ns
== ns
)
4657 gfc_omp_namelist
*n2
;
4658 for (n2
= omp_clauses
->lists
[OMP_LIST_UNIFORM
];
4660 if (n2
->sym
== expr
->symtree
->n
.sym
)
4665 gfc_error ("%qs in LINEAR clause at %L requires "
4666 "a constant integer linear-step "
4667 "expression or dummy argument "
4668 "specified in UNIFORM clause",
4669 n
->sym
->name
, &n
->where
);
4673 /* Workaround for PR middle-end/26316, nothing really needs
4674 to be done here for OMP_LIST_PRIVATE. */
4675 case OMP_LIST_PRIVATE
:
4676 gcc_assert (code
&& code
->op
!= EXEC_NOP
);
4678 case OMP_LIST_USE_DEVICE
:
4679 if (n
->sym
->attr
.allocatable
4680 || (n
->sym
->ts
.type
== BT_CLASS
&& CLASS_DATA (n
->sym
)
4681 && CLASS_DATA (n
->sym
)->attr
.allocatable
))
4682 gfc_error ("ALLOCATABLE object %qs in %s clause at %L",
4683 n
->sym
->name
, name
, &n
->where
);
4684 if (n
->sym
->ts
.type
== BT_CLASS
4685 && CLASS_DATA (n
->sym
)
4686 && CLASS_DATA (n
->sym
)->attr
.class_pointer
)
4687 gfc_error ("POINTER object %qs of polymorphic type in "
4688 "%s clause at %L", n
->sym
->name
, name
,
4690 if (n
->sym
->attr
.cray_pointer
)
4691 gfc_error ("Cray pointer object %qs in %s clause at %L",
4692 n
->sym
->name
, name
, &n
->where
);
4693 else if (n
->sym
->attr
.cray_pointee
)
4694 gfc_error ("Cray pointee object %qs in %s clause at %L",
4695 n
->sym
->name
, name
, &n
->where
);
4696 else if (n
->sym
->attr
.flavor
== FL_VARIABLE
4698 && !n
->sym
->attr
.pointer
)
4699 gfc_error ("%s clause variable %qs at %L is neither "
4700 "a POINTER nor an array", name
,
4701 n
->sym
->name
, &n
->where
);
4703 case OMP_LIST_DEVICE_RESIDENT
:
4704 check_symbol_not_pointer (n
->sym
, n
->where
, name
);
4705 check_array_not_assumed (n
->sym
, n
->where
, name
);
4714 if (omp_clauses
->safelen_expr
)
4715 resolve_positive_int_expr (omp_clauses
->safelen_expr
, "SAFELEN");
4716 if (omp_clauses
->simdlen_expr
)
4717 resolve_positive_int_expr (omp_clauses
->simdlen_expr
, "SIMDLEN");
4718 if (omp_clauses
->num_teams
)
4719 resolve_positive_int_expr (omp_clauses
->num_teams
, "NUM_TEAMS");
4720 if (omp_clauses
->device
)
4721 resolve_nonnegative_int_expr (omp_clauses
->device
, "DEVICE");
4722 if (omp_clauses
->hint
)
4723 resolve_scalar_int_expr (omp_clauses
->hint
, "HINT");
4724 if (omp_clauses
->priority
)
4725 resolve_nonnegative_int_expr (omp_clauses
->priority
, "PRIORITY");
4726 if (omp_clauses
->dist_chunk_size
)
4728 gfc_expr
*expr
= omp_clauses
->dist_chunk_size
;
4729 if (!gfc_resolve_expr (expr
)
4730 || expr
->ts
.type
!= BT_INTEGER
|| expr
->rank
!= 0)
4731 gfc_error ("DIST_SCHEDULE clause's chunk_size at %L requires "
4732 "a scalar INTEGER expression", &expr
->where
);
4734 if (omp_clauses
->thread_limit
)
4735 resolve_positive_int_expr (omp_clauses
->thread_limit
, "THREAD_LIMIT");
4736 if (omp_clauses
->grainsize
)
4737 resolve_positive_int_expr (omp_clauses
->grainsize
, "GRAINSIZE");
4738 if (omp_clauses
->num_tasks
)
4739 resolve_positive_int_expr (omp_clauses
->num_tasks
, "NUM_TASKS");
4740 if (omp_clauses
->async
)
4741 if (omp_clauses
->async_expr
)
4742 resolve_scalar_int_expr (omp_clauses
->async_expr
, "ASYNC");
4743 if (omp_clauses
->num_gangs_expr
)
4744 resolve_positive_int_expr (omp_clauses
->num_gangs_expr
, "NUM_GANGS");
4745 if (omp_clauses
->num_workers_expr
)
4746 resolve_positive_int_expr (omp_clauses
->num_workers_expr
, "NUM_WORKERS");
4747 if (omp_clauses
->vector_length_expr
)
4748 resolve_positive_int_expr (omp_clauses
->vector_length_expr
,
4750 if (omp_clauses
->gang_num_expr
)
4751 resolve_positive_int_expr (omp_clauses
->gang_num_expr
, "GANG");
4752 if (omp_clauses
->gang_static_expr
)
4753 resolve_positive_int_expr (omp_clauses
->gang_static_expr
, "GANG");
4754 if (omp_clauses
->worker_expr
)
4755 resolve_positive_int_expr (omp_clauses
->worker_expr
, "WORKER");
4756 if (omp_clauses
->vector_expr
)
4757 resolve_positive_int_expr (omp_clauses
->vector_expr
, "VECTOR");
4758 if (omp_clauses
->wait
)
4759 if (omp_clauses
->wait_list
)
4760 for (el
= omp_clauses
->wait_list
; el
; el
= el
->next
)
4761 resolve_scalar_int_expr (el
->expr
, "WAIT");
4762 if (omp_clauses
->collapse
&& omp_clauses
->tile_list
)
4763 gfc_error ("Incompatible use of TILE and COLLAPSE at %L", &code
->loc
);
4764 if (omp_clauses
->depend_source
&& code
->op
!= EXEC_OMP_ORDERED
)
4765 gfc_error ("SOURCE dependence type only allowed "
4766 "on ORDERED directive at %L", &code
->loc
);
4767 if (!openacc
&& code
&& omp_clauses
->lists
[OMP_LIST_MAP
] == NULL
)
4769 const char *p
= NULL
;
4772 case EXEC_OMP_TARGET_DATA
: p
= "TARGET DATA"; break;
4773 case EXEC_OMP_TARGET_ENTER_DATA
: p
= "TARGET ENTER DATA"; break;
4774 case EXEC_OMP_TARGET_EXIT_DATA
: p
= "TARGET EXIT DATA"; break;
4778 gfc_error ("%s must contain at least one MAP clause at %L",
4784 /* Return true if SYM is ever referenced in EXPR except in the SE node. */
4787 expr_references_sym (gfc_expr
*e
, gfc_symbol
*s
, gfc_expr
*se
)
4789 gfc_actual_arglist
*arg
;
4790 if (e
== NULL
|| e
== se
)
4792 switch (e
->expr_type
)
4797 case EXPR_STRUCTURE
:
4799 if (e
->symtree
!= NULL
4800 && e
->symtree
->n
.sym
== s
)
4803 case EXPR_SUBSTRING
:
4805 && (expr_references_sym (e
->ref
->u
.ss
.start
, s
, se
)
4806 || expr_references_sym (e
->ref
->u
.ss
.end
, s
, se
)))
4810 if (expr_references_sym (e
->value
.op
.op2
, s
, se
))
4812 return expr_references_sym (e
->value
.op
.op1
, s
, se
);
4814 for (arg
= e
->value
.function
.actual
; arg
; arg
= arg
->next
)
4815 if (expr_references_sym (arg
->expr
, s
, se
))
4824 /* If EXPR is a conversion function that widens the type
4825 if WIDENING is true or narrows the type if WIDENING is false,
4826 return the inner expression, otherwise return NULL. */
4829 is_conversion (gfc_expr
*expr
, bool widening
)
4831 gfc_typespec
*ts1
, *ts2
;
4833 if (expr
->expr_type
!= EXPR_FUNCTION
4834 || expr
->value
.function
.isym
== NULL
4835 || expr
->value
.function
.esym
!= NULL
4836 || expr
->value
.function
.isym
->id
!= GFC_ISYM_CONVERSION
)
4842 ts2
= &expr
->value
.function
.actual
->expr
->ts
;
4846 ts1
= &expr
->value
.function
.actual
->expr
->ts
;
4850 if (ts1
->type
> ts2
->type
4851 || (ts1
->type
== ts2
->type
&& ts1
->kind
> ts2
->kind
))
4852 return expr
->value
.function
.actual
->expr
;
4859 resolve_omp_atomic (gfc_code
*code
)
4861 gfc_code
*atomic_code
= code
;
4863 gfc_expr
*expr2
, *expr2_tmp
;
4864 gfc_omp_atomic_op aop
4865 = (gfc_omp_atomic_op
) (atomic_code
->ext
.omp_atomic
& GFC_OMP_ATOMIC_MASK
);
4867 code
= code
->block
->next
;
4868 /* resolve_blocks asserts this is initially EXEC_ASSIGN.
4869 If it changed to EXEC_NOP, assume an error has been emitted already. */
4870 if (code
->op
== EXEC_NOP
)
4872 if (code
->op
!= EXEC_ASSIGN
)
4875 gfc_error ("unexpected !$OMP ATOMIC expression at %L", &code
->loc
);
4878 if (aop
!= GFC_OMP_ATOMIC_CAPTURE
)
4880 if (code
->next
!= NULL
)
4885 if (code
->next
== NULL
)
4887 if (code
->next
->op
== EXEC_NOP
)
4889 if (code
->next
->op
!= EXEC_ASSIGN
|| code
->next
->next
)
4896 if (code
->expr1
->expr_type
!= EXPR_VARIABLE
4897 || code
->expr1
->symtree
== NULL
4898 || code
->expr1
->rank
!= 0
4899 || (code
->expr1
->ts
.type
!= BT_INTEGER
4900 && code
->expr1
->ts
.type
!= BT_REAL
4901 && code
->expr1
->ts
.type
!= BT_COMPLEX
4902 && code
->expr1
->ts
.type
!= BT_LOGICAL
))
4904 gfc_error ("!$OMP ATOMIC statement must set a scalar variable of "
4905 "intrinsic type at %L", &code
->loc
);
4909 var
= code
->expr1
->symtree
->n
.sym
;
4910 expr2
= is_conversion (code
->expr2
, false);
4913 if (aop
== GFC_OMP_ATOMIC_READ
|| aop
== GFC_OMP_ATOMIC_WRITE
)
4914 expr2
= is_conversion (code
->expr2
, true);
4916 expr2
= code
->expr2
;
4921 case GFC_OMP_ATOMIC_READ
:
4922 if (expr2
->expr_type
!= EXPR_VARIABLE
4923 || expr2
->symtree
== NULL
4925 || (expr2
->ts
.type
!= BT_INTEGER
4926 && expr2
->ts
.type
!= BT_REAL
4927 && expr2
->ts
.type
!= BT_COMPLEX
4928 && expr2
->ts
.type
!= BT_LOGICAL
))
4929 gfc_error ("!$OMP ATOMIC READ statement must read from a scalar "
4930 "variable of intrinsic type at %L", &expr2
->where
);
4932 case GFC_OMP_ATOMIC_WRITE
:
4933 if (expr2
->rank
!= 0 || expr_references_sym (code
->expr2
, var
, NULL
))
4934 gfc_error ("expr in !$OMP ATOMIC WRITE assignment var = expr "
4935 "must be scalar and cannot reference var at %L",
4938 case GFC_OMP_ATOMIC_CAPTURE
:
4940 if (expr2
== code
->expr2
)
4942 expr2_tmp
= is_conversion (code
->expr2
, true);
4943 if (expr2_tmp
== NULL
)
4946 if (expr2_tmp
->expr_type
== EXPR_VARIABLE
)
4948 if (expr2_tmp
->symtree
== NULL
4949 || expr2_tmp
->rank
!= 0
4950 || (expr2_tmp
->ts
.type
!= BT_INTEGER
4951 && expr2_tmp
->ts
.type
!= BT_REAL
4952 && expr2_tmp
->ts
.type
!= BT_COMPLEX
4953 && expr2_tmp
->ts
.type
!= BT_LOGICAL
)
4954 || expr2_tmp
->symtree
->n
.sym
== var
)
4956 gfc_error ("!$OMP ATOMIC CAPTURE capture statement must read from "
4957 "a scalar variable of intrinsic type at %L",
4961 var
= expr2_tmp
->symtree
->n
.sym
;
4963 if (code
->expr1
->expr_type
!= EXPR_VARIABLE
4964 || code
->expr1
->symtree
== NULL
4965 || code
->expr1
->rank
!= 0
4966 || (code
->expr1
->ts
.type
!= BT_INTEGER
4967 && code
->expr1
->ts
.type
!= BT_REAL
4968 && code
->expr1
->ts
.type
!= BT_COMPLEX
4969 && code
->expr1
->ts
.type
!= BT_LOGICAL
))
4971 gfc_error ("!$OMP ATOMIC CAPTURE update statement must set "
4972 "a scalar variable of intrinsic type at %L",
4973 &code
->expr1
->where
);
4976 if (code
->expr1
->symtree
->n
.sym
!= var
)
4978 gfc_error ("!$OMP ATOMIC CAPTURE capture statement reads from "
4979 "different variable than update statement writes "
4980 "into at %L", &code
->expr1
->where
);
4983 expr2
= is_conversion (code
->expr2
, false);
4985 expr2
= code
->expr2
;
4992 if (gfc_expr_attr (code
->expr1
).allocatable
)
4994 gfc_error ("!$OMP ATOMIC with ALLOCATABLE variable at %L",
4999 if (aop
== GFC_OMP_ATOMIC_CAPTURE
5000 && code
->next
== NULL
5001 && code
->expr2
->rank
== 0
5002 && !expr_references_sym (code
->expr2
, var
, NULL
))
5003 atomic_code
->ext
.omp_atomic
5004 = (gfc_omp_atomic_op
) (atomic_code
->ext
.omp_atomic
5005 | GFC_OMP_ATOMIC_SWAP
);
5006 else if (expr2
->expr_type
== EXPR_OP
)
5008 gfc_expr
*v
= NULL
, *e
, *c
;
5009 gfc_intrinsic_op op
= expr2
->value
.op
.op
;
5010 gfc_intrinsic_op alt_op
= INTRINSIC_NONE
;
5014 case INTRINSIC_PLUS
:
5015 alt_op
= INTRINSIC_MINUS
;
5017 case INTRINSIC_TIMES
:
5018 alt_op
= INTRINSIC_DIVIDE
;
5020 case INTRINSIC_MINUS
:
5021 alt_op
= INTRINSIC_PLUS
;
5023 case INTRINSIC_DIVIDE
:
5024 alt_op
= INTRINSIC_TIMES
;
5030 alt_op
= INTRINSIC_NEQV
;
5032 case INTRINSIC_NEQV
:
5033 alt_op
= INTRINSIC_EQV
;
5036 gfc_error ("!$OMP ATOMIC assignment operator must be binary "
5037 "+, *, -, /, .AND., .OR., .EQV. or .NEQV. at %L",
5042 /* Check for var = var op expr resp. var = expr op var where
5043 expr doesn't reference var and var op expr is mathematically
5044 equivalent to var op (expr) resp. expr op var equivalent to
5045 (expr) op var. We rely here on the fact that the matcher
5046 for x op1 y op2 z where op1 and op2 have equal precedence
5047 returns (x op1 y) op2 z. */
5048 e
= expr2
->value
.op
.op2
;
5049 if (e
->expr_type
== EXPR_VARIABLE
5050 && e
->symtree
!= NULL
5051 && e
->symtree
->n
.sym
== var
)
5053 else if ((c
= is_conversion (e
, true)) != NULL
5054 && c
->expr_type
== EXPR_VARIABLE
5055 && c
->symtree
!= NULL
5056 && c
->symtree
->n
.sym
== var
)
5060 gfc_expr
**p
= NULL
, **q
;
5061 for (q
= &expr2
->value
.op
.op1
; (e
= *q
) != NULL
; )
5062 if (e
->expr_type
== EXPR_VARIABLE
5063 && e
->symtree
!= NULL
5064 && e
->symtree
->n
.sym
== var
)
5069 else if ((c
= is_conversion (e
, true)) != NULL
)
5070 q
= &e
->value
.function
.actual
->expr
;
5071 else if (e
->expr_type
!= EXPR_OP
5072 || (e
->value
.op
.op
!= op
5073 && e
->value
.op
.op
!= alt_op
)
5079 q
= &e
->value
.op
.op1
;
5084 gfc_error ("!$OMP ATOMIC assignment must be var = var op expr "
5085 "or var = expr op var at %L", &expr2
->where
);
5092 switch (e
->value
.op
.op
)
5094 case INTRINSIC_MINUS
:
5095 case INTRINSIC_DIVIDE
:
5097 case INTRINSIC_NEQV
:
5098 gfc_error ("!$OMP ATOMIC var = var op expr not "
5099 "mathematically equivalent to var = var op "
5100 "(expr) at %L", &expr2
->where
);
5106 /* Canonicalize into var = var op (expr). */
5107 *p
= e
->value
.op
.op2
;
5108 e
->value
.op
.op2
= expr2
;
5110 if (code
->expr2
== expr2
)
5111 code
->expr2
= expr2
= e
;
5113 code
->expr2
->value
.function
.actual
->expr
= expr2
= e
;
5115 if (!gfc_compare_types (&expr2
->value
.op
.op1
->ts
, &expr2
->ts
))
5117 for (p
= &expr2
->value
.op
.op1
; *p
!= v
;
5118 p
= &(*p
)->value
.function
.actual
->expr
)
5121 gfc_free_expr (expr2
->value
.op
.op1
);
5122 expr2
->value
.op
.op1
= v
;
5123 gfc_convert_type (v
, &expr2
->ts
, 2);
5128 if (e
->rank
!= 0 || expr_references_sym (code
->expr2
, var
, v
))
5130 gfc_error ("expr in !$OMP ATOMIC assignment var = var op expr "
5131 "must be scalar and cannot reference var at %L",
5136 else if (expr2
->expr_type
== EXPR_FUNCTION
5137 && expr2
->value
.function
.isym
!= NULL
5138 && expr2
->value
.function
.esym
== NULL
5139 && expr2
->value
.function
.actual
!= NULL
5140 && expr2
->value
.function
.actual
->next
!= NULL
)
5142 gfc_actual_arglist
*arg
, *var_arg
;
5144 switch (expr2
->value
.function
.isym
->id
)
5152 if (expr2
->value
.function
.actual
->next
->next
!= NULL
)
5154 gfc_error ("!$OMP ATOMIC assignment intrinsic IAND, IOR "
5155 "or IEOR must have two arguments at %L",
5161 gfc_error ("!$OMP ATOMIC assignment intrinsic must be "
5162 "MIN, MAX, IAND, IOR or IEOR at %L",
5168 for (arg
= expr2
->value
.function
.actual
; arg
; arg
= arg
->next
)
5170 if ((arg
== expr2
->value
.function
.actual
5171 || (var_arg
== NULL
&& arg
->next
== NULL
))
5172 && arg
->expr
->expr_type
== EXPR_VARIABLE
5173 && arg
->expr
->symtree
!= NULL
5174 && arg
->expr
->symtree
->n
.sym
== var
)
5176 else if (expr_references_sym (arg
->expr
, var
, NULL
))
5178 gfc_error ("!$OMP ATOMIC intrinsic arguments except one must "
5179 "not reference %qs at %L",
5180 var
->name
, &arg
->expr
->where
);
5183 if (arg
->expr
->rank
!= 0)
5185 gfc_error ("!$OMP ATOMIC intrinsic arguments must be scalar "
5186 "at %L", &arg
->expr
->where
);
5191 if (var_arg
== NULL
)
5193 gfc_error ("First or last !$OMP ATOMIC intrinsic argument must "
5194 "be %qs at %L", var
->name
, &expr2
->where
);
5198 if (var_arg
!= expr2
->value
.function
.actual
)
5200 /* Canonicalize, so that var comes first. */
5201 gcc_assert (var_arg
->next
== NULL
);
5202 for (arg
= expr2
->value
.function
.actual
;
5203 arg
->next
!= var_arg
; arg
= arg
->next
)
5205 var_arg
->next
= expr2
->value
.function
.actual
;
5206 expr2
->value
.function
.actual
= var_arg
;
5211 gfc_error ("!$OMP ATOMIC assignment must have an operator or "
5212 "intrinsic on right hand side at %L", &expr2
->where
);
5214 if (aop
== GFC_OMP_ATOMIC_CAPTURE
&& code
->next
)
5217 if (code
->expr1
->expr_type
!= EXPR_VARIABLE
5218 || code
->expr1
->symtree
== NULL
5219 || code
->expr1
->rank
!= 0
5220 || (code
->expr1
->ts
.type
!= BT_INTEGER
5221 && code
->expr1
->ts
.type
!= BT_REAL
5222 && code
->expr1
->ts
.type
!= BT_COMPLEX
5223 && code
->expr1
->ts
.type
!= BT_LOGICAL
))
5225 gfc_error ("!$OMP ATOMIC CAPTURE capture statement must set "
5226 "a scalar variable of intrinsic type at %L",
5227 &code
->expr1
->where
);
5231 expr2
= is_conversion (code
->expr2
, false);
5234 expr2
= is_conversion (code
->expr2
, true);
5236 expr2
= code
->expr2
;
5239 if (expr2
->expr_type
!= EXPR_VARIABLE
5240 || expr2
->symtree
== NULL
5242 || (expr2
->ts
.type
!= BT_INTEGER
5243 && expr2
->ts
.type
!= BT_REAL
5244 && expr2
->ts
.type
!= BT_COMPLEX
5245 && expr2
->ts
.type
!= BT_LOGICAL
))
5247 gfc_error ("!$OMP ATOMIC CAPTURE capture statement must read "
5248 "from a scalar variable of intrinsic type at %L",
5252 if (expr2
->symtree
->n
.sym
!= var
)
5254 gfc_error ("!$OMP ATOMIC CAPTURE capture statement reads from "
5255 "different variable than update statement writes "
5256 "into at %L", &expr2
->where
);
5263 static struct fortran_omp_context
5266 hash_set
<gfc_symbol
*> *sharing_clauses
;
5267 hash_set
<gfc_symbol
*> *private_iterators
;
5268 struct fortran_omp_context
*previous
;
5271 static gfc_code
*omp_current_do_code
;
5272 static int omp_current_do_collapse
;
5275 gfc_resolve_omp_do_blocks (gfc_code
*code
, gfc_namespace
*ns
)
5277 if (code
->block
->next
&& code
->block
->next
->op
== EXEC_DO
)
5282 omp_current_do_code
= code
->block
->next
;
5283 if (code
->ext
.omp_clauses
->orderedc
)
5284 omp_current_do_collapse
= code
->ext
.omp_clauses
->orderedc
;
5286 omp_current_do_collapse
= code
->ext
.omp_clauses
->collapse
;
5287 for (i
= 1, c
= omp_current_do_code
; i
< omp_current_do_collapse
; i
++)
5290 if (c
->op
!= EXEC_DO
|| c
->next
== NULL
)
5293 if (c
->op
!= EXEC_DO
)
5296 if (i
< omp_current_do_collapse
|| omp_current_do_collapse
<= 0)
5297 omp_current_do_collapse
= 1;
5299 gfc_resolve_blocks (code
->block
, ns
);
5300 omp_current_do_collapse
= 0;
5301 omp_current_do_code
= NULL
;
5306 gfc_resolve_omp_parallel_blocks (gfc_code
*code
, gfc_namespace
*ns
)
5308 struct fortran_omp_context ctx
;
5309 gfc_omp_clauses
*omp_clauses
= code
->ext
.omp_clauses
;
5310 gfc_omp_namelist
*n
;
5314 ctx
.sharing_clauses
= new hash_set
<gfc_symbol
*>;
5315 ctx
.private_iterators
= new hash_set
<gfc_symbol
*>;
5316 ctx
.previous
= omp_current_ctx
;
5317 ctx
.is_openmp
= true;
5318 omp_current_ctx
= &ctx
;
5320 for (list
= 0; list
< OMP_LIST_NUM
; list
++)
5323 case OMP_LIST_SHARED
:
5324 case OMP_LIST_PRIVATE
:
5325 case OMP_LIST_FIRSTPRIVATE
:
5326 case OMP_LIST_LASTPRIVATE
:
5327 case OMP_LIST_REDUCTION
:
5328 case OMP_LIST_LINEAR
:
5329 for (n
= omp_clauses
->lists
[list
]; n
; n
= n
->next
)
5330 ctx
.sharing_clauses
->add (n
->sym
);
5338 case EXEC_OMP_PARALLEL_DO
:
5339 case EXEC_OMP_PARALLEL_DO_SIMD
:
5340 case EXEC_OMP_TARGET_PARALLEL_DO
:
5341 case EXEC_OMP_TARGET_PARALLEL_DO_SIMD
:
5342 case EXEC_OMP_TARGET_TEAMS_DISTRIBUTE
:
5343 case EXEC_OMP_TARGET_TEAMS_DISTRIBUTE_PARALLEL_DO
:
5344 case EXEC_OMP_TARGET_TEAMS_DISTRIBUTE_PARALLEL_DO_SIMD
:
5345 case EXEC_OMP_TARGET_TEAMS_DISTRIBUTE_SIMD
:
5346 case EXEC_OMP_TASKLOOP
:
5347 case EXEC_OMP_TASKLOOP_SIMD
:
5348 case EXEC_OMP_TEAMS_DISTRIBUTE
:
5349 case EXEC_OMP_TEAMS_DISTRIBUTE_PARALLEL_DO
:
5350 case EXEC_OMP_TEAMS_DISTRIBUTE_PARALLEL_DO_SIMD
:
5351 case EXEC_OMP_TEAMS_DISTRIBUTE_SIMD
:
5352 gfc_resolve_omp_do_blocks (code
, ns
);
5355 gfc_resolve_blocks (code
->block
, ns
);
5358 omp_current_ctx
= ctx
.previous
;
5359 delete ctx
.sharing_clauses
;
5360 delete ctx
.private_iterators
;
5364 /* Save and clear openmp.c private state. */
5367 gfc_omp_save_and_clear_state (struct gfc_omp_saved_state
*state
)
5369 state
->ptrs
[0] = omp_current_ctx
;
5370 state
->ptrs
[1] = omp_current_do_code
;
5371 state
->ints
[0] = omp_current_do_collapse
;
5372 omp_current_ctx
= NULL
;
5373 omp_current_do_code
= NULL
;
5374 omp_current_do_collapse
= 0;
5378 /* Restore openmp.c private state from the saved state. */
5381 gfc_omp_restore_state (struct gfc_omp_saved_state
*state
)
5383 omp_current_ctx
= (struct fortran_omp_context
*) state
->ptrs
[0];
5384 omp_current_do_code
= (gfc_code
*) state
->ptrs
[1];
5385 omp_current_do_collapse
= state
->ints
[0];
5389 /* Note a DO iterator variable. This is special in !$omp parallel
5390 construct, where they are predetermined private. */
5393 gfc_resolve_do_iterator (gfc_code
*code
, gfc_symbol
*sym
, bool add_clause
)
5395 if (omp_current_ctx
== NULL
)
5398 int i
= omp_current_do_collapse
;
5399 gfc_code
*c
= omp_current_do_code
;
5401 if (sym
->attr
.threadprivate
)
5404 /* !$omp do and !$omp parallel do iteration variable is predetermined
5405 private just in the !$omp do resp. !$omp parallel do construct,
5406 with no implications for the outer parallel constructs. */
5416 /* An openacc context may represent a data clause. Abort if so. */
5417 if (!omp_current_ctx
->is_openmp
&& !oacc_is_loop (omp_current_ctx
->code
))
5420 if (omp_current_ctx
->is_openmp
5421 && omp_current_ctx
->sharing_clauses
->contains (sym
))
5424 if (! omp_current_ctx
->private_iterators
->add (sym
) && add_clause
)
5426 gfc_omp_clauses
*omp_clauses
= omp_current_ctx
->code
->ext
.omp_clauses
;
5427 gfc_omp_namelist
*p
;
5429 p
= gfc_get_omp_namelist ();
5431 p
->next
= omp_clauses
->lists
[OMP_LIST_PRIVATE
];
5432 omp_clauses
->lists
[OMP_LIST_PRIVATE
] = p
;
5437 handle_local_var (gfc_symbol
*sym
)
5439 if (sym
->attr
.flavor
!= FL_VARIABLE
5441 || (sym
->ts
.type
!= BT_INTEGER
&& sym
->ts
.type
!= BT_REAL
))
5443 gfc_resolve_do_iterator (sym
->ns
->code
, sym
, false);
5447 gfc_resolve_omp_local_vars (gfc_namespace
*ns
)
5449 if (omp_current_ctx
)
5450 gfc_traverse_ns (ns
, handle_local_var
);
5454 resolve_omp_do (gfc_code
*code
)
5456 gfc_code
*do_code
, *c
;
5457 int list
, i
, collapse
;
5458 gfc_omp_namelist
*n
;
5461 bool is_simd
= false;
5465 case EXEC_OMP_DISTRIBUTE
: name
= "!$OMP DISTRIBUTE"; break;
5466 case EXEC_OMP_DISTRIBUTE_PARALLEL_DO
:
5467 name
= "!$OMP DISTRIBUTE PARALLEL DO";
5469 case EXEC_OMP_DISTRIBUTE_PARALLEL_DO_SIMD
:
5470 name
= "!$OMP DISTRIBUTE PARALLEL DO SIMD";
5473 case EXEC_OMP_DISTRIBUTE_SIMD
:
5474 name
= "!$OMP DISTRIBUTE SIMD";
5477 case EXEC_OMP_DO
: name
= "!$OMP DO"; break;
5478 case EXEC_OMP_DO_SIMD
: name
= "!$OMP DO SIMD"; is_simd
= true; break;
5479 case EXEC_OMP_PARALLEL_DO
: name
= "!$OMP PARALLEL DO"; break;
5480 case EXEC_OMP_PARALLEL_DO_SIMD
:
5481 name
= "!$OMP PARALLEL DO SIMD";
5484 case EXEC_OMP_SIMD
: name
= "!$OMP SIMD"; is_simd
= true; break;
5485 case EXEC_OMP_TARGET_PARALLEL_DO
: name
= "!$OMP TARGET PARALLEL DO"; break;
5486 case EXEC_OMP_TARGET_PARALLEL_DO_SIMD
:
5487 name
= "!$OMP TARGET PARALLEL DO SIMD";
5490 case EXEC_OMP_TARGET_SIMD
:
5491 name
= "!$OMP TARGET SIMD";
5494 case EXEC_OMP_TARGET_TEAMS_DISTRIBUTE
:
5495 name
= "!$OMP TARGET TEAMS DISTRIBUTE";
5497 case EXEC_OMP_TARGET_TEAMS_DISTRIBUTE_PARALLEL_DO
:
5498 name
= "!$OMP TARGET TEAMS DISTRIBUTE PARALLEL DO";
5500 case EXEC_OMP_TARGET_TEAMS_DISTRIBUTE_PARALLEL_DO_SIMD
:
5501 name
= "!$OMP TARGET TEAMS DISTRIBUTE PARALLEL DO SIMD";
5504 case EXEC_OMP_TARGET_TEAMS_DISTRIBUTE_SIMD
:
5505 name
= "!$OMP TARGET TEAMS DISTRIBUTE SIMD";
5508 case EXEC_OMP_TASKLOOP
: name
= "!$OMP TASKLOOP"; break;
5509 case EXEC_OMP_TASKLOOP_SIMD
:
5510 name
= "!$OMP TASKLOOP SIMD";
5513 case EXEC_OMP_TEAMS_DISTRIBUTE
: name
= "!$OMP TEAMS DISTRIBUTE"; break;
5514 case EXEC_OMP_TEAMS_DISTRIBUTE_PARALLEL_DO
:
5515 name
= "!$OMP TEAMS DISTRIBUTE PARALLEL DO";
5517 case EXEC_OMP_TEAMS_DISTRIBUTE_PARALLEL_DO_SIMD
:
5518 name
= "!$OMP TEAMS DISTRIBUTE PARALLEL DO SIMD";
5521 case EXEC_OMP_TEAMS_DISTRIBUTE_SIMD
:
5522 name
= "!$OMP TEAMS DISTRIBUTE SIMD";
5525 default: gcc_unreachable ();
5528 if (code
->ext
.omp_clauses
)
5529 resolve_omp_clauses (code
, code
->ext
.omp_clauses
, NULL
);
5531 do_code
= code
->block
->next
;
5532 if (code
->ext
.omp_clauses
->orderedc
)
5533 collapse
= code
->ext
.omp_clauses
->orderedc
;
5536 collapse
= code
->ext
.omp_clauses
->collapse
;
5540 for (i
= 1; i
<= collapse
; i
++)
5542 if (do_code
->op
== EXEC_DO_WHILE
)
5544 gfc_error ("%s cannot be a DO WHILE or DO without loop control "
5545 "at %L", name
, &do_code
->loc
);
5548 if (do_code
->op
== EXEC_DO_CONCURRENT
)
5550 gfc_error ("%s cannot be a DO CONCURRENT loop at %L", name
,
5554 gcc_assert (do_code
->op
== EXEC_DO
);
5555 if (do_code
->ext
.iterator
->var
->ts
.type
!= BT_INTEGER
)
5556 gfc_error ("%s iteration variable must be of type integer at %L",
5557 name
, &do_code
->loc
);
5558 dovar
= do_code
->ext
.iterator
->var
->symtree
->n
.sym
;
5559 if (dovar
->attr
.threadprivate
)
5560 gfc_error ("%s iteration variable must not be THREADPRIVATE "
5561 "at %L", name
, &do_code
->loc
);
5562 if (code
->ext
.omp_clauses
)
5563 for (list
= 0; list
< OMP_LIST_NUM
; list
++)
5565 ? (list
!= OMP_LIST_PRIVATE
&& list
!= OMP_LIST_LASTPRIVATE
)
5566 : code
->ext
.omp_clauses
->collapse
> 1
5567 ? (list
!= OMP_LIST_LASTPRIVATE
)
5568 : (list
!= OMP_LIST_LINEAR
))
5569 for (n
= code
->ext
.omp_clauses
->lists
[list
]; n
; n
= n
->next
)
5570 if (dovar
== n
->sym
)
5573 gfc_error ("%s iteration variable present on clause "
5574 "other than PRIVATE or LASTPRIVATE at %L",
5575 name
, &do_code
->loc
);
5576 else if (code
->ext
.omp_clauses
->collapse
> 1)
5577 gfc_error ("%s iteration variable present on clause "
5578 "other than LASTPRIVATE at %L",
5579 name
, &do_code
->loc
);
5581 gfc_error ("%s iteration variable present on clause "
5582 "other than LINEAR at %L",
5583 name
, &do_code
->loc
);
5588 gfc_code
*do_code2
= code
->block
->next
;
5591 for (j
= 1; j
< i
; j
++)
5593 gfc_symbol
*ivar
= do_code2
->ext
.iterator
->var
->symtree
->n
.sym
;
5595 || gfc_find_sym_in_expr (ivar
, do_code
->ext
.iterator
->start
)
5596 || gfc_find_sym_in_expr (ivar
, do_code
->ext
.iterator
->end
)
5597 || gfc_find_sym_in_expr (ivar
, do_code
->ext
.iterator
->step
))
5599 gfc_error ("%s collapsed loops don't form rectangular "
5600 "iteration space at %L", name
, &do_code
->loc
);
5605 do_code2
= do_code2
->block
->next
;
5610 for (c
= do_code
->next
; c
; c
= c
->next
)
5611 if (c
->op
!= EXEC_NOP
&& c
->op
!= EXEC_CONTINUE
)
5613 gfc_error ("collapsed %s loops not perfectly nested at %L",
5619 do_code
= do_code
->block
;
5620 if (do_code
->op
!= EXEC_DO
&& do_code
->op
!= EXEC_DO_WHILE
)
5622 gfc_error ("not enough DO loops for collapsed %s at %L",
5626 do_code
= do_code
->next
;
5628 || (do_code
->op
!= EXEC_DO
&& do_code
->op
!= EXEC_DO_WHILE
))
5630 gfc_error ("not enough DO loops for collapsed %s at %L",
5638 oacc_is_parallel (gfc_code
*code
)
5640 return code
->op
== EXEC_OACC_PARALLEL
|| code
->op
== EXEC_OACC_PARALLEL_LOOP
;
5644 oacc_is_kernels (gfc_code
*code
)
5646 return code
->op
== EXEC_OACC_KERNELS
|| code
->op
== EXEC_OACC_KERNELS_LOOP
;
5649 static gfc_statement
5650 omp_code_to_statement (gfc_code
*code
)
5654 case EXEC_OMP_PARALLEL
:
5655 return ST_OMP_PARALLEL
;
5656 case EXEC_OMP_PARALLEL_SECTIONS
:
5657 return ST_OMP_PARALLEL_SECTIONS
;
5658 case EXEC_OMP_SECTIONS
:
5659 return ST_OMP_SECTIONS
;
5660 case EXEC_OMP_ORDERED
:
5661 return ST_OMP_ORDERED
;
5662 case EXEC_OMP_CRITICAL
:
5663 return ST_OMP_CRITICAL
;
5664 case EXEC_OMP_MASTER
:
5665 return ST_OMP_MASTER
;
5666 case EXEC_OMP_SINGLE
:
5667 return ST_OMP_SINGLE
;
5670 case EXEC_OMP_WORKSHARE
:
5671 return ST_OMP_WORKSHARE
;
5672 case EXEC_OMP_PARALLEL_WORKSHARE
:
5673 return ST_OMP_PARALLEL_WORKSHARE
;
5681 static gfc_statement
5682 oacc_code_to_statement (gfc_code
*code
)
5686 case EXEC_OACC_PARALLEL
:
5687 return ST_OACC_PARALLEL
;
5688 case EXEC_OACC_KERNELS
:
5689 return ST_OACC_KERNELS
;
5690 case EXEC_OACC_DATA
:
5691 return ST_OACC_DATA
;
5692 case EXEC_OACC_HOST_DATA
:
5693 return ST_OACC_HOST_DATA
;
5694 case EXEC_OACC_PARALLEL_LOOP
:
5695 return ST_OACC_PARALLEL_LOOP
;
5696 case EXEC_OACC_KERNELS_LOOP
:
5697 return ST_OACC_KERNELS_LOOP
;
5698 case EXEC_OACC_LOOP
:
5699 return ST_OACC_LOOP
;
5700 case EXEC_OACC_ATOMIC
:
5701 return ST_OACC_ATOMIC
;
5708 resolve_oacc_directive_inside_omp_region (gfc_code
*code
)
5710 if (omp_current_ctx
!= NULL
&& omp_current_ctx
->is_openmp
)
5712 gfc_statement st
= omp_code_to_statement (omp_current_ctx
->code
);
5713 gfc_statement oacc_st
= oacc_code_to_statement (code
);
5714 gfc_error ("The %s directive cannot be specified within "
5715 "a %s region at %L", gfc_ascii_statement (oacc_st
),
5716 gfc_ascii_statement (st
), &code
->loc
);
5721 resolve_omp_directive_inside_oacc_region (gfc_code
*code
)
5723 if (omp_current_ctx
!= NULL
&& !omp_current_ctx
->is_openmp
)
5725 gfc_statement st
= oacc_code_to_statement (omp_current_ctx
->code
);
5726 gfc_statement omp_st
= omp_code_to_statement (code
);
5727 gfc_error ("The %s directive cannot be specified within "
5728 "a %s region at %L", gfc_ascii_statement (omp_st
),
5729 gfc_ascii_statement (st
), &code
->loc
);
5735 resolve_oacc_nested_loops (gfc_code
*code
, gfc_code
* do_code
, int collapse
,
5742 for (i
= 1; i
<= collapse
; i
++)
5744 if (do_code
->op
== EXEC_DO_WHILE
)
5746 gfc_error ("!$ACC LOOP cannot be a DO WHILE or DO without loop control "
5747 "at %L", &do_code
->loc
);
5750 gcc_assert (do_code
->op
== EXEC_DO
|| do_code
->op
== EXEC_DO_CONCURRENT
);
5751 if (do_code
->ext
.iterator
->var
->ts
.type
!= BT_INTEGER
)
5752 gfc_error ("!$ACC LOOP iteration variable must be of type integer at %L",
5754 dovar
= do_code
->ext
.iterator
->var
->symtree
->n
.sym
;
5757 gfc_code
*do_code2
= code
->block
->next
;
5760 for (j
= 1; j
< i
; j
++)
5762 gfc_symbol
*ivar
= do_code2
->ext
.iterator
->var
->symtree
->n
.sym
;
5764 || gfc_find_sym_in_expr (ivar
, do_code
->ext
.iterator
->start
)
5765 || gfc_find_sym_in_expr (ivar
, do_code
->ext
.iterator
->end
)
5766 || gfc_find_sym_in_expr (ivar
, do_code
->ext
.iterator
->step
))
5768 gfc_error ("!$ACC LOOP %s loops don't form rectangular iteration space at %L",
5769 clause
, &do_code
->loc
);
5774 do_code2
= do_code2
->block
->next
;
5779 for (c
= do_code
->next
; c
; c
= c
->next
)
5780 if (c
->op
!= EXEC_NOP
&& c
->op
!= EXEC_CONTINUE
)
5782 gfc_error ("%s !$ACC LOOP loops not perfectly nested at %L",
5788 do_code
= do_code
->block
;
5789 if (do_code
->op
!= EXEC_DO
&& do_code
->op
!= EXEC_DO_WHILE
5790 && do_code
->op
!= EXEC_DO_CONCURRENT
)
5792 gfc_error ("not enough DO loops for %s !$ACC LOOP at %L",
5793 clause
, &code
->loc
);
5796 do_code
= do_code
->next
;
5798 || (do_code
->op
!= EXEC_DO
&& do_code
->op
!= EXEC_DO_WHILE
5799 && do_code
->op
!= EXEC_DO_CONCURRENT
))
5801 gfc_error ("not enough DO loops for %s !$ACC LOOP at %L",
5802 clause
, &code
->loc
);
5810 resolve_oacc_params_in_parallel (gfc_code
*code
, const char *clause
,
5813 fortran_omp_context
*c
;
5815 if (oacc_is_parallel (code
))
5816 gfc_error ("!$ACC LOOP %s in PARALLEL region doesn't allow "
5817 "%s arguments at %L", clause
, arg
, &code
->loc
);
5818 for (c
= omp_current_ctx
; c
; c
= c
->previous
)
5820 if (oacc_is_loop (c
->code
))
5822 if (oacc_is_parallel (c
->code
))
5823 gfc_error ("!$ACC LOOP %s in PARALLEL region doesn't allow "
5824 "%s arguments at %L", clause
, arg
, &code
->loc
);
5830 resolve_oacc_loop_blocks (gfc_code
*code
)
5832 fortran_omp_context
*c
;
5834 if (!oacc_is_loop (code
))
5837 if (code
->op
== EXEC_OACC_LOOP
)
5838 for (c
= omp_current_ctx
; c
; c
= c
->previous
)
5840 if (oacc_is_loop (c
->code
))
5842 if (code
->ext
.omp_clauses
->gang
)
5844 if (c
->code
->ext
.omp_clauses
->gang
)
5845 gfc_error ("Loop parallelized across gangs is not allowed "
5846 "inside another loop parallelized across gangs at %L",
5848 if (c
->code
->ext
.omp_clauses
->worker
)
5849 gfc_error ("Loop parallelized across gangs is not allowed "
5850 "inside loop parallelized across workers at %L",
5852 if (c
->code
->ext
.omp_clauses
->vector
)
5853 gfc_error ("Loop parallelized across gangs is not allowed "
5854 "inside loop parallelized across workers at %L",
5857 if (code
->ext
.omp_clauses
->worker
)
5859 if (c
->code
->ext
.omp_clauses
->worker
)
5860 gfc_error ("Loop parallelized across workers is not allowed "
5861 "inside another loop parallelized across workers at %L",
5863 if (c
->code
->ext
.omp_clauses
->vector
)
5864 gfc_error ("Loop parallelized across workers is not allowed "
5865 "inside another loop parallelized across vectors at %L",
5868 if (code
->ext
.omp_clauses
->vector
)
5869 if (c
->code
->ext
.omp_clauses
->vector
)
5870 gfc_error ("Loop parallelized across vectors is not allowed "
5871 "inside another loop parallelized across vectors at %L",
5875 if (oacc_is_parallel (c
->code
) || oacc_is_kernels (c
->code
))
5879 if (code
->ext
.omp_clauses
->seq
)
5881 if (code
->ext
.omp_clauses
->independent
)
5882 gfc_error ("Clause SEQ conflicts with INDEPENDENT at %L", &code
->loc
);
5883 if (code
->ext
.omp_clauses
->gang
)
5884 gfc_error ("Clause SEQ conflicts with GANG at %L", &code
->loc
);
5885 if (code
->ext
.omp_clauses
->worker
)
5886 gfc_error ("Clause SEQ conflicts with WORKER at %L", &code
->loc
);
5887 if (code
->ext
.omp_clauses
->vector
)
5888 gfc_error ("Clause SEQ conflicts with VECTOR at %L", &code
->loc
);
5889 if (code
->ext
.omp_clauses
->par_auto
)
5890 gfc_error ("Clause SEQ conflicts with AUTO at %L", &code
->loc
);
5892 if (code
->ext
.omp_clauses
->par_auto
)
5894 if (code
->ext
.omp_clauses
->gang
)
5895 gfc_error ("Clause AUTO conflicts with GANG at %L", &code
->loc
);
5896 if (code
->ext
.omp_clauses
->worker
)
5897 gfc_error ("Clause AUTO conflicts with WORKER at %L", &code
->loc
);
5898 if (code
->ext
.omp_clauses
->vector
)
5899 gfc_error ("Clause AUTO conflicts with VECTOR at %L", &code
->loc
);
5901 if (code
->ext
.omp_clauses
->tile_list
&& code
->ext
.omp_clauses
->gang
5902 && code
->ext
.omp_clauses
->worker
&& code
->ext
.omp_clauses
->vector
)
5903 gfc_error ("Tiled loop cannot be parallelized across gangs, workers and "
5904 "vectors at the same time at %L", &code
->loc
);
5906 if (code
->ext
.omp_clauses
->gang
5907 && code
->ext
.omp_clauses
->gang_num_expr
)
5908 resolve_oacc_params_in_parallel (code
, "GANG", "num");
5910 if (code
->ext
.omp_clauses
->worker
5911 && code
->ext
.omp_clauses
->worker_expr
)
5912 resolve_oacc_params_in_parallel (code
, "WORKER", "num");
5914 if (code
->ext
.omp_clauses
->vector
5915 && code
->ext
.omp_clauses
->vector_expr
)
5916 resolve_oacc_params_in_parallel (code
, "VECTOR", "length");
5918 if (code
->ext
.omp_clauses
->tile_list
)
5922 for (el
= code
->ext
.omp_clauses
->tile_list
; el
; el
= el
->next
)
5925 if (el
->expr
== NULL
)
5927 /* NULL expressions are used to represent '*' arguments.
5928 Convert those to a 0 expressions. */
5929 el
->expr
= gfc_get_constant_expr (BT_INTEGER
,
5930 gfc_default_integer_kind
,
5932 mpz_set_si (el
->expr
->value
.integer
, 0);
5936 resolve_positive_int_expr (el
->expr
, "TILE");
5937 if (el
->expr
->expr_type
!= EXPR_CONSTANT
)
5938 gfc_error ("TILE requires constant expression at %L",
5942 resolve_oacc_nested_loops (code
, code
->block
->next
, num
, "tiled");
5948 gfc_resolve_oacc_blocks (gfc_code
*code
, gfc_namespace
*ns
)
5950 fortran_omp_context ctx
;
5952 resolve_oacc_loop_blocks (code
);
5955 ctx
.sharing_clauses
= NULL
;
5956 ctx
.private_iterators
= new hash_set
<gfc_symbol
*>;
5957 ctx
.previous
= omp_current_ctx
;
5958 ctx
.is_openmp
= false;
5959 omp_current_ctx
= &ctx
;
5961 gfc_resolve_blocks (code
->block
, ns
);
5963 omp_current_ctx
= ctx
.previous
;
5964 delete ctx
.private_iterators
;
5969 resolve_oacc_loop (gfc_code
*code
)
5974 if (code
->ext
.omp_clauses
)
5975 resolve_omp_clauses (code
, code
->ext
.omp_clauses
, NULL
, true);
5977 do_code
= code
->block
->next
;
5978 collapse
= code
->ext
.omp_clauses
->collapse
;
5982 resolve_oacc_nested_loops (code
, do_code
, collapse
, "collapsed");
5986 gfc_resolve_oacc_declare (gfc_namespace
*ns
)
5989 gfc_omp_namelist
*n
;
5990 gfc_oacc_declare
*oc
;
5992 if (ns
->oacc_declare
== NULL
)
5995 for (oc
= ns
->oacc_declare
; oc
; oc
= oc
->next
)
5997 for (list
= 0; list
< OMP_LIST_NUM
; list
++)
5998 for (n
= oc
->clauses
->lists
[list
]; n
; n
= n
->next
)
6001 if (n
->sym
->attr
.flavor
== FL_PARAMETER
)
6003 gfc_error ("PARAMETER object %qs is not allowed at %L",
6004 n
->sym
->name
, &oc
->loc
);
6008 if (n
->expr
&& n
->expr
->ref
->type
== REF_ARRAY
)
6010 gfc_error ("Array sections: %qs not allowed in"
6011 " !$ACC DECLARE at %L", n
->sym
->name
, &oc
->loc
);
6016 for (n
= oc
->clauses
->lists
[OMP_LIST_DEVICE_RESIDENT
]; n
; n
= n
->next
)
6017 check_array_not_assumed (n
->sym
, oc
->loc
, "DEVICE_RESIDENT");
6020 for (oc
= ns
->oacc_declare
; oc
; oc
= oc
->next
)
6022 for (list
= 0; list
< OMP_LIST_NUM
; list
++)
6023 for (n
= oc
->clauses
->lists
[list
]; n
; n
= n
->next
)
6027 gfc_error ("Symbol %qs present on multiple clauses at %L",
6028 n
->sym
->name
, &oc
->loc
);
6036 for (oc
= ns
->oacc_declare
; oc
; oc
= oc
->next
)
6038 for (list
= 0; list
< OMP_LIST_NUM
; list
++)
6039 for (n
= oc
->clauses
->lists
[list
]; n
; n
= n
->next
)
6045 gfc_resolve_oacc_directive (gfc_code
*code
, gfc_namespace
*ns ATTRIBUTE_UNUSED
)
6047 resolve_oacc_directive_inside_omp_region (code
);
6051 case EXEC_OACC_PARALLEL
:
6052 case EXEC_OACC_KERNELS
:
6053 case EXEC_OACC_DATA
:
6054 case EXEC_OACC_HOST_DATA
:
6055 case EXEC_OACC_UPDATE
:
6056 case EXEC_OACC_ENTER_DATA
:
6057 case EXEC_OACC_EXIT_DATA
:
6058 case EXEC_OACC_WAIT
:
6059 case EXEC_OACC_CACHE
:
6060 resolve_omp_clauses (code
, code
->ext
.omp_clauses
, NULL
, true);
6062 case EXEC_OACC_PARALLEL_LOOP
:
6063 case EXEC_OACC_KERNELS_LOOP
:
6064 case EXEC_OACC_LOOP
:
6065 resolve_oacc_loop (code
);
6067 case EXEC_OACC_ATOMIC
:
6068 resolve_omp_atomic (code
);
6076 /* Resolve OpenMP directive clauses and check various requirements
6077 of each directive. */
6080 gfc_resolve_omp_directive (gfc_code
*code
, gfc_namespace
*ns ATTRIBUTE_UNUSED
)
6082 resolve_omp_directive_inside_oacc_region (code
);
6084 if (code
->op
!= EXEC_OMP_ATOMIC
)
6085 gfc_maybe_initialize_eh ();
6089 case EXEC_OMP_DISTRIBUTE
:
6090 case EXEC_OMP_DISTRIBUTE_PARALLEL_DO
:
6091 case EXEC_OMP_DISTRIBUTE_PARALLEL_DO_SIMD
:
6092 case EXEC_OMP_DISTRIBUTE_SIMD
:
6094 case EXEC_OMP_DO_SIMD
:
6095 case EXEC_OMP_PARALLEL_DO
:
6096 case EXEC_OMP_PARALLEL_DO_SIMD
:
6098 case EXEC_OMP_TARGET_PARALLEL_DO
:
6099 case EXEC_OMP_TARGET_PARALLEL_DO_SIMD
:
6100 case EXEC_OMP_TARGET_SIMD
:
6101 case EXEC_OMP_TARGET_TEAMS_DISTRIBUTE
:
6102 case EXEC_OMP_TARGET_TEAMS_DISTRIBUTE_PARALLEL_DO
:
6103 case EXEC_OMP_TARGET_TEAMS_DISTRIBUTE_PARALLEL_DO_SIMD
:
6104 case EXEC_OMP_TARGET_TEAMS_DISTRIBUTE_SIMD
:
6105 case EXEC_OMP_TASKLOOP
:
6106 case EXEC_OMP_TASKLOOP_SIMD
:
6107 case EXEC_OMP_TEAMS_DISTRIBUTE
:
6108 case EXEC_OMP_TEAMS_DISTRIBUTE_PARALLEL_DO
:
6109 case EXEC_OMP_TEAMS_DISTRIBUTE_PARALLEL_DO_SIMD
:
6110 case EXEC_OMP_TEAMS_DISTRIBUTE_SIMD
:
6111 resolve_omp_do (code
);
6113 case EXEC_OMP_CANCEL
:
6114 case EXEC_OMP_PARALLEL_WORKSHARE
:
6115 case EXEC_OMP_PARALLEL
:
6116 case EXEC_OMP_PARALLEL_SECTIONS
:
6117 case EXEC_OMP_SECTIONS
:
6118 case EXEC_OMP_SINGLE
:
6119 case EXEC_OMP_TARGET
:
6120 case EXEC_OMP_TARGET_DATA
:
6121 case EXEC_OMP_TARGET_ENTER_DATA
:
6122 case EXEC_OMP_TARGET_EXIT_DATA
:
6123 case EXEC_OMP_TARGET_PARALLEL
:
6124 case EXEC_OMP_TARGET_TEAMS
:
6126 case EXEC_OMP_TEAMS
:
6127 case EXEC_OMP_WORKSHARE
:
6128 if (code
->ext
.omp_clauses
)
6129 resolve_omp_clauses (code
, code
->ext
.omp_clauses
, NULL
);
6131 case EXEC_OMP_TARGET_UPDATE
:
6132 if (code
->ext
.omp_clauses
)
6133 resolve_omp_clauses (code
, code
->ext
.omp_clauses
, NULL
);
6134 if (code
->ext
.omp_clauses
== NULL
6135 || (code
->ext
.omp_clauses
->lists
[OMP_LIST_TO
] == NULL
6136 && code
->ext
.omp_clauses
->lists
[OMP_LIST_FROM
] == NULL
))
6137 gfc_error ("OMP TARGET UPDATE at %L requires at least one TO or "
6138 "FROM clause", &code
->loc
);
6140 case EXEC_OMP_ATOMIC
:
6141 resolve_omp_atomic (code
);
6148 /* Resolve !$omp declare simd constructs in NS. */
6151 gfc_resolve_omp_declare_simd (gfc_namespace
*ns
)
6153 gfc_omp_declare_simd
*ods
;
6155 for (ods
= ns
->omp_declare_simd
; ods
; ods
= ods
->next
)
6157 if (ods
->proc_name
!= NULL
6158 && ods
->proc_name
!= ns
->proc_name
)
6159 gfc_error ("!$OMP DECLARE SIMD should refer to containing procedure "
6160 "%qs at %L", ns
->proc_name
->name
, &ods
->where
);
6162 resolve_omp_clauses (NULL
, ods
->clauses
, ns
);
6166 struct omp_udr_callback_data
6168 gfc_omp_udr
*omp_udr
;
6169 bool is_initializer
;
6173 omp_udr_callback (gfc_expr
**e
, int *walk_subtrees ATTRIBUTE_UNUSED
,
6176 struct omp_udr_callback_data
*cd
= (struct omp_udr_callback_data
*) data
;
6177 if ((*e
)->expr_type
== EXPR_VARIABLE
)
6179 if (cd
->is_initializer
)
6181 if ((*e
)->symtree
->n
.sym
!= cd
->omp_udr
->omp_priv
6182 && (*e
)->symtree
->n
.sym
!= cd
->omp_udr
->omp_orig
)
6183 gfc_error ("Variable other than OMP_PRIV or OMP_ORIG used in "
6184 "INITIALIZER clause of !$OMP DECLARE REDUCTION at %L",
6189 if ((*e
)->symtree
->n
.sym
!= cd
->omp_udr
->omp_out
6190 && (*e
)->symtree
->n
.sym
!= cd
->omp_udr
->omp_in
)
6191 gfc_error ("Variable other than OMP_OUT or OMP_IN used in "
6192 "combiner of !$OMP DECLARE REDUCTION at %L",
6199 /* Resolve !$omp declare reduction constructs. */
6202 gfc_resolve_omp_udr (gfc_omp_udr
*omp_udr
)
6204 gfc_actual_arglist
*a
;
6205 const char *predef_name
= NULL
;
6207 switch (omp_udr
->rop
)
6209 case OMP_REDUCTION_PLUS
:
6210 case OMP_REDUCTION_TIMES
:
6211 case OMP_REDUCTION_MINUS
:
6212 case OMP_REDUCTION_AND
:
6213 case OMP_REDUCTION_OR
:
6214 case OMP_REDUCTION_EQV
:
6215 case OMP_REDUCTION_NEQV
:
6216 case OMP_REDUCTION_MAX
:
6217 case OMP_REDUCTION_USER
:
6220 gfc_error ("Invalid operator for !$OMP DECLARE REDUCTION %s at %L",
6221 omp_udr
->name
, &omp_udr
->where
);
6225 if (gfc_omp_udr_predef (omp_udr
->rop
, omp_udr
->name
,
6226 &omp_udr
->ts
, &predef_name
))
6229 gfc_error_now ("Redefinition of predefined %s "
6230 "!$OMP DECLARE REDUCTION at %L",
6231 predef_name
, &omp_udr
->where
);
6233 gfc_error_now ("Redefinition of predefined "
6234 "!$OMP DECLARE REDUCTION at %L", &omp_udr
->where
);
6238 if (omp_udr
->ts
.type
== BT_CHARACTER
6239 && omp_udr
->ts
.u
.cl
->length
6240 && omp_udr
->ts
.u
.cl
->length
->expr_type
!= EXPR_CONSTANT
)
6242 gfc_error ("CHARACTER length in !$OMP DECLARE REDUCTION %s not "
6243 "constant at %L", omp_udr
->name
, &omp_udr
->where
);
6247 struct omp_udr_callback_data cd
;
6248 cd
.omp_udr
= omp_udr
;
6249 cd
.is_initializer
= false;
6250 gfc_code_walker (&omp_udr
->combiner_ns
->code
, gfc_dummy_code_callback
,
6251 omp_udr_callback
, &cd
);
6252 if (omp_udr
->combiner_ns
->code
->op
== EXEC_CALL
)
6254 for (a
= omp_udr
->combiner_ns
->code
->ext
.actual
; a
; a
= a
->next
)
6255 if (a
->expr
== NULL
)
6258 gfc_error ("Subroutine call with alternate returns in combiner "
6259 "of !$OMP DECLARE REDUCTION at %L",
6260 &omp_udr
->combiner_ns
->code
->loc
);
6262 if (omp_udr
->initializer_ns
)
6264 cd
.is_initializer
= true;
6265 gfc_code_walker (&omp_udr
->initializer_ns
->code
, gfc_dummy_code_callback
,
6266 omp_udr_callback
, &cd
);
6267 if (omp_udr
->initializer_ns
->code
->op
== EXEC_CALL
)
6269 for (a
= omp_udr
->initializer_ns
->code
->ext
.actual
; a
; a
= a
->next
)
6270 if (a
->expr
== NULL
)
6273 gfc_error ("Subroutine call with alternate returns in "
6274 "INITIALIZER clause of !$OMP DECLARE REDUCTION "
6275 "at %L", &omp_udr
->initializer_ns
->code
->loc
);
6276 for (a
= omp_udr
->initializer_ns
->code
->ext
.actual
; a
; a
= a
->next
)
6278 && a
->expr
->expr_type
== EXPR_VARIABLE
6279 && a
->expr
->symtree
->n
.sym
== omp_udr
->omp_priv
6280 && a
->expr
->ref
== NULL
)
6283 gfc_error ("One of actual subroutine arguments in INITIALIZER "
6284 "clause of !$OMP DECLARE REDUCTION must be OMP_PRIV "
6285 "at %L", &omp_udr
->initializer_ns
->code
->loc
);
6288 else if (omp_udr
->ts
.type
== BT_DERIVED
6289 && !gfc_has_default_initializer (omp_udr
->ts
.u
.derived
))
6291 gfc_error ("Missing INITIALIZER clause for !$OMP DECLARE REDUCTION "
6292 "of derived type without default initializer at %L",
6299 gfc_resolve_omp_udrs (gfc_symtree
*st
)
6301 gfc_omp_udr
*omp_udr
;
6305 gfc_resolve_omp_udrs (st
->left
);
6306 gfc_resolve_omp_udrs (st
->right
);
6307 for (omp_udr
= st
->n
.omp_udr
; omp_udr
; omp_udr
= omp_udr
->next
)
6308 gfc_resolve_omp_udr (omp_udr
);