1 /* OpenMP directive matching and resolving.
2 Copyright (C) 2005-2016 Free Software Foundation, Inc.
3 Contributed by Jakub Jelinek
5 This file is part of GCC.
7 GCC is free software; you can redistribute it and/or modify it under
8 the terms of the GNU General Public License as published by the Free
9 Software Foundation; either version 3, or (at your option) any later
12 GCC is distributed in the hope that it will be useful, but WITHOUT ANY
13 WARRANTY; without even the implied warranty of MERCHANTABILITY or
14 FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License
17 You should have received a copy of the GNU General Public License
18 along with GCC; see the file COPYING3. If not see
19 <http://www.gnu.org/licenses/>. */
23 #include "coretypes.h"
28 #include "diagnostic.h"
29 #include "gomp-constants.h"
31 /* Match an end of OpenMP directive. End of OpenMP directive is optional
32 whitespace, followed by '\n' or comment '!'. */
35 gfc_match_omp_eos (void)
40 old_loc
= gfc_current_locus
;
41 gfc_gobble_whitespace ();
43 c
= gfc_next_ascii_char ();
48 c
= gfc_next_ascii_char ();
56 gfc_current_locus
= old_loc
;
60 /* Free an omp_clauses structure. */
63 gfc_free_omp_clauses (gfc_omp_clauses
*c
)
69 gfc_free_expr (c
->if_expr
);
70 gfc_free_expr (c
->final_expr
);
71 gfc_free_expr (c
->num_threads
);
72 gfc_free_expr (c
->chunk_size
);
73 gfc_free_expr (c
->safelen_expr
);
74 gfc_free_expr (c
->simdlen_expr
);
75 gfc_free_expr (c
->num_teams
);
76 gfc_free_expr (c
->device
);
77 gfc_free_expr (c
->thread_limit
);
78 gfc_free_expr (c
->dist_chunk_size
);
79 gfc_free_expr (c
->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 const char *p
= gfc_extract_int (cexpr
, &collapse
);
1034 else if (collapse
<= 0)
1036 gfc_error_now ("COLLAPSE clause argument not"
1037 " constant positive integer at %C");
1040 c
->collapse
= collapse
;
1041 gfc_free_expr (cexpr
);
1045 if ((mask
& OMP_CLAUSE_COPY
)
1046 && gfc_match ("copy ( ") == MATCH_YES
1047 && gfc_match_omp_map_clause (&c
->lists
[OMP_LIST_MAP
],
1048 OMP_MAP_FORCE_TOFROM
))
1050 if (mask
& OMP_CLAUSE_COPYIN
)
1054 if (gfc_match ("copyin ( ") == MATCH_YES
1055 && gfc_match_omp_map_clause (&c
->lists
[OMP_LIST_MAP
],
1059 else if (gfc_match_omp_variable_list ("copyin (",
1060 &c
->lists
[OMP_LIST_COPYIN
],
1064 if ((mask
& OMP_CLAUSE_COPYOUT
)
1065 && gfc_match ("copyout ( ") == MATCH_YES
1066 && gfc_match_omp_map_clause (&c
->lists
[OMP_LIST_MAP
],
1067 OMP_MAP_FORCE_FROM
))
1069 if ((mask
& OMP_CLAUSE_COPYPRIVATE
)
1070 && gfc_match_omp_variable_list ("copyprivate (",
1071 &c
->lists
[OMP_LIST_COPYPRIVATE
],
1074 if ((mask
& OMP_CLAUSE_CREATE
)
1075 && gfc_match ("create ( ") == MATCH_YES
1076 && gfc_match_omp_map_clause (&c
->lists
[OMP_LIST_MAP
],
1077 OMP_MAP_FORCE_ALLOC
))
1081 if ((mask
& OMP_CLAUSE_DEFAULT
)
1082 && c
->default_sharing
== OMP_DEFAULT_UNKNOWN
)
1084 if (gfc_match ("default ( none )") == MATCH_YES
)
1085 c
->default_sharing
= OMP_DEFAULT_NONE
;
1087 /* c->default_sharing = OMP_DEFAULT_UNKNOWN */;
1088 else if (gfc_match ("default ( shared )") == MATCH_YES
)
1089 c
->default_sharing
= OMP_DEFAULT_SHARED
;
1090 else if (gfc_match ("default ( private )") == MATCH_YES
)
1091 c
->default_sharing
= OMP_DEFAULT_PRIVATE
;
1092 else if (gfc_match ("default ( firstprivate )") == MATCH_YES
)
1093 c
->default_sharing
= OMP_DEFAULT_FIRSTPRIVATE
;
1094 if (c
->default_sharing
!= OMP_DEFAULT_UNKNOWN
)
1097 if ((mask
& OMP_CLAUSE_DEFAULTMAP
)
1099 && gfc_match ("defaultmap ( tofrom : scalar )") == MATCH_YES
)
1101 c
->defaultmap
= true;
1104 if ((mask
& OMP_CLAUSE_DELETE
)
1105 && gfc_match ("delete ( ") == MATCH_YES
1106 && gfc_match_omp_map_clause (&c
->lists
[OMP_LIST_MAP
],
1109 if ((mask
& OMP_CLAUSE_DEPEND
)
1110 && gfc_match ("depend ( ") == MATCH_YES
)
1112 match m
= MATCH_YES
;
1113 gfc_omp_depend_op depend_op
= OMP_DEPEND_OUT
;
1114 if (gfc_match ("inout") == MATCH_YES
)
1115 depend_op
= OMP_DEPEND_INOUT
;
1116 else if (gfc_match ("in") == MATCH_YES
)
1117 depend_op
= OMP_DEPEND_IN
;
1118 else if (gfc_match ("out") == MATCH_YES
)
1119 depend_op
= OMP_DEPEND_OUT
;
1120 else if (!c
->depend_source
1121 && gfc_match ("source )") == MATCH_YES
)
1123 c
->depend_source
= true;
1126 else if (gfc_match ("sink : ") == MATCH_YES
)
1128 if (gfc_match_omp_depend_sink (&c
->lists
[OMP_LIST_DEPEND
])
1137 && gfc_match_omp_variable_list (" : ",
1138 &c
->lists
[OMP_LIST_DEPEND
],
1142 gfc_omp_namelist
*n
;
1143 for (n
= *head
; n
; n
= n
->next
)
1144 n
->u
.depend_op
= depend_op
;
1148 gfc_current_locus
= old_loc
;
1150 if ((mask
& OMP_CLAUSE_DEVICE
)
1152 && c
->device
== NULL
1153 && gfc_match ("device ( %e )", &c
->device
) == MATCH_YES
)
1155 if ((mask
& OMP_CLAUSE_DEVICE
)
1157 && gfc_match ("device ( ") == MATCH_YES
1158 && gfc_match_omp_map_clause (&c
->lists
[OMP_LIST_MAP
],
1161 if ((mask
& OMP_CLAUSE_DEVICEPTR
)
1162 && gfc_match ("deviceptr ( ") == MATCH_YES
)
1164 gfc_omp_namelist
**list
= &c
->lists
[OMP_LIST_MAP
];
1165 gfc_omp_namelist
**head
= NULL
;
1166 if (gfc_match_omp_variable_list ("", list
, true, NULL
,
1167 &head
, false) == MATCH_YES
)
1169 gfc_omp_namelist
*n
;
1170 for (n
= *head
; n
; n
= n
->next
)
1171 n
->u
.map_op
= OMP_MAP_FORCE_DEVICEPTR
;
1175 if ((mask
& OMP_CLAUSE_DEVICE_RESIDENT
)
1176 && gfc_match_omp_variable_list
1177 ("device_resident (",
1178 &c
->lists
[OMP_LIST_DEVICE_RESIDENT
], true) == MATCH_YES
)
1180 if ((mask
& OMP_CLAUSE_DIST_SCHEDULE
)
1181 && c
->dist_sched_kind
== OMP_SCHED_NONE
1182 && gfc_match ("dist_schedule ( static") == MATCH_YES
)
1185 c
->dist_sched_kind
= OMP_SCHED_STATIC
;
1186 m
= gfc_match (" , %e )", &c
->dist_chunk_size
);
1188 m
= gfc_match_char (')');
1191 c
->dist_sched_kind
= OMP_SCHED_NONE
;
1192 gfc_current_locus
= old_loc
;
1199 if ((mask
& OMP_CLAUSE_FINAL
)
1200 && c
->final_expr
== NULL
1201 && gfc_match ("final ( %e )", &c
->final_expr
) == MATCH_YES
)
1203 if ((mask
& OMP_CLAUSE_FIRSTPRIVATE
)
1204 && gfc_match_omp_variable_list ("firstprivate (",
1205 &c
->lists
[OMP_LIST_FIRSTPRIVATE
],
1208 if ((mask
& OMP_CLAUSE_FROM
)
1209 && gfc_match_omp_variable_list ("from (",
1210 &c
->lists
[OMP_LIST_FROM
], false,
1211 NULL
, &head
, true) == MATCH_YES
)
1215 if ((mask
& OMP_CLAUSE_GANG
)
1217 && gfc_match ("gang") == MATCH_YES
)
1220 match m
= match_oacc_clause_gwv (c
, GOMP_DIM_GANG
);
1221 if (m
== MATCH_ERROR
)
1223 gfc_current_locus
= old_loc
;
1226 else if (m
== MATCH_NO
)
1230 if ((mask
& OMP_CLAUSE_GRAINSIZE
)
1231 && c
->grainsize
== NULL
1232 && gfc_match ("grainsize ( %e )", &c
->grainsize
) == MATCH_YES
)
1236 if ((mask
& OMP_CLAUSE_HINT
)
1238 && gfc_match ("hint ( %e )", &c
->hint
) == MATCH_YES
)
1240 if ((mask
& OMP_CLAUSE_HOST_SELF
)
1241 && gfc_match ("host ( ") == MATCH_YES
1242 && gfc_match_omp_map_clause (&c
->lists
[OMP_LIST_MAP
],
1243 OMP_MAP_FORCE_FROM
))
1247 if ((mask
& OMP_CLAUSE_IF
)
1248 && c
->if_expr
== NULL
1249 && gfc_match ("if ( ") == MATCH_YES
)
1251 if (gfc_match ("%e )", &c
->if_expr
) == MATCH_YES
)
1255 /* This should match the enum gfc_omp_if_kind order. */
1256 static const char *ifs
[OMP_IF_LAST
] = {
1261 " target data : %e )",
1262 " target update : %e )",
1263 " target enter data : %e )",
1264 " target exit data : %e )" };
1266 for (i
= 0; i
< OMP_IF_LAST
; i
++)
1267 if (c
->if_exprs
[i
] == NULL
1268 && gfc_match (ifs
[i
], &c
->if_exprs
[i
]) == MATCH_YES
)
1270 if (i
< OMP_IF_LAST
)
1273 gfc_current_locus
= old_loc
;
1275 if ((mask
& OMP_CLAUSE_INBRANCH
)
1278 && gfc_match ("inbranch") == MATCH_YES
)
1280 c
->inbranch
= needs_space
= true;
1283 if ((mask
& OMP_CLAUSE_INDEPENDENT
)
1285 && gfc_match ("independent") == MATCH_YES
)
1287 c
->independent
= true;
1291 if ((mask
& OMP_CLAUSE_IS_DEVICE_PTR
)
1292 && gfc_match_omp_variable_list
1294 &c
->lists
[OMP_LIST_IS_DEVICE_PTR
], false) == MATCH_YES
)
1298 if ((mask
& OMP_CLAUSE_LASTPRIVATE
)
1299 && gfc_match_omp_variable_list ("lastprivate (",
1300 &c
->lists
[OMP_LIST_LASTPRIVATE
],
1305 if ((mask
& OMP_CLAUSE_LINEAR
)
1306 && gfc_match ("linear (") == MATCH_YES
)
1308 gfc_omp_linear_op linear_op
= OMP_LINEAR_DEFAULT
;
1309 gfc_expr
*step
= NULL
;
1311 if (gfc_match_omp_variable_list (" ref (",
1312 &c
->lists
[OMP_LIST_LINEAR
],
1315 linear_op
= OMP_LINEAR_REF
;
1316 else if (gfc_match_omp_variable_list (" val (",
1317 &c
->lists
[OMP_LIST_LINEAR
],
1320 linear_op
= OMP_LINEAR_VAL
;
1321 else if (gfc_match_omp_variable_list (" uval (",
1322 &c
->lists
[OMP_LIST_LINEAR
],
1325 linear_op
= OMP_LINEAR_UVAL
;
1326 else if (gfc_match_omp_variable_list ("",
1327 &c
->lists
[OMP_LIST_LINEAR
],
1328 false, &end_colon
, &head
)
1330 linear_op
= OMP_LINEAR_DEFAULT
;
1333 gfc_free_omp_namelist (*head
);
1334 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 const char *p
= gfc_extract_int (cexpr
, &ordered
);
1494 else if (ordered
<= 0)
1496 gfc_error_now ("ORDERED clause argument not"
1497 " constant positive integer at %C");
1500 c
->orderedc
= ordered
;
1501 gfc_free_expr (cexpr
);
1510 if ((mask
& OMP_CLAUSE_PRESENT_OR_COPY
)
1511 && gfc_match ("pcopy ( ") == MATCH_YES
1512 && gfc_match_omp_map_clause (&c
->lists
[OMP_LIST_MAP
],
1515 if ((mask
& OMP_CLAUSE_PRESENT_OR_COPYIN
)
1516 && gfc_match ("pcopyin ( ") == MATCH_YES
1517 && gfc_match_omp_map_clause (&c
->lists
[OMP_LIST_MAP
],
1520 if ((mask
& OMP_CLAUSE_PRESENT_OR_COPYOUT
)
1521 && gfc_match ("pcopyout ( ") == MATCH_YES
1522 && gfc_match_omp_map_clause (&c
->lists
[OMP_LIST_MAP
],
1525 if ((mask
& OMP_CLAUSE_PRESENT_OR_CREATE
)
1526 && gfc_match ("pcreate ( ") == MATCH_YES
1527 && gfc_match_omp_map_clause (&c
->lists
[OMP_LIST_MAP
],
1530 if ((mask
& OMP_CLAUSE_PRESENT
)
1531 && gfc_match ("present ( ") == MATCH_YES
1532 && gfc_match_omp_map_clause (&c
->lists
[OMP_LIST_MAP
],
1533 OMP_MAP_FORCE_PRESENT
))
1535 if ((mask
& OMP_CLAUSE_PRESENT_OR_COPY
)
1536 && gfc_match ("present_or_copy ( ") == MATCH_YES
1537 && gfc_match_omp_map_clause (&c
->lists
[OMP_LIST_MAP
],
1540 if ((mask
& OMP_CLAUSE_PRESENT_OR_COPYIN
)
1541 && gfc_match ("present_or_copyin ( ") == MATCH_YES
1542 && gfc_match_omp_map_clause (&c
->lists
[OMP_LIST_MAP
],
1545 if ((mask
& OMP_CLAUSE_PRESENT_OR_COPYOUT
)
1546 && gfc_match ("present_or_copyout ( ") == MATCH_YES
1547 && gfc_match_omp_map_clause (&c
->lists
[OMP_LIST_MAP
],
1550 if ((mask
& OMP_CLAUSE_PRESENT_OR_CREATE
)
1551 && gfc_match ("present_or_create ( ") == MATCH_YES
1552 && gfc_match_omp_map_clause (&c
->lists
[OMP_LIST_MAP
],
1555 if ((mask
& OMP_CLAUSE_PRIORITY
)
1556 && c
->priority
== NULL
1557 && gfc_match ("priority ( %e )", &c
->priority
) == MATCH_YES
)
1559 if ((mask
& OMP_CLAUSE_PRIVATE
)
1560 && gfc_match_omp_variable_list ("private (",
1561 &c
->lists
[OMP_LIST_PRIVATE
],
1564 if ((mask
& OMP_CLAUSE_PROC_BIND
)
1565 && c
->proc_bind
== OMP_PROC_BIND_UNKNOWN
)
1567 if (gfc_match ("proc_bind ( master )") == MATCH_YES
)
1568 c
->proc_bind
= OMP_PROC_BIND_MASTER
;
1569 else if (gfc_match ("proc_bind ( spread )") == MATCH_YES
)
1570 c
->proc_bind
= OMP_PROC_BIND_SPREAD
;
1571 else if (gfc_match ("proc_bind ( close )") == MATCH_YES
)
1572 c
->proc_bind
= OMP_PROC_BIND_CLOSE
;
1573 if (c
->proc_bind
!= OMP_PROC_BIND_UNKNOWN
)
1578 if ((mask
& OMP_CLAUSE_REDUCTION
)
1579 && gfc_match ("reduction ( ") == MATCH_YES
)
1581 gfc_omp_reduction_op rop
= OMP_REDUCTION_NONE
;
1582 char buffer
[GFC_MAX_SYMBOL_LEN
+ 3];
1583 if (gfc_match_char ('+') == MATCH_YES
)
1584 rop
= OMP_REDUCTION_PLUS
;
1585 else if (gfc_match_char ('*') == MATCH_YES
)
1586 rop
= OMP_REDUCTION_TIMES
;
1587 else if (gfc_match_char ('-') == MATCH_YES
)
1588 rop
= OMP_REDUCTION_MINUS
;
1589 else if (gfc_match (".and.") == MATCH_YES
)
1590 rop
= OMP_REDUCTION_AND
;
1591 else if (gfc_match (".or.") == MATCH_YES
)
1592 rop
= OMP_REDUCTION_OR
;
1593 else if (gfc_match (".eqv.") == MATCH_YES
)
1594 rop
= OMP_REDUCTION_EQV
;
1595 else if (gfc_match (".neqv.") == MATCH_YES
)
1596 rop
= OMP_REDUCTION_NEQV
;
1597 if (rop
!= OMP_REDUCTION_NONE
)
1598 snprintf (buffer
, sizeof buffer
, "operator %s",
1599 gfc_op2string ((gfc_intrinsic_op
) rop
));
1600 else if (gfc_match_defined_op_name (buffer
+ 1, 1) == MATCH_YES
)
1603 strcat (buffer
, ".");
1605 else if (gfc_match_name (buffer
) == MATCH_YES
)
1608 const char *n
= buffer
;
1610 gfc_find_symbol (buffer
, NULL
, 1, &sym
);
1613 if (sym
->attr
.intrinsic
)
1615 else if ((sym
->attr
.flavor
!= FL_UNKNOWN
1616 && sym
->attr
.flavor
!= FL_PROCEDURE
)
1617 || sym
->attr
.external
1618 || sym
->attr
.generic
1622 || sym
->attr
.subroutine
1623 || sym
->attr
.pointer
1625 || sym
->attr
.cray_pointer
1626 || sym
->attr
.cray_pointee
1627 || (sym
->attr
.proc
!= PROC_UNKNOWN
1628 && sym
->attr
.proc
!= PROC_INTRINSIC
)
1629 || sym
->attr
.if_source
!= IFSRC_UNKNOWN
1630 || sym
== sym
->ns
->proc_name
)
1639 rop
= OMP_REDUCTION_NONE
;
1640 else if (strcmp (n
, "max") == 0)
1641 rop
= OMP_REDUCTION_MAX
;
1642 else if (strcmp (n
, "min") == 0)
1643 rop
= OMP_REDUCTION_MIN
;
1644 else if (strcmp (n
, "iand") == 0)
1645 rop
= OMP_REDUCTION_IAND
;
1646 else if (strcmp (n
, "ior") == 0)
1647 rop
= OMP_REDUCTION_IOR
;
1648 else if (strcmp (n
, "ieor") == 0)
1649 rop
= OMP_REDUCTION_IEOR
;
1650 if (rop
!= OMP_REDUCTION_NONE
1652 && ! sym
->attr
.intrinsic
1653 && ! sym
->attr
.use_assoc
1654 && ((sym
->attr
.flavor
== FL_UNKNOWN
1655 && !gfc_add_flavor (&sym
->attr
, FL_PROCEDURE
,
1657 || !gfc_add_intrinsic (&sym
->attr
, NULL
)))
1658 rop
= OMP_REDUCTION_NONE
;
1664 ? gfc_find_omp_udr (gfc_current_ns
, buffer
, NULL
) : NULL
);
1665 gfc_omp_namelist
**head
= NULL
;
1666 if (rop
== OMP_REDUCTION_NONE
&& udr
)
1667 rop
= OMP_REDUCTION_USER
;
1669 if (gfc_match_omp_variable_list (" :",
1670 &c
->lists
[OMP_LIST_REDUCTION
],
1672 openacc
) == MATCH_YES
)
1674 gfc_omp_namelist
*n
;
1675 if (rop
== OMP_REDUCTION_NONE
)
1679 gfc_error_now ("!$OMP DECLARE REDUCTION %s not found "
1680 "at %L", buffer
, &old_loc
);
1681 gfc_free_omp_namelist (n
);
1684 for (n
= *head
; n
; n
= n
->next
)
1686 n
->u
.reduction_op
= rop
;
1689 n
->udr
= gfc_get_omp_namelist_udr ();
1696 gfc_current_locus
= old_loc
;
1700 if ((mask
& OMP_CLAUSE_SAFELEN
)
1701 && c
->safelen_expr
== NULL
1702 && gfc_match ("safelen ( %e )", &c
->safelen_expr
) == MATCH_YES
)
1704 if ((mask
& OMP_CLAUSE_SCHEDULE
)
1705 && c
->sched_kind
== OMP_SCHED_NONE
1706 && gfc_match ("schedule ( ") == MATCH_YES
)
1709 locus old_loc2
= gfc_current_locus
;
1713 && gfc_match ("simd") == MATCH_YES
)
1715 c
->sched_simd
= true;
1718 else if (!c
->sched_monotonic
1719 && !c
->sched_nonmonotonic
1720 && gfc_match ("monotonic") == MATCH_YES
)
1722 c
->sched_monotonic
= true;
1725 else if (!c
->sched_monotonic
1726 && !c
->sched_nonmonotonic
1727 && gfc_match ("nonmonotonic") == MATCH_YES
)
1729 c
->sched_nonmonotonic
= true;
1735 gfc_current_locus
= old_loc2
;
1739 && gfc_match (" , ") == MATCH_YES
)
1741 else if (gfc_match (" : ") == MATCH_YES
)
1743 gfc_current_locus
= old_loc2
;
1747 if (gfc_match ("static") == MATCH_YES
)
1748 c
->sched_kind
= OMP_SCHED_STATIC
;
1749 else if (gfc_match ("dynamic") == MATCH_YES
)
1750 c
->sched_kind
= OMP_SCHED_DYNAMIC
;
1751 else if (gfc_match ("guided") == MATCH_YES
)
1752 c
->sched_kind
= OMP_SCHED_GUIDED
;
1753 else if (gfc_match ("runtime") == MATCH_YES
)
1754 c
->sched_kind
= OMP_SCHED_RUNTIME
;
1755 else if (gfc_match ("auto") == MATCH_YES
)
1756 c
->sched_kind
= OMP_SCHED_AUTO
;
1757 if (c
->sched_kind
!= OMP_SCHED_NONE
)
1760 if (c
->sched_kind
!= OMP_SCHED_RUNTIME
1761 && c
->sched_kind
!= OMP_SCHED_AUTO
)
1762 m
= gfc_match (" , %e )", &c
->chunk_size
);
1764 m
= gfc_match_char (')');
1766 c
->sched_kind
= OMP_SCHED_NONE
;
1768 if (c
->sched_kind
!= OMP_SCHED_NONE
)
1771 gfc_current_locus
= old_loc
;
1773 if ((mask
& OMP_CLAUSE_HOST_SELF
)
1774 && gfc_match ("self ( ") == MATCH_YES
1775 && gfc_match_omp_map_clause (&c
->lists
[OMP_LIST_MAP
],
1776 OMP_MAP_FORCE_FROM
))
1778 if ((mask
& OMP_CLAUSE_SEQ
)
1780 && gfc_match ("seq") == MATCH_YES
)
1786 if ((mask
& OMP_CLAUSE_SHARED
)
1787 && gfc_match_omp_variable_list ("shared (",
1788 &c
->lists
[OMP_LIST_SHARED
],
1791 if ((mask
& OMP_CLAUSE_SIMDLEN
)
1792 && c
->simdlen_expr
== NULL
1793 && gfc_match ("simdlen ( %e )", &c
->simdlen_expr
) == MATCH_YES
)
1795 if ((mask
& OMP_CLAUSE_SIMD
)
1797 && gfc_match ("simd") == MATCH_YES
)
1799 c
->simd
= needs_space
= true;
1804 if ((mask
& OMP_CLAUSE_THREAD_LIMIT
)
1805 && c
->thread_limit
== NULL
1806 && gfc_match ("thread_limit ( %e )",
1807 &c
->thread_limit
) == MATCH_YES
)
1809 if ((mask
& OMP_CLAUSE_THREADS
)
1811 && gfc_match ("threads") == MATCH_YES
)
1813 c
->threads
= needs_space
= true;
1816 if ((mask
& OMP_CLAUSE_TILE
)
1818 && match_oacc_expr_list ("tile (", &c
->tile_list
,
1821 if ((mask
& OMP_CLAUSE_TO
) && (mask
& OMP_CLAUSE_LINK
))
1823 if (gfc_match_omp_to_link ("to (", &c
->lists
[OMP_LIST_TO
])
1827 else if ((mask
& OMP_CLAUSE_TO
)
1828 && gfc_match_omp_variable_list ("to (",
1829 &c
->lists
[OMP_LIST_TO
], false,
1830 NULL
, &head
, true) == MATCH_YES
)
1834 if ((mask
& OMP_CLAUSE_UNIFORM
)
1835 && gfc_match_omp_variable_list ("uniform (",
1836 &c
->lists
[OMP_LIST_UNIFORM
],
1837 false) == MATCH_YES
)
1839 if ((mask
& OMP_CLAUSE_UNTIED
)
1841 && gfc_match ("untied") == MATCH_YES
)
1843 c
->untied
= needs_space
= true;
1846 if ((mask
& OMP_CLAUSE_USE_DEVICE
)
1847 && gfc_match_omp_variable_list ("use_device (",
1848 &c
->lists
[OMP_LIST_USE_DEVICE
],
1851 if ((mask
& OMP_CLAUSE_USE_DEVICE_PTR
)
1852 && gfc_match_omp_variable_list
1853 ("use_device_ptr (",
1854 &c
->lists
[OMP_LIST_USE_DEVICE_PTR
], false) == MATCH_YES
)
1858 /* VECTOR_LENGTH must be matched before VECTOR, because the latter
1859 doesn't unconditionally match '('. */
1860 if ((mask
& OMP_CLAUSE_VECTOR_LENGTH
)
1861 && c
->vector_length_expr
== NULL
1862 && (gfc_match ("vector_length ( %e )", &c
->vector_length_expr
)
1865 if ((mask
& OMP_CLAUSE_VECTOR
)
1867 && gfc_match ("vector") == MATCH_YES
)
1870 match m
= match_oacc_clause_gwv (c
, GOMP_DIM_VECTOR
);
1871 if (m
== MATCH_ERROR
)
1873 gfc_current_locus
= old_loc
;
1882 if ((mask
& OMP_CLAUSE_WAIT
)
1884 && gfc_match ("wait") == MATCH_YES
)
1887 match m
= match_oacc_expr_list (" (", &c
->wait_list
, false);
1888 if (m
== MATCH_ERROR
)
1890 gfc_current_locus
= old_loc
;
1893 else if (m
== MATCH_NO
)
1897 if ((mask
& OMP_CLAUSE_WORKER
)
1899 && gfc_match ("worker") == MATCH_YES
)
1902 match m
= match_oacc_clause_gwv (c
, GOMP_DIM_WORKER
);
1903 if (m
== MATCH_ERROR
)
1905 gfc_current_locus
= old_loc
;
1908 else if (m
== MATCH_NO
)
1917 if (gfc_match_omp_eos () != MATCH_YES
)
1919 gfc_free_omp_clauses (c
);
1928 #define OACC_PARALLEL_CLAUSES \
1929 (omp_mask (OMP_CLAUSE_IF) | OMP_CLAUSE_ASYNC | OMP_CLAUSE_NUM_GANGS \
1930 | OMP_CLAUSE_NUM_WORKERS | OMP_CLAUSE_VECTOR_LENGTH | OMP_CLAUSE_REDUCTION \
1931 | OMP_CLAUSE_COPY | OMP_CLAUSE_COPYIN | OMP_CLAUSE_COPYOUT \
1932 | OMP_CLAUSE_CREATE | OMP_CLAUSE_PRESENT | OMP_CLAUSE_PRESENT_OR_COPY \
1933 | OMP_CLAUSE_PRESENT_OR_COPYIN | OMP_CLAUSE_PRESENT_OR_COPYOUT \
1934 | OMP_CLAUSE_PRESENT_OR_CREATE | OMP_CLAUSE_DEVICEPTR | OMP_CLAUSE_PRIVATE \
1935 | OMP_CLAUSE_FIRSTPRIVATE | OMP_CLAUSE_DEFAULT | OMP_CLAUSE_WAIT)
1936 #define OACC_KERNELS_CLAUSES \
1937 (omp_mask (OMP_CLAUSE_IF) | OMP_CLAUSE_ASYNC | OMP_CLAUSE_DEVICEPTR \
1938 | OMP_CLAUSE_COPY | OMP_CLAUSE_COPYIN | OMP_CLAUSE_COPYOUT \
1939 | OMP_CLAUSE_CREATE | OMP_CLAUSE_PRESENT | OMP_CLAUSE_PRESENT_OR_COPY \
1940 | OMP_CLAUSE_PRESENT_OR_COPYIN | OMP_CLAUSE_PRESENT_OR_COPYOUT \
1941 | OMP_CLAUSE_PRESENT_OR_CREATE | OMP_CLAUSE_DEFAULT | OMP_CLAUSE_WAIT)
1942 #define OACC_DATA_CLAUSES \
1943 (omp_mask (OMP_CLAUSE_IF) | OMP_CLAUSE_DEVICEPTR | OMP_CLAUSE_COPY \
1944 | OMP_CLAUSE_COPYIN | OMP_CLAUSE_COPYOUT | OMP_CLAUSE_CREATE \
1945 | OMP_CLAUSE_PRESENT | OMP_CLAUSE_PRESENT_OR_COPY \
1946 | OMP_CLAUSE_PRESENT_OR_COPYIN | OMP_CLAUSE_PRESENT_OR_COPYOUT \
1947 | OMP_CLAUSE_PRESENT_OR_CREATE)
1948 #define OACC_LOOP_CLAUSES \
1949 (omp_mask (OMP_CLAUSE_COLLAPSE) | OMP_CLAUSE_GANG | OMP_CLAUSE_WORKER \
1950 | OMP_CLAUSE_VECTOR | OMP_CLAUSE_SEQ | OMP_CLAUSE_INDEPENDENT \
1951 | OMP_CLAUSE_PRIVATE | OMP_CLAUSE_REDUCTION | OMP_CLAUSE_AUTO \
1953 #define OACC_PARALLEL_LOOP_CLAUSES \
1954 (OACC_LOOP_CLAUSES | OACC_PARALLEL_CLAUSES)
1955 #define OACC_KERNELS_LOOP_CLAUSES \
1956 (OACC_LOOP_CLAUSES | OACC_KERNELS_CLAUSES)
1957 #define OACC_HOST_DATA_CLAUSES omp_mask (OMP_CLAUSE_USE_DEVICE)
1958 #define OACC_DECLARE_CLAUSES \
1959 (omp_mask (OMP_CLAUSE_COPY) | OMP_CLAUSE_COPYIN | OMP_CLAUSE_COPYOUT \
1960 | OMP_CLAUSE_CREATE | OMP_CLAUSE_DEVICEPTR | OMP_CLAUSE_DEVICE_RESIDENT \
1961 | OMP_CLAUSE_PRESENT | OMP_CLAUSE_PRESENT_OR_COPY \
1962 | OMP_CLAUSE_PRESENT_OR_COPYIN | OMP_CLAUSE_PRESENT_OR_COPYOUT \
1963 | OMP_CLAUSE_PRESENT_OR_CREATE | OMP_CLAUSE_LINK)
1964 #define OACC_UPDATE_CLAUSES \
1965 (omp_mask (OMP_CLAUSE_IF) | OMP_CLAUSE_ASYNC | OMP_CLAUSE_HOST_SELF \
1966 | OMP_CLAUSE_DEVICE | OMP_CLAUSE_WAIT)
1967 #define OACC_ENTER_DATA_CLAUSES \
1968 (omp_mask (OMP_CLAUSE_IF) | OMP_CLAUSE_ASYNC | OMP_CLAUSE_WAIT \
1969 | OMP_CLAUSE_COPYIN | OMP_CLAUSE_CREATE | OMP_CLAUSE_PRESENT_OR_COPYIN \
1970 | OMP_CLAUSE_PRESENT_OR_CREATE)
1971 #define OACC_EXIT_DATA_CLAUSES \
1972 (omp_mask (OMP_CLAUSE_IF) | OMP_CLAUSE_ASYNC | OMP_CLAUSE_WAIT \
1973 | OMP_CLAUSE_COPYOUT | OMP_CLAUSE_DELETE)
1974 #define OACC_WAIT_CLAUSES \
1975 omp_mask (OMP_CLAUSE_ASYNC)
1976 #define OACC_ROUTINE_CLAUSES \
1977 (omp_mask (OMP_CLAUSE_GANG) | OMP_CLAUSE_WORKER | OMP_CLAUSE_VECTOR \
1982 match_acc (gfc_exec_op op
, const omp_mask mask
)
1985 if (gfc_match_omp_clauses (&c
, mask
, false, false, true) != MATCH_YES
)
1988 new_st
.ext
.omp_clauses
= c
;
1993 gfc_match_oacc_parallel_loop (void)
1995 return match_acc (EXEC_OACC_PARALLEL_LOOP
, OACC_PARALLEL_LOOP_CLAUSES
);
2000 gfc_match_oacc_parallel (void)
2002 return match_acc (EXEC_OACC_PARALLEL
, OACC_PARALLEL_CLAUSES
);
2007 gfc_match_oacc_kernels_loop (void)
2009 return match_acc (EXEC_OACC_KERNELS_LOOP
, OACC_KERNELS_LOOP_CLAUSES
);
2014 gfc_match_oacc_kernels (void)
2016 return match_acc (EXEC_OACC_KERNELS
, OACC_KERNELS_CLAUSES
);
2021 gfc_match_oacc_data (void)
2023 return match_acc (EXEC_OACC_DATA
, OACC_DATA_CLAUSES
);
2028 gfc_match_oacc_host_data (void)
2030 return match_acc (EXEC_OACC_HOST_DATA
, OACC_HOST_DATA_CLAUSES
);
2035 gfc_match_oacc_loop (void)
2037 return match_acc (EXEC_OACC_LOOP
, OACC_LOOP_CLAUSES
);
2042 gfc_match_oacc_declare (void)
2045 gfc_omp_namelist
*n
;
2046 gfc_namespace
*ns
= gfc_current_ns
;
2047 gfc_oacc_declare
*new_oc
;
2048 bool module_var
= false;
2049 locus where
= gfc_current_locus
;
2051 if (gfc_match_omp_clauses (&c
, OACC_DECLARE_CLAUSES
, false, false, true)
2055 for (n
= c
->lists
[OMP_LIST_DEVICE_RESIDENT
]; n
!= NULL
; n
= n
->next
)
2056 n
->sym
->attr
.oacc_declare_device_resident
= 1;
2058 for (n
= c
->lists
[OMP_LIST_LINK
]; n
!= NULL
; n
= n
->next
)
2059 n
->sym
->attr
.oacc_declare_link
= 1;
2061 for (n
= c
->lists
[OMP_LIST_MAP
]; n
!= NULL
; n
= n
->next
)
2063 gfc_symbol
*s
= n
->sym
;
2065 if (s
->ns
->proc_name
&& s
->ns
->proc_name
->attr
.proc
== PROC_MODULE
)
2067 if (n
->u
.map_op
!= OMP_MAP_FORCE_ALLOC
2068 && n
->u
.map_op
!= OMP_MAP_FORCE_TO
)
2070 gfc_error ("Invalid clause in module with $!ACC DECLARE at %L",
2078 if (s
->attr
.use_assoc
)
2080 gfc_error ("Variable is USE-associated with $!ACC DECLARE at %L",
2085 if ((s
->attr
.dimension
|| s
->attr
.codimension
)
2086 && s
->attr
.dummy
&& s
->as
->type
!= AS_EXPLICIT
)
2088 gfc_error ("Assumed-size dummy array with $!ACC DECLARE at %L",
2093 switch (n
->u
.map_op
)
2095 case OMP_MAP_FORCE_ALLOC
:
2096 s
->attr
.oacc_declare_create
= 1;
2099 case OMP_MAP_FORCE_TO
:
2100 s
->attr
.oacc_declare_copyin
= 1;
2103 case OMP_MAP_FORCE_DEVICEPTR
:
2104 s
->attr
.oacc_declare_deviceptr
= 1;
2112 new_oc
= gfc_get_oacc_declare ();
2113 new_oc
->next
= ns
->oacc_declare
;
2114 new_oc
->module_var
= module_var
;
2115 new_oc
->clauses
= c
;
2116 new_oc
->loc
= gfc_current_locus
;
2117 ns
->oacc_declare
= new_oc
;
2124 gfc_match_oacc_update (void)
2127 locus here
= gfc_current_locus
;
2129 if (gfc_match_omp_clauses (&c
, OACC_UPDATE_CLAUSES
, false, false, true)
2133 if (!c
->lists
[OMP_LIST_MAP
])
2135 gfc_error ("%<acc update%> must contain at least one "
2136 "%<device%> or %<host%> or %<self%> clause at %L", &here
);
2140 new_st
.op
= EXEC_OACC_UPDATE
;
2141 new_st
.ext
.omp_clauses
= c
;
2147 gfc_match_oacc_enter_data (void)
2149 return match_acc (EXEC_OACC_ENTER_DATA
, OACC_ENTER_DATA_CLAUSES
);
2154 gfc_match_oacc_exit_data (void)
2156 return match_acc (EXEC_OACC_EXIT_DATA
, OACC_EXIT_DATA_CLAUSES
);
2161 gfc_match_oacc_wait (void)
2163 gfc_omp_clauses
*c
= gfc_get_omp_clauses ();
2164 gfc_expr_list
*wait_list
= NULL
, *el
;
2168 m
= match_oacc_expr_list (" (", &wait_list
, true);
2169 if (m
== MATCH_ERROR
)
2171 else if (m
== MATCH_YES
)
2174 if (gfc_match_omp_clauses (&c
, OACC_WAIT_CLAUSES
, space
, space
, true)
2179 for (el
= wait_list
; el
; el
= el
->next
)
2181 if (el
->expr
== NULL
)
2183 gfc_error ("Invalid argument to $!ACC WAIT at %L",
2184 &wait_list
->expr
->where
);
2188 if (!gfc_resolve_expr (el
->expr
)
2189 || el
->expr
->ts
.type
!= BT_INTEGER
|| el
->expr
->rank
!= 0
2190 || el
->expr
->expr_type
!= EXPR_CONSTANT
)
2192 gfc_error ("WAIT clause at %L requires a scalar INTEGER expression",
2198 c
->wait_list
= wait_list
;
2199 new_st
.op
= EXEC_OACC_WAIT
;
2200 new_st
.ext
.omp_clauses
= c
;
2206 gfc_match_oacc_cache (void)
2208 gfc_omp_clauses
*c
= gfc_get_omp_clauses ();
2209 /* The OpenACC cache directive explicitly only allows "array elements or
2210 subarrays", which we're currently not checking here. Either check this
2211 after the call of gfc_match_omp_variable_list, or add something like a
2212 only_sections variant next to its allow_sections parameter. */
2213 match m
= gfc_match_omp_variable_list (" (",
2214 &c
->lists
[OMP_LIST_CACHE
], true,
2218 gfc_free_omp_clauses(c
);
2222 if (gfc_current_state() != COMP_DO
2223 && gfc_current_state() != COMP_DO_CONCURRENT
)
2225 gfc_error ("ACC CACHE directive must be inside of loop %C");
2226 gfc_free_omp_clauses(c
);
2230 new_st
.op
= EXEC_OACC_CACHE
;
2231 new_st
.ext
.omp_clauses
= c
;
2235 /* Determine the loop level for a routine. */
2238 gfc_oacc_routine_dims (gfc_omp_clauses
*clauses
)
2247 level
= GOMP_DIM_GANG
, mask
|= GOMP_DIM_MASK (level
);
2248 if (clauses
->worker
)
2249 level
= GOMP_DIM_WORKER
, mask
|= GOMP_DIM_MASK (level
);
2250 if (clauses
->vector
)
2251 level
= GOMP_DIM_VECTOR
, mask
|= GOMP_DIM_MASK (level
);
2253 level
= GOMP_DIM_MAX
, mask
|= GOMP_DIM_MASK (level
);
2255 if (mask
!= (mask
& -mask
))
2256 gfc_error ("Multiple loop axes specified for routine");
2260 level
= GOMP_DIM_MAX
;
2266 gfc_match_oacc_routine (void)
2269 gfc_symbol
*sym
= NULL
;
2271 gfc_omp_clauses
*c
= NULL
;
2272 gfc_oacc_routine_name
*n
= NULL
;
2274 old_loc
= gfc_current_locus
;
2276 m
= gfc_match (" (");
2278 if (gfc_current_ns
->proc_name
2279 && gfc_current_ns
->proc_name
->attr
.if_source
== IFSRC_IFBODY
2282 gfc_error ("Only the !$ACC ROUTINE form without "
2283 "list is allowed in interface block at %C");
2289 char buffer
[GFC_MAX_SYMBOL_LEN
+ 1];
2292 m
= gfc_match_name (buffer
);
2295 st
= gfc_find_symtree (gfc_current_ns
->sym_root
, buffer
);
2299 if (strcmp (sym
->name
, gfc_current_ns
->proc_name
->name
) == 0)
2305 && !sym
->attr
.external
2306 && !sym
->attr
.function
2307 && !sym
->attr
.subroutine
))
2309 gfc_error ("Syntax error in !$ACC ROUTINE ( NAME ) at %C, "
2310 "invalid function name %s",
2311 (sym
) ? sym
->name
: buffer
);
2312 gfc_current_locus
= old_loc
;
2318 gfc_error ("Syntax error in !$ACC ROUTINE ( NAME ) at %C");
2319 gfc_current_locus
= old_loc
;
2323 if (gfc_match_char (')') != MATCH_YES
)
2325 gfc_error ("Syntax error in !$ACC ROUTINE ( NAME ) at %C, expecting"
2327 gfc_current_locus
= old_loc
;
2332 if (gfc_match_omp_eos () != MATCH_YES
2333 && (gfc_match_omp_clauses (&c
, OACC_ROUTINE_CLAUSES
, false, false, true)
2339 n
= gfc_get_oacc_routine_name ();
2343 if (gfc_current_ns
->oacc_routine_names
!= NULL
)
2344 n
->next
= gfc_current_ns
->oacc_routine_names
;
2346 gfc_current_ns
->oacc_routine_names
= n
;
2348 else if (gfc_current_ns
->proc_name
)
2350 if (!gfc_add_omp_declare_target (&gfc_current_ns
->proc_name
->attr
,
2351 gfc_current_ns
->proc_name
->name
,
2354 gfc_current_ns
->proc_name
->attr
.oacc_function
2355 = gfc_oacc_routine_dims (c
) + 1;
2360 else if (gfc_current_ns
->oacc_routine
)
2361 gfc_current_ns
->oacc_routine_clauses
= c
;
2363 new_st
.op
= EXEC_OACC_ROUTINE
;
2364 new_st
.ext
.omp_clauses
= c
;
2368 gfc_current_locus
= old_loc
;
2373 #define OMP_PARALLEL_CLAUSES \
2374 (omp_mask (OMP_CLAUSE_PRIVATE) | OMP_CLAUSE_FIRSTPRIVATE \
2375 | OMP_CLAUSE_SHARED | OMP_CLAUSE_COPYIN | OMP_CLAUSE_REDUCTION \
2376 | OMP_CLAUSE_IF | OMP_CLAUSE_NUM_THREADS | OMP_CLAUSE_DEFAULT \
2377 | OMP_CLAUSE_PROC_BIND)
2378 #define OMP_DECLARE_SIMD_CLAUSES \
2379 (omp_mask (OMP_CLAUSE_SIMDLEN) | OMP_CLAUSE_LINEAR \
2380 | OMP_CLAUSE_UNIFORM | OMP_CLAUSE_ALIGNED | OMP_CLAUSE_INBRANCH \
2381 | OMP_CLAUSE_NOTINBRANCH)
2382 #define OMP_DO_CLAUSES \
2383 (omp_mask (OMP_CLAUSE_PRIVATE) | OMP_CLAUSE_FIRSTPRIVATE \
2384 | OMP_CLAUSE_LASTPRIVATE | OMP_CLAUSE_REDUCTION \
2385 | OMP_CLAUSE_SCHEDULE | OMP_CLAUSE_ORDERED | OMP_CLAUSE_COLLAPSE \
2386 | OMP_CLAUSE_LINEAR)
2387 #define OMP_SECTIONS_CLAUSES \
2388 (omp_mask (OMP_CLAUSE_PRIVATE) | OMP_CLAUSE_FIRSTPRIVATE \
2389 | OMP_CLAUSE_LASTPRIVATE | OMP_CLAUSE_REDUCTION)
2390 #define OMP_SIMD_CLAUSES \
2391 (omp_mask (OMP_CLAUSE_PRIVATE) | OMP_CLAUSE_LASTPRIVATE \
2392 | OMP_CLAUSE_REDUCTION | OMP_CLAUSE_COLLAPSE | OMP_CLAUSE_SAFELEN \
2393 | OMP_CLAUSE_LINEAR | OMP_CLAUSE_ALIGNED | OMP_CLAUSE_SIMDLEN)
2394 #define OMP_TASK_CLAUSES \
2395 (omp_mask (OMP_CLAUSE_PRIVATE) | OMP_CLAUSE_FIRSTPRIVATE \
2396 | OMP_CLAUSE_SHARED | OMP_CLAUSE_IF | OMP_CLAUSE_DEFAULT \
2397 | OMP_CLAUSE_UNTIED | OMP_CLAUSE_FINAL | OMP_CLAUSE_MERGEABLE \
2398 | OMP_CLAUSE_DEPEND | OMP_CLAUSE_PRIORITY)
2399 #define OMP_TASKLOOP_CLAUSES \
2400 (omp_mask (OMP_CLAUSE_PRIVATE) | OMP_CLAUSE_FIRSTPRIVATE \
2401 | OMP_CLAUSE_LASTPRIVATE | OMP_CLAUSE_SHARED | OMP_CLAUSE_IF \
2402 | OMP_CLAUSE_DEFAULT | OMP_CLAUSE_UNTIED | OMP_CLAUSE_FINAL \
2403 | OMP_CLAUSE_MERGEABLE | OMP_CLAUSE_PRIORITY | OMP_CLAUSE_GRAINSIZE \
2404 | OMP_CLAUSE_NUM_TASKS | OMP_CLAUSE_COLLAPSE | OMP_CLAUSE_NOGROUP)
2405 #define OMP_TARGET_CLAUSES \
2406 (omp_mask (OMP_CLAUSE_DEVICE) | OMP_CLAUSE_MAP | OMP_CLAUSE_IF \
2407 | OMP_CLAUSE_DEPEND | OMP_CLAUSE_NOWAIT | OMP_CLAUSE_PRIVATE \
2408 | OMP_CLAUSE_FIRSTPRIVATE | OMP_CLAUSE_DEFAULTMAP \
2409 | OMP_CLAUSE_IS_DEVICE_PTR)
2410 #define OMP_TARGET_DATA_CLAUSES \
2411 (omp_mask (OMP_CLAUSE_DEVICE) | OMP_CLAUSE_MAP | OMP_CLAUSE_IF \
2412 | OMP_CLAUSE_USE_DEVICE_PTR)
2413 #define OMP_TARGET_ENTER_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_EXIT_DATA_CLAUSES \
2417 (omp_mask (OMP_CLAUSE_DEVICE) | OMP_CLAUSE_MAP | OMP_CLAUSE_IF \
2418 | OMP_CLAUSE_DEPEND | OMP_CLAUSE_NOWAIT)
2419 #define OMP_TARGET_UPDATE_CLAUSES \
2420 (omp_mask (OMP_CLAUSE_DEVICE) | OMP_CLAUSE_IF | OMP_CLAUSE_TO \
2421 | OMP_CLAUSE_FROM | OMP_CLAUSE_DEPEND | OMP_CLAUSE_NOWAIT)
2422 #define OMP_TEAMS_CLAUSES \
2423 (omp_mask (OMP_CLAUSE_NUM_TEAMS) | OMP_CLAUSE_THREAD_LIMIT \
2424 | OMP_CLAUSE_DEFAULT | OMP_CLAUSE_PRIVATE | OMP_CLAUSE_FIRSTPRIVATE \
2425 | OMP_CLAUSE_SHARED | OMP_CLAUSE_REDUCTION)
2426 #define OMP_DISTRIBUTE_CLAUSES \
2427 (omp_mask (OMP_CLAUSE_PRIVATE) | OMP_CLAUSE_FIRSTPRIVATE \
2428 | OMP_CLAUSE_COLLAPSE | OMP_CLAUSE_DIST_SCHEDULE)
2429 #define OMP_SINGLE_CLAUSES \
2430 (omp_mask (OMP_CLAUSE_PRIVATE) | OMP_CLAUSE_FIRSTPRIVATE)
2431 #define OMP_ORDERED_CLAUSES \
2432 (omp_mask (OMP_CLAUSE_THREADS) | OMP_CLAUSE_SIMD)
2433 #define OMP_DECLARE_TARGET_CLAUSES \
2434 (omp_mask (OMP_CLAUSE_TO) | OMP_CLAUSE_LINK)
2438 match_omp (gfc_exec_op op
, const omp_mask mask
)
2441 if (gfc_match_omp_clauses (&c
, mask
) != MATCH_YES
)
2444 new_st
.ext
.omp_clauses
= c
;
2450 gfc_match_omp_critical (void)
2452 char n
[GFC_MAX_SYMBOL_LEN
+1];
2453 gfc_omp_clauses
*c
= NULL
;
2455 if (gfc_match (" ( %n )", n
) != MATCH_YES
)
2458 if (gfc_match_omp_eos () != MATCH_YES
)
2460 gfc_error ("Unexpected junk after $OMP CRITICAL statement at %C");
2464 else if (gfc_match_omp_clauses (&c
, omp_mask (OMP_CLAUSE_HINT
)) != MATCH_YES
)
2467 new_st
.op
= EXEC_OMP_CRITICAL
;
2468 new_st
.ext
.omp_clauses
= c
;
2470 c
->critical_name
= xstrdup (n
);
2476 gfc_match_omp_end_critical (void)
2478 char n
[GFC_MAX_SYMBOL_LEN
+1];
2480 if (gfc_match (" ( %n )", n
) != MATCH_YES
)
2482 if (gfc_match_omp_eos () != MATCH_YES
)
2484 gfc_error ("Unexpected junk after $OMP CRITICAL statement at %C");
2488 new_st
.op
= EXEC_OMP_END_CRITICAL
;
2489 new_st
.ext
.omp_name
= n
[0] ? xstrdup (n
) : NULL
;
2495 gfc_match_omp_distribute (void)
2497 return match_omp (EXEC_OMP_DISTRIBUTE
, OMP_DISTRIBUTE_CLAUSES
);
2502 gfc_match_omp_distribute_parallel_do (void)
2504 return match_omp (EXEC_OMP_DISTRIBUTE_PARALLEL_DO
,
2505 (OMP_DISTRIBUTE_CLAUSES
| OMP_PARALLEL_CLAUSES
2507 & ~(omp_mask (OMP_CLAUSE_ORDERED
))
2508 & ~(omp_mask (OMP_CLAUSE_LINEAR
)));
2513 gfc_match_omp_distribute_parallel_do_simd (void)
2515 return match_omp (EXEC_OMP_DISTRIBUTE_PARALLEL_DO_SIMD
,
2516 (OMP_DISTRIBUTE_CLAUSES
| OMP_PARALLEL_CLAUSES
2517 | OMP_DO_CLAUSES
| OMP_SIMD_CLAUSES
)
2518 & ~(omp_mask (OMP_CLAUSE_ORDERED
)));
2523 gfc_match_omp_distribute_simd (void)
2525 return match_omp (EXEC_OMP_DISTRIBUTE_SIMD
,
2526 OMP_DISTRIBUTE_CLAUSES
| OMP_SIMD_CLAUSES
);
2531 gfc_match_omp_do (void)
2533 return match_omp (EXEC_OMP_DO
, OMP_DO_CLAUSES
);
2538 gfc_match_omp_do_simd (void)
2540 return match_omp (EXEC_OMP_DO_SIMD
, OMP_DO_CLAUSES
| OMP_SIMD_CLAUSES
);
2545 gfc_match_omp_flush (void)
2547 gfc_omp_namelist
*list
= NULL
;
2548 gfc_match_omp_variable_list (" (", &list
, true);
2549 if (gfc_match_omp_eos () != MATCH_YES
)
2551 gfc_error ("Unexpected junk after $OMP FLUSH statement at %C");
2552 gfc_free_omp_namelist (list
);
2555 new_st
.op
= EXEC_OMP_FLUSH
;
2556 new_st
.ext
.omp_namelist
= list
;
2562 gfc_match_omp_declare_simd (void)
2564 locus where
= gfc_current_locus
;
2565 gfc_symbol
*proc_name
;
2567 gfc_omp_declare_simd
*ods
;
2568 bool needs_space
= false;
2570 switch (gfc_match (" ( %s ) ", &proc_name
))
2572 case MATCH_YES
: break;
2573 case MATCH_NO
: proc_name
= NULL
; needs_space
= true; break;
2574 case MATCH_ERROR
: return MATCH_ERROR
;
2577 if (gfc_match_omp_clauses (&c
, OMP_DECLARE_SIMD_CLAUSES
, true,
2578 needs_space
) != MATCH_YES
)
2581 if (gfc_current_ns
->is_block_data
)
2583 gfc_free_omp_clauses (c
);
2587 ods
= gfc_get_omp_declare_simd ();
2589 ods
->proc_name
= proc_name
;
2591 ods
->next
= gfc_current_ns
->omp_declare_simd
;
2592 gfc_current_ns
->omp_declare_simd
= ods
;
2598 match_udr_expr (gfc_symtree
*omp_sym1
, gfc_symtree
*omp_sym2
)
2601 locus old_loc
= gfc_current_locus
;
2602 char sname
[GFC_MAX_SYMBOL_LEN
+ 1];
2604 gfc_namespace
*ns
= gfc_current_ns
;
2605 gfc_expr
*lvalue
= NULL
, *rvalue
= NULL
;
2607 gfc_actual_arglist
*arglist
;
2609 m
= gfc_match (" %v =", &lvalue
);
2611 gfc_current_locus
= old_loc
;
2614 m
= gfc_match (" %e )", &rvalue
);
2617 ns
->code
= gfc_get_code (EXEC_ASSIGN
);
2618 ns
->code
->expr1
= lvalue
;
2619 ns
->code
->expr2
= rvalue
;
2620 ns
->code
->loc
= old_loc
;
2624 gfc_current_locus
= old_loc
;
2625 gfc_free_expr (lvalue
);
2628 m
= gfc_match (" %n", sname
);
2632 if (strcmp (sname
, omp_sym1
->name
) == 0
2633 || strcmp (sname
, omp_sym2
->name
) == 0)
2636 gfc_current_ns
= ns
->parent
;
2637 if (gfc_get_ha_sym_tree (sname
, &st
))
2641 if (sym
->attr
.flavor
!= FL_PROCEDURE
2642 && sym
->attr
.flavor
!= FL_UNKNOWN
)
2645 if (!sym
->attr
.generic
2646 && !sym
->attr
.subroutine
2647 && !sym
->attr
.function
)
2649 if (!(sym
->attr
.external
&& !sym
->attr
.referenced
))
2651 /* ...create a symbol in this scope... */
2652 if (sym
->ns
!= gfc_current_ns
2653 && gfc_get_sym_tree (sname
, NULL
, &st
, false) == 1)
2656 if (sym
!= st
->n
.sym
)
2660 /* ...and then to try to make the symbol into a subroutine. */
2661 if (!gfc_add_subroutine (&sym
->attr
, sym
->name
, NULL
))
2665 gfc_set_sym_referenced (sym
);
2666 gfc_gobble_whitespace ();
2667 if (gfc_peek_ascii_char () != '(')
2670 gfc_current_ns
= ns
;
2671 m
= gfc_match_actual_arglist (1, &arglist
);
2675 if (gfc_match_char (')') != MATCH_YES
)
2678 ns
->code
= gfc_get_code (EXEC_CALL
);
2679 ns
->code
->symtree
= st
;
2680 ns
->code
->ext
.actual
= arglist
;
2681 ns
->code
->loc
= old_loc
;
2686 gfc_omp_udr_predef (gfc_omp_reduction_op rop
, const char *name
,
2687 gfc_typespec
*ts
, const char **n
)
2689 if (!gfc_numeric_ts (ts
) && ts
->type
!= BT_LOGICAL
)
2694 case OMP_REDUCTION_PLUS
:
2695 case OMP_REDUCTION_MINUS
:
2696 case OMP_REDUCTION_TIMES
:
2697 return ts
->type
!= BT_LOGICAL
;
2698 case OMP_REDUCTION_AND
:
2699 case OMP_REDUCTION_OR
:
2700 case OMP_REDUCTION_EQV
:
2701 case OMP_REDUCTION_NEQV
:
2702 return ts
->type
== BT_LOGICAL
;
2703 case OMP_REDUCTION_USER
:
2704 if (name
[0] != '.' && (ts
->type
== BT_INTEGER
|| ts
->type
== BT_REAL
))
2708 gfc_find_symbol (name
, NULL
, 1, &sym
);
2711 if (sym
->attr
.intrinsic
)
2713 else if ((sym
->attr
.flavor
!= FL_UNKNOWN
2714 && sym
->attr
.flavor
!= FL_PROCEDURE
)
2715 || sym
->attr
.external
2716 || sym
->attr
.generic
2720 || sym
->attr
.subroutine
2721 || sym
->attr
.pointer
2723 || sym
->attr
.cray_pointer
2724 || sym
->attr
.cray_pointee
2725 || (sym
->attr
.proc
!= PROC_UNKNOWN
2726 && sym
->attr
.proc
!= PROC_INTRINSIC
)
2727 || sym
->attr
.if_source
!= IFSRC_UNKNOWN
2728 || sym
== sym
->ns
->proc_name
)
2736 && (strcmp (*n
, "max") == 0 || strcmp (*n
, "min") == 0))
2739 && ts
->type
== BT_INTEGER
2740 && (strcmp (*n
, "iand") == 0
2741 || strcmp (*n
, "ior") == 0
2742 || strcmp (*n
, "ieor") == 0))
2753 gfc_omp_udr_find (gfc_symtree
*st
, gfc_typespec
*ts
)
2755 gfc_omp_udr
*omp_udr
;
2760 for (omp_udr
= st
->n
.omp_udr
; omp_udr
; omp_udr
= omp_udr
->next
)
2761 if (omp_udr
->ts
.type
== ts
->type
2762 || ((omp_udr
->ts
.type
== BT_DERIVED
|| omp_udr
->ts
.type
== BT_CLASS
)
2763 && (ts
->type
== BT_DERIVED
|| ts
->type
== BT_CLASS
)))
2765 if (omp_udr
->ts
.type
== BT_DERIVED
|| omp_udr
->ts
.type
== BT_CLASS
)
2767 if (strcmp (omp_udr
->ts
.u
.derived
->name
, ts
->u
.derived
->name
) == 0)
2770 else if (omp_udr
->ts
.kind
== ts
->kind
)
2772 if (omp_udr
->ts
.type
== BT_CHARACTER
)
2774 if (omp_udr
->ts
.u
.cl
->length
== NULL
2775 || ts
->u
.cl
->length
== NULL
)
2777 if (omp_udr
->ts
.u
.cl
->length
->expr_type
!= EXPR_CONSTANT
)
2779 if (ts
->u
.cl
->length
->expr_type
!= EXPR_CONSTANT
)
2781 if (omp_udr
->ts
.u
.cl
->length
->ts
.type
!= BT_INTEGER
)
2783 if (ts
->u
.cl
->length
->ts
.type
!= BT_INTEGER
)
2785 if (gfc_compare_expr (omp_udr
->ts
.u
.cl
->length
,
2786 ts
->u
.cl
->length
, INTRINSIC_EQ
) != 0)
2796 gfc_match_omp_declare_reduction (void)
2799 gfc_intrinsic_op op
;
2800 char name
[GFC_MAX_SYMBOL_LEN
+ 3];
2801 auto_vec
<gfc_typespec
, 5> tss
;
2805 locus where
= gfc_current_locus
;
2806 locus end_loc
= gfc_current_locus
;
2807 bool end_loc_set
= false;
2808 gfc_omp_reduction_op rop
= OMP_REDUCTION_NONE
;
2810 if (gfc_match_char ('(') != MATCH_YES
)
2813 m
= gfc_match (" %o : ", &op
);
2814 if (m
== MATCH_ERROR
)
2818 snprintf (name
, sizeof name
, "operator %s", gfc_op2string (op
));
2819 rop
= (gfc_omp_reduction_op
) op
;
2823 m
= gfc_match_defined_op_name (name
+ 1, 1);
2824 if (m
== MATCH_ERROR
)
2830 if (gfc_match (" : ") != MATCH_YES
)
2835 if (gfc_match (" %n : ", name
) != MATCH_YES
)
2838 rop
= OMP_REDUCTION_USER
;
2841 m
= gfc_match_type_spec (&ts
);
2844 /* Treat len=: the same as len=*. */
2845 if (ts
.type
== BT_CHARACTER
)
2846 ts
.deferred
= false;
2849 while (gfc_match_char (',') == MATCH_YES
)
2851 m
= gfc_match_type_spec (&ts
);
2856 if (gfc_match_char (':') != MATCH_YES
)
2859 st
= gfc_find_symtree (gfc_current_ns
->omp_udr_root
, name
);
2860 for (i
= 0; i
< tss
.length (); i
++)
2862 gfc_symtree
*omp_out
, *omp_in
;
2863 gfc_symtree
*omp_priv
= NULL
, *omp_orig
= NULL
;
2864 gfc_namespace
*combiner_ns
, *initializer_ns
= NULL
;
2865 gfc_omp_udr
*prev_udr
, *omp_udr
;
2866 const char *predef_name
= NULL
;
2868 omp_udr
= gfc_get_omp_udr ();
2869 omp_udr
->name
= gfc_get_string (name
);
2871 omp_udr
->ts
= tss
[i
];
2872 omp_udr
->where
= where
;
2874 gfc_current_ns
= combiner_ns
= gfc_get_namespace (gfc_current_ns
, 1);
2875 combiner_ns
->proc_name
= combiner_ns
->parent
->proc_name
;
2877 gfc_get_sym_tree ("omp_out", combiner_ns
, &omp_out
, false);
2878 gfc_get_sym_tree ("omp_in", combiner_ns
, &omp_in
, false);
2879 combiner_ns
->omp_udr_ns
= 1;
2880 omp_out
->n
.sym
->ts
= tss
[i
];
2881 omp_in
->n
.sym
->ts
= tss
[i
];
2882 omp_out
->n
.sym
->attr
.omp_udr_artificial_var
= 1;
2883 omp_in
->n
.sym
->attr
.omp_udr_artificial_var
= 1;
2884 omp_out
->n
.sym
->attr
.flavor
= FL_VARIABLE
;
2885 omp_in
->n
.sym
->attr
.flavor
= FL_VARIABLE
;
2886 gfc_commit_symbols ();
2887 omp_udr
->combiner_ns
= combiner_ns
;
2888 omp_udr
->omp_out
= omp_out
->n
.sym
;
2889 omp_udr
->omp_in
= omp_in
->n
.sym
;
2891 locus old_loc
= gfc_current_locus
;
2893 if (!match_udr_expr (omp_out
, omp_in
))
2896 gfc_current_locus
= old_loc
;
2897 gfc_current_ns
= combiner_ns
->parent
;
2898 gfc_undo_symbols ();
2899 gfc_free_omp_udr (omp_udr
);
2903 if (gfc_match (" initializer ( ") == MATCH_YES
)
2905 gfc_current_ns
= combiner_ns
->parent
;
2906 initializer_ns
= gfc_get_namespace (gfc_current_ns
, 1);
2907 gfc_current_ns
= initializer_ns
;
2908 initializer_ns
->proc_name
= initializer_ns
->parent
->proc_name
;
2910 gfc_get_sym_tree ("omp_priv", initializer_ns
, &omp_priv
, false);
2911 gfc_get_sym_tree ("omp_orig", initializer_ns
, &omp_orig
, false);
2912 initializer_ns
->omp_udr_ns
= 1;
2913 omp_priv
->n
.sym
->ts
= tss
[i
];
2914 omp_orig
->n
.sym
->ts
= tss
[i
];
2915 omp_priv
->n
.sym
->attr
.omp_udr_artificial_var
= 1;
2916 omp_orig
->n
.sym
->attr
.omp_udr_artificial_var
= 1;
2917 omp_priv
->n
.sym
->attr
.flavor
= FL_VARIABLE
;
2918 omp_orig
->n
.sym
->attr
.flavor
= FL_VARIABLE
;
2919 gfc_commit_symbols ();
2920 omp_udr
->initializer_ns
= initializer_ns
;
2921 omp_udr
->omp_priv
= omp_priv
->n
.sym
;
2922 omp_udr
->omp_orig
= omp_orig
->n
.sym
;
2924 if (!match_udr_expr (omp_priv
, omp_orig
))
2928 gfc_current_ns
= combiner_ns
->parent
;
2932 end_loc
= gfc_current_locus
;
2934 gfc_current_locus
= old_loc
;
2936 prev_udr
= gfc_omp_udr_find (st
, &tss
[i
]);
2937 if (gfc_omp_udr_predef (rop
, name
, &tss
[i
], &predef_name
)
2938 /* Don't error on !$omp declare reduction (min : integer : ...)
2939 just yet, there could be integer :: min afterwards,
2940 making it valid. When the UDR is resolved, we'll get
2942 && (rop
!= OMP_REDUCTION_USER
|| name
[0] == '.'))
2945 gfc_error_now ("Redefinition of predefined %s "
2946 "!$OMP DECLARE REDUCTION at %L",
2947 predef_name
, &where
);
2949 gfc_error_now ("Redefinition of predefined "
2950 "!$OMP DECLARE REDUCTION at %L", &where
);
2954 gfc_error_now ("Redefinition of !$OMP DECLARE REDUCTION at %L",
2956 gfc_error_now ("Previous !$OMP DECLARE REDUCTION at %L",
2961 omp_udr
->next
= st
->n
.omp_udr
;
2962 st
->n
.omp_udr
= omp_udr
;
2966 st
= gfc_new_symtree (&gfc_current_ns
->omp_udr_root
, name
);
2967 st
->n
.omp_udr
= omp_udr
;
2973 gfc_current_locus
= end_loc
;
2974 if (gfc_match_omp_eos () != MATCH_YES
)
2976 gfc_error ("Unexpected junk after !$OMP DECLARE REDUCTION at %C");
2977 gfc_current_locus
= where
;
2989 gfc_match_omp_declare_target (void)
2993 gfc_omp_clauses
*c
= NULL
;
2995 gfc_omp_namelist
*n
;
2998 old_loc
= gfc_current_locus
;
3000 if (gfc_current_ns
->proc_name
3001 && gfc_match_omp_eos () == MATCH_YES
)
3003 if (!gfc_add_omp_declare_target (&gfc_current_ns
->proc_name
->attr
,
3004 gfc_current_ns
->proc_name
->name
,
3010 if (gfc_current_ns
->proc_name
3011 && gfc_current_ns
->proc_name
->attr
.if_source
== IFSRC_IFBODY
)
3013 gfc_error ("Only the !$OMP DECLARE TARGET form without "
3014 "clauses is allowed in interface block at %C");
3018 m
= gfc_match (" (");
3021 c
= gfc_get_omp_clauses ();
3022 gfc_current_locus
= old_loc
;
3023 m
= gfc_match_omp_to_link (" (", &c
->lists
[OMP_LIST_TO
]);
3026 if (gfc_match_omp_eos () != MATCH_YES
)
3028 gfc_error ("Unexpected junk after !$OMP DECLARE TARGET at %C");
3032 else if (gfc_match_omp_clauses (&c
, OMP_DECLARE_TARGET_CLAUSES
) != MATCH_YES
)
3035 gfc_buffer_error (false);
3037 for (list
= OMP_LIST_TO
; list
!= OMP_LIST_NUM
;
3038 list
= (list
== OMP_LIST_TO
? OMP_LIST_LINK
: OMP_LIST_NUM
))
3039 for (n
= c
->lists
[list
]; n
; n
= n
->next
)
3042 else if (n
->u
.common
->head
)
3043 n
->u
.common
->head
->mark
= 0;
3045 for (list
= OMP_LIST_TO
; list
!= OMP_LIST_NUM
;
3046 list
= (list
== OMP_LIST_TO
? OMP_LIST_LINK
: OMP_LIST_NUM
))
3047 for (n
= c
->lists
[list
]; n
; n
= n
->next
)
3050 if (n
->sym
->attr
.in_common
)
3051 gfc_error_now ("OMP DECLARE TARGET variable at %L is an "
3052 "element of a COMMON block", &n
->where
);
3053 else if (n
->sym
->attr
.omp_declare_target
3054 && n
->sym
->attr
.omp_declare_target_link
3055 && list
!= OMP_LIST_LINK
)
3056 gfc_error_now ("OMP DECLARE TARGET variable at %L previously "
3057 "mentioned in LINK clause and later in TO clause",
3059 else if (n
->sym
->attr
.omp_declare_target
3060 && !n
->sym
->attr
.omp_declare_target_link
3061 && list
== OMP_LIST_LINK
)
3062 gfc_error_now ("OMP DECLARE TARGET variable at %L previously "
3063 "mentioned in TO clause and later in LINK clause",
3065 else if (n
->sym
->mark
)
3066 gfc_error_now ("Variable at %L mentioned multiple times in "
3067 "clauses of the same OMP DECLARE TARGET directive",
3069 else if (gfc_add_omp_declare_target (&n
->sym
->attr
, n
->sym
->name
,
3070 &n
->sym
->declared_at
))
3072 if (list
== OMP_LIST_LINK
)
3073 gfc_add_omp_declare_target_link (&n
->sym
->attr
, n
->sym
->name
,
3074 &n
->sym
->declared_at
);
3078 else if (n
->u
.common
->omp_declare_target
3079 && n
->u
.common
->omp_declare_target_link
3080 && list
!= OMP_LIST_LINK
)
3081 gfc_error_now ("OMP DECLARE TARGET COMMON at %L previously "
3082 "mentioned in LINK clause and later in TO clause",
3084 else if (n
->u
.common
->omp_declare_target
3085 && !n
->u
.common
->omp_declare_target_link
3086 && list
== OMP_LIST_LINK
)
3087 gfc_error_now ("OMP DECLARE TARGET COMMON at %L previously "
3088 "mentioned in TO clause and later in LINK clause",
3090 else if (n
->u
.common
->head
&& n
->u
.common
->head
->mark
)
3091 gfc_error_now ("COMMON at %L mentioned multiple times in "
3092 "clauses of the same OMP DECLARE TARGET directive",
3096 n
->u
.common
->omp_declare_target
= 1;
3097 n
->u
.common
->omp_declare_target_link
= (list
== OMP_LIST_LINK
);
3098 for (s
= n
->u
.common
->head
; s
; s
= s
->common_next
)
3101 if (gfc_add_omp_declare_target (&s
->attr
, s
->name
,
3104 if (list
== OMP_LIST_LINK
)
3105 gfc_add_omp_declare_target_link (&s
->attr
, s
->name
,
3111 gfc_buffer_error (true);
3114 gfc_free_omp_clauses (c
);
3118 gfc_error ("Syntax error in !$OMP DECLARE TARGET list at %C");
3121 gfc_current_locus
= old_loc
;
3123 gfc_free_omp_clauses (c
);
3129 gfc_match_omp_threadprivate (void)
3132 char n
[GFC_MAX_SYMBOL_LEN
+1];
3137 old_loc
= gfc_current_locus
;
3139 m
= gfc_match (" (");
3145 m
= gfc_match_symbol (&sym
, 0);
3149 if (sym
->attr
.in_common
)
3150 gfc_error_now ("Threadprivate variable at %C is an element of "
3152 else if (!gfc_add_threadprivate (&sym
->attr
, sym
->name
, &sym
->declared_at
))
3161 m
= gfc_match (" / %n /", n
);
3162 if (m
== MATCH_ERROR
)
3164 if (m
== MATCH_NO
|| n
[0] == '\0')
3167 st
= gfc_find_symtree (gfc_current_ns
->common_root
, n
);
3170 gfc_error ("COMMON block /%s/ not found at %C", n
);
3173 st
->n
.common
->threadprivate
= 1;
3174 for (sym
= st
->n
.common
->head
; sym
; sym
= sym
->common_next
)
3175 if (!gfc_add_threadprivate (&sym
->attr
, sym
->name
, &sym
->declared_at
))
3179 if (gfc_match_char (')') == MATCH_YES
)
3181 if (gfc_match_char (',') != MATCH_YES
)
3185 if (gfc_match_omp_eos () != MATCH_YES
)
3187 gfc_error ("Unexpected junk after OMP THREADPRIVATE at %C");
3194 gfc_error ("Syntax error in !$OMP THREADPRIVATE list at %C");
3197 gfc_current_locus
= old_loc
;
3203 gfc_match_omp_parallel (void)
3205 return match_omp (EXEC_OMP_PARALLEL
, OMP_PARALLEL_CLAUSES
);
3210 gfc_match_omp_parallel_do (void)
3212 return match_omp (EXEC_OMP_PARALLEL_DO
,
3213 OMP_PARALLEL_CLAUSES
| OMP_DO_CLAUSES
);
3218 gfc_match_omp_parallel_do_simd (void)
3220 return match_omp (EXEC_OMP_PARALLEL_DO_SIMD
,
3221 OMP_PARALLEL_CLAUSES
| OMP_DO_CLAUSES
| OMP_SIMD_CLAUSES
);
3226 gfc_match_omp_parallel_sections (void)
3228 return match_omp (EXEC_OMP_PARALLEL_SECTIONS
,
3229 OMP_PARALLEL_CLAUSES
| OMP_SECTIONS_CLAUSES
);
3234 gfc_match_omp_parallel_workshare (void)
3236 return match_omp (EXEC_OMP_PARALLEL_WORKSHARE
, OMP_PARALLEL_CLAUSES
);
3241 gfc_match_omp_sections (void)
3243 return match_omp (EXEC_OMP_SECTIONS
, OMP_SECTIONS_CLAUSES
);
3248 gfc_match_omp_simd (void)
3250 return match_omp (EXEC_OMP_SIMD
, OMP_SIMD_CLAUSES
);
3255 gfc_match_omp_single (void)
3257 return match_omp (EXEC_OMP_SINGLE
, OMP_SINGLE_CLAUSES
);
3262 gfc_match_omp_target (void)
3264 return match_omp (EXEC_OMP_TARGET
, OMP_TARGET_CLAUSES
);
3269 gfc_match_omp_target_data (void)
3271 return match_omp (EXEC_OMP_TARGET_DATA
, OMP_TARGET_DATA_CLAUSES
);
3276 gfc_match_omp_target_enter_data (void)
3278 return match_omp (EXEC_OMP_TARGET_ENTER_DATA
, OMP_TARGET_ENTER_DATA_CLAUSES
);
3283 gfc_match_omp_target_exit_data (void)
3285 return match_omp (EXEC_OMP_TARGET_EXIT_DATA
, OMP_TARGET_EXIT_DATA_CLAUSES
);
3290 gfc_match_omp_target_parallel (void)
3292 return match_omp (EXEC_OMP_TARGET_PARALLEL
,
3293 (OMP_TARGET_CLAUSES
| OMP_PARALLEL_CLAUSES
)
3294 & ~(omp_mask (OMP_CLAUSE_COPYIN
)));
3299 gfc_match_omp_target_parallel_do (void)
3301 return match_omp (EXEC_OMP_TARGET_PARALLEL_DO
,
3302 (OMP_TARGET_CLAUSES
| OMP_PARALLEL_CLAUSES
3303 | OMP_DO_CLAUSES
) & ~(omp_mask (OMP_CLAUSE_COPYIN
)));
3308 gfc_match_omp_target_parallel_do_simd (void)
3310 return match_omp (EXEC_OMP_TARGET_PARALLEL_DO_SIMD
,
3311 (OMP_TARGET_CLAUSES
| OMP_PARALLEL_CLAUSES
| OMP_DO_CLAUSES
3312 | OMP_SIMD_CLAUSES
) & ~(omp_mask (OMP_CLAUSE_COPYIN
)));
3317 gfc_match_omp_target_simd (void)
3319 return match_omp (EXEC_OMP_TARGET_SIMD
,
3320 OMP_TARGET_CLAUSES
| OMP_SIMD_CLAUSES
);
3325 gfc_match_omp_target_teams (void)
3327 return match_omp (EXEC_OMP_TARGET_TEAMS
,
3328 OMP_TARGET_CLAUSES
| OMP_TEAMS_CLAUSES
);
3333 gfc_match_omp_target_teams_distribute (void)
3335 return match_omp (EXEC_OMP_TARGET_TEAMS_DISTRIBUTE
,
3336 OMP_TARGET_CLAUSES
| OMP_TEAMS_CLAUSES
3337 | OMP_DISTRIBUTE_CLAUSES
);
3342 gfc_match_omp_target_teams_distribute_parallel_do (void)
3344 return match_omp (EXEC_OMP_TARGET_TEAMS_DISTRIBUTE_PARALLEL_DO
,
3345 (OMP_TARGET_CLAUSES
| OMP_TEAMS_CLAUSES
3346 | OMP_DISTRIBUTE_CLAUSES
| OMP_PARALLEL_CLAUSES
3348 & ~(omp_mask (OMP_CLAUSE_ORDERED
))
3349 & ~(omp_mask (OMP_CLAUSE_LINEAR
)));
3354 gfc_match_omp_target_teams_distribute_parallel_do_simd (void)
3356 return match_omp (EXEC_OMP_TARGET_TEAMS_DISTRIBUTE_PARALLEL_DO_SIMD
,
3357 (OMP_TARGET_CLAUSES
| OMP_TEAMS_CLAUSES
3358 | OMP_DISTRIBUTE_CLAUSES
| OMP_PARALLEL_CLAUSES
3359 | OMP_DO_CLAUSES
| OMP_SIMD_CLAUSES
)
3360 & ~(omp_mask (OMP_CLAUSE_ORDERED
)));
3365 gfc_match_omp_target_teams_distribute_simd (void)
3367 return match_omp (EXEC_OMP_TARGET_TEAMS_DISTRIBUTE_SIMD
,
3368 OMP_TARGET_CLAUSES
| OMP_TEAMS_CLAUSES
3369 | OMP_DISTRIBUTE_CLAUSES
| OMP_SIMD_CLAUSES
);
3374 gfc_match_omp_target_update (void)
3376 return match_omp (EXEC_OMP_TARGET_UPDATE
, OMP_TARGET_UPDATE_CLAUSES
);
3381 gfc_match_omp_task (void)
3383 return match_omp (EXEC_OMP_TASK
, OMP_TASK_CLAUSES
);
3388 gfc_match_omp_taskloop (void)
3390 return match_omp (EXEC_OMP_TASKLOOP
, OMP_TASKLOOP_CLAUSES
);
3395 gfc_match_omp_taskloop_simd (void)
3397 return match_omp (EXEC_OMP_TASKLOOP_SIMD
,
3398 (OMP_TASKLOOP_CLAUSES
| OMP_SIMD_CLAUSES
)
3399 & ~(omp_mask (OMP_CLAUSE_REDUCTION
)));
3404 gfc_match_omp_taskwait (void)
3406 if (gfc_match_omp_eos () != MATCH_YES
)
3408 gfc_error ("Unexpected junk after TASKWAIT clause at %C");
3411 new_st
.op
= EXEC_OMP_TASKWAIT
;
3412 new_st
.ext
.omp_clauses
= NULL
;
3418 gfc_match_omp_taskyield (void)
3420 if (gfc_match_omp_eos () != MATCH_YES
)
3422 gfc_error ("Unexpected junk after TASKYIELD clause at %C");
3425 new_st
.op
= EXEC_OMP_TASKYIELD
;
3426 new_st
.ext
.omp_clauses
= NULL
;
3432 gfc_match_omp_teams (void)
3434 return match_omp (EXEC_OMP_TEAMS
, OMP_TEAMS_CLAUSES
);
3439 gfc_match_omp_teams_distribute (void)
3441 return match_omp (EXEC_OMP_TEAMS_DISTRIBUTE
,
3442 OMP_TEAMS_CLAUSES
| OMP_DISTRIBUTE_CLAUSES
);
3447 gfc_match_omp_teams_distribute_parallel_do (void)
3449 return match_omp (EXEC_OMP_TEAMS_DISTRIBUTE_PARALLEL_DO
,
3450 (OMP_TEAMS_CLAUSES
| OMP_DISTRIBUTE_CLAUSES
3451 | OMP_PARALLEL_CLAUSES
| OMP_DO_CLAUSES
)
3452 & ~(omp_mask (OMP_CLAUSE_ORDERED
))
3453 & ~(omp_mask (OMP_CLAUSE_LINEAR
)));
3458 gfc_match_omp_teams_distribute_parallel_do_simd (void)
3460 return match_omp (EXEC_OMP_TEAMS_DISTRIBUTE_PARALLEL_DO_SIMD
,
3461 (OMP_TEAMS_CLAUSES
| OMP_DISTRIBUTE_CLAUSES
3462 | OMP_PARALLEL_CLAUSES
| OMP_DO_CLAUSES
3463 | OMP_SIMD_CLAUSES
) & ~(omp_mask (OMP_CLAUSE_ORDERED
)));
3468 gfc_match_omp_teams_distribute_simd (void)
3470 return match_omp (EXEC_OMP_TEAMS_DISTRIBUTE_SIMD
,
3471 OMP_TEAMS_CLAUSES
| OMP_DISTRIBUTE_CLAUSES
3472 | OMP_SIMD_CLAUSES
);
3477 gfc_match_omp_workshare (void)
3479 if (gfc_match_omp_eos () != MATCH_YES
)
3481 gfc_error ("Unexpected junk after $OMP WORKSHARE statement at %C");
3484 new_st
.op
= EXEC_OMP_WORKSHARE
;
3485 new_st
.ext
.omp_clauses
= gfc_get_omp_clauses ();
3491 gfc_match_omp_master (void)
3493 if (gfc_match_omp_eos () != MATCH_YES
)
3495 gfc_error ("Unexpected junk after $OMP MASTER statement at %C");
3498 new_st
.op
= EXEC_OMP_MASTER
;
3499 new_st
.ext
.omp_clauses
= NULL
;
3505 gfc_match_omp_ordered (void)
3507 return match_omp (EXEC_OMP_ORDERED
, OMP_ORDERED_CLAUSES
);
3512 gfc_match_omp_ordered_depend (void)
3514 return match_omp (EXEC_OMP_ORDERED
, omp_mask (OMP_CLAUSE_DEPEND
));
3519 gfc_match_omp_oacc_atomic (bool omp_p
)
3521 gfc_omp_atomic_op op
= GFC_OMP_ATOMIC_UPDATE
;
3523 if (gfc_match ("% seq_cst") == MATCH_YES
)
3525 locus old_loc
= gfc_current_locus
;
3526 if (seq_cst
&& gfc_match_char (',') == MATCH_YES
)
3529 || gfc_match_space () == MATCH_YES
)
3531 gfc_gobble_whitespace ();
3532 if (gfc_match ("update") == MATCH_YES
)
3533 op
= GFC_OMP_ATOMIC_UPDATE
;
3534 else if (gfc_match ("read") == MATCH_YES
)
3535 op
= GFC_OMP_ATOMIC_READ
;
3536 else if (gfc_match ("write") == MATCH_YES
)
3537 op
= GFC_OMP_ATOMIC_WRITE
;
3538 else if (gfc_match ("capture") == MATCH_YES
)
3539 op
= GFC_OMP_ATOMIC_CAPTURE
;
3543 gfc_current_locus
= old_loc
;
3547 && (gfc_match (", seq_cst") == MATCH_YES
3548 || gfc_match ("% seq_cst") == MATCH_YES
))
3552 if (gfc_match_omp_eos () != MATCH_YES
)
3554 gfc_error ("Unexpected junk after $OMP ATOMIC statement at %C");
3557 new_st
.op
= (omp_p
? EXEC_OMP_ATOMIC
: EXEC_OACC_ATOMIC
);
3559 op
= (gfc_omp_atomic_op
) (op
| GFC_OMP_ATOMIC_SEQ_CST
);
3560 new_st
.ext
.omp_atomic
= op
;
3565 gfc_match_oacc_atomic (void)
3567 return gfc_match_omp_oacc_atomic (false);
3571 gfc_match_omp_atomic (void)
3573 return gfc_match_omp_oacc_atomic (true);
3577 gfc_match_omp_barrier (void)
3579 if (gfc_match_omp_eos () != MATCH_YES
)
3581 gfc_error ("Unexpected junk after $OMP BARRIER statement at %C");
3584 new_st
.op
= EXEC_OMP_BARRIER
;
3585 new_st
.ext
.omp_clauses
= NULL
;
3591 gfc_match_omp_taskgroup (void)
3593 if (gfc_match_omp_eos () != MATCH_YES
)
3595 gfc_error ("Unexpected junk after $OMP TASKGROUP statement at %C");
3598 new_st
.op
= EXEC_OMP_TASKGROUP
;
3603 static enum gfc_omp_cancel_kind
3604 gfc_match_omp_cancel_kind (void)
3606 if (gfc_match_space () != MATCH_YES
)
3607 return OMP_CANCEL_UNKNOWN
;
3608 if (gfc_match ("parallel") == MATCH_YES
)
3609 return OMP_CANCEL_PARALLEL
;
3610 if (gfc_match ("sections") == MATCH_YES
)
3611 return OMP_CANCEL_SECTIONS
;
3612 if (gfc_match ("do") == MATCH_YES
)
3613 return OMP_CANCEL_DO
;
3614 if (gfc_match ("taskgroup") == MATCH_YES
)
3615 return OMP_CANCEL_TASKGROUP
;
3616 return OMP_CANCEL_UNKNOWN
;
3621 gfc_match_omp_cancel (void)
3624 enum gfc_omp_cancel_kind kind
= gfc_match_omp_cancel_kind ();
3625 if (kind
== OMP_CANCEL_UNKNOWN
)
3627 if (gfc_match_omp_clauses (&c
, omp_mask (OMP_CLAUSE_IF
), false) != MATCH_YES
)
3630 new_st
.op
= EXEC_OMP_CANCEL
;
3631 new_st
.ext
.omp_clauses
= c
;
3637 gfc_match_omp_cancellation_point (void)
3640 enum gfc_omp_cancel_kind kind
= gfc_match_omp_cancel_kind ();
3641 if (kind
== OMP_CANCEL_UNKNOWN
)
3643 if (gfc_match_omp_eos () != MATCH_YES
)
3645 gfc_error ("Unexpected junk after $OMP CANCELLATION POINT statement "
3649 c
= gfc_get_omp_clauses ();
3651 new_st
.op
= EXEC_OMP_CANCELLATION_POINT
;
3652 new_st
.ext
.omp_clauses
= c
;
3658 gfc_match_omp_end_nowait (void)
3660 bool nowait
= false;
3661 if (gfc_match ("% nowait") == MATCH_YES
)
3663 if (gfc_match_omp_eos () != MATCH_YES
)
3665 gfc_error ("Unexpected junk after NOWAIT clause at %C");
3668 new_st
.op
= EXEC_OMP_END_NOWAIT
;
3669 new_st
.ext
.omp_bool
= nowait
;
3675 gfc_match_omp_end_single (void)
3678 if (gfc_match ("% nowait") == MATCH_YES
)
3680 new_st
.op
= EXEC_OMP_END_NOWAIT
;
3681 new_st
.ext
.omp_bool
= true;
3684 if (gfc_match_omp_clauses (&c
, omp_mask (OMP_CLAUSE_COPYPRIVATE
))
3687 new_st
.op
= EXEC_OMP_END_SINGLE
;
3688 new_st
.ext
.omp_clauses
= c
;
3694 oacc_is_loop (gfc_code
*code
)
3696 return code
->op
== EXEC_OACC_PARALLEL_LOOP
3697 || code
->op
== EXEC_OACC_KERNELS_LOOP
3698 || code
->op
== EXEC_OACC_LOOP
;
3702 resolve_scalar_int_expr (gfc_expr
*expr
, const char *clause
)
3704 if (!gfc_resolve_expr (expr
)
3705 || expr
->ts
.type
!= BT_INTEGER
3707 gfc_error ("%s clause at %L requires a scalar INTEGER expression",
3708 clause
, &expr
->where
);
3712 resolve_positive_int_expr (gfc_expr
*expr
, const char *clause
)
3714 resolve_scalar_int_expr (expr
, clause
);
3715 if (expr
->expr_type
== EXPR_CONSTANT
3716 && expr
->ts
.type
== BT_INTEGER
3717 && mpz_sgn (expr
->value
.integer
) <= 0)
3718 gfc_warning (0, "INTEGER expression of %s clause at %L must be positive",
3719 clause
, &expr
->where
);
3723 resolve_nonnegative_int_expr (gfc_expr
*expr
, const char *clause
)
3725 resolve_scalar_int_expr (expr
, clause
);
3726 if (expr
->expr_type
== EXPR_CONSTANT
3727 && expr
->ts
.type
== BT_INTEGER
3728 && mpz_sgn (expr
->value
.integer
) < 0)
3729 gfc_warning (0, "INTEGER expression of %s clause at %L must be "
3730 "non-negative", clause
, &expr
->where
);
3733 /* Emits error when symbol is pointer, cray pointer or cray pointee
3734 of derived of polymorphic type. */
3737 check_symbol_not_pointer (gfc_symbol
*sym
, locus loc
, const char *name
)
3739 if (sym
->ts
.type
== BT_DERIVED
&& sym
->attr
.pointer
)
3740 gfc_error ("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_pointer
)
3743 gfc_error ("Cray pointer object of derived type %qs in %s clause at %L",
3744 sym
->name
, name
, &loc
);
3745 if (sym
->ts
.type
== BT_DERIVED
&& sym
->attr
.cray_pointee
)
3746 gfc_error ("Cray pointee object of derived type %qs in %s clause at %L",
3747 sym
->name
, name
, &loc
);
3749 if ((sym
->ts
.type
== BT_ASSUMED
&& sym
->attr
.pointer
)
3750 || (sym
->ts
.type
== BT_CLASS
&& CLASS_DATA (sym
)
3751 && CLASS_DATA (sym
)->attr
.pointer
))
3752 gfc_error ("POINTER object %qs of polymorphic type in %s clause at %L",
3753 sym
->name
, name
, &loc
);
3754 if ((sym
->ts
.type
== BT_ASSUMED
&& sym
->attr
.cray_pointer
)
3755 || (sym
->ts
.type
== BT_CLASS
&& CLASS_DATA (sym
)
3756 && CLASS_DATA (sym
)->attr
.cray_pointer
))
3757 gfc_error ("Cray pointer object of polymorphic type %qs in %s clause at %L",
3758 sym
->name
, name
, &loc
);
3759 if ((sym
->ts
.type
== BT_ASSUMED
&& sym
->attr
.cray_pointee
)
3760 || (sym
->ts
.type
== BT_CLASS
&& CLASS_DATA (sym
)
3761 && CLASS_DATA (sym
)->attr
.cray_pointee
))
3762 gfc_error ("Cray pointee object of polymorphic type %qs in %s clause at %L",
3763 sym
->name
, name
, &loc
);
3766 /* Emits error when symbol represents assumed size/rank array. */
3769 check_array_not_assumed (gfc_symbol
*sym
, locus loc
, const char *name
)
3771 if (sym
->as
&& sym
->as
->type
== AS_ASSUMED_SIZE
)
3772 gfc_error ("Assumed size array %qs in %s clause at %L",
3773 sym
->name
, name
, &loc
);
3774 if (sym
->as
&& sym
->as
->type
== AS_ASSUMED_RANK
)
3775 gfc_error ("Assumed rank array %qs in %s clause at %L",
3776 sym
->name
, name
, &loc
);
3777 if (sym
->as
&& sym
->as
->type
== AS_DEFERRED
&& sym
->attr
.pointer
3778 && !sym
->attr
.contiguous
)
3779 gfc_error ("Noncontiguous deferred shape array %qs in %s clause at %L",
3780 sym
->name
, name
, &loc
);
3784 resolve_oacc_data_clauses (gfc_symbol
*sym
, locus loc
, const char *name
)
3786 if (sym
->ts
.type
== BT_DERIVED
&& sym
->attr
.allocatable
)
3787 gfc_error ("ALLOCATABLE object %qs of derived type in %s clause at %L",
3788 sym
->name
, name
, &loc
);
3789 if ((sym
->ts
.type
== BT_ASSUMED
&& sym
->attr
.allocatable
)
3790 || (sym
->ts
.type
== BT_CLASS
&& CLASS_DATA (sym
)
3791 && CLASS_DATA (sym
)->attr
.allocatable
))
3792 gfc_error ("ALLOCATABLE object %qs of polymorphic type "
3793 "in %s clause at %L", sym
->name
, name
, &loc
);
3794 check_symbol_not_pointer (sym
, loc
, name
);
3795 check_array_not_assumed (sym
, loc
, name
);
3799 resolve_oacc_deviceptr_clause (gfc_symbol
*sym
, locus loc
, const char *name
)
3801 if (sym
->attr
.pointer
3802 || (sym
->ts
.type
== BT_CLASS
&& CLASS_DATA (sym
)
3803 && CLASS_DATA (sym
)->attr
.class_pointer
))
3804 gfc_error ("POINTER object %qs in %s clause at %L",
3805 sym
->name
, name
, &loc
);
3806 if (sym
->attr
.cray_pointer
3807 || (sym
->ts
.type
== BT_CLASS
&& CLASS_DATA (sym
)
3808 && CLASS_DATA (sym
)->attr
.cray_pointer
))
3809 gfc_error ("Cray pointer object %qs in %s clause at %L",
3810 sym
->name
, name
, &loc
);
3811 if (sym
->attr
.cray_pointee
3812 || (sym
->ts
.type
== BT_CLASS
&& CLASS_DATA (sym
)
3813 && CLASS_DATA (sym
)->attr
.cray_pointee
))
3814 gfc_error ("Cray pointee object %qs in %s clause at %L",
3815 sym
->name
, name
, &loc
);
3816 if (sym
->attr
.allocatable
3817 || (sym
->ts
.type
== BT_CLASS
&& CLASS_DATA (sym
)
3818 && CLASS_DATA (sym
)->attr
.allocatable
))
3819 gfc_error ("ALLOCATABLE object %qs in %s clause at %L",
3820 sym
->name
, name
, &loc
);
3821 if (sym
->attr
.value
)
3822 gfc_error ("VALUE object %qs in %s clause at %L",
3823 sym
->name
, name
, &loc
);
3824 check_array_not_assumed (sym
, loc
, name
);
3828 struct resolve_omp_udr_callback_data
3830 gfc_symbol
*sym1
, *sym2
;
3835 resolve_omp_udr_callback (gfc_expr
**e
, int *, void *data
)
3837 struct resolve_omp_udr_callback_data
*rcd
3838 = (struct resolve_omp_udr_callback_data
*) data
;
3839 if ((*e
)->expr_type
== EXPR_VARIABLE
3840 && ((*e
)->symtree
->n
.sym
== rcd
->sym1
3841 || (*e
)->symtree
->n
.sym
== rcd
->sym2
))
3843 gfc_ref
*ref
= gfc_get_ref ();
3844 ref
->type
= REF_ARRAY
;
3845 ref
->u
.ar
.where
= (*e
)->where
;
3846 ref
->u
.ar
.as
= (*e
)->symtree
->n
.sym
->as
;
3847 ref
->u
.ar
.type
= AR_FULL
;
3848 ref
->u
.ar
.dimen
= 0;
3849 ref
->next
= (*e
)->ref
;
3857 resolve_omp_udr_callback2 (gfc_expr
**e
, int *, void *)
3859 if ((*e
)->expr_type
== EXPR_FUNCTION
3860 && (*e
)->value
.function
.isym
== NULL
)
3862 gfc_symbol
*sym
= (*e
)->symtree
->n
.sym
;
3863 if (!sym
->attr
.intrinsic
3864 && sym
->attr
.if_source
== IFSRC_UNKNOWN
)
3865 gfc_error ("Implicitly declared function %s used in "
3866 "!$OMP DECLARE REDUCTION at %L ", sym
->name
, &(*e
)->where
);
3873 resolve_omp_udr_clause (gfc_omp_namelist
*n
, gfc_namespace
*ns
,
3874 gfc_symbol
*sym1
, gfc_symbol
*sym2
)
3877 gfc_symbol sym1_copy
, sym2_copy
;
3879 if (ns
->code
->op
== EXEC_ASSIGN
)
3881 copy
= gfc_get_code (EXEC_ASSIGN
);
3882 copy
->expr1
= gfc_copy_expr (ns
->code
->expr1
);
3883 copy
->expr2
= gfc_copy_expr (ns
->code
->expr2
);
3887 copy
= gfc_get_code (EXEC_CALL
);
3888 copy
->symtree
= ns
->code
->symtree
;
3889 copy
->ext
.actual
= gfc_copy_actual_arglist (ns
->code
->ext
.actual
);
3891 copy
->loc
= ns
->code
->loc
;
3896 sym1
->name
= sym1_copy
.name
;
3897 sym2
->name
= sym2_copy
.name
;
3898 ns
->proc_name
= ns
->parent
->proc_name
;
3899 if (n
->sym
->attr
.dimension
)
3901 struct resolve_omp_udr_callback_data rcd
;
3904 gfc_code_walker (©
, gfc_dummy_code_callback
,
3905 resolve_omp_udr_callback
, &rcd
);
3907 gfc_resolve_code (copy
, gfc_current_ns
);
3908 if (copy
->op
== EXEC_CALL
&& copy
->resolved_isym
== NULL
)
3910 gfc_symbol
*sym
= copy
->resolved_sym
;
3912 && !sym
->attr
.intrinsic
3913 && sym
->attr
.if_source
== IFSRC_UNKNOWN
)
3914 gfc_error ("Implicitly declared subroutine %s used in "
3915 "!$OMP DECLARE REDUCTION at %L ", sym
->name
,
3918 gfc_code_walker (©
, gfc_dummy_code_callback
,
3919 resolve_omp_udr_callback2
, NULL
);
3925 /* OpenMP directive resolving routines. */
3928 resolve_omp_clauses (gfc_code
*code
, gfc_omp_clauses
*omp_clauses
,
3929 gfc_namespace
*ns
, bool openacc
= false)
3931 gfc_omp_namelist
*n
;
3935 bool if_without_mod
= false;
3936 gfc_omp_linear_op linear_op
= OMP_LINEAR_DEFAULT
;
3937 static const char *clause_names
[]
3938 = { "PRIVATE", "FIRSTPRIVATE", "LASTPRIVATE", "COPYPRIVATE", "SHARED",
3939 "COPYIN", "UNIFORM", "ALIGNED", "LINEAR", "DEPEND", "MAP",
3940 "TO", "FROM", "REDUCTION", "DEVICE_RESIDENT", "LINK", "USE_DEVICE",
3941 "CACHE", "IS_DEVICE_PTR", "USE_DEVICE_PTR" };
3943 if (omp_clauses
== NULL
)
3946 if (omp_clauses
->orderedc
&& omp_clauses
->orderedc
< omp_clauses
->collapse
)
3947 gfc_error ("ORDERED clause parameter is less than COLLAPSE at %L",
3950 if (omp_clauses
->if_expr
)
3952 gfc_expr
*expr
= omp_clauses
->if_expr
;
3953 if (!gfc_resolve_expr (expr
)
3954 || expr
->ts
.type
!= BT_LOGICAL
|| expr
->rank
!= 0)
3955 gfc_error ("IF clause at %L requires a scalar LOGICAL expression",
3957 if_without_mod
= true;
3959 for (ifc
= 0; ifc
< OMP_IF_LAST
; ifc
++)
3960 if (omp_clauses
->if_exprs
[ifc
])
3962 gfc_expr
*expr
= omp_clauses
->if_exprs
[ifc
];
3964 if (!gfc_resolve_expr (expr
)
3965 || expr
->ts
.type
!= BT_LOGICAL
|| expr
->rank
!= 0)
3966 gfc_error ("IF clause at %L requires a scalar LOGICAL expression",
3968 else if (if_without_mod
)
3970 gfc_error ("IF clause without modifier at %L used together with"
3971 "IF clauses with modifiers",
3972 &omp_clauses
->if_expr
->where
);
3973 if_without_mod
= false;
3978 case EXEC_OMP_PARALLEL
:
3979 case EXEC_OMP_PARALLEL_DO
:
3980 case EXEC_OMP_PARALLEL_SECTIONS
:
3981 case EXEC_OMP_PARALLEL_WORKSHARE
:
3982 case EXEC_OMP_PARALLEL_DO_SIMD
:
3983 case EXEC_OMP_DISTRIBUTE_PARALLEL_DO
:
3984 case EXEC_OMP_DISTRIBUTE_PARALLEL_DO_SIMD
:
3985 case EXEC_OMP_TEAMS_DISTRIBUTE_PARALLEL_DO
:
3986 case EXEC_OMP_TEAMS_DISTRIBUTE_PARALLEL_DO_SIMD
:
3987 ok
= ifc
== OMP_IF_PARALLEL
;
3991 ok
= ifc
== OMP_IF_TASK
;
3994 case EXEC_OMP_TASKLOOP
:
3995 case EXEC_OMP_TASKLOOP_SIMD
:
3996 ok
= ifc
== OMP_IF_TASKLOOP
;
3999 case EXEC_OMP_TARGET
:
4000 case EXEC_OMP_TARGET_TEAMS
:
4001 case EXEC_OMP_TARGET_TEAMS_DISTRIBUTE
:
4002 case EXEC_OMP_TARGET_TEAMS_DISTRIBUTE_SIMD
:
4003 case EXEC_OMP_TARGET_SIMD
:
4004 ok
= ifc
== OMP_IF_TARGET
;
4007 case EXEC_OMP_TARGET_DATA
:
4008 ok
= ifc
== OMP_IF_TARGET_DATA
;
4011 case EXEC_OMP_TARGET_UPDATE
:
4012 ok
= ifc
== OMP_IF_TARGET_UPDATE
;
4015 case EXEC_OMP_TARGET_ENTER_DATA
:
4016 ok
= ifc
== OMP_IF_TARGET_ENTER_DATA
;
4019 case EXEC_OMP_TARGET_EXIT_DATA
:
4020 ok
= ifc
== OMP_IF_TARGET_EXIT_DATA
;
4023 case EXEC_OMP_TARGET_TEAMS_DISTRIBUTE_PARALLEL_DO
:
4024 case EXEC_OMP_TARGET_TEAMS_DISTRIBUTE_PARALLEL_DO_SIMD
:
4025 case EXEC_OMP_TARGET_PARALLEL
:
4026 case EXEC_OMP_TARGET_PARALLEL_DO
:
4027 case EXEC_OMP_TARGET_PARALLEL_DO_SIMD
:
4028 ok
= ifc
== OMP_IF_TARGET
|| ifc
== OMP_IF_PARALLEL
;
4037 static const char *ifs
[] = {
4044 "TARGET ENTER DATA",
4047 gfc_error ("IF clause modifier %s at %L not appropriate for "
4048 "the current OpenMP construct", ifs
[ifc
], &expr
->where
);
4052 if (omp_clauses
->final_expr
)
4054 gfc_expr
*expr
= omp_clauses
->final_expr
;
4055 if (!gfc_resolve_expr (expr
)
4056 || expr
->ts
.type
!= BT_LOGICAL
|| expr
->rank
!= 0)
4057 gfc_error ("FINAL clause at %L requires a scalar LOGICAL expression",
4060 if (omp_clauses
->num_threads
)
4061 resolve_positive_int_expr (omp_clauses
->num_threads
, "NUM_THREADS");
4062 if (omp_clauses
->chunk_size
)
4064 gfc_expr
*expr
= omp_clauses
->chunk_size
;
4065 if (!gfc_resolve_expr (expr
)
4066 || expr
->ts
.type
!= BT_INTEGER
|| expr
->rank
!= 0)
4067 gfc_error ("SCHEDULE clause's chunk_size at %L requires "
4068 "a scalar INTEGER expression", &expr
->where
);
4069 else if (expr
->expr_type
== EXPR_CONSTANT
4070 && expr
->ts
.type
== BT_INTEGER
4071 && mpz_sgn (expr
->value
.integer
) <= 0)
4072 gfc_warning (0, "INTEGER expression of SCHEDULE clause's chunk_size "
4073 "at %L must be positive", &expr
->where
);
4076 /* Check that no symbol appears on multiple clauses, except that
4077 a symbol can appear on both firstprivate and lastprivate. */
4078 for (list
= 0; list
< OMP_LIST_NUM
; list
++)
4079 for (n
= omp_clauses
->lists
[list
]; n
; n
= n
->next
)
4082 if (n
->sym
->attr
.flavor
== FL_VARIABLE
4083 || n
->sym
->attr
.proc_pointer
4084 || (!code
&& (!n
->sym
->attr
.dummy
|| n
->sym
->ns
!= ns
)))
4086 if (!code
&& (!n
->sym
->attr
.dummy
|| n
->sym
->ns
!= ns
))
4087 gfc_error ("Variable %qs is not a dummy argument at %L",
4088 n
->sym
->name
, &n
->where
);
4091 if (n
->sym
->attr
.flavor
== FL_PROCEDURE
4092 && n
->sym
->result
== n
->sym
4093 && n
->sym
->attr
.function
)
4095 if (gfc_current_ns
->proc_name
== n
->sym
4096 || (gfc_current_ns
->parent
4097 && gfc_current_ns
->parent
->proc_name
== n
->sym
))
4099 if (gfc_current_ns
->proc_name
->attr
.entry_master
)
4101 gfc_entry_list
*el
= gfc_current_ns
->entries
;
4102 for (; el
; el
= el
->next
)
4103 if (el
->sym
== n
->sym
)
4108 if (gfc_current_ns
->parent
4109 && gfc_current_ns
->parent
->proc_name
->attr
.entry_master
)
4111 gfc_entry_list
*el
= gfc_current_ns
->parent
->entries
;
4112 for (; el
; el
= el
->next
)
4113 if (el
->sym
== n
->sym
)
4119 gfc_error ("Object %qs is not a variable at %L", n
->sym
->name
,
4123 for (list
= 0; list
< OMP_LIST_NUM
; list
++)
4124 if (list
!= OMP_LIST_FIRSTPRIVATE
4125 && list
!= OMP_LIST_LASTPRIVATE
4126 && list
!= OMP_LIST_ALIGNED
4127 && list
!= OMP_LIST_DEPEND
4128 && (list
!= OMP_LIST_MAP
|| openacc
)
4129 && list
!= OMP_LIST_FROM
4130 && list
!= OMP_LIST_TO
4131 && (list
!= OMP_LIST_REDUCTION
|| !openacc
))
4132 for (n
= omp_clauses
->lists
[list
]; n
; n
= n
->next
)
4135 gfc_error ("Symbol %qs present on multiple clauses at %L",
4136 n
->sym
->name
, &n
->where
);
4141 gcc_assert (OMP_LIST_LASTPRIVATE
== OMP_LIST_FIRSTPRIVATE
+ 1);
4142 for (list
= OMP_LIST_FIRSTPRIVATE
; list
<= OMP_LIST_LASTPRIVATE
; list
++)
4143 for (n
= omp_clauses
->lists
[list
]; n
; n
= n
->next
)
4146 gfc_error ("Symbol %qs present on multiple clauses at %L",
4147 n
->sym
->name
, &n
->where
);
4151 for (n
= omp_clauses
->lists
[OMP_LIST_FIRSTPRIVATE
]; n
; n
= n
->next
)
4154 gfc_error ("Symbol %qs present on multiple clauses at %L",
4155 n
->sym
->name
, &n
->where
);
4159 for (n
= omp_clauses
->lists
[OMP_LIST_LASTPRIVATE
]; n
; n
= n
->next
)
4162 for (n
= omp_clauses
->lists
[OMP_LIST_LASTPRIVATE
]; n
; n
= n
->next
)
4165 gfc_error ("Symbol %qs present on multiple clauses at %L",
4166 n
->sym
->name
, &n
->where
);
4171 for (n
= omp_clauses
->lists
[OMP_LIST_ALIGNED
]; n
; n
= n
->next
)
4174 for (n
= omp_clauses
->lists
[OMP_LIST_ALIGNED
]; n
; n
= n
->next
)
4177 gfc_error ("Symbol %qs present on multiple clauses at %L",
4178 n
->sym
->name
, &n
->where
);
4183 /* OpenACC reductions. */
4186 for (n
= omp_clauses
->lists
[OMP_LIST_REDUCTION
]; n
; n
= n
->next
)
4189 for (n
= omp_clauses
->lists
[OMP_LIST_REDUCTION
]; n
; n
= n
->next
)
4192 gfc_error ("Symbol %qs present on multiple clauses at %L",
4193 n
->sym
->name
, &n
->where
);
4197 /* OpenACC does not support reductions on arrays. */
4199 gfc_error ("Array %qs is not permitted in reduction at %L",
4200 n
->sym
->name
, &n
->where
);
4204 for (n
= omp_clauses
->lists
[OMP_LIST_TO
]; n
; n
= n
->next
)
4206 for (n
= omp_clauses
->lists
[OMP_LIST_FROM
]; n
; n
= n
->next
)
4207 if (n
->expr
== NULL
)
4209 for (n
= omp_clauses
->lists
[OMP_LIST_TO
]; n
; n
= n
->next
)
4211 if (n
->expr
== NULL
&& n
->sym
->mark
)
4212 gfc_error ("Symbol %qs present on both FROM and TO clauses at %L",
4213 n
->sym
->name
, &n
->where
);
4218 for (list
= 0; list
< OMP_LIST_NUM
; list
++)
4219 if ((n
= omp_clauses
->lists
[list
]) != NULL
)
4223 if (list
< OMP_LIST_NUM
)
4224 name
= clause_names
[list
];
4230 case OMP_LIST_COPYIN
:
4231 for (; n
!= NULL
; n
= n
->next
)
4233 if (!n
->sym
->attr
.threadprivate
)
4234 gfc_error ("Non-THREADPRIVATE object %qs in COPYIN clause"
4235 " at %L", n
->sym
->name
, &n
->where
);
4238 case OMP_LIST_COPYPRIVATE
:
4239 for (; n
!= NULL
; n
= n
->next
)
4241 if (n
->sym
->as
&& n
->sym
->as
->type
== AS_ASSUMED_SIZE
)
4242 gfc_error ("Assumed size array %qs in COPYPRIVATE clause "
4243 "at %L", n
->sym
->name
, &n
->where
);
4244 if (n
->sym
->attr
.pointer
&& n
->sym
->attr
.intent
== INTENT_IN
)
4245 gfc_error ("INTENT(IN) POINTER %qs in COPYPRIVATE clause "
4246 "at %L", n
->sym
->name
, &n
->where
);
4249 case OMP_LIST_SHARED
:
4250 for (; n
!= NULL
; n
= n
->next
)
4252 if (n
->sym
->attr
.threadprivate
)
4253 gfc_error ("THREADPRIVATE object %qs in SHARED clause at "
4254 "%L", n
->sym
->name
, &n
->where
);
4255 if (n
->sym
->attr
.cray_pointee
)
4256 gfc_error ("Cray pointee %qs in SHARED clause at %L",
4257 n
->sym
->name
, &n
->where
);
4258 if (n
->sym
->attr
.associate_var
)
4259 gfc_error ("ASSOCIATE name %qs in SHARED clause at %L",
4260 n
->sym
->name
, &n
->where
);
4263 case OMP_LIST_ALIGNED
:
4264 for (; n
!= NULL
; n
= n
->next
)
4266 if (!n
->sym
->attr
.pointer
4267 && !n
->sym
->attr
.allocatable
4268 && !n
->sym
->attr
.cray_pointer
4269 && (n
->sym
->ts
.type
!= BT_DERIVED
4270 || (n
->sym
->ts
.u
.derived
->from_intmod
4271 != INTMOD_ISO_C_BINDING
)
4272 || (n
->sym
->ts
.u
.derived
->intmod_sym_id
4273 != ISOCBINDING_PTR
)))
4274 gfc_error ("%qs in ALIGNED clause must be POINTER, "
4275 "ALLOCATABLE, Cray pointer or C_PTR at %L",
4276 n
->sym
->name
, &n
->where
);
4279 gfc_expr
*expr
= n
->expr
;
4281 if (!gfc_resolve_expr (expr
)
4282 || expr
->ts
.type
!= BT_INTEGER
4284 || gfc_extract_int (expr
, &alignment
)
4286 gfc_error ("%qs in ALIGNED clause at %L requires a scalar "
4287 "positive constant integer alignment "
4288 "expression", n
->sym
->name
, &n
->where
);
4292 case OMP_LIST_DEPEND
:
4296 case OMP_LIST_CACHE
:
4297 for (; n
!= NULL
; n
= n
->next
)
4299 if (list
== OMP_LIST_DEPEND
)
4301 if (n
->u
.depend_op
== OMP_DEPEND_SINK_FIRST
4302 || n
->u
.depend_op
== OMP_DEPEND_SINK
)
4304 if (code
->op
!= EXEC_OMP_ORDERED
)
4305 gfc_error ("SINK dependence type only allowed "
4306 "on ORDERED directive at %L", &n
->where
);
4307 else if (omp_clauses
->depend_source
)
4309 gfc_error ("DEPEND SINK used together with "
4310 "DEPEND SOURCE on the same construct "
4311 "at %L", &n
->where
);
4312 omp_clauses
->depend_source
= false;
4316 if (!gfc_resolve_expr (n
->expr
)
4317 || n
->expr
->ts
.type
!= BT_INTEGER
4318 || n
->expr
->rank
!= 0)
4319 gfc_error ("SINK addend not a constant integer"
4320 "at %L", &n
->where
);
4324 else if (code
->op
== EXEC_OMP_ORDERED
)
4325 gfc_error ("Only SOURCE or SINK dependence types "
4326 "are allowed on ORDERED directive at %L",
4331 if (!gfc_resolve_expr (n
->expr
)
4332 || n
->expr
->expr_type
!= EXPR_VARIABLE
4333 || n
->expr
->ref
== NULL
4334 || n
->expr
->ref
->next
4335 || n
->expr
->ref
->type
!= REF_ARRAY
)
4336 gfc_error ("%qs in %s clause at %L is not a proper "
4337 "array section", n
->sym
->name
, name
,
4339 else if (n
->expr
->ref
->u
.ar
.codimen
)
4340 gfc_error ("Coarrays not supported in %s clause at %L",
4345 gfc_array_ref
*ar
= &n
->expr
->ref
->u
.ar
;
4346 for (i
= 0; i
< ar
->dimen
; i
++)
4349 gfc_error ("Stride should not be specified for "
4350 "array section in %s clause at %L",
4354 else if (ar
->dimen_type
[i
] != DIMEN_ELEMENT
4355 && ar
->dimen_type
[i
] != DIMEN_RANGE
)
4357 gfc_error ("%qs in %s clause at %L is not a "
4358 "proper array section",
4359 n
->sym
->name
, name
, &n
->where
);
4362 else if (list
== OMP_LIST_DEPEND
4364 && ar
->start
[i
]->expr_type
== EXPR_CONSTANT
4366 && ar
->end
[i
]->expr_type
== EXPR_CONSTANT
4367 && mpz_cmp (ar
->start
[i
]->value
.integer
,
4368 ar
->end
[i
]->value
.integer
) > 0)
4370 gfc_error ("%qs in DEPEND clause at %L is a "
4371 "zero size array section",
4372 n
->sym
->name
, &n
->where
);
4379 if (list
== OMP_LIST_MAP
4380 && n
->u
.map_op
== OMP_MAP_FORCE_DEVICEPTR
)
4381 resolve_oacc_deviceptr_clause (n
->sym
, n
->where
, name
);
4383 resolve_oacc_data_clauses (n
->sym
, n
->where
, name
);
4385 if (list
== OMP_LIST_MAP
&& !openacc
)
4388 case EXEC_OMP_TARGET
:
4389 case EXEC_OMP_TARGET_DATA
:
4390 switch (n
->u
.map_op
)
4393 case OMP_MAP_ALWAYS_TO
:
4395 case OMP_MAP_ALWAYS_FROM
:
4396 case OMP_MAP_TOFROM
:
4397 case OMP_MAP_ALWAYS_TOFROM
:
4401 gfc_error ("TARGET%s with map-type other than TO, "
4402 "FROM, TOFROM, or ALLOC on MAP clause "
4404 code
->op
== EXEC_OMP_TARGET
4405 ? "" : " DATA", &n
->where
);
4409 case EXEC_OMP_TARGET_ENTER_DATA
:
4410 switch (n
->u
.map_op
)
4413 case OMP_MAP_ALWAYS_TO
:
4417 gfc_error ("TARGET ENTER DATA with map-type other "
4418 "than TO, or ALLOC on MAP clause at %L",
4423 case EXEC_OMP_TARGET_EXIT_DATA
:
4424 switch (n
->u
.map_op
)
4427 case OMP_MAP_ALWAYS_FROM
:
4428 case OMP_MAP_RELEASE
:
4429 case OMP_MAP_DELETE
:
4432 gfc_error ("TARGET EXIT DATA with map-type other "
4433 "than FROM, RELEASE, or DELETE on MAP "
4434 "clause at %L", &n
->where
);
4443 if (list
!= OMP_LIST_DEPEND
)
4444 for (n
= omp_clauses
->lists
[list
]; n
!= NULL
; n
= n
->next
)
4446 n
->sym
->attr
.referenced
= 1;
4447 if (n
->sym
->attr
.threadprivate
)
4448 gfc_error ("THREADPRIVATE object %qs in %s clause at %L",
4449 n
->sym
->name
, name
, &n
->where
);
4450 if (n
->sym
->attr
.cray_pointee
)
4451 gfc_error ("Cray pointee %qs in %s clause at %L",
4452 n
->sym
->name
, name
, &n
->where
);
4455 case OMP_LIST_IS_DEVICE_PTR
:
4456 case OMP_LIST_USE_DEVICE_PTR
:
4457 /* FIXME: Handle these. */
4460 for (; n
!= NULL
; n
= n
->next
)
4463 if (n
->sym
->attr
.threadprivate
)
4464 gfc_error ("THREADPRIVATE object %qs in %s clause at %L",
4465 n
->sym
->name
, name
, &n
->where
);
4466 if (n
->sym
->attr
.cray_pointee
)
4467 gfc_error ("Cray pointee %qs in %s clause at %L",
4468 n
->sym
->name
, name
, &n
->where
);
4469 if (n
->sym
->attr
.associate_var
)
4470 gfc_error ("ASSOCIATE name %qs in %s clause at %L",
4471 n
->sym
->name
, name
, &n
->where
);
4472 if (list
!= OMP_LIST_PRIVATE
)
4474 if (n
->sym
->attr
.proc_pointer
&& list
== OMP_LIST_REDUCTION
)
4475 gfc_error ("Procedure pointer %qs in %s clause at %L",
4476 n
->sym
->name
, name
, &n
->where
);
4477 if (n
->sym
->attr
.pointer
&& list
== OMP_LIST_REDUCTION
)
4478 gfc_error ("POINTER object %qs in %s clause at %L",
4479 n
->sym
->name
, name
, &n
->where
);
4480 if (n
->sym
->attr
.cray_pointer
&& list
== OMP_LIST_REDUCTION
)
4481 gfc_error ("Cray pointer %qs in %s clause at %L",
4482 n
->sym
->name
, name
, &n
->where
);
4485 && (oacc_is_loop (code
) || code
->op
== EXEC_OACC_PARALLEL
))
4486 check_array_not_assumed (n
->sym
, n
->where
, name
);
4487 else if (n
->sym
->as
&& n
->sym
->as
->type
== AS_ASSUMED_SIZE
)
4488 gfc_error ("Assumed size array %qs in %s clause at %L",
4489 n
->sym
->name
, name
, &n
->where
);
4490 if (n
->sym
->attr
.in_namelist
&& list
!= OMP_LIST_REDUCTION
)
4491 gfc_error ("Variable %qs in %s clause is used in "
4492 "NAMELIST statement at %L",
4493 n
->sym
->name
, name
, &n
->where
);
4494 if (n
->sym
->attr
.pointer
&& n
->sym
->attr
.intent
== INTENT_IN
)
4497 case OMP_LIST_PRIVATE
:
4498 case OMP_LIST_LASTPRIVATE
:
4499 case OMP_LIST_LINEAR
:
4500 /* case OMP_LIST_REDUCTION: */
4501 gfc_error ("INTENT(IN) POINTER %qs in %s clause at %L",
4502 n
->sym
->name
, name
, &n
->where
);
4510 case OMP_LIST_REDUCTION
:
4511 switch (n
->u
.reduction_op
)
4513 case OMP_REDUCTION_PLUS
:
4514 case OMP_REDUCTION_TIMES
:
4515 case OMP_REDUCTION_MINUS
:
4516 if (!gfc_numeric_ts (&n
->sym
->ts
))
4519 case OMP_REDUCTION_AND
:
4520 case OMP_REDUCTION_OR
:
4521 case OMP_REDUCTION_EQV
:
4522 case OMP_REDUCTION_NEQV
:
4523 if (n
->sym
->ts
.type
!= BT_LOGICAL
)
4526 case OMP_REDUCTION_MAX
:
4527 case OMP_REDUCTION_MIN
:
4528 if (n
->sym
->ts
.type
!= BT_INTEGER
4529 && n
->sym
->ts
.type
!= BT_REAL
)
4532 case OMP_REDUCTION_IAND
:
4533 case OMP_REDUCTION_IOR
:
4534 case OMP_REDUCTION_IEOR
:
4535 if (n
->sym
->ts
.type
!= BT_INTEGER
)
4538 case OMP_REDUCTION_USER
:
4548 const char *udr_name
= NULL
;
4551 udr_name
= n
->udr
->udr
->name
;
4553 = gfc_find_omp_udr (NULL
, udr_name
,
4555 if (n
->udr
->udr
== NULL
)
4563 if (udr_name
== NULL
)
4564 switch (n
->u
.reduction_op
)
4566 case OMP_REDUCTION_PLUS
:
4567 case OMP_REDUCTION_TIMES
:
4568 case OMP_REDUCTION_MINUS
:
4569 case OMP_REDUCTION_AND
:
4570 case OMP_REDUCTION_OR
:
4571 case OMP_REDUCTION_EQV
:
4572 case OMP_REDUCTION_NEQV
:
4573 udr_name
= gfc_op2string ((gfc_intrinsic_op
)
4576 case OMP_REDUCTION_MAX
:
4579 case OMP_REDUCTION_MIN
:
4582 case OMP_REDUCTION_IAND
:
4585 case OMP_REDUCTION_IOR
:
4588 case OMP_REDUCTION_IEOR
:
4594 gfc_error ("!$OMP DECLARE REDUCTION %s not found "
4595 "for type %s at %L", udr_name
,
4596 gfc_typename (&n
->sym
->ts
), &n
->where
);
4600 gfc_omp_udr
*udr
= n
->udr
->udr
;
4601 n
->u
.reduction_op
= OMP_REDUCTION_USER
;
4603 = resolve_omp_udr_clause (n
, udr
->combiner_ns
,
4606 if (udr
->initializer_ns
)
4608 = resolve_omp_udr_clause (n
,
4609 udr
->initializer_ns
,
4615 case OMP_LIST_LINEAR
:
4617 && n
->u
.linear_op
!= OMP_LINEAR_DEFAULT
4618 && n
->u
.linear_op
!= linear_op
)
4620 gfc_error ("LINEAR clause modifier used on DO or SIMD"
4621 " construct at %L", &n
->where
);
4622 linear_op
= n
->u
.linear_op
;
4624 else if (omp_clauses
->orderedc
)
4625 gfc_error ("LINEAR clause specified together with"
4626 "ORDERED clause with argument at %L",
4628 else if (n
->u
.linear_op
!= OMP_LINEAR_REF
4629 && n
->sym
->ts
.type
!= BT_INTEGER
)
4630 gfc_error ("LINEAR variable %qs must be INTEGER "
4631 "at %L", n
->sym
->name
, &n
->where
);
4632 else if ((n
->u
.linear_op
== OMP_LINEAR_REF
4633 || n
->u
.linear_op
== OMP_LINEAR_UVAL
)
4634 && n
->sym
->attr
.value
)
4635 gfc_error ("LINEAR dummy argument %qs with VALUE "
4636 "attribute with %s modifier at %L",
4638 n
->u
.linear_op
== OMP_LINEAR_REF
4639 ? "REF" : "UVAL", &n
->where
);
4642 gfc_expr
*expr
= n
->expr
;
4643 if (!gfc_resolve_expr (expr
)
4644 || expr
->ts
.type
!= BT_INTEGER
4646 gfc_error ("%qs in LINEAR clause at %L requires "
4647 "a scalar integer linear-step expression",
4648 n
->sym
->name
, &n
->where
);
4649 else if (!code
&& expr
->expr_type
!= EXPR_CONSTANT
)
4651 if (expr
->expr_type
== EXPR_VARIABLE
4652 && expr
->symtree
->n
.sym
->attr
.dummy
4653 && expr
->symtree
->n
.sym
->ns
== ns
)
4655 gfc_omp_namelist
*n2
;
4656 for (n2
= omp_clauses
->lists
[OMP_LIST_UNIFORM
];
4658 if (n2
->sym
== expr
->symtree
->n
.sym
)
4663 gfc_error ("%qs in LINEAR clause at %L requires "
4664 "a constant integer linear-step "
4665 "expression or dummy argument "
4666 "specified in UNIFORM clause",
4667 n
->sym
->name
, &n
->where
);
4671 /* Workaround for PR middle-end/26316, nothing really needs
4672 to be done here for OMP_LIST_PRIVATE. */
4673 case OMP_LIST_PRIVATE
:
4674 gcc_assert (code
&& code
->op
!= EXEC_NOP
);
4676 case OMP_LIST_USE_DEVICE
:
4677 if (n
->sym
->attr
.allocatable
4678 || (n
->sym
->ts
.type
== BT_CLASS
&& CLASS_DATA (n
->sym
)
4679 && CLASS_DATA (n
->sym
)->attr
.allocatable
))
4680 gfc_error ("ALLOCATABLE object %qs in %s clause at %L",
4681 n
->sym
->name
, name
, &n
->where
);
4682 if (n
->sym
->ts
.type
== BT_CLASS
4683 && CLASS_DATA (n
->sym
)
4684 && CLASS_DATA (n
->sym
)->attr
.class_pointer
)
4685 gfc_error ("POINTER object %qs of polymorphic type in "
4686 "%s clause at %L", n
->sym
->name
, name
,
4688 if (n
->sym
->attr
.cray_pointer
)
4689 gfc_error ("Cray pointer object %qs in %s clause at %L",
4690 n
->sym
->name
, name
, &n
->where
);
4691 else if (n
->sym
->attr
.cray_pointee
)
4692 gfc_error ("Cray pointee object %qs in %s clause at %L",
4693 n
->sym
->name
, name
, &n
->where
);
4694 else if (n
->sym
->attr
.flavor
== FL_VARIABLE
4696 && !n
->sym
->attr
.pointer
)
4697 gfc_error ("%s clause variable %qs at %L is neither "
4698 "a POINTER nor an array", name
,
4699 n
->sym
->name
, &n
->where
);
4701 case OMP_LIST_DEVICE_RESIDENT
:
4702 check_symbol_not_pointer (n
->sym
, n
->where
, name
);
4703 check_array_not_assumed (n
->sym
, n
->where
, name
);
4712 if (omp_clauses
->safelen_expr
)
4713 resolve_positive_int_expr (omp_clauses
->safelen_expr
, "SAFELEN");
4714 if (omp_clauses
->simdlen_expr
)
4715 resolve_positive_int_expr (omp_clauses
->simdlen_expr
, "SIMDLEN");
4716 if (omp_clauses
->num_teams
)
4717 resolve_positive_int_expr (omp_clauses
->num_teams
, "NUM_TEAMS");
4718 if (omp_clauses
->device
)
4719 resolve_nonnegative_int_expr (omp_clauses
->device
, "DEVICE");
4720 if (omp_clauses
->hint
)
4721 resolve_scalar_int_expr (omp_clauses
->hint
, "HINT");
4722 if (omp_clauses
->priority
)
4723 resolve_nonnegative_int_expr (omp_clauses
->priority
, "PRIORITY");
4724 if (omp_clauses
->dist_chunk_size
)
4726 gfc_expr
*expr
= omp_clauses
->dist_chunk_size
;
4727 if (!gfc_resolve_expr (expr
)
4728 || expr
->ts
.type
!= BT_INTEGER
|| expr
->rank
!= 0)
4729 gfc_error ("DIST_SCHEDULE clause's chunk_size at %L requires "
4730 "a scalar INTEGER expression", &expr
->where
);
4732 if (omp_clauses
->thread_limit
)
4733 resolve_positive_int_expr (omp_clauses
->thread_limit
, "THREAD_LIMIT");
4734 if (omp_clauses
->grainsize
)
4735 resolve_positive_int_expr (omp_clauses
->grainsize
, "GRAINSIZE");
4736 if (omp_clauses
->num_tasks
)
4737 resolve_positive_int_expr (omp_clauses
->num_tasks
, "NUM_TASKS");
4738 if (omp_clauses
->async
)
4739 if (omp_clauses
->async_expr
)
4740 resolve_scalar_int_expr (omp_clauses
->async_expr
, "ASYNC");
4741 if (omp_clauses
->num_gangs_expr
)
4742 resolve_positive_int_expr (omp_clauses
->num_gangs_expr
, "NUM_GANGS");
4743 if (omp_clauses
->num_workers_expr
)
4744 resolve_positive_int_expr (omp_clauses
->num_workers_expr
, "NUM_WORKERS");
4745 if (omp_clauses
->vector_length_expr
)
4746 resolve_positive_int_expr (omp_clauses
->vector_length_expr
,
4748 if (omp_clauses
->gang_num_expr
)
4749 resolve_positive_int_expr (omp_clauses
->gang_num_expr
, "GANG");
4750 if (omp_clauses
->gang_static_expr
)
4751 resolve_positive_int_expr (omp_clauses
->gang_static_expr
, "GANG");
4752 if (omp_clauses
->worker_expr
)
4753 resolve_positive_int_expr (omp_clauses
->worker_expr
, "WORKER");
4754 if (omp_clauses
->vector_expr
)
4755 resolve_positive_int_expr (omp_clauses
->vector_expr
, "VECTOR");
4756 if (omp_clauses
->wait
)
4757 if (omp_clauses
->wait_list
)
4758 for (el
= omp_clauses
->wait_list
; el
; el
= el
->next
)
4759 resolve_scalar_int_expr (el
->expr
, "WAIT");
4760 if (omp_clauses
->depend_source
&& code
->op
!= EXEC_OMP_ORDERED
)
4761 gfc_error ("SOURCE dependence type only allowed "
4762 "on ORDERED directive at %L", &code
->loc
);
4763 if (!openacc
&& code
&& omp_clauses
->lists
[OMP_LIST_MAP
] == NULL
)
4765 const char *p
= NULL
;
4768 case EXEC_OMP_TARGET_DATA
: p
= "TARGET DATA"; break;
4769 case EXEC_OMP_TARGET_ENTER_DATA
: p
= "TARGET ENTER DATA"; break;
4770 case EXEC_OMP_TARGET_EXIT_DATA
: p
= "TARGET EXIT DATA"; break;
4774 gfc_error ("%s must contain at least one MAP clause at %L",
4780 /* Return true if SYM is ever referenced in EXPR except in the SE node. */
4783 expr_references_sym (gfc_expr
*e
, gfc_symbol
*s
, gfc_expr
*se
)
4785 gfc_actual_arglist
*arg
;
4786 if (e
== NULL
|| e
== se
)
4788 switch (e
->expr_type
)
4793 case EXPR_STRUCTURE
:
4795 if (e
->symtree
!= NULL
4796 && e
->symtree
->n
.sym
== s
)
4799 case EXPR_SUBSTRING
:
4801 && (expr_references_sym (e
->ref
->u
.ss
.start
, s
, se
)
4802 || expr_references_sym (e
->ref
->u
.ss
.end
, s
, se
)))
4806 if (expr_references_sym (e
->value
.op
.op2
, s
, se
))
4808 return expr_references_sym (e
->value
.op
.op1
, s
, se
);
4810 for (arg
= e
->value
.function
.actual
; arg
; arg
= arg
->next
)
4811 if (expr_references_sym (arg
->expr
, s
, se
))
4820 /* If EXPR is a conversion function that widens the type
4821 if WIDENING is true or narrows the type if WIDENING is false,
4822 return the inner expression, otherwise return NULL. */
4825 is_conversion (gfc_expr
*expr
, bool widening
)
4827 gfc_typespec
*ts1
, *ts2
;
4829 if (expr
->expr_type
!= EXPR_FUNCTION
4830 || expr
->value
.function
.isym
== NULL
4831 || expr
->value
.function
.esym
!= NULL
4832 || expr
->value
.function
.isym
->id
!= GFC_ISYM_CONVERSION
)
4838 ts2
= &expr
->value
.function
.actual
->expr
->ts
;
4842 ts1
= &expr
->value
.function
.actual
->expr
->ts
;
4846 if (ts1
->type
> ts2
->type
4847 || (ts1
->type
== ts2
->type
&& ts1
->kind
> ts2
->kind
))
4848 return expr
->value
.function
.actual
->expr
;
4855 resolve_omp_atomic (gfc_code
*code
)
4857 gfc_code
*atomic_code
= code
;
4859 gfc_expr
*expr2
, *expr2_tmp
;
4860 gfc_omp_atomic_op aop
4861 = (gfc_omp_atomic_op
) (atomic_code
->ext
.omp_atomic
& GFC_OMP_ATOMIC_MASK
);
4863 code
= code
->block
->next
;
4864 /* resolve_blocks asserts this is initially EXEC_ASSIGN.
4865 If it changed to EXEC_NOP, assume an error has been emitted already. */
4866 if (code
->op
== EXEC_NOP
)
4868 if (code
->op
!= EXEC_ASSIGN
)
4871 gfc_error ("unexpected !$OMP ATOMIC expression at %L", &code
->loc
);
4874 if (aop
!= GFC_OMP_ATOMIC_CAPTURE
)
4876 if (code
->next
!= NULL
)
4881 if (code
->next
== NULL
)
4883 if (code
->next
->op
== EXEC_NOP
)
4885 if (code
->next
->op
!= EXEC_ASSIGN
|| code
->next
->next
)
4892 if (code
->expr1
->expr_type
!= EXPR_VARIABLE
4893 || code
->expr1
->symtree
== NULL
4894 || code
->expr1
->rank
!= 0
4895 || (code
->expr1
->ts
.type
!= BT_INTEGER
4896 && code
->expr1
->ts
.type
!= BT_REAL
4897 && code
->expr1
->ts
.type
!= BT_COMPLEX
4898 && code
->expr1
->ts
.type
!= BT_LOGICAL
))
4900 gfc_error ("!$OMP ATOMIC statement must set a scalar variable of "
4901 "intrinsic type at %L", &code
->loc
);
4905 var
= code
->expr1
->symtree
->n
.sym
;
4906 expr2
= is_conversion (code
->expr2
, false);
4909 if (aop
== GFC_OMP_ATOMIC_READ
|| aop
== GFC_OMP_ATOMIC_WRITE
)
4910 expr2
= is_conversion (code
->expr2
, true);
4912 expr2
= code
->expr2
;
4917 case GFC_OMP_ATOMIC_READ
:
4918 if (expr2
->expr_type
!= EXPR_VARIABLE
4919 || expr2
->symtree
== NULL
4921 || (expr2
->ts
.type
!= BT_INTEGER
4922 && expr2
->ts
.type
!= BT_REAL
4923 && expr2
->ts
.type
!= BT_COMPLEX
4924 && expr2
->ts
.type
!= BT_LOGICAL
))
4925 gfc_error ("!$OMP ATOMIC READ statement must read from a scalar "
4926 "variable of intrinsic type at %L", &expr2
->where
);
4928 case GFC_OMP_ATOMIC_WRITE
:
4929 if (expr2
->rank
!= 0 || expr_references_sym (code
->expr2
, var
, NULL
))
4930 gfc_error ("expr in !$OMP ATOMIC WRITE assignment var = expr "
4931 "must be scalar and cannot reference var at %L",
4934 case GFC_OMP_ATOMIC_CAPTURE
:
4936 if (expr2
== code
->expr2
)
4938 expr2_tmp
= is_conversion (code
->expr2
, true);
4939 if (expr2_tmp
== NULL
)
4942 if (expr2_tmp
->expr_type
== EXPR_VARIABLE
)
4944 if (expr2_tmp
->symtree
== NULL
4945 || expr2_tmp
->rank
!= 0
4946 || (expr2_tmp
->ts
.type
!= BT_INTEGER
4947 && expr2_tmp
->ts
.type
!= BT_REAL
4948 && expr2_tmp
->ts
.type
!= BT_COMPLEX
4949 && expr2_tmp
->ts
.type
!= BT_LOGICAL
)
4950 || expr2_tmp
->symtree
->n
.sym
== var
)
4952 gfc_error ("!$OMP ATOMIC CAPTURE capture statement must read from "
4953 "a scalar variable of intrinsic type at %L",
4957 var
= expr2_tmp
->symtree
->n
.sym
;
4959 if (code
->expr1
->expr_type
!= EXPR_VARIABLE
4960 || code
->expr1
->symtree
== NULL
4961 || code
->expr1
->rank
!= 0
4962 || (code
->expr1
->ts
.type
!= BT_INTEGER
4963 && code
->expr1
->ts
.type
!= BT_REAL
4964 && code
->expr1
->ts
.type
!= BT_COMPLEX
4965 && code
->expr1
->ts
.type
!= BT_LOGICAL
))
4967 gfc_error ("!$OMP ATOMIC CAPTURE update statement must set "
4968 "a scalar variable of intrinsic type at %L",
4969 &code
->expr1
->where
);
4972 if (code
->expr1
->symtree
->n
.sym
!= var
)
4974 gfc_error ("!$OMP ATOMIC CAPTURE capture statement reads from "
4975 "different variable than update statement writes "
4976 "into at %L", &code
->expr1
->where
);
4979 expr2
= is_conversion (code
->expr2
, false);
4981 expr2
= code
->expr2
;
4988 if (gfc_expr_attr (code
->expr1
).allocatable
)
4990 gfc_error ("!$OMP ATOMIC with ALLOCATABLE variable at %L",
4995 if (aop
== GFC_OMP_ATOMIC_CAPTURE
4996 && code
->next
== NULL
4997 && code
->expr2
->rank
== 0
4998 && !expr_references_sym (code
->expr2
, var
, NULL
))
4999 atomic_code
->ext
.omp_atomic
5000 = (gfc_omp_atomic_op
) (atomic_code
->ext
.omp_atomic
5001 | GFC_OMP_ATOMIC_SWAP
);
5002 else if (expr2
->expr_type
== EXPR_OP
)
5004 gfc_expr
*v
= NULL
, *e
, *c
;
5005 gfc_intrinsic_op op
= expr2
->value
.op
.op
;
5006 gfc_intrinsic_op alt_op
= INTRINSIC_NONE
;
5010 case INTRINSIC_PLUS
:
5011 alt_op
= INTRINSIC_MINUS
;
5013 case INTRINSIC_TIMES
:
5014 alt_op
= INTRINSIC_DIVIDE
;
5016 case INTRINSIC_MINUS
:
5017 alt_op
= INTRINSIC_PLUS
;
5019 case INTRINSIC_DIVIDE
:
5020 alt_op
= INTRINSIC_TIMES
;
5026 alt_op
= INTRINSIC_NEQV
;
5028 case INTRINSIC_NEQV
:
5029 alt_op
= INTRINSIC_EQV
;
5032 gfc_error ("!$OMP ATOMIC assignment operator must be binary "
5033 "+, *, -, /, .AND., .OR., .EQV. or .NEQV. at %L",
5038 /* Check for var = var op expr resp. var = expr op var where
5039 expr doesn't reference var and var op expr is mathematically
5040 equivalent to var op (expr) resp. expr op var equivalent to
5041 (expr) op var. We rely here on the fact that the matcher
5042 for x op1 y op2 z where op1 and op2 have equal precedence
5043 returns (x op1 y) op2 z. */
5044 e
= expr2
->value
.op
.op2
;
5045 if (e
->expr_type
== EXPR_VARIABLE
5046 && e
->symtree
!= NULL
5047 && e
->symtree
->n
.sym
== var
)
5049 else if ((c
= is_conversion (e
, true)) != NULL
5050 && c
->expr_type
== EXPR_VARIABLE
5051 && c
->symtree
!= NULL
5052 && c
->symtree
->n
.sym
== var
)
5056 gfc_expr
**p
= NULL
, **q
;
5057 for (q
= &expr2
->value
.op
.op1
; (e
= *q
) != NULL
; )
5058 if (e
->expr_type
== EXPR_VARIABLE
5059 && e
->symtree
!= NULL
5060 && e
->symtree
->n
.sym
== var
)
5065 else if ((c
= is_conversion (e
, true)) != NULL
)
5066 q
= &e
->value
.function
.actual
->expr
;
5067 else if (e
->expr_type
!= EXPR_OP
5068 || (e
->value
.op
.op
!= op
5069 && e
->value
.op
.op
!= alt_op
)
5075 q
= &e
->value
.op
.op1
;
5080 gfc_error ("!$OMP ATOMIC assignment must be var = var op expr "
5081 "or var = expr op var at %L", &expr2
->where
);
5088 switch (e
->value
.op
.op
)
5090 case INTRINSIC_MINUS
:
5091 case INTRINSIC_DIVIDE
:
5093 case INTRINSIC_NEQV
:
5094 gfc_error ("!$OMP ATOMIC var = var op expr not "
5095 "mathematically equivalent to var = var op "
5096 "(expr) at %L", &expr2
->where
);
5102 /* Canonicalize into var = var op (expr). */
5103 *p
= e
->value
.op
.op2
;
5104 e
->value
.op
.op2
= expr2
;
5106 if (code
->expr2
== expr2
)
5107 code
->expr2
= expr2
= e
;
5109 code
->expr2
->value
.function
.actual
->expr
= expr2
= e
;
5111 if (!gfc_compare_types (&expr2
->value
.op
.op1
->ts
, &expr2
->ts
))
5113 for (p
= &expr2
->value
.op
.op1
; *p
!= v
;
5114 p
= &(*p
)->value
.function
.actual
->expr
)
5117 gfc_free_expr (expr2
->value
.op
.op1
);
5118 expr2
->value
.op
.op1
= v
;
5119 gfc_convert_type (v
, &expr2
->ts
, 2);
5124 if (e
->rank
!= 0 || expr_references_sym (code
->expr2
, var
, v
))
5126 gfc_error ("expr in !$OMP ATOMIC assignment var = var op expr "
5127 "must be scalar and cannot reference var at %L",
5132 else if (expr2
->expr_type
== EXPR_FUNCTION
5133 && expr2
->value
.function
.isym
!= NULL
5134 && expr2
->value
.function
.esym
== NULL
5135 && expr2
->value
.function
.actual
!= NULL
5136 && expr2
->value
.function
.actual
->next
!= NULL
)
5138 gfc_actual_arglist
*arg
, *var_arg
;
5140 switch (expr2
->value
.function
.isym
->id
)
5148 if (expr2
->value
.function
.actual
->next
->next
!= NULL
)
5150 gfc_error ("!$OMP ATOMIC assignment intrinsic IAND, IOR "
5151 "or IEOR must have two arguments at %L",
5157 gfc_error ("!$OMP ATOMIC assignment intrinsic must be "
5158 "MIN, MAX, IAND, IOR or IEOR at %L",
5164 for (arg
= expr2
->value
.function
.actual
; arg
; arg
= arg
->next
)
5166 if ((arg
== expr2
->value
.function
.actual
5167 || (var_arg
== NULL
&& arg
->next
== NULL
))
5168 && arg
->expr
->expr_type
== EXPR_VARIABLE
5169 && arg
->expr
->symtree
!= NULL
5170 && arg
->expr
->symtree
->n
.sym
== var
)
5172 else if (expr_references_sym (arg
->expr
, var
, NULL
))
5174 gfc_error ("!$OMP ATOMIC intrinsic arguments except one must "
5175 "not reference %qs at %L",
5176 var
->name
, &arg
->expr
->where
);
5179 if (arg
->expr
->rank
!= 0)
5181 gfc_error ("!$OMP ATOMIC intrinsic arguments must be scalar "
5182 "at %L", &arg
->expr
->where
);
5187 if (var_arg
== NULL
)
5189 gfc_error ("First or last !$OMP ATOMIC intrinsic argument must "
5190 "be %qs at %L", var
->name
, &expr2
->where
);
5194 if (var_arg
!= expr2
->value
.function
.actual
)
5196 /* Canonicalize, so that var comes first. */
5197 gcc_assert (var_arg
->next
== NULL
);
5198 for (arg
= expr2
->value
.function
.actual
;
5199 arg
->next
!= var_arg
; arg
= arg
->next
)
5201 var_arg
->next
= expr2
->value
.function
.actual
;
5202 expr2
->value
.function
.actual
= var_arg
;
5207 gfc_error ("!$OMP ATOMIC assignment must have an operator or "
5208 "intrinsic on right hand side at %L", &expr2
->where
);
5210 if (aop
== GFC_OMP_ATOMIC_CAPTURE
&& code
->next
)
5213 if (code
->expr1
->expr_type
!= EXPR_VARIABLE
5214 || code
->expr1
->symtree
== NULL
5215 || code
->expr1
->rank
!= 0
5216 || (code
->expr1
->ts
.type
!= BT_INTEGER
5217 && code
->expr1
->ts
.type
!= BT_REAL
5218 && code
->expr1
->ts
.type
!= BT_COMPLEX
5219 && code
->expr1
->ts
.type
!= BT_LOGICAL
))
5221 gfc_error ("!$OMP ATOMIC CAPTURE capture statement must set "
5222 "a scalar variable of intrinsic type at %L",
5223 &code
->expr1
->where
);
5227 expr2
= is_conversion (code
->expr2
, false);
5230 expr2
= is_conversion (code
->expr2
, true);
5232 expr2
= code
->expr2
;
5235 if (expr2
->expr_type
!= EXPR_VARIABLE
5236 || expr2
->symtree
== NULL
5238 || (expr2
->ts
.type
!= BT_INTEGER
5239 && expr2
->ts
.type
!= BT_REAL
5240 && expr2
->ts
.type
!= BT_COMPLEX
5241 && expr2
->ts
.type
!= BT_LOGICAL
))
5243 gfc_error ("!$OMP ATOMIC CAPTURE capture statement must read "
5244 "from a scalar variable of intrinsic type at %L",
5248 if (expr2
->symtree
->n
.sym
!= var
)
5250 gfc_error ("!$OMP ATOMIC CAPTURE capture statement reads from "
5251 "different variable than update statement writes "
5252 "into at %L", &expr2
->where
);
5259 struct fortran_omp_context
5262 hash_set
<gfc_symbol
*> *sharing_clauses
;
5263 hash_set
<gfc_symbol
*> *private_iterators
;
5264 struct fortran_omp_context
*previous
;
5267 static gfc_code
*omp_current_do_code
;
5268 static int omp_current_do_collapse
;
5271 gfc_resolve_omp_do_blocks (gfc_code
*code
, gfc_namespace
*ns
)
5273 if (code
->block
->next
&& code
->block
->next
->op
== EXEC_DO
)
5278 omp_current_do_code
= code
->block
->next
;
5279 if (code
->ext
.omp_clauses
->orderedc
)
5280 omp_current_do_collapse
= code
->ext
.omp_clauses
->orderedc
;
5282 omp_current_do_collapse
= code
->ext
.omp_clauses
->collapse
;
5283 for (i
= 1, c
= omp_current_do_code
; i
< omp_current_do_collapse
; i
++)
5286 if (c
->op
!= EXEC_DO
|| c
->next
== NULL
)
5289 if (c
->op
!= EXEC_DO
)
5292 if (i
< omp_current_do_collapse
|| omp_current_do_collapse
<= 0)
5293 omp_current_do_collapse
= 1;
5295 gfc_resolve_blocks (code
->block
, ns
);
5296 omp_current_do_collapse
= 0;
5297 omp_current_do_code
= NULL
;
5302 gfc_resolve_omp_parallel_blocks (gfc_code
*code
, gfc_namespace
*ns
)
5304 struct fortran_omp_context ctx
;
5305 gfc_omp_clauses
*omp_clauses
= code
->ext
.omp_clauses
;
5306 gfc_omp_namelist
*n
;
5310 ctx
.sharing_clauses
= new hash_set
<gfc_symbol
*>;
5311 ctx
.private_iterators
= new hash_set
<gfc_symbol
*>;
5312 ctx
.previous
= omp_current_ctx
;
5313 ctx
.is_openmp
= true;
5314 omp_current_ctx
= &ctx
;
5316 for (list
= 0; list
< OMP_LIST_NUM
; list
++)
5319 case OMP_LIST_SHARED
:
5320 case OMP_LIST_PRIVATE
:
5321 case OMP_LIST_FIRSTPRIVATE
:
5322 case OMP_LIST_LASTPRIVATE
:
5323 case OMP_LIST_REDUCTION
:
5324 case OMP_LIST_LINEAR
:
5325 for (n
= omp_clauses
->lists
[list
]; n
; n
= n
->next
)
5326 ctx
.sharing_clauses
->add (n
->sym
);
5334 case EXEC_OMP_PARALLEL_DO
:
5335 case EXEC_OMP_PARALLEL_DO_SIMD
:
5336 case EXEC_OMP_TARGET_PARALLEL_DO
:
5337 case EXEC_OMP_TARGET_PARALLEL_DO_SIMD
:
5338 case EXEC_OMP_TARGET_TEAMS_DISTRIBUTE
:
5339 case EXEC_OMP_TARGET_TEAMS_DISTRIBUTE_PARALLEL_DO
:
5340 case EXEC_OMP_TARGET_TEAMS_DISTRIBUTE_PARALLEL_DO_SIMD
:
5341 case EXEC_OMP_TARGET_TEAMS_DISTRIBUTE_SIMD
:
5342 case EXEC_OMP_TEAMS_DISTRIBUTE
:
5343 case EXEC_OMP_TEAMS_DISTRIBUTE_PARALLEL_DO
:
5344 case EXEC_OMP_TEAMS_DISTRIBUTE_PARALLEL_DO_SIMD
:
5345 case EXEC_OMP_TEAMS_DISTRIBUTE_SIMD
:
5346 gfc_resolve_omp_do_blocks (code
, ns
);
5349 gfc_resolve_blocks (code
->block
, ns
);
5352 omp_current_ctx
= ctx
.previous
;
5353 delete ctx
.sharing_clauses
;
5354 delete ctx
.private_iterators
;
5358 /* Save and clear openmp.c private state. */
5361 gfc_omp_save_and_clear_state (struct gfc_omp_saved_state
*state
)
5363 state
->ptrs
[0] = omp_current_ctx
;
5364 state
->ptrs
[1] = omp_current_do_code
;
5365 state
->ints
[0] = omp_current_do_collapse
;
5366 omp_current_ctx
= NULL
;
5367 omp_current_do_code
= NULL
;
5368 omp_current_do_collapse
= 0;
5372 /* Restore openmp.c private state from the saved state. */
5375 gfc_omp_restore_state (struct gfc_omp_saved_state
*state
)
5377 omp_current_ctx
= (struct fortran_omp_context
*) state
->ptrs
[0];
5378 omp_current_do_code
= (gfc_code
*) state
->ptrs
[1];
5379 omp_current_do_collapse
= state
->ints
[0];
5383 /* Note a DO iterator variable. This is special in !$omp parallel
5384 construct, where they are predetermined private. */
5387 gfc_resolve_do_iterator (gfc_code
*code
, gfc_symbol
*sym
)
5389 int i
= omp_current_do_collapse
;
5390 gfc_code
*c
= omp_current_do_code
;
5392 if (sym
->attr
.threadprivate
)
5395 /* !$omp do and !$omp parallel do iteration variable is predetermined
5396 private just in the !$omp do resp. !$omp parallel do construct,
5397 with no implications for the outer parallel constructs. */
5407 if (omp_current_ctx
== NULL
)
5410 /* An openacc context may represent a data clause. Abort if so. */
5411 if (!omp_current_ctx
->is_openmp
&& !oacc_is_loop (omp_current_ctx
->code
))
5414 if (omp_current_ctx
->is_openmp
5415 && omp_current_ctx
->sharing_clauses
->contains (sym
))
5418 if (! omp_current_ctx
->private_iterators
->add (sym
))
5420 gfc_omp_clauses
*omp_clauses
= omp_current_ctx
->code
->ext
.omp_clauses
;
5421 gfc_omp_namelist
*p
;
5423 p
= gfc_get_omp_namelist ();
5425 p
->next
= omp_clauses
->lists
[OMP_LIST_PRIVATE
];
5426 omp_clauses
->lists
[OMP_LIST_PRIVATE
] = p
;
5432 resolve_omp_do (gfc_code
*code
)
5434 gfc_code
*do_code
, *c
;
5435 int list
, i
, collapse
;
5436 gfc_omp_namelist
*n
;
5439 bool is_simd
= false;
5443 case EXEC_OMP_DISTRIBUTE
: name
= "!$OMP DISTRIBUTE"; break;
5444 case EXEC_OMP_DISTRIBUTE_PARALLEL_DO
:
5445 name
= "!$OMP DISTRIBUTE PARALLEL DO";
5447 case EXEC_OMP_DISTRIBUTE_PARALLEL_DO_SIMD
:
5448 name
= "!$OMP DISTRIBUTE PARALLEL DO SIMD";
5451 case EXEC_OMP_DISTRIBUTE_SIMD
:
5452 name
= "!$OMP DISTRIBUTE SIMD";
5455 case EXEC_OMP_DO
: name
= "!$OMP DO"; break;
5456 case EXEC_OMP_DO_SIMD
: name
= "!$OMP DO SIMD"; is_simd
= true; break;
5457 case EXEC_OMP_PARALLEL_DO
: name
= "!$OMP PARALLEL DO"; break;
5458 case EXEC_OMP_PARALLEL_DO_SIMD
:
5459 name
= "!$OMP PARALLEL DO SIMD";
5462 case EXEC_OMP_SIMD
: name
= "!$OMP SIMD"; is_simd
= true; break;
5463 case EXEC_OMP_TARGET_PARALLEL_DO
: name
= "!$OMP TARGET PARALLEL DO"; break;
5464 case EXEC_OMP_TARGET_PARALLEL_DO_SIMD
:
5465 name
= "!$OMP TARGET PARALLEL DO SIMD";
5468 case EXEC_OMP_TARGET_SIMD
:
5469 name
= "!$OMP TARGET SIMD";
5472 case EXEC_OMP_TARGET_TEAMS_DISTRIBUTE
:
5473 name
= "!$OMP TARGET TEAMS DISTRIBUTE";
5475 case EXEC_OMP_TARGET_TEAMS_DISTRIBUTE_PARALLEL_DO
:
5476 name
= "!$OMP TARGET TEAMS DISTRIBUTE PARALLEL DO";
5478 case EXEC_OMP_TARGET_TEAMS_DISTRIBUTE_PARALLEL_DO_SIMD
:
5479 name
= "!$OMP TARGET TEAMS DISTRIBUTE PARALLEL DO SIMD";
5482 case EXEC_OMP_TARGET_TEAMS_DISTRIBUTE_SIMD
:
5483 name
= "!$OMP TARGET TEAMS DISTRIBUTE SIMD";
5486 case EXEC_OMP_TASKLOOP
: name
= "!$OMP TASKLOOP"; break;
5487 case EXEC_OMP_TASKLOOP_SIMD
:
5488 name
= "!$OMP TASKLOOP SIMD";
5491 case EXEC_OMP_TEAMS_DISTRIBUTE
: name
= "!$OMP TEAMS DISTRIBUTE"; break;
5492 case EXEC_OMP_TEAMS_DISTRIBUTE_PARALLEL_DO
:
5493 name
= "!$OMP TEAMS DISTRIBUTE PARALLEL DO";
5495 case EXEC_OMP_TEAMS_DISTRIBUTE_PARALLEL_DO_SIMD
:
5496 name
= "!$OMP TEAMS DISTRIBUTE PARALLEL DO SIMD";
5499 case EXEC_OMP_TEAMS_DISTRIBUTE_SIMD
:
5500 name
= "!$OMP TEAMS DISTRIBUTE SIMD";
5503 default: gcc_unreachable ();
5506 if (code
->ext
.omp_clauses
)
5507 resolve_omp_clauses (code
, code
->ext
.omp_clauses
, NULL
);
5509 do_code
= code
->block
->next
;
5510 if (code
->ext
.omp_clauses
->orderedc
)
5511 collapse
= code
->ext
.omp_clauses
->orderedc
;
5514 collapse
= code
->ext
.omp_clauses
->collapse
;
5518 for (i
= 1; i
<= collapse
; i
++)
5520 if (do_code
->op
== EXEC_DO_WHILE
)
5522 gfc_error ("%s cannot be a DO WHILE or DO without loop control "
5523 "at %L", name
, &do_code
->loc
);
5526 if (do_code
->op
== EXEC_DO_CONCURRENT
)
5528 gfc_error ("%s cannot be a DO CONCURRENT loop at %L", name
,
5532 gcc_assert (do_code
->op
== EXEC_DO
);
5533 if (do_code
->ext
.iterator
->var
->ts
.type
!= BT_INTEGER
)
5534 gfc_error ("%s iteration variable must be of type integer at %L",
5535 name
, &do_code
->loc
);
5536 dovar
= do_code
->ext
.iterator
->var
->symtree
->n
.sym
;
5537 if (dovar
->attr
.threadprivate
)
5538 gfc_error ("%s iteration variable must not be THREADPRIVATE "
5539 "at %L", name
, &do_code
->loc
);
5540 if (code
->ext
.omp_clauses
)
5541 for (list
= 0; list
< OMP_LIST_NUM
; list
++)
5543 ? (list
!= OMP_LIST_PRIVATE
&& list
!= OMP_LIST_LASTPRIVATE
)
5544 : code
->ext
.omp_clauses
->collapse
> 1
5545 ? (list
!= OMP_LIST_LASTPRIVATE
)
5546 : (list
!= OMP_LIST_LINEAR
))
5547 for (n
= code
->ext
.omp_clauses
->lists
[list
]; n
; n
= n
->next
)
5548 if (dovar
== n
->sym
)
5551 gfc_error ("%s iteration variable present on clause "
5552 "other than PRIVATE or LASTPRIVATE at %L",
5553 name
, &do_code
->loc
);
5554 else if (code
->ext
.omp_clauses
->collapse
> 1)
5555 gfc_error ("%s iteration variable present on clause "
5556 "other than LASTPRIVATE at %L",
5557 name
, &do_code
->loc
);
5559 gfc_error ("%s iteration variable present on clause "
5560 "other than LINEAR at %L",
5561 name
, &do_code
->loc
);
5566 gfc_code
*do_code2
= code
->block
->next
;
5569 for (j
= 1; j
< i
; j
++)
5571 gfc_symbol
*ivar
= do_code2
->ext
.iterator
->var
->symtree
->n
.sym
;
5573 || gfc_find_sym_in_expr (ivar
, do_code
->ext
.iterator
->start
)
5574 || gfc_find_sym_in_expr (ivar
, do_code
->ext
.iterator
->end
)
5575 || gfc_find_sym_in_expr (ivar
, do_code
->ext
.iterator
->step
))
5577 gfc_error ("%s collapsed loops don't form rectangular "
5578 "iteration space at %L", name
, &do_code
->loc
);
5583 do_code2
= do_code2
->block
->next
;
5588 for (c
= do_code
->next
; c
; c
= c
->next
)
5589 if (c
->op
!= EXEC_NOP
&& c
->op
!= EXEC_CONTINUE
)
5591 gfc_error ("collapsed %s loops not perfectly nested at %L",
5597 do_code
= do_code
->block
;
5598 if (do_code
->op
!= EXEC_DO
&& do_code
->op
!= EXEC_DO_WHILE
)
5600 gfc_error ("not enough DO loops for collapsed %s at %L",
5604 do_code
= do_code
->next
;
5606 || (do_code
->op
!= EXEC_DO
&& do_code
->op
!= EXEC_DO_WHILE
))
5608 gfc_error ("not enough DO loops for collapsed %s at %L",
5616 oacc_is_parallel (gfc_code
*code
)
5618 return code
->op
== EXEC_OACC_PARALLEL
|| code
->op
== EXEC_OACC_PARALLEL_LOOP
;
5622 oacc_is_kernels (gfc_code
*code
)
5624 return code
->op
== EXEC_OACC_KERNELS
|| code
->op
== EXEC_OACC_KERNELS_LOOP
;
5627 static gfc_statement
5628 omp_code_to_statement (gfc_code
*code
)
5632 case EXEC_OMP_PARALLEL
:
5633 return ST_OMP_PARALLEL
;
5634 case EXEC_OMP_PARALLEL_SECTIONS
:
5635 return ST_OMP_PARALLEL_SECTIONS
;
5636 case EXEC_OMP_SECTIONS
:
5637 return ST_OMP_SECTIONS
;
5638 case EXEC_OMP_ORDERED
:
5639 return ST_OMP_ORDERED
;
5640 case EXEC_OMP_CRITICAL
:
5641 return ST_OMP_CRITICAL
;
5642 case EXEC_OMP_MASTER
:
5643 return ST_OMP_MASTER
;
5644 case EXEC_OMP_SINGLE
:
5645 return ST_OMP_SINGLE
;
5648 case EXEC_OMP_WORKSHARE
:
5649 return ST_OMP_WORKSHARE
;
5650 case EXEC_OMP_PARALLEL_WORKSHARE
:
5651 return ST_OMP_PARALLEL_WORKSHARE
;
5659 static gfc_statement
5660 oacc_code_to_statement (gfc_code
*code
)
5664 case EXEC_OACC_PARALLEL
:
5665 return ST_OACC_PARALLEL
;
5666 case EXEC_OACC_KERNELS
:
5667 return ST_OACC_KERNELS
;
5668 case EXEC_OACC_DATA
:
5669 return ST_OACC_DATA
;
5670 case EXEC_OACC_HOST_DATA
:
5671 return ST_OACC_HOST_DATA
;
5672 case EXEC_OACC_PARALLEL_LOOP
:
5673 return ST_OACC_PARALLEL_LOOP
;
5674 case EXEC_OACC_KERNELS_LOOP
:
5675 return ST_OACC_KERNELS_LOOP
;
5676 case EXEC_OACC_LOOP
:
5677 return ST_OACC_LOOP
;
5678 case EXEC_OACC_ATOMIC
:
5679 return ST_OACC_ATOMIC
;
5686 resolve_oacc_directive_inside_omp_region (gfc_code
*code
)
5688 if (omp_current_ctx
!= NULL
&& omp_current_ctx
->is_openmp
)
5690 gfc_statement st
= omp_code_to_statement (omp_current_ctx
->code
);
5691 gfc_statement oacc_st
= oacc_code_to_statement (code
);
5692 gfc_error ("The %s directive cannot be specified within "
5693 "a %s region at %L", gfc_ascii_statement (oacc_st
),
5694 gfc_ascii_statement (st
), &code
->loc
);
5699 resolve_omp_directive_inside_oacc_region (gfc_code
*code
)
5701 if (omp_current_ctx
!= NULL
&& !omp_current_ctx
->is_openmp
)
5703 gfc_statement st
= oacc_code_to_statement (omp_current_ctx
->code
);
5704 gfc_statement omp_st
= omp_code_to_statement (code
);
5705 gfc_error ("The %s directive cannot be specified within "
5706 "a %s region at %L", gfc_ascii_statement (omp_st
),
5707 gfc_ascii_statement (st
), &code
->loc
);
5713 resolve_oacc_nested_loops (gfc_code
*code
, gfc_code
* do_code
, int collapse
,
5720 for (i
= 1; i
<= collapse
; i
++)
5722 if (do_code
->op
== EXEC_DO_WHILE
)
5724 gfc_error ("!$ACC LOOP cannot be a DO WHILE or DO without loop control "
5725 "at %L", &do_code
->loc
);
5728 gcc_assert (do_code
->op
== EXEC_DO
|| do_code
->op
== EXEC_DO_CONCURRENT
);
5729 if (do_code
->ext
.iterator
->var
->ts
.type
!= BT_INTEGER
)
5730 gfc_error ("!$ACC LOOP iteration variable must be of type integer at %L",
5732 dovar
= do_code
->ext
.iterator
->var
->symtree
->n
.sym
;
5735 gfc_code
*do_code2
= code
->block
->next
;
5738 for (j
= 1; j
< i
; j
++)
5740 gfc_symbol
*ivar
= do_code2
->ext
.iterator
->var
->symtree
->n
.sym
;
5742 || gfc_find_sym_in_expr (ivar
, do_code
->ext
.iterator
->start
)
5743 || gfc_find_sym_in_expr (ivar
, do_code
->ext
.iterator
->end
)
5744 || gfc_find_sym_in_expr (ivar
, do_code
->ext
.iterator
->step
))
5746 gfc_error ("!$ACC LOOP %s loops don't form rectangular iteration space at %L",
5747 clause
, &do_code
->loc
);
5752 do_code2
= do_code2
->block
->next
;
5757 for (c
= do_code
->next
; c
; c
= c
->next
)
5758 if (c
->op
!= EXEC_NOP
&& c
->op
!= EXEC_CONTINUE
)
5760 gfc_error ("%s !$ACC LOOP loops not perfectly nested at %L",
5766 do_code
= do_code
->block
;
5767 if (do_code
->op
!= EXEC_DO
&& do_code
->op
!= EXEC_DO_WHILE
5768 && do_code
->op
!= EXEC_DO_CONCURRENT
)
5770 gfc_error ("not enough DO loops for %s !$ACC LOOP at %L",
5771 clause
, &code
->loc
);
5774 do_code
= do_code
->next
;
5776 || (do_code
->op
!= EXEC_DO
&& do_code
->op
!= EXEC_DO_WHILE
5777 && do_code
->op
!= EXEC_DO_CONCURRENT
))
5779 gfc_error ("not enough DO loops for %s !$ACC LOOP at %L",
5780 clause
, &code
->loc
);
5788 resolve_oacc_params_in_parallel (gfc_code
*code
, const char *clause
,
5791 fortran_omp_context
*c
;
5793 if (oacc_is_parallel (code
))
5794 gfc_error ("!$ACC LOOP %s in PARALLEL region doesn't allow "
5795 "%s arguments at %L", clause
, arg
, &code
->loc
);
5796 for (c
= omp_current_ctx
; c
; c
= c
->previous
)
5798 if (oacc_is_loop (c
->code
))
5800 if (oacc_is_parallel (c
->code
))
5801 gfc_error ("!$ACC LOOP %s in PARALLEL region doesn't allow "
5802 "%s arguments at %L", clause
, arg
, &code
->loc
);
5808 resolve_oacc_loop_blocks (gfc_code
*code
)
5810 fortran_omp_context
*c
;
5812 if (!oacc_is_loop (code
))
5815 if (code
->op
== EXEC_OACC_LOOP
)
5816 for (c
= omp_current_ctx
; c
; c
= c
->previous
)
5818 if (oacc_is_loop (c
->code
))
5820 if (code
->ext
.omp_clauses
->gang
)
5822 if (c
->code
->ext
.omp_clauses
->gang
)
5823 gfc_error ("Loop parallelized across gangs is not allowed "
5824 "inside another loop parallelized across gangs at %L",
5826 if (c
->code
->ext
.omp_clauses
->worker
)
5827 gfc_error ("Loop parallelized across gangs is not allowed "
5828 "inside loop parallelized across workers at %L",
5830 if (c
->code
->ext
.omp_clauses
->vector
)
5831 gfc_error ("Loop parallelized across gangs is not allowed "
5832 "inside loop parallelized across workers at %L",
5835 if (code
->ext
.omp_clauses
->worker
)
5837 if (c
->code
->ext
.omp_clauses
->worker
)
5838 gfc_error ("Loop parallelized across workers is not allowed "
5839 "inside another loop parallelized across workers at %L",
5841 if (c
->code
->ext
.omp_clauses
->vector
)
5842 gfc_error ("Loop parallelized across workers is not allowed "
5843 "inside another loop parallelized across vectors at %L",
5846 if (code
->ext
.omp_clauses
->vector
)
5847 if (c
->code
->ext
.omp_clauses
->vector
)
5848 gfc_error ("Loop parallelized across vectors is not allowed "
5849 "inside another loop parallelized across vectors at %L",
5853 if (oacc_is_parallel (c
->code
) || oacc_is_kernels (c
->code
))
5857 if (code
->ext
.omp_clauses
->seq
)
5859 if (code
->ext
.omp_clauses
->independent
)
5860 gfc_error ("Clause SEQ conflicts with INDEPENDENT at %L", &code
->loc
);
5861 if (code
->ext
.omp_clauses
->gang
)
5862 gfc_error ("Clause SEQ conflicts with GANG at %L", &code
->loc
);
5863 if (code
->ext
.omp_clauses
->worker
)
5864 gfc_error ("Clause SEQ conflicts with WORKER at %L", &code
->loc
);
5865 if (code
->ext
.omp_clauses
->vector
)
5866 gfc_error ("Clause SEQ conflicts with VECTOR at %L", &code
->loc
);
5867 if (code
->ext
.omp_clauses
->par_auto
)
5868 gfc_error ("Clause SEQ conflicts with AUTO at %L", &code
->loc
);
5870 if (code
->ext
.omp_clauses
->par_auto
)
5872 if (code
->ext
.omp_clauses
->gang
)
5873 gfc_error ("Clause AUTO conflicts with GANG at %L", &code
->loc
);
5874 if (code
->ext
.omp_clauses
->worker
)
5875 gfc_error ("Clause AUTO conflicts with WORKER at %L", &code
->loc
);
5876 if (code
->ext
.omp_clauses
->vector
)
5877 gfc_error ("Clause AUTO conflicts with VECTOR at %L", &code
->loc
);
5879 if (code
->ext
.omp_clauses
->tile_list
&& code
->ext
.omp_clauses
->gang
5880 && code
->ext
.omp_clauses
->worker
&& code
->ext
.omp_clauses
->vector
)
5881 gfc_error ("Tiled loop cannot be parallelized across gangs, workers and "
5882 "vectors at the same time at %L", &code
->loc
);
5884 if (code
->ext
.omp_clauses
->gang
5885 && code
->ext
.omp_clauses
->gang_num_expr
)
5886 resolve_oacc_params_in_parallel (code
, "GANG", "num");
5888 if (code
->ext
.omp_clauses
->worker
5889 && code
->ext
.omp_clauses
->worker_expr
)
5890 resolve_oacc_params_in_parallel (code
, "WORKER", "num");
5892 if (code
->ext
.omp_clauses
->vector
5893 && code
->ext
.omp_clauses
->vector_expr
)
5894 resolve_oacc_params_in_parallel (code
, "VECTOR", "length");
5896 if (code
->ext
.omp_clauses
->tile_list
)
5900 for (el
= code
->ext
.omp_clauses
->tile_list
; el
; el
= el
->next
)
5903 if (el
->expr
== NULL
)
5905 /* NULL expressions are used to represent '*' arguments.
5906 Convert those to a -1 expressions. */
5907 el
->expr
= gfc_get_constant_expr (BT_INTEGER
,
5908 gfc_default_integer_kind
,
5910 mpz_set_si (el
->expr
->value
.integer
, -1);
5914 resolve_positive_int_expr (el
->expr
, "TILE");
5915 if (el
->expr
->expr_type
!= EXPR_CONSTANT
)
5916 gfc_error ("TILE requires constant expression at %L",
5920 resolve_oacc_nested_loops (code
, code
->block
->next
, num
, "tiled");
5926 gfc_resolve_oacc_blocks (gfc_code
*code
, gfc_namespace
*ns
)
5928 fortran_omp_context ctx
;
5930 resolve_oacc_loop_blocks (code
);
5933 ctx
.sharing_clauses
= NULL
;
5934 ctx
.private_iterators
= new hash_set
<gfc_symbol
*>;
5935 ctx
.previous
= omp_current_ctx
;
5936 ctx
.is_openmp
= false;
5937 omp_current_ctx
= &ctx
;
5939 gfc_resolve_blocks (code
->block
, ns
);
5941 omp_current_ctx
= ctx
.previous
;
5942 delete ctx
.private_iterators
;
5947 resolve_oacc_loop (gfc_code
*code
)
5952 if (code
->ext
.omp_clauses
)
5953 resolve_omp_clauses (code
, code
->ext
.omp_clauses
, NULL
, true);
5955 do_code
= code
->block
->next
;
5956 collapse
= code
->ext
.omp_clauses
->collapse
;
5960 resolve_oacc_nested_loops (code
, do_code
, collapse
, "collapsed");
5964 gfc_resolve_oacc_declare (gfc_namespace
*ns
)
5967 gfc_omp_namelist
*n
;
5968 gfc_oacc_declare
*oc
;
5970 if (ns
->oacc_declare
== NULL
)
5973 for (oc
= ns
->oacc_declare
; oc
; oc
= oc
->next
)
5975 for (list
= 0; list
< OMP_LIST_NUM
; list
++)
5976 for (n
= oc
->clauses
->lists
[list
]; n
; n
= n
->next
)
5979 if (n
->sym
->attr
.flavor
== FL_PARAMETER
)
5981 gfc_error ("PARAMETER object %qs is not allowed at %L",
5982 n
->sym
->name
, &oc
->loc
);
5986 if (n
->expr
&& n
->expr
->ref
->type
== REF_ARRAY
)
5988 gfc_error ("Array sections: %qs not allowed in"
5989 " $!ACC DECLARE at %L", n
->sym
->name
, &oc
->loc
);
5994 for (n
= oc
->clauses
->lists
[OMP_LIST_DEVICE_RESIDENT
]; n
; n
= n
->next
)
5995 check_array_not_assumed (n
->sym
, oc
->loc
, "DEVICE_RESIDENT");
5998 for (oc
= ns
->oacc_declare
; oc
; oc
= oc
->next
)
6000 for (list
= 0; list
< OMP_LIST_NUM
; list
++)
6001 for (n
= oc
->clauses
->lists
[list
]; n
; n
= n
->next
)
6005 gfc_error ("Symbol %qs present on multiple clauses at %L",
6006 n
->sym
->name
, &oc
->loc
);
6014 for (oc
= ns
->oacc_declare
; oc
; oc
= oc
->next
)
6016 for (list
= 0; list
< OMP_LIST_NUM
; list
++)
6017 for (n
= oc
->clauses
->lists
[list
]; n
; n
= n
->next
)
6023 gfc_resolve_oacc_directive (gfc_code
*code
, gfc_namespace
*ns ATTRIBUTE_UNUSED
)
6025 resolve_oacc_directive_inside_omp_region (code
);
6029 case EXEC_OACC_PARALLEL
:
6030 case EXEC_OACC_KERNELS
:
6031 case EXEC_OACC_DATA
:
6032 case EXEC_OACC_HOST_DATA
:
6033 case EXEC_OACC_UPDATE
:
6034 case EXEC_OACC_ENTER_DATA
:
6035 case EXEC_OACC_EXIT_DATA
:
6036 case EXEC_OACC_WAIT
:
6037 case EXEC_OACC_CACHE
:
6038 resolve_omp_clauses (code
, code
->ext
.omp_clauses
, NULL
, true);
6040 case EXEC_OACC_PARALLEL_LOOP
:
6041 case EXEC_OACC_KERNELS_LOOP
:
6042 case EXEC_OACC_LOOP
:
6043 resolve_oacc_loop (code
);
6045 case EXEC_OACC_ATOMIC
:
6046 resolve_omp_atomic (code
);
6054 /* Resolve OpenMP directive clauses and check various requirements
6055 of each directive. */
6058 gfc_resolve_omp_directive (gfc_code
*code
, gfc_namespace
*ns ATTRIBUTE_UNUSED
)
6060 resolve_omp_directive_inside_oacc_region (code
);
6062 if (code
->op
!= EXEC_OMP_ATOMIC
)
6063 gfc_maybe_initialize_eh ();
6067 case EXEC_OMP_DISTRIBUTE
:
6068 case EXEC_OMP_DISTRIBUTE_PARALLEL_DO
:
6069 case EXEC_OMP_DISTRIBUTE_PARALLEL_DO_SIMD
:
6070 case EXEC_OMP_DISTRIBUTE_SIMD
:
6072 case EXEC_OMP_DO_SIMD
:
6073 case EXEC_OMP_PARALLEL_DO
:
6074 case EXEC_OMP_PARALLEL_DO_SIMD
:
6076 case EXEC_OMP_TARGET_PARALLEL_DO
:
6077 case EXEC_OMP_TARGET_PARALLEL_DO_SIMD
:
6078 case EXEC_OMP_TARGET_SIMD
:
6079 case EXEC_OMP_TARGET_TEAMS_DISTRIBUTE
:
6080 case EXEC_OMP_TARGET_TEAMS_DISTRIBUTE_PARALLEL_DO
:
6081 case EXEC_OMP_TARGET_TEAMS_DISTRIBUTE_PARALLEL_DO_SIMD
:
6082 case EXEC_OMP_TARGET_TEAMS_DISTRIBUTE_SIMD
:
6083 case EXEC_OMP_TASKLOOP
:
6084 case EXEC_OMP_TASKLOOP_SIMD
:
6085 case EXEC_OMP_TEAMS_DISTRIBUTE
:
6086 case EXEC_OMP_TEAMS_DISTRIBUTE_PARALLEL_DO
:
6087 case EXEC_OMP_TEAMS_DISTRIBUTE_PARALLEL_DO_SIMD
:
6088 case EXEC_OMP_TEAMS_DISTRIBUTE_SIMD
:
6089 resolve_omp_do (code
);
6091 case EXEC_OMP_CANCEL
:
6092 case EXEC_OMP_PARALLEL_WORKSHARE
:
6093 case EXEC_OMP_PARALLEL
:
6094 case EXEC_OMP_PARALLEL_SECTIONS
:
6095 case EXEC_OMP_SECTIONS
:
6096 case EXEC_OMP_SINGLE
:
6097 case EXEC_OMP_TARGET
:
6098 case EXEC_OMP_TARGET_DATA
:
6099 case EXEC_OMP_TARGET_ENTER_DATA
:
6100 case EXEC_OMP_TARGET_EXIT_DATA
:
6101 case EXEC_OMP_TARGET_PARALLEL
:
6102 case EXEC_OMP_TARGET_TEAMS
:
6104 case EXEC_OMP_TEAMS
:
6105 case EXEC_OMP_WORKSHARE
:
6106 if (code
->ext
.omp_clauses
)
6107 resolve_omp_clauses (code
, code
->ext
.omp_clauses
, NULL
);
6109 case EXEC_OMP_TARGET_UPDATE
:
6110 if (code
->ext
.omp_clauses
)
6111 resolve_omp_clauses (code
, code
->ext
.omp_clauses
, NULL
);
6112 if (code
->ext
.omp_clauses
== NULL
6113 || (code
->ext
.omp_clauses
->lists
[OMP_LIST_TO
] == NULL
6114 && code
->ext
.omp_clauses
->lists
[OMP_LIST_FROM
] == NULL
))
6115 gfc_error ("OMP TARGET UPDATE at %L requires at least one TO or "
6116 "FROM clause", &code
->loc
);
6118 case EXEC_OMP_ATOMIC
:
6119 resolve_omp_atomic (code
);
6126 /* Resolve !$omp declare simd constructs in NS. */
6129 gfc_resolve_omp_declare_simd (gfc_namespace
*ns
)
6131 gfc_omp_declare_simd
*ods
;
6133 for (ods
= ns
->omp_declare_simd
; ods
; ods
= ods
->next
)
6135 if (ods
->proc_name
!= NULL
6136 && ods
->proc_name
!= ns
->proc_name
)
6137 gfc_error ("!$OMP DECLARE SIMD should refer to containing procedure "
6138 "%qs at %L", ns
->proc_name
->name
, &ods
->where
);
6140 resolve_omp_clauses (NULL
, ods
->clauses
, ns
);
6144 struct omp_udr_callback_data
6146 gfc_omp_udr
*omp_udr
;
6147 bool is_initializer
;
6151 omp_udr_callback (gfc_expr
**e
, int *walk_subtrees ATTRIBUTE_UNUSED
,
6154 struct omp_udr_callback_data
*cd
= (struct omp_udr_callback_data
*) data
;
6155 if ((*e
)->expr_type
== EXPR_VARIABLE
)
6157 if (cd
->is_initializer
)
6159 if ((*e
)->symtree
->n
.sym
!= cd
->omp_udr
->omp_priv
6160 && (*e
)->symtree
->n
.sym
!= cd
->omp_udr
->omp_orig
)
6161 gfc_error ("Variable other than OMP_PRIV or OMP_ORIG used in "
6162 "INITIALIZER clause of !$OMP DECLARE REDUCTION at %L",
6167 if ((*e
)->symtree
->n
.sym
!= cd
->omp_udr
->omp_out
6168 && (*e
)->symtree
->n
.sym
!= cd
->omp_udr
->omp_in
)
6169 gfc_error ("Variable other than OMP_OUT or OMP_IN used in "
6170 "combiner of !$OMP DECLARE REDUCTION at %L",
6177 /* Resolve !$omp declare reduction constructs. */
6180 gfc_resolve_omp_udr (gfc_omp_udr
*omp_udr
)
6182 gfc_actual_arglist
*a
;
6183 const char *predef_name
= NULL
;
6185 switch (omp_udr
->rop
)
6187 case OMP_REDUCTION_PLUS
:
6188 case OMP_REDUCTION_TIMES
:
6189 case OMP_REDUCTION_MINUS
:
6190 case OMP_REDUCTION_AND
:
6191 case OMP_REDUCTION_OR
:
6192 case OMP_REDUCTION_EQV
:
6193 case OMP_REDUCTION_NEQV
:
6194 case OMP_REDUCTION_MAX
:
6195 case OMP_REDUCTION_USER
:
6198 gfc_error ("Invalid operator for !$OMP DECLARE REDUCTION %s at %L",
6199 omp_udr
->name
, &omp_udr
->where
);
6203 if (gfc_omp_udr_predef (omp_udr
->rop
, omp_udr
->name
,
6204 &omp_udr
->ts
, &predef_name
))
6207 gfc_error_now ("Redefinition of predefined %s "
6208 "!$OMP DECLARE REDUCTION at %L",
6209 predef_name
, &omp_udr
->where
);
6211 gfc_error_now ("Redefinition of predefined "
6212 "!$OMP DECLARE REDUCTION at %L", &omp_udr
->where
);
6216 if (omp_udr
->ts
.type
== BT_CHARACTER
6217 && omp_udr
->ts
.u
.cl
->length
6218 && omp_udr
->ts
.u
.cl
->length
->expr_type
!= EXPR_CONSTANT
)
6220 gfc_error ("CHARACTER length in !$OMP DECLARE REDUCTION %s not "
6221 "constant at %L", omp_udr
->name
, &omp_udr
->where
);
6225 struct omp_udr_callback_data cd
;
6226 cd
.omp_udr
= omp_udr
;
6227 cd
.is_initializer
= false;
6228 gfc_code_walker (&omp_udr
->combiner_ns
->code
, gfc_dummy_code_callback
,
6229 omp_udr_callback
, &cd
);
6230 if (omp_udr
->combiner_ns
->code
->op
== EXEC_CALL
)
6232 for (a
= omp_udr
->combiner_ns
->code
->ext
.actual
; a
; a
= a
->next
)
6233 if (a
->expr
== NULL
)
6236 gfc_error ("Subroutine call with alternate returns in combiner "
6237 "of !$OMP DECLARE REDUCTION at %L",
6238 &omp_udr
->combiner_ns
->code
->loc
);
6240 if (omp_udr
->initializer_ns
)
6242 cd
.is_initializer
= true;
6243 gfc_code_walker (&omp_udr
->initializer_ns
->code
, gfc_dummy_code_callback
,
6244 omp_udr_callback
, &cd
);
6245 if (omp_udr
->initializer_ns
->code
->op
== EXEC_CALL
)
6247 for (a
= omp_udr
->initializer_ns
->code
->ext
.actual
; a
; a
= a
->next
)
6248 if (a
->expr
== NULL
)
6251 gfc_error ("Subroutine call with alternate returns in "
6252 "INITIALIZER clause of !$OMP DECLARE REDUCTION "
6253 "at %L", &omp_udr
->initializer_ns
->code
->loc
);
6254 for (a
= omp_udr
->initializer_ns
->code
->ext
.actual
; a
; a
= a
->next
)
6256 && a
->expr
->expr_type
== EXPR_VARIABLE
6257 && a
->expr
->symtree
->n
.sym
== omp_udr
->omp_priv
6258 && a
->expr
->ref
== NULL
)
6261 gfc_error ("One of actual subroutine arguments in INITIALIZER "
6262 "clause of !$OMP DECLARE REDUCTION must be OMP_PRIV "
6263 "at %L", &omp_udr
->initializer_ns
->code
->loc
);
6266 else if (omp_udr
->ts
.type
== BT_DERIVED
6267 && !gfc_has_default_initializer (omp_udr
->ts
.u
.derived
))
6269 gfc_error ("Missing INITIALIZER clause for !$OMP DECLARE REDUCTION "
6270 "of derived type without default initializer at %L",
6277 gfc_resolve_omp_udrs (gfc_symtree
*st
)
6279 gfc_omp_udr
*omp_udr
;
6283 gfc_resolve_omp_udrs (st
->left
);
6284 gfc_resolve_omp_udrs (st
->right
);
6285 for (omp_udr
= st
->n
.omp_udr
; omp_udr
; omp_udr
= omp_udr
->next
)
6286 gfc_resolve_omp_udr (omp_udr
);