1 /* OpenMP directive matching and resolving.
2 Copyright (C) 2005-2023 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"
29 #include "constructor.h"
30 #include "diagnostic.h"
31 #include "gomp-constants.h"
32 #include "target-memory.h" /* For gfc_encode_character. */
34 #include "omp-api.h" /* For omp_runtime_api_procname. */
37 static gfc_statement
omp_code_to_statement (gfc_code
*);
39 enum gfc_omp_directive_kind
{
40 GFC_OMP_DIR_DECLARATIVE
,
41 GFC_OMP_DIR_EXECUTABLE
,
42 GFC_OMP_DIR_INFORMATIONAL
,
44 GFC_OMP_DIR_SUBSIDIARY
,
48 struct gfc_omp_directive
{
50 enum gfc_omp_directive_kind kind
;
54 /* Alphabetically sorted OpenMP clauses, except that longer strings are before
55 substrings; excludes combined/composite directives. See note for "ordered"
58 static const struct gfc_omp_directive gfc_omp_directives
[] = {
59 {"allocate", GFC_OMP_DIR_DECLARATIVE
, ST_OMP_ALLOCATE
},
60 {"allocators", GFC_OMP_DIR_EXECUTABLE
, ST_OMP_ALLOCATORS
},
61 {"assumes", GFC_OMP_DIR_INFORMATIONAL
, ST_OMP_ASSUMES
},
62 {"assume", GFC_OMP_DIR_INFORMATIONAL
, ST_OMP_ASSUME
},
63 {"atomic", GFC_OMP_DIR_EXECUTABLE
, ST_OMP_ATOMIC
},
64 {"barrier", GFC_OMP_DIR_EXECUTABLE
, ST_OMP_BARRIER
},
65 {"cancellation point", GFC_OMP_DIR_EXECUTABLE
, ST_OMP_CANCELLATION_POINT
},
66 {"cancel", GFC_OMP_DIR_EXECUTABLE
, ST_OMP_CANCEL
},
67 {"critical", GFC_OMP_DIR_EXECUTABLE
, ST_OMP_CRITICAL
},
68 /* {"declare mapper", GFC_OMP_DIR_DECLARATIVE, ST_OMP_DECLARE_MAPPER}, */
69 {"declare reduction", GFC_OMP_DIR_DECLARATIVE
, ST_OMP_DECLARE_REDUCTION
},
70 {"declare simd", GFC_OMP_DIR_DECLARATIVE
, ST_OMP_DECLARE_SIMD
},
71 {"declare target", GFC_OMP_DIR_DECLARATIVE
, ST_OMP_DECLARE_TARGET
},
72 {"declare variant", GFC_OMP_DIR_DECLARATIVE
, ST_OMP_DECLARE_VARIANT
},
73 {"depobj", GFC_OMP_DIR_EXECUTABLE
, ST_OMP_DEPOBJ
},
74 /* {"dispatch", GFC_OMP_DIR_EXECUTABLE, ST_OMP_DISPATCH}, */
75 {"distribute", GFC_OMP_DIR_EXECUTABLE
, ST_OMP_DISTRIBUTE
},
76 {"do", GFC_OMP_DIR_EXECUTABLE
, ST_OMP_DO
},
77 /* "error" becomes GFC_OMP_DIR_EXECUTABLE with at(execution) */
78 {"error", GFC_OMP_DIR_UTILITY
, ST_OMP_ERROR
},
79 {"flush", GFC_OMP_DIR_EXECUTABLE
, ST_OMP_FLUSH
},
80 /* {"interop", GFC_OMP_DIR_EXECUTABLE, ST_OMP_INTEROP}, */
81 {"loop", GFC_OMP_DIR_EXECUTABLE
, ST_OMP_LOOP
},
82 {"masked", GFC_OMP_DIR_EXECUTABLE
, ST_OMP_MASKED
},
83 /* {"metadirective", GFC_OMP_DIR_META, ST_OMP_METADIRECTIVE}, */
84 /* Note: gfc_match_omp_nothing returns ST_NONE. */
85 {"nothing", GFC_OMP_DIR_UTILITY
, ST_OMP_NOTHING
},
86 /* Special case; for now map to the first one.
87 ordered-blockassoc = ST_OMP_ORDERED
88 ordered-standalone = ST_OMP_ORDERED_DEPEND + depend/doacross. */
89 {"ordered", GFC_OMP_DIR_EXECUTABLE
, ST_OMP_ORDERED
},
90 {"parallel", GFC_OMP_DIR_EXECUTABLE
, ST_OMP_PARALLEL
},
91 {"requires", GFC_OMP_DIR_INFORMATIONAL
, ST_OMP_REQUIRES
},
92 {"scan", GFC_OMP_DIR_SUBSIDIARY
, ST_OMP_SCAN
},
93 {"scope", GFC_OMP_DIR_EXECUTABLE
, ST_OMP_SCOPE
},
94 {"sections", GFC_OMP_DIR_EXECUTABLE
, ST_OMP_SECTIONS
},
95 {"section", GFC_OMP_DIR_SUBSIDIARY
, ST_OMP_SECTION
},
96 {"simd", GFC_OMP_DIR_EXECUTABLE
, ST_OMP_SIMD
},
97 {"single", GFC_OMP_DIR_EXECUTABLE
, ST_OMP_SINGLE
},
98 {"target data", GFC_OMP_DIR_EXECUTABLE
, ST_OMP_TARGET_DATA
},
99 {"target enter data", GFC_OMP_DIR_EXECUTABLE
, ST_OMP_TARGET_ENTER_DATA
},
100 {"target exit data", GFC_OMP_DIR_EXECUTABLE
, ST_OMP_TARGET_EXIT_DATA
},
101 {"target update", GFC_OMP_DIR_EXECUTABLE
, ST_OMP_TARGET_UPDATE
},
102 {"target", GFC_OMP_DIR_EXECUTABLE
, ST_OMP_TARGET
},
103 {"taskloop", GFC_OMP_DIR_EXECUTABLE
, ST_OMP_TASKLOOP
},
104 {"taskwait", GFC_OMP_DIR_EXECUTABLE
, ST_OMP_TASKWAIT
},
105 {"taskyield", GFC_OMP_DIR_EXECUTABLE
, ST_OMP_TASKYIELD
},
106 {"task", GFC_OMP_DIR_EXECUTABLE
, ST_OMP_TASK
},
107 {"teams", GFC_OMP_DIR_EXECUTABLE
, ST_OMP_TEAMS
},
108 {"threadprivate", GFC_OMP_DIR_DECLARATIVE
, ST_OMP_THREADPRIVATE
},
109 /* {"tile", GFC_OMP_DIR_EXECUTABLE, ST_OMP_TILE}, */
110 /* {"unroll", GFC_OMP_DIR_EXECUTABLE, ST_OMP_UNROLL}, */
111 {"workshare", GFC_OMP_DIR_EXECUTABLE
, ST_OMP_WORKSHARE
},
115 /* Match an end of OpenMP directive. End of OpenMP directive is optional
116 whitespace, followed by '\n' or comment '!'. */
119 gfc_match_omp_eos (void)
124 old_loc
= gfc_current_locus
;
125 gfc_gobble_whitespace ();
127 c
= gfc_next_ascii_char ();
132 c
= gfc_next_ascii_char ();
140 gfc_current_locus
= old_loc
;
145 gfc_match_omp_eos_error (void)
147 if (gfc_match_omp_eos() == MATCH_YES
)
150 gfc_error ("Unexpected junk at %C");
155 /* Free an omp_clauses structure. */
158 gfc_free_omp_clauses (gfc_omp_clauses
*c
)
164 gfc_free_expr (c
->if_expr
);
165 for (i
= 0; i
< OMP_IF_LAST
; i
++)
166 gfc_free_expr (c
->if_exprs
[i
]);
167 gfc_free_expr (c
->final_expr
);
168 gfc_free_expr (c
->num_threads
);
169 gfc_free_expr (c
->chunk_size
);
170 gfc_free_expr (c
->safelen_expr
);
171 gfc_free_expr (c
->simdlen_expr
);
172 gfc_free_expr (c
->num_teams_lower
);
173 gfc_free_expr (c
->num_teams_upper
);
174 gfc_free_expr (c
->device
);
175 gfc_free_expr (c
->thread_limit
);
176 gfc_free_expr (c
->dist_chunk_size
);
177 gfc_free_expr (c
->grainsize
);
178 gfc_free_expr (c
->hint
);
179 gfc_free_expr (c
->num_tasks
);
180 gfc_free_expr (c
->priority
);
181 gfc_free_expr (c
->detach
);
182 gfc_free_expr (c
->async_expr
);
183 gfc_free_expr (c
->gang_num_expr
);
184 gfc_free_expr (c
->gang_static_expr
);
185 gfc_free_expr (c
->worker_expr
);
186 gfc_free_expr (c
->vector_expr
);
187 gfc_free_expr (c
->num_gangs_expr
);
188 gfc_free_expr (c
->num_workers_expr
);
189 gfc_free_expr (c
->vector_length_expr
);
190 for (i
= 0; i
< OMP_LIST_NUM
; i
++)
191 gfc_free_omp_namelist (c
->lists
[i
],
192 i
== OMP_LIST_AFFINITY
|| i
== OMP_LIST_DEPEND
,
193 i
== OMP_LIST_ALLOCATE
,
194 i
== OMP_LIST_USES_ALLOCATORS
);
195 gfc_free_expr_list (c
->wait_list
);
196 gfc_free_expr_list (c
->tile_list
);
197 free (CONST_CAST (char *, c
->critical_name
));
200 free (c
->assume
->absent
);
201 free (c
->assume
->contains
);
202 gfc_free_expr_list (c
->assume
->holds
);
208 /* Free oacc_declare structures. */
211 gfc_free_oacc_declare_clauses (struct gfc_oacc_declare
*oc
)
213 struct gfc_oacc_declare
*decl
= oc
;
217 struct gfc_oacc_declare
*next
;
220 gfc_free_omp_clauses (decl
->clauses
);
227 /* Free expression list. */
229 gfc_free_expr_list (gfc_expr_list
*list
)
233 for (; list
; list
= n
)
240 /* Free an !$omp declare simd construct list. */
243 gfc_free_omp_declare_simd (gfc_omp_declare_simd
*ods
)
247 gfc_free_omp_clauses (ods
->clauses
);
253 gfc_free_omp_declare_simd_list (gfc_omp_declare_simd
*list
)
257 gfc_omp_declare_simd
*current
= list
;
259 gfc_free_omp_declare_simd (current
);
264 gfc_free_omp_trait_property_list (gfc_omp_trait_property
*list
)
268 gfc_omp_trait_property
*current
= list
;
270 switch (current
->property_kind
)
272 case CTX_PROPERTY_ID
:
273 free (current
->name
);
275 case CTX_PROPERTY_NAME_LIST
:
276 if (current
->is_name
)
277 free (current
->name
);
279 case CTX_PROPERTY_SIMD
:
280 gfc_free_omp_clauses (current
->clauses
);
290 gfc_free_omp_selector_list (gfc_omp_selector
*list
)
294 gfc_omp_selector
*current
= list
;
296 gfc_free_omp_trait_property_list (current
->properties
);
302 gfc_free_omp_set_selector_list (gfc_omp_set_selector
*list
)
306 gfc_omp_set_selector
*current
= list
;
308 gfc_free_omp_selector_list (current
->trait_selectors
);
313 /* Free an !$omp declare variant construct list. */
316 gfc_free_omp_declare_variant_list (gfc_omp_declare_variant
*list
)
320 gfc_omp_declare_variant
*current
= list
;
322 gfc_free_omp_set_selector_list (current
->set_selectors
);
327 /* Free an !$omp declare reduction. */
330 gfc_free_omp_udr (gfc_omp_udr
*omp_udr
)
334 gfc_free_omp_udr (omp_udr
->next
);
335 gfc_free_namespace (omp_udr
->combiner_ns
);
336 if (omp_udr
->initializer_ns
)
337 gfc_free_namespace (omp_udr
->initializer_ns
);
344 gfc_find_omp_udr (gfc_namespace
*ns
, const char *name
, gfc_typespec
*ts
)
352 gfc_omp_udr
*omp_udr
;
354 st
= gfc_find_symtree (ns
->omp_udr_root
, name
);
357 for (omp_udr
= st
->n
.omp_udr
; omp_udr
; omp_udr
= omp_udr
->next
)
360 else if (gfc_compare_types (&omp_udr
->ts
, ts
))
362 if (ts
->type
== BT_CHARACTER
)
364 if (omp_udr
->ts
.u
.cl
->length
== NULL
)
366 if (ts
->u
.cl
->length
== NULL
)
368 if (gfc_compare_expr (omp_udr
->ts
.u
.cl
->length
,
377 /* Don't escape an interface block. */
378 if (ns
&& !ns
->has_import_set
379 && ns
->proc_name
&& ns
->proc_name
->attr
.if_source
== IFSRC_IFBODY
)
390 /* Match a variable/common block list and construct a namelist from it;
391 if has_all_memory != NULL, *has_all_memory is set and omp_all_memory
392 yields a list->sym NULL entry. */
395 gfc_match_omp_variable_list (const char *str
, gfc_omp_namelist
**list
,
396 bool allow_common
, bool *end_colon
= NULL
,
397 gfc_omp_namelist
***headp
= NULL
,
398 bool allow_sections
= false,
399 bool allow_derived
= false,
400 bool *has_all_memory
= NULL
,
401 bool reject_common_vars
= false)
403 gfc_omp_namelist
*head
, *tail
, *p
;
404 locus old_loc
, cur_loc
;
405 char n
[GFC_MAX_SYMBOL_LEN
+1];
412 old_loc
= gfc_current_locus
;
414 *has_all_memory
= false;
421 cur_loc
= gfc_current_locus
;
423 m
= gfc_match_name (n
);
424 if (m
== MATCH_YES
&& strcmp (n
, "omp_all_memory") == 0)
428 gfc_error ("%<omp_all_memory%> at %C not permitted in this "
432 *has_all_memory
= true;
433 p
= gfc_get_omp_namelist ();
441 tail
->where
= cur_loc
;
447 if ((m
= gfc_get_ha_sym_tree (n
, &st
) ? MATCH_ERROR
: MATCH_YES
)
456 gfc_gobble_whitespace ();
457 if ((allow_sections
&& gfc_peek_ascii_char () == '(')
458 || (allow_derived
&& gfc_peek_ascii_char () == '%'))
460 gfc_current_locus
= cur_loc
;
461 m
= gfc_match_variable (&expr
, 0);
471 if (gfc_is_coindexed (expr
))
473 gfc_error ("List item shall not be coindexed at %C");
477 gfc_set_sym_referenced (sym
);
478 p
= gfc_get_omp_namelist ();
488 tail
->where
= cur_loc
;
489 if (reject_common_vars
&& sym
->attr
.in_common
)
491 gcc_assert (allow_common
);
492 gfc_error ("%qs at %L is part of the common block %</%s/%> and "
493 "may only be specificed implicitly via the named "
494 "common block", sym
->name
, &cur_loc
,
495 sym
->common_head
->name
);
508 m
= gfc_match (" / %n /", n
);
509 if (m
== MATCH_ERROR
)
514 st
= gfc_find_symtree (gfc_current_ns
->common_root
, n
);
517 gfc_error ("COMMON block /%s/ not found at %C", n
);
520 for (sym
= st
->n
.common
->head
; sym
; sym
= sym
->common_next
)
522 gfc_set_sym_referenced (sym
);
523 p
= gfc_get_omp_namelist ();
532 tail
->where
= cur_loc
;
536 if (end_colon
&& gfc_match_char (':') == MATCH_YES
)
541 if (gfc_match_char (')') == MATCH_YES
)
543 if (gfc_match_char (',') != MATCH_YES
)
548 list
= &(*list
)->next
;
556 gfc_error ("Syntax error in OpenMP variable list at %C");
559 gfc_free_omp_namelist (head
, false, false, false);
560 gfc_current_locus
= old_loc
;
564 /* Match a variable/procedure/common block list and construct a namelist
568 gfc_match_omp_to_link (const char *str
, gfc_omp_namelist
**list
)
570 gfc_omp_namelist
*head
, *tail
, *p
;
571 locus old_loc
, cur_loc
;
572 char n
[GFC_MAX_SYMBOL_LEN
+1];
579 old_loc
= gfc_current_locus
;
587 cur_loc
= gfc_current_locus
;
588 m
= gfc_match_symbol (&sym
, 1);
592 p
= gfc_get_omp_namelist ();
601 tail
->where
= cur_loc
;
609 m
= gfc_match (" / %n /", n
);
610 if (m
== MATCH_ERROR
)
615 st
= gfc_find_symtree (gfc_current_ns
->common_root
, n
);
618 gfc_error ("COMMON block /%s/ not found at %C", n
);
621 p
= gfc_get_omp_namelist ();
629 tail
->u
.common
= st
->n
.common
;
630 tail
->where
= cur_loc
;
633 if (gfc_match_char (')') == MATCH_YES
)
635 if (gfc_match_char (',') != MATCH_YES
)
640 list
= &(*list
)->next
;
646 gfc_error ("Syntax error in OpenMP variable list at %C");
649 gfc_free_omp_namelist (head
, false, false, false);
650 gfc_current_locus
= old_loc
;
654 /* Match detach(event-handle). */
657 gfc_match_omp_detach (gfc_expr
**expr
)
659 locus old_loc
= gfc_current_locus
;
661 if (gfc_match ("detach ( ") != MATCH_YES
)
664 if (gfc_match_variable (expr
, 0) != MATCH_YES
)
667 if (gfc_match_char (')') != MATCH_YES
)
673 gfc_error ("Syntax error in OpenMP detach clause at %C");
674 gfc_current_locus
= old_loc
;
679 /* Match doacross(sink : ...) construct a namelist from it;
680 if depend is true, match legacy 'depend(sink : ...)'. */
683 gfc_match_omp_doacross_sink (gfc_omp_namelist
**list
, bool depend
)
685 char n
[GFC_MAX_SYMBOL_LEN
+1];
686 gfc_omp_namelist
*head
, *tail
, *p
;
687 locus old_loc
, cur_loc
;
692 old_loc
= gfc_current_locus
;
696 cur_loc
= gfc_current_locus
;
698 if (gfc_match_name (n
) != MATCH_YES
)
700 if (UNLIKELY (strcmp (n
, "omp_all_memory") == 0))
702 gfc_error ("%<omp_all_memory%> used with dependence-type "
703 "other than OUT or INOUT at %C");
707 if (!(strcmp (n
, "omp_cur_iteration") == 0))
710 if (gfc_get_ha_sym_tree (n
, &st
))
713 gfc_set_sym_referenced (sym
);
715 p
= gfc_get_omp_namelist ();
719 head
->u
.depend_doacross_op
= (depend
? OMP_DEPEND_SINK_FIRST
720 : OMP_DOACROSS_SINK_FIRST
);
726 tail
->u
.depend_doacross_op
= OMP_DOACROSS_SINK
;
730 tail
->where
= cur_loc
;
731 if (gfc_match_char ('+') == MATCH_YES
)
733 if (gfc_match_literal_constant (&tail
->expr
, 0) != MATCH_YES
)
736 else if (gfc_match_char ('-') == MATCH_YES
)
738 if (gfc_match_literal_constant (&tail
->expr
, 0) != MATCH_YES
)
740 tail
->expr
= gfc_uminus (tail
->expr
);
742 if (gfc_match_char (')') == MATCH_YES
)
744 if (gfc_match_char (',') != MATCH_YES
)
749 list
= &(*list
)->next
;
755 gfc_error ("Syntax error in OpenMP SINK dependence-type list at %C");
758 gfc_free_omp_namelist (head
, false, false, false);
759 gfc_current_locus
= old_loc
;
764 match_oacc_expr_list (const char *str
, gfc_expr_list
**list
,
767 gfc_expr_list
*head
, *tail
, *p
;
774 old_loc
= gfc_current_locus
;
782 m
= gfc_match_expr (&expr
);
783 if (m
== MATCH_YES
|| allow_asterisk
)
785 p
= gfc_get_expr_list ();
795 else if (gfc_match (" *") != MATCH_YES
)
799 if (m
== MATCH_ERROR
)
804 if (gfc_match_char (')') == MATCH_YES
)
806 if (gfc_match_char (',') != MATCH_YES
)
811 list
= &(*list
)->next
;
817 gfc_error ("Syntax error in OpenACC expression list at %C");
820 gfc_free_expr_list (head
);
821 gfc_current_locus
= old_loc
;
826 match_oacc_clause_gwv (gfc_omp_clauses
*cp
, unsigned gwv
)
828 match ret
= MATCH_YES
;
830 if (gfc_match (" ( ") != MATCH_YES
)
833 if (gwv
== GOMP_DIM_GANG
)
835 /* The gang clause accepts two optional arguments, num and static.
836 The num argument may either be explicit (num: <val>) or
837 implicit without (<val> without num:). */
839 while (ret
== MATCH_YES
)
841 if (gfc_match (" static :") == MATCH_YES
)
846 cp
->gang_static
= true;
847 if (gfc_match_char ('*') == MATCH_YES
)
848 cp
->gang_static_expr
= NULL
;
849 else if (gfc_match (" %e ", &cp
->gang_static_expr
) != MATCH_YES
)
854 if (cp
->gang_num_expr
)
857 /* The 'num' argument is optional. */
858 gfc_match (" num :");
860 if (gfc_match (" %e ", &cp
->gang_num_expr
) != MATCH_YES
)
864 ret
= gfc_match (" , ");
867 else if (gwv
== GOMP_DIM_WORKER
)
869 /* The 'num' argument is optional. */
870 gfc_match (" num :");
872 if (gfc_match (" %e ", &cp
->worker_expr
) != MATCH_YES
)
875 else if (gwv
== GOMP_DIM_VECTOR
)
877 /* The 'length' argument is optional. */
878 gfc_match (" length :");
880 if (gfc_match (" %e ", &cp
->vector_expr
) != MATCH_YES
)
884 gfc_fatal_error ("Unexpected OpenACC parallelism.");
886 return gfc_match (" )");
890 gfc_match_oacc_clause_link (const char *str
, gfc_omp_namelist
**list
)
892 gfc_omp_namelist
*head
= NULL
;
893 gfc_omp_namelist
*tail
, *p
;
895 char n
[GFC_MAX_SYMBOL_LEN
+1];
900 old_loc
= gfc_current_locus
;
906 m
= gfc_match (" (");
910 m
= gfc_match_symbol (&sym
, 0);
914 if (sym
->attr
.in_common
)
916 gfc_error_now ("Variable at %C is an element of a COMMON block");
919 gfc_set_sym_referenced (sym
);
920 p
= gfc_get_omp_namelist ();
930 tail
->where
= gfc_current_locus
;
939 m
= gfc_match (" / %n /", n
);
940 if (m
== MATCH_ERROR
)
942 if (m
== MATCH_NO
|| n
[0] == '\0')
945 st
= gfc_find_symtree (gfc_current_ns
->common_root
, n
);
948 gfc_error ("COMMON block /%s/ not found at %C", n
);
952 for (sym
= st
->n
.common
->head
; sym
; sym
= sym
->common_next
)
954 gfc_set_sym_referenced (sym
);
955 p
= gfc_get_omp_namelist ();
964 tail
->where
= gfc_current_locus
;
968 if (gfc_match_char (')') == MATCH_YES
)
970 if (gfc_match_char (',') != MATCH_YES
)
974 if (gfc_match_omp_eos () != MATCH_YES
)
976 gfc_error ("Unexpected junk after !$ACC DECLARE at %C");
981 list
= &(*list
)->next
;
986 gfc_error ("Syntax error in !$ACC DECLARE list at %C");
989 gfc_current_locus
= old_loc
;
993 /* OpenMP clauses. */
997 OMP_CLAUSE_FIRSTPRIVATE
,
998 OMP_CLAUSE_LASTPRIVATE
,
999 OMP_CLAUSE_COPYPRIVATE
,
1002 OMP_CLAUSE_REDUCTION
,
1003 OMP_CLAUSE_IN_REDUCTION
,
1004 OMP_CLAUSE_TASK_REDUCTION
,
1006 OMP_CLAUSE_NUM_THREADS
,
1007 OMP_CLAUSE_SCHEDULE
,
1011 OMP_CLAUSE_COLLAPSE
,
1014 OMP_CLAUSE_MERGEABLE
,
1017 OMP_CLAUSE_INBRANCH
,
1019 OMP_CLAUSE_NOTINBRANCH
,
1020 OMP_CLAUSE_PROC_BIND
,
1028 OMP_CLAUSE_NUM_TEAMS
,
1029 OMP_CLAUSE_THREAD_LIMIT
,
1030 OMP_CLAUSE_DIST_SCHEDULE
,
1031 OMP_CLAUSE_DEFAULTMAP
,
1032 OMP_CLAUSE_GRAINSIZE
,
1034 OMP_CLAUSE_IS_DEVICE_PTR
,
1037 OMP_CLAUSE_NOTEMPORAL
,
1038 OMP_CLAUSE_NUM_TASKS
,
1039 OMP_CLAUSE_PRIORITY
,
1042 OMP_CLAUSE_USE_DEVICE_PTR
,
1043 OMP_CLAUSE_USE_DEVICE_ADDR
, /* OpenMP 5.0. */
1044 OMP_CLAUSE_DEVICE_TYPE
, /* OpenMP 5.0. */
1045 OMP_CLAUSE_ATOMIC
, /* OpenMP 5.0. */
1046 OMP_CLAUSE_CAPTURE
, /* OpenMP 5.0. */
1047 OMP_CLAUSE_MEMORDER
, /* OpenMP 5.0. */
1048 OMP_CLAUSE_DETACH
, /* OpenMP 5.0. */
1049 OMP_CLAUSE_AFFINITY
, /* OpenMP 5.0. */
1050 OMP_CLAUSE_ALLOCATE
, /* OpenMP 5.0. */
1051 OMP_CLAUSE_BIND
, /* OpenMP 5.0. */
1052 OMP_CLAUSE_FILTER
, /* OpenMP 5.1. */
1053 OMP_CLAUSE_AT
, /* OpenMP 5.1. */
1054 OMP_CLAUSE_MESSAGE
, /* OpenMP 5.1. */
1055 OMP_CLAUSE_SEVERITY
, /* OpenMP 5.1. */
1056 OMP_CLAUSE_COMPARE
, /* OpenMP 5.1. */
1057 OMP_CLAUSE_FAIL
, /* OpenMP 5.1. */
1058 OMP_CLAUSE_WEAK
, /* OpenMP 5.1. */
1060 /* This must come last. */
1064 /* More OpenMP clauses and OpenACC 2.0+ specific clauses. */
1068 OMP_CLAUSE_NUM_GANGS
,
1069 OMP_CLAUSE_NUM_WORKERS
,
1070 OMP_CLAUSE_VECTOR_LENGTH
,
1074 OMP_CLAUSE_NO_CREATE
,
1076 OMP_CLAUSE_DEVICEPTR
,
1081 OMP_CLAUSE_INDEPENDENT
,
1082 OMP_CLAUSE_USE_DEVICE
,
1083 OMP_CLAUSE_DEVICE_RESIDENT
,
1090 OMP_CLAUSE_IF_PRESENT
,
1091 OMP_CLAUSE_FINALIZE
,
1094 OMP_CLAUSE_HAS_DEVICE_ADDR
, /* OpenMP 5.1 */
1095 OMP_CLAUSE_ENTER
, /* OpenMP 5.2 */
1096 OMP_CLAUSE_DOACROSS
, /* OpenMP 5.2 */
1097 OMP_CLAUSE_ASSUMPTIONS
, /* OpenMP 5.1. */
1098 OMP_CLAUSE_USES_ALLOCATORS
, /* OpenMP 5.0 */
1099 /* This must come last. */
1103 struct omp_inv_mask
;
1105 /* Customized bitset for up to 128-bits.
1106 The two enums above provide bit numbers to use, and which of the
1107 two enums it is determines which of the two mask fields is used.
1108 Supported operations are defining a mask, like:
1109 #define XXX_CLAUSES \
1110 (omp_mask (OMP_CLAUSE_XXX) | OMP_CLAUSE_YYY | OMP_CLAUSE_ZZZ)
1111 oring such bitsets together or removing selected bits:
1112 (XXX_CLAUSES | YYY_CLAUSES) & ~(omp_mask (OMP_CLAUSE_VVV))
1113 and testing individual bits:
1114 if (mask & OMP_CLAUSE_UUU) */
1117 const uint64_t mask1
;
1118 const uint64_t mask2
;
1120 inline omp_mask (omp_mask1
);
1121 inline omp_mask (omp_mask2
);
1122 inline omp_mask (uint64_t, uint64_t);
1123 inline omp_mask
operator| (omp_mask1
) const;
1124 inline omp_mask
operator| (omp_mask2
) const;
1125 inline omp_mask
operator| (omp_mask
) const;
1126 inline omp_mask
operator& (const omp_inv_mask
&) const;
1127 inline bool operator& (omp_mask1
) const;
1128 inline bool operator& (omp_mask2
) const;
1129 inline omp_inv_mask
operator~ () const;
1132 struct omp_inv_mask
: public omp_mask
{
1133 inline omp_inv_mask (const omp_mask
&);
1136 omp_mask::omp_mask () : mask1 (0), mask2 (0)
1140 omp_mask::omp_mask (omp_mask1 m
) : mask1 (((uint64_t) 1) << m
), mask2 (0)
1144 omp_mask::omp_mask (omp_mask2 m
) : mask1 (0), mask2 (((uint64_t) 1) << m
)
1148 omp_mask::omp_mask (uint64_t m1
, uint64_t m2
) : mask1 (m1
), mask2 (m2
)
1153 omp_mask::operator| (omp_mask1 m
) const
1155 return omp_mask (mask1
| (((uint64_t) 1) << m
), mask2
);
1159 omp_mask::operator| (omp_mask2 m
) const
1161 return omp_mask (mask1
, mask2
| (((uint64_t) 1) << m
));
1165 omp_mask::operator| (omp_mask m
) const
1167 return omp_mask (mask1
| m
.mask1
, mask2
| m
.mask2
);
1171 omp_mask::operator& (const omp_inv_mask
&m
) const
1173 return omp_mask (mask1
& ~m
.mask1
, mask2
& ~m
.mask2
);
1177 omp_mask::operator& (omp_mask1 m
) const
1179 return (mask1
& (((uint64_t) 1) << m
)) != 0;
1183 omp_mask::operator& (omp_mask2 m
) const
1185 return (mask2
& (((uint64_t) 1) << m
)) != 0;
1189 omp_mask::operator~ () const
1191 return omp_inv_mask (*this);
1194 omp_inv_mask::omp_inv_mask (const omp_mask
&m
) : omp_mask (m
)
1198 /* Helper function for OpenACC and OpenMP clauses involving memory
1202 gfc_match_omp_map_clause (gfc_omp_namelist
**list
, gfc_omp_map_op map_op
,
1203 bool allow_common
, bool allow_derived
)
1205 gfc_omp_namelist
**head
= NULL
;
1206 if (gfc_match_omp_variable_list ("", list
, allow_common
, NULL
, &head
, true,
1210 gfc_omp_namelist
*n
;
1211 for (n
= *head
; n
; n
= n
->next
)
1212 n
->u
.map_op
= map_op
;
1220 gfc_match_iterator (gfc_namespace
**ns
, bool permit_var
)
1222 locus old_loc
= gfc_current_locus
;
1224 if (gfc_match ("iterator ( ") != MATCH_YES
)
1228 gfc_symbol
*last
= NULL
;
1229 gfc_expr
*begin
, *end
, *step
;
1230 *ns
= gfc_build_block_ns (gfc_current_ns
);
1231 char name
[GFC_MAX_SYMBOL_LEN
+ 1];
1234 locus prev_loc
= gfc_current_locus
;
1235 if (gfc_match_type_spec (&ts
) == MATCH_YES
1236 && gfc_match (" :: ") == MATCH_YES
)
1238 if (ts
.type
!= BT_INTEGER
)
1240 gfc_error ("Expected INTEGER type at %L", &prev_loc
);
1247 ts
.type
= BT_INTEGER
;
1248 ts
.kind
= gfc_default_integer_kind
;
1249 gfc_current_locus
= prev_loc
;
1251 prev_loc
= gfc_current_locus
;
1252 if (gfc_match_name (name
) != MATCH_YES
)
1254 gfc_error ("Expected identifier at %C");
1257 if (gfc_find_symtree ((*ns
)->sym_root
, name
))
1259 gfc_error ("Same identifier %qs specified again at %C", name
);
1263 gfc_symbol
*sym
= gfc_new_symbol (name
, *ns
);
1267 (*ns
)->omp_affinity_iterators
= sym
;
1269 sym
->declared_at
= prev_loc
;
1271 sym
->attr
.flavor
= FL_VARIABLE
;
1272 sym
->attr
.artificial
= 1;
1273 sym
->attr
.referenced
= 1;
1275 gfc_symtree
*st
= gfc_new_symtree (&(*ns
)->sym_root
, name
);
1278 prev_loc
= gfc_current_locus
;
1279 if (gfc_match (" = ") != MATCH_YES
)
1282 begin
= end
= step
= NULL
;
1283 if (gfc_match ("%e : ", &begin
) != MATCH_YES
1284 || gfc_match ("%e ", &end
) != MATCH_YES
)
1286 gfc_error ("Expected range-specification at %C");
1287 gfc_free_expr (begin
);
1288 gfc_free_expr (end
);
1291 if (':' == gfc_peek_ascii_char ())
1293 if (gfc_match (": %e ", &step
) != MATCH_YES
)
1295 gfc_free_expr (begin
);
1296 gfc_free_expr (end
);
1297 gfc_free_expr (step
);
1302 gfc_expr
*e
= gfc_get_expr ();
1303 e
->where
= prev_loc
;
1304 e
->expr_type
= EXPR_ARRAY
;
1307 e
->shape
= gfc_get_shape (1);
1308 mpz_init_set_ui (e
->shape
[0], step
? 3 : 2);
1309 gfc_constructor_append_expr (&e
->value
.constructor
, begin
, &begin
->where
);
1310 gfc_constructor_append_expr (&e
->value
.constructor
, end
, &end
->where
);
1312 gfc_constructor_append_expr (&e
->value
.constructor
, step
, &step
->where
);
1315 if (gfc_match (") ") == MATCH_YES
)
1317 if (gfc_match (", ") != MATCH_YES
)
1323 gfc_namespace
*prev_ns
= NULL
;
1324 for (gfc_namespace
*it
= gfc_current_ns
->contained
; it
; it
= it
->sibling
)
1329 prev_ns
->sibling
= it
->sibling
;
1331 gfc_current_ns
->contained
= it
->sibling
;
1332 gfc_free_namespace (it
);
1340 gfc_current_locus
= old_loc
;
1344 /* Match target update's to/from( [present:] var-list). */
1347 gfc_match_motion_var_list (const char *str
, gfc_omp_namelist
**list
,
1348 gfc_omp_namelist
***headp
)
1350 match m
= gfc_match (str
);
1354 match m_present
= gfc_match (" present : ");
1356 m
= gfc_match_omp_variable_list ("", list
, false, NULL
, headp
, true, true);
1359 if (m_present
== MATCH_YES
)
1361 gfc_omp_namelist
*n
;
1362 for (n
= **headp
; n
; n
= n
->next
)
1363 n
->u
.present_modifier
= true;
1368 /* reduction ( reduction-modifier, reduction-operator : variable-list )
1369 in_reduction ( reduction-operator : variable-list )
1370 task_reduction ( reduction-operator : variable-list ) */
1373 gfc_match_omp_clause_reduction (char pc
, gfc_omp_clauses
*c
, bool openacc
,
1374 bool allow_derived
, bool openmp_target
= false)
1376 if (pc
== 'r' && gfc_match ("reduction ( ") != MATCH_YES
)
1378 else if (pc
== 'i' && gfc_match ("in_reduction ( ") != MATCH_YES
)
1380 else if (pc
== 't' && gfc_match ("task_reduction ( ") != MATCH_YES
)
1383 locus old_loc
= gfc_current_locus
;
1386 if (pc
== 'r' && !openacc
)
1388 if (gfc_match ("inscan") == MATCH_YES
)
1389 list_idx
= OMP_LIST_REDUCTION_INSCAN
;
1390 else if (gfc_match ("task") == MATCH_YES
)
1391 list_idx
= OMP_LIST_REDUCTION_TASK
;
1392 else if (gfc_match ("default") == MATCH_YES
)
1393 list_idx
= OMP_LIST_REDUCTION
;
1394 if (list_idx
!= 0 && gfc_match (", ") != MATCH_YES
)
1396 gfc_error ("Comma expected at %C");
1397 gfc_current_locus
= old_loc
;
1401 list_idx
= OMP_LIST_REDUCTION
;
1404 list_idx
= OMP_LIST_IN_REDUCTION
;
1406 list_idx
= OMP_LIST_TASK_REDUCTION
;
1408 list_idx
= OMP_LIST_REDUCTION
;
1410 gfc_omp_reduction_op rop
= OMP_REDUCTION_NONE
;
1411 char buffer
[GFC_MAX_SYMBOL_LEN
+ 3];
1412 if (gfc_match_char ('+') == MATCH_YES
)
1413 rop
= OMP_REDUCTION_PLUS
;
1414 else if (gfc_match_char ('*') == MATCH_YES
)
1415 rop
= OMP_REDUCTION_TIMES
;
1416 else if (gfc_match_char ('-') == MATCH_YES
)
1417 rop
= OMP_REDUCTION_MINUS
;
1418 else if (gfc_match (".and.") == MATCH_YES
)
1419 rop
= OMP_REDUCTION_AND
;
1420 else if (gfc_match (".or.") == MATCH_YES
)
1421 rop
= OMP_REDUCTION_OR
;
1422 else if (gfc_match (".eqv.") == MATCH_YES
)
1423 rop
= OMP_REDUCTION_EQV
;
1424 else if (gfc_match (".neqv.") == MATCH_YES
)
1425 rop
= OMP_REDUCTION_NEQV
;
1426 if (rop
!= OMP_REDUCTION_NONE
)
1427 snprintf (buffer
, sizeof buffer
, "operator %s",
1428 gfc_op2string ((gfc_intrinsic_op
) rop
));
1429 else if (gfc_match_defined_op_name (buffer
+ 1, 1) == MATCH_YES
)
1432 strcat (buffer
, ".");
1434 else if (gfc_match_name (buffer
) == MATCH_YES
)
1437 const char *n
= buffer
;
1439 gfc_find_symbol (buffer
, NULL
, 1, &sym
);
1442 if (sym
->attr
.intrinsic
)
1444 else if ((sym
->attr
.flavor
!= FL_UNKNOWN
1445 && sym
->attr
.flavor
!= FL_PROCEDURE
)
1446 || sym
->attr
.external
1447 || sym
->attr
.generic
1451 || sym
->attr
.subroutine
1452 || sym
->attr
.pointer
1454 || sym
->attr
.cray_pointer
1455 || sym
->attr
.cray_pointee
1456 || (sym
->attr
.proc
!= PROC_UNKNOWN
1457 && sym
->attr
.proc
!= PROC_INTRINSIC
)
1458 || sym
->attr
.if_source
!= IFSRC_UNKNOWN
1459 || sym
== sym
->ns
->proc_name
)
1468 rop
= OMP_REDUCTION_NONE
;
1469 else if (strcmp (n
, "max") == 0)
1470 rop
= OMP_REDUCTION_MAX
;
1471 else if (strcmp (n
, "min") == 0)
1472 rop
= OMP_REDUCTION_MIN
;
1473 else if (strcmp (n
, "iand") == 0)
1474 rop
= OMP_REDUCTION_IAND
;
1475 else if (strcmp (n
, "ior") == 0)
1476 rop
= OMP_REDUCTION_IOR
;
1477 else if (strcmp (n
, "ieor") == 0)
1478 rop
= OMP_REDUCTION_IEOR
;
1479 if (rop
!= OMP_REDUCTION_NONE
1481 && ! sym
->attr
.intrinsic
1482 && ! sym
->attr
.use_assoc
1483 && ((sym
->attr
.flavor
== FL_UNKNOWN
1484 && !gfc_add_flavor (&sym
->attr
, FL_PROCEDURE
,
1486 || !gfc_add_intrinsic (&sym
->attr
, NULL
)))
1487 rop
= OMP_REDUCTION_NONE
;
1491 gfc_omp_udr
*udr
= (buffer
[0] ? gfc_find_omp_udr (gfc_current_ns
, buffer
, NULL
)
1493 gfc_omp_namelist
**head
= NULL
;
1494 if (rop
== OMP_REDUCTION_NONE
&& udr
)
1495 rop
= OMP_REDUCTION_USER
;
1497 if (gfc_match_omp_variable_list (" :", &c
->lists
[list_idx
], false, NULL
,
1498 &head
, openacc
, allow_derived
) != MATCH_YES
)
1500 gfc_current_locus
= old_loc
;
1503 gfc_omp_namelist
*n
;
1504 if (rop
== OMP_REDUCTION_NONE
)
1508 gfc_error_now ("!$OMP DECLARE REDUCTION %s not found at %L",
1510 gfc_free_omp_namelist (n
, false, false, false);
1513 for (n
= *head
; n
; n
= n
->next
)
1515 n
->u
.reduction_op
= rop
;
1518 n
->u2
.udr
= gfc_get_omp_namelist_udr ();
1519 n
->u2
.udr
->udr
= udr
;
1521 if (openmp_target
&& list_idx
== OMP_LIST_IN_REDUCTION
)
1523 gfc_omp_namelist
*p
= gfc_get_omp_namelist (), **tl
;
1525 p
->where
= p
->where
;
1526 p
->u
.map_op
= OMP_MAP_ALWAYS_TOFROM
;
1528 tl
= &c
->lists
[OMP_LIST_MAP
];
1530 tl
= &((*tl
)->next
);
1539 gfc_omp_absent_contains_clause (gfc_omp_assumptions
**assume
, bool is_absent
)
1541 if (*assume
== NULL
)
1542 *assume
= gfc_get_omp_assumptions ();
1545 gfc_statement st
= ST_NONE
;
1546 gfc_gobble_whitespace ();
1547 locus old_loc
= gfc_current_locus
;
1548 char c
= gfc_peek_ascii_char ();
1549 enum gfc_omp_directive_kind kind
1550 = GFC_OMP_DIR_DECLARATIVE
; /* Silence warning. */
1551 for (size_t i
= 0; i
< ARRAY_SIZE (gfc_omp_directives
); i
++)
1553 if (gfc_omp_directives
[i
].name
[0] > c
)
1555 if (gfc_omp_directives
[i
].name
[0] != c
)
1557 if (gfc_match (gfc_omp_directives
[i
].name
) == MATCH_YES
)
1559 st
= gfc_omp_directives
[i
].st
;
1560 kind
= gfc_omp_directives
[i
].kind
;
1563 gfc_gobble_whitespace ();
1564 c
= gfc_peek_ascii_char ();
1565 if (st
== ST_NONE
|| (c
!= ',' && c
!= ')'))
1568 gfc_error ("Unknown directive at %L", &old_loc
);
1570 gfc_error ("Invalid combined or composite directive at %L",
1574 if (kind
== GFC_OMP_DIR_DECLARATIVE
1575 || kind
== GFC_OMP_DIR_INFORMATIONAL
1576 || kind
== GFC_OMP_DIR_META
)
1578 gfc_error ("Invalid %qs directive at %L in %s clause: declarative, "
1579 "informational and meta directives not permitted",
1580 gfc_ascii_statement (st
, true), &old_loc
,
1581 is_absent
? "ABSENT" : "CONTAINS");
1586 /* Use exponential allocation; equivalent to pow2p(x). */
1587 int i
= (*assume
)->n_absent
;
1588 int size
= ((i
== 0) ? 4
1589 : pow2p_hwi (i
) == 1 ? i
*2 : 0);
1591 (*assume
)->absent
= XRESIZEVEC (gfc_statement
,
1592 (*assume
)->absent
, size
);
1593 (*assume
)->absent
[(*assume
)->n_absent
++] = st
;
1597 int i
= (*assume
)->n_contains
;
1598 int size
= ((i
== 0) ? 4
1599 : pow2p_hwi (i
) == 1 ? i
*2 : 0);
1601 (*assume
)->contains
= XRESIZEVEC (gfc_statement
,
1602 (*assume
)->contains
, size
);
1603 (*assume
)->contains
[(*assume
)->n_contains
++] = st
;
1605 gfc_gobble_whitespace ();
1606 if (gfc_match(",") == MATCH_YES
)
1608 if (gfc_match(")") == MATCH_YES
)
1610 gfc_error ("Expected %<,%> or %<)%> at %C");
1618 /* Check 'check' argument for duplicated statements in absent and/or contains
1619 clauses. If 'merge', merge them from check to 'merge'. */
1622 omp_verify_merge_absent_contains (gfc_statement st
, gfc_omp_assumptions
*check
,
1623 gfc_omp_assumptions
*merge
, locus
*loc
)
1627 bitmap_head absent_head
, contains_head
;
1628 bitmap_obstack_initialize (NULL
);
1629 bitmap_initialize (&absent_head
, &bitmap_default_obstack
);
1630 bitmap_initialize (&contains_head
, &bitmap_default_obstack
);
1632 match m
= MATCH_YES
;
1633 for (int i
= 0; i
< check
->n_absent
; i
++)
1634 if (!bitmap_set_bit (&absent_head
, check
->absent
[i
]))
1636 gfc_error ("%qs directive mentioned multiple times in %s clause in %s "
1638 gfc_ascii_statement (check
->absent
[i
], true),
1639 "ABSENT", gfc_ascii_statement (st
), loc
);
1642 for (int i
= 0; i
< check
->n_contains
; i
++)
1644 if (!bitmap_set_bit (&contains_head
, check
->contains
[i
]))
1646 gfc_error ("%qs directive mentioned multiple times in %s clause in %s "
1648 gfc_ascii_statement (check
->contains
[i
], true),
1649 "CONTAINS", gfc_ascii_statement (st
), loc
);
1652 if (bitmap_bit_p (&absent_head
, check
->contains
[i
]))
1654 gfc_error ("%qs directive mentioned both times in ABSENT and CONTAINS "
1655 "clauses in %s directive at %L",
1656 gfc_ascii_statement (check
->absent
[i
], true),
1657 gfc_ascii_statement (st
), loc
);
1662 if (m
== MATCH_ERROR
)
1666 if (merge
->absent
== NULL
&& check
->absent
)
1668 merge
->n_absent
= check
->n_absent
;
1669 merge
->absent
= check
->absent
;
1670 check
->absent
= NULL
;
1672 else if (merge
->absent
&& check
->absent
)
1674 check
->absent
= XRESIZEVEC (gfc_statement
, check
->absent
,
1675 merge
->n_absent
+ check
->n_absent
);
1676 for (int i
= 0; i
< merge
->n_absent
; i
++)
1677 if (!bitmap_bit_p (&absent_head
, merge
->absent
[i
]))
1678 check
->absent
[check
->n_absent
++] = merge
->absent
[i
];
1679 free (merge
->absent
);
1680 merge
->absent
= check
->absent
;
1681 merge
->n_absent
= check
->n_absent
;
1682 check
->absent
= NULL
;
1684 if (merge
->contains
== NULL
&& check
->contains
)
1686 merge
->n_contains
= check
->n_contains
;
1687 merge
->contains
= check
->contains
;
1688 check
->contains
= NULL
;
1690 else if (merge
->contains
&& check
->contains
)
1692 check
->contains
= XRESIZEVEC (gfc_statement
, check
->contains
,
1693 merge
->n_contains
+ check
->n_contains
);
1694 for (int i
= 0; i
< merge
->n_contains
; i
++)
1695 if (!bitmap_bit_p (&contains_head
, merge
->contains
[i
]))
1696 check
->contains
[check
->n_contains
++] = merge
->contains
[i
];
1697 free (merge
->contains
);
1698 merge
->contains
= check
->contains
;
1699 merge
->n_contains
= check
->n_contains
;
1700 check
->contains
= NULL
;
1706 uses_allocators ( allocator-list )
1709 predefined-allocator
1710 variable ( traits-array )
1713 uses_allocators ( [modifier-list :] allocator-list )
1716 variable or predefined-allocator
1718 traits ( traits-array )
1719 memspace ( mem-space-handle ) */
1722 gfc_match_omp_clause_uses_allocators (gfc_omp_clauses
*c
)
1724 gfc_symbol
*memspace_sym
= NULL
;
1725 gfc_symbol
*traits_sym
= NULL
;
1726 gfc_omp_namelist
*head
= NULL
;
1727 gfc_omp_namelist
*p
, *tail
, **list
;
1728 int ntraits
, nmemspace
;
1730 locus old_loc
, cur_loc
;
1732 gfc_gobble_whitespace ();
1733 old_loc
= gfc_current_locus
;
1734 ntraits
= nmemspace
= 0;
1737 cur_loc
= gfc_current_locus
;
1738 if (gfc_match ("traits ( %S ) ", &traits_sym
) == MATCH_YES
)
1740 else if (gfc_match ("memspace ( %S ) ", &memspace_sym
) == MATCH_YES
)
1742 if (ntraits
> 1 || nmemspace
> 1)
1744 gfc_error ("Duplicate %s modifier at %L in USES_ALLOCATORS clause",
1745 ntraits
> 1 ? "TRAITS" : "MEMSPACE", &cur_loc
);
1748 if (gfc_match (", ") == MATCH_YES
)
1750 if (gfc_match (": ") != MATCH_YES
)
1752 /* Assume no modifier. */
1753 memspace_sym
= traits_sym
= NULL
;
1754 gfc_current_locus
= old_loc
;
1760 has_modifiers
= traits_sym
!= NULL
|| memspace_sym
!= NULL
;
1763 p
= gfc_get_omp_namelist ();
1764 p
->where
= gfc_current_locus
;
1772 if (gfc_match ("%S ", &p
->sym
) != MATCH_YES
)
1775 gfc_match ("( %S ) ", &p
->u2
.traits_sym
);
1776 else if (gfc_peek_ascii_char () == '(')
1778 gfc_error ("Unexpected %<(%> at %C");
1783 p
->u
.memspace_sym
= memspace_sym
;
1784 p
->u2
.traits_sym
= traits_sym
;
1786 if (gfc_match (", ") == MATCH_YES
)
1788 if (gfc_match (") ") == MATCH_YES
)
1793 list
= &c
->lists
[OMP_LIST_USES_ALLOCATORS
];
1795 list
= &(*list
)->next
;
1801 gfc_free_omp_namelist (head
, false, false, true);
1806 /* Match with duplicate check. Matches 'name'. If expr != NULL, it
1807 then matches '(expr)', otherwise, if open_parens is true,
1808 it matches a ' ( ' after 'name'.
1809 dupl_message requires '%qs %L' - and is used by
1810 gfc_match_dupl_memorder and gfc_match_dupl_atomic. */
1813 gfc_match_dupl_check (bool not_dupl
, const char *name
, bool open_parens
= false,
1814 gfc_expr
**expr
= NULL
, const char *dupl_msg
= NULL
)
1817 locus old_loc
= gfc_current_locus
;
1818 if ((m
= gfc_match (name
)) != MATCH_YES
)
1823 gfc_error (dupl_msg
, name
, &old_loc
);
1825 gfc_error ("Duplicated %qs clause at %L", name
, &old_loc
);
1828 if (open_parens
|| expr
)
1830 if (gfc_match (" ( ") != MATCH_YES
)
1832 gfc_error ("Expected %<(%> after %qs at %C", name
);
1837 if (gfc_match ("%e )", expr
) != MATCH_YES
)
1839 gfc_error ("Invalid expression after %<%s(%> at %C", name
);
1848 gfc_match_dupl_memorder (bool not_dupl
, const char *name
)
1850 return gfc_match_dupl_check (not_dupl
, name
, false, NULL
,
1851 "Duplicated memory-order clause: unexpected %s "
1856 gfc_match_dupl_atomic (bool not_dupl
, const char *name
)
1858 return gfc_match_dupl_check (not_dupl
, name
, false, NULL
,
1859 "Duplicated atomic clause: unexpected %s "
1863 /* Match OpenMP and OpenACC directive clauses. MASK is a bitmask of
1864 clauses that are allowed for a particular directive. */
1867 gfc_match_omp_clauses (gfc_omp_clauses
**cp
, const omp_mask mask
,
1868 bool first
= true, bool needs_space
= true,
1869 bool openacc
= false, bool context_selector
= false,
1870 bool openmp_target
= false)
1873 gfc_omp_clauses
*c
= gfc_get_omp_clauses ();
1875 /* Determine whether we're dealing with an OpenACC directive that permits
1876 derived type member accesses. This in particular disallows
1877 "!$acc declare" from using such accesses, because it's not clear if/how
1878 that should work. */
1879 bool allow_derived
= (openacc
1880 && ((mask
& OMP_CLAUSE_ATTACH
)
1881 || (mask
& OMP_CLAUSE_DETACH
)));
1883 gcc_checking_assert (OMP_MASK1_LAST
<= 64 && OMP_MASK2_LAST
<= 64);
1888 if ((first
|| (m
= gfc_match_char (',')) != MATCH_YES
)
1889 && (needs_space
&& gfc_match_space () != MATCH_YES
))
1891 needs_space
= false;
1893 gfc_gobble_whitespace ();
1895 gfc_omp_namelist
**head
;
1896 old_loc
= gfc_current_locus
;
1897 char pc
= gfc_peek_ascii_char ();
1898 if (pc
== '\n' && m
== MATCH_YES
)
1900 gfc_error ("Clause expected at %C after trailing comma");
1908 if ((mask
& OMP_CLAUSE_ASSUMPTIONS
)
1909 && gfc_match ("absent ( ") == MATCH_YES
)
1911 if (gfc_omp_absent_contains_clause (&c
->assume
, true)
1916 if ((mask
& OMP_CLAUSE_ALIGNED
)
1917 && gfc_match_omp_variable_list ("aligned (",
1918 &c
->lists
[OMP_LIST_ALIGNED
],
1920 &head
) == MATCH_YES
)
1922 gfc_expr
*alignment
= NULL
;
1923 gfc_omp_namelist
*n
;
1925 if (end_colon
&& gfc_match (" %e )", &alignment
) != MATCH_YES
)
1927 gfc_free_omp_namelist (*head
, false, false, false);
1928 gfc_current_locus
= old_loc
;
1932 for (n
= *head
; n
; n
= n
->next
)
1933 if (n
->next
&& alignment
)
1934 n
->expr
= gfc_copy_expr (alignment
);
1936 n
->expr
= alignment
;
1939 if ((mask
& OMP_CLAUSE_MEMORDER
)
1940 && (m
= gfc_match_dupl_memorder ((c
->memorder
1941 == OMP_MEMORDER_UNSET
),
1942 "acq_rel")) != MATCH_NO
)
1944 if (m
== MATCH_ERROR
)
1946 c
->memorder
= OMP_MEMORDER_ACQ_REL
;
1950 if ((mask
& OMP_CLAUSE_MEMORDER
)
1951 && (m
= gfc_match_dupl_memorder ((c
->memorder
1952 == OMP_MEMORDER_UNSET
),
1953 "acquire")) != MATCH_NO
)
1955 if (m
== MATCH_ERROR
)
1957 c
->memorder
= OMP_MEMORDER_ACQUIRE
;
1961 if ((mask
& OMP_CLAUSE_AFFINITY
)
1962 && gfc_match ("affinity ( ") == MATCH_YES
)
1964 gfc_namespace
*ns_iter
= NULL
, *ns_curr
= gfc_current_ns
;
1965 m
= gfc_match_iterator (&ns_iter
, true);
1966 if (m
== MATCH_ERROR
)
1968 if (m
== MATCH_YES
&& gfc_match (" : ") != MATCH_YES
)
1970 gfc_error ("Expected %<:%> at %C");
1974 gfc_current_ns
= ns_iter
;
1976 m
= gfc_match_omp_variable_list ("", &c
->lists
[OMP_LIST_AFFINITY
],
1977 false, NULL
, &head
, true);
1978 gfc_current_ns
= ns_curr
;
1979 if (m
== MATCH_ERROR
)
1983 for (gfc_omp_namelist
*n
= *head
; n
; n
= n
->next
)
1991 if ((mask
& OMP_CLAUSE_ALLOCATE
)
1992 && gfc_match ("allocate ( ") == MATCH_YES
)
1994 gfc_expr
*allocator
= NULL
;
1995 gfc_expr
*align
= NULL
;
1996 old_loc
= gfc_current_locus
;
1997 if ((m
= gfc_match ("allocator ( %e )", &allocator
)) == MATCH_YES
)
1998 gfc_match (" , align ( %e )", &align
);
1999 else if ((m
= gfc_match ("align ( %e )", &align
)) == MATCH_YES
)
2000 gfc_match (" , allocator ( %e )", &allocator
);
2004 if (gfc_match (" : ") != MATCH_YES
)
2006 gfc_error ("Expected %<:%> at %C");
2012 m
= gfc_match_expr (&allocator
);
2013 if (m
== MATCH_YES
&& gfc_match (" : ") != MATCH_YES
)
2015 /* If no ":" then there is no allocator, we backtrack
2016 and read the variable list. */
2017 gfc_free_expr (allocator
);
2019 gfc_current_locus
= old_loc
;
2022 gfc_omp_namelist
**head
= NULL
;
2023 m
= gfc_match_omp_variable_list ("", &c
->lists
[OMP_LIST_ALLOCATE
],
2028 gfc_free_expr (allocator
);
2029 gfc_free_expr (align
);
2030 gfc_error ("Expected variable list at %C");
2034 for (gfc_omp_namelist
*n
= *head
; n
; n
= n
->next
)
2036 n
->u2
.allocator
= allocator
;
2037 n
->u
.align
= (align
) ? gfc_copy_expr (align
) : NULL
;
2039 gfc_free_expr (align
);
2042 if ((mask
& OMP_CLAUSE_AT
)
2043 && (m
= gfc_match_dupl_check (c
->at
== OMP_AT_UNSET
, "at", true))
2046 if (m
== MATCH_ERROR
)
2048 if (gfc_match ("compilation )") == MATCH_YES
)
2049 c
->at
= OMP_AT_COMPILATION
;
2050 else if (gfc_match ("execution )") == MATCH_YES
)
2051 c
->at
= OMP_AT_EXECUTION
;
2054 gfc_error ("Expected COMPILATION or EXECUTION in AT clause "
2060 if ((mask
& OMP_CLAUSE_ASYNC
)
2061 && (m
= gfc_match_dupl_check (!c
->async
, "async")) != MATCH_NO
)
2063 if (m
== MATCH_ERROR
)
2066 m
= gfc_match (" ( %e )", &c
->async_expr
);
2067 if (m
== MATCH_ERROR
)
2069 gfc_current_locus
= old_loc
;
2072 else if (m
== MATCH_NO
)
2075 = gfc_get_constant_expr (BT_INTEGER
,
2076 gfc_default_integer_kind
,
2077 &gfc_current_locus
);
2078 mpz_set_si (c
->async_expr
->value
.integer
, GOMP_ASYNC_NOVAL
);
2083 if ((mask
& OMP_CLAUSE_AUTO
)
2084 && (m
= gfc_match_dupl_check (!c
->par_auto
, "auto"))
2087 if (m
== MATCH_ERROR
)
2093 if ((mask
& OMP_CLAUSE_ATTACH
)
2094 && gfc_match ("attach ( ") == MATCH_YES
2095 && gfc_match_omp_map_clause (&c
->lists
[OMP_LIST_MAP
],
2096 OMP_MAP_ATTACH
, false,
2101 if ((mask
& OMP_CLAUSE_BIND
)
2102 && (m
= gfc_match_dupl_check (c
->bind
== OMP_BIND_UNSET
, "bind",
2105 if (m
== MATCH_ERROR
)
2107 if (gfc_match ("teams )") == MATCH_YES
)
2108 c
->bind
= OMP_BIND_TEAMS
;
2109 else if (gfc_match ("parallel )") == MATCH_YES
)
2110 c
->bind
= OMP_BIND_PARALLEL
;
2111 else if (gfc_match ("thread )") == MATCH_YES
)
2112 c
->bind
= OMP_BIND_THREAD
;
2115 gfc_error ("Expected TEAMS, PARALLEL or THREAD as binding in "
2123 if ((mask
& OMP_CLAUSE_CAPTURE
)
2124 && (m
= gfc_match_dupl_check (!c
->capture
, "capture"))
2127 if (m
== MATCH_ERROR
)
2133 if (mask
& OMP_CLAUSE_COLLAPSE
)
2135 gfc_expr
*cexpr
= NULL
;
2136 if ((m
= gfc_match_dupl_check (!c
->collapse
, "collapse", true,
2137 &cexpr
)) != MATCH_NO
)
2140 if (m
== MATCH_ERROR
)
2142 if (gfc_extract_int (cexpr
, &collapse
, -1))
2144 else if (collapse
<= 0)
2146 gfc_error_now ("COLLAPSE clause argument not constant "
2147 "positive integer at %C");
2150 gfc_free_expr (cexpr
);
2151 c
->collapse
= collapse
;
2155 if ((mask
& OMP_CLAUSE_COMPARE
)
2156 && (m
= gfc_match_dupl_check (!c
->compare
, "compare"))
2159 if (m
== MATCH_ERROR
)
2165 if ((mask
& OMP_CLAUSE_ASSUMPTIONS
)
2166 && gfc_match ("contains ( ") == MATCH_YES
)
2168 if (gfc_omp_absent_contains_clause (&c
->assume
, false)
2173 if ((mask
& OMP_CLAUSE_COPY
)
2174 && gfc_match ("copy ( ") == MATCH_YES
2175 && gfc_match_omp_map_clause (&c
->lists
[OMP_LIST_MAP
],
2176 OMP_MAP_TOFROM
, true,
2179 if (mask
& OMP_CLAUSE_COPYIN
)
2183 if (gfc_match ("copyin ( ") == MATCH_YES
2184 && gfc_match_omp_map_clause (&c
->lists
[OMP_LIST_MAP
],
2189 else if (gfc_match_omp_variable_list ("copyin (",
2190 &c
->lists
[OMP_LIST_COPYIN
],
2194 if ((mask
& OMP_CLAUSE_COPYOUT
)
2195 && gfc_match ("copyout ( ") == MATCH_YES
2196 && gfc_match_omp_map_clause (&c
->lists
[OMP_LIST_MAP
],
2197 OMP_MAP_FROM
, true, allow_derived
))
2199 if ((mask
& OMP_CLAUSE_COPYPRIVATE
)
2200 && gfc_match_omp_variable_list ("copyprivate (",
2201 &c
->lists
[OMP_LIST_COPYPRIVATE
],
2204 if ((mask
& OMP_CLAUSE_CREATE
)
2205 && gfc_match ("create ( ") == MATCH_YES
2206 && gfc_match_omp_map_clause (&c
->lists
[OMP_LIST_MAP
],
2207 OMP_MAP_ALLOC
, true, allow_derived
))
2211 if ((mask
& OMP_CLAUSE_DEFAULTMAP
)
2212 && gfc_match ("defaultmap ( ") == MATCH_YES
)
2214 enum gfc_omp_defaultmap behavior
;
2215 gfc_omp_defaultmap_category category
2216 = OMP_DEFAULTMAP_CAT_UNCATEGORIZED
;
2217 if (gfc_match ("alloc ") == MATCH_YES
)
2218 behavior
= OMP_DEFAULTMAP_ALLOC
;
2219 else if (gfc_match ("tofrom ") == MATCH_YES
)
2220 behavior
= OMP_DEFAULTMAP_TOFROM
;
2221 else if (gfc_match ("to ") == MATCH_YES
)
2222 behavior
= OMP_DEFAULTMAP_TO
;
2223 else if (gfc_match ("from ") == MATCH_YES
)
2224 behavior
= OMP_DEFAULTMAP_FROM
;
2225 else if (gfc_match ("firstprivate ") == MATCH_YES
)
2226 behavior
= OMP_DEFAULTMAP_FIRSTPRIVATE
;
2227 else if (gfc_match ("present ") == MATCH_YES
)
2228 behavior
= OMP_DEFAULTMAP_PRESENT
;
2229 else if (gfc_match ("none ") == MATCH_YES
)
2230 behavior
= OMP_DEFAULTMAP_NONE
;
2231 else if (gfc_match ("default ") == MATCH_YES
)
2232 behavior
= OMP_DEFAULTMAP_DEFAULT
;
2235 gfc_error ("Expected ALLOC, TO, FROM, TOFROM, FIRSTPRIVATE, "
2236 "PRESENT, NONE or DEFAULT at %C");
2239 if (')' == gfc_peek_ascii_char ())
2241 else if (gfc_match (": ") != MATCH_YES
)
2245 if (gfc_match ("scalar ") == MATCH_YES
)
2246 category
= OMP_DEFAULTMAP_CAT_SCALAR
;
2247 else if (gfc_match ("aggregate ") == MATCH_YES
)
2248 category
= OMP_DEFAULTMAP_CAT_AGGREGATE
;
2249 else if (gfc_match ("allocatable ") == MATCH_YES
)
2250 category
= OMP_DEFAULTMAP_CAT_ALLOCATABLE
;
2251 else if (gfc_match ("pointer ") == MATCH_YES
)
2252 category
= OMP_DEFAULTMAP_CAT_POINTER
;
2253 else if (gfc_match ("all ") == MATCH_YES
)
2254 category
= OMP_DEFAULTMAP_CAT_ALL
;
2257 gfc_error ("Expected SCALAR, AGGREGATE, ALLOCATABLE, "
2258 "POINTER or ALL at %C");
2262 for (int i
= 0; i
< OMP_DEFAULTMAP_CAT_NUM
; ++i
)
2265 && category
!= OMP_DEFAULTMAP_CAT_UNCATEGORIZED
2266 && category
!= OMP_DEFAULTMAP_CAT_ALL
2267 && i
!= OMP_DEFAULTMAP_CAT_UNCATEGORIZED
2268 && i
!= OMP_DEFAULTMAP_CAT_ALL
)
2270 if (c
->defaultmap
[i
] != OMP_DEFAULTMAP_UNSET
)
2272 const char *pcategory
= NULL
;
2275 case OMP_DEFAULTMAP_CAT_UNCATEGORIZED
: break;
2276 case OMP_DEFAULTMAP_CAT_ALL
: pcategory
= "ALL"; break;
2277 case OMP_DEFAULTMAP_CAT_SCALAR
: pcategory
= "SCALAR"; break;
2278 case OMP_DEFAULTMAP_CAT_AGGREGATE
:
2279 pcategory
= "AGGREGATE";
2281 case OMP_DEFAULTMAP_CAT_ALLOCATABLE
:
2282 pcategory
= "ALLOCATABLE";
2284 case OMP_DEFAULTMAP_CAT_POINTER
:
2285 pcategory
= "POINTER";
2287 default: gcc_unreachable ();
2289 if (i
== OMP_DEFAULTMAP_CAT_UNCATEGORIZED
)
2290 gfc_error ("DEFAULTMAP at %C but prior DEFAULTMAP with "
2291 "unspecified category");
2293 gfc_error ("DEFAULTMAP at %C but prior DEFAULTMAP for "
2294 "category %s", pcategory
);
2298 c
->defaultmap
[category
] = behavior
;
2299 if (gfc_match (")") != MATCH_YES
)
2303 if ((mask
& OMP_CLAUSE_DEFAULT
)
2304 && (m
= gfc_match_dupl_check (c
->default_sharing
2305 == OMP_DEFAULT_UNKNOWN
, "default",
2308 if (m
== MATCH_ERROR
)
2310 if (gfc_match ("none") == MATCH_YES
)
2311 c
->default_sharing
= OMP_DEFAULT_NONE
;
2314 if (gfc_match ("present") == MATCH_YES
)
2315 c
->default_sharing
= OMP_DEFAULT_PRESENT
;
2319 if (gfc_match ("firstprivate") == MATCH_YES
)
2320 c
->default_sharing
= OMP_DEFAULT_FIRSTPRIVATE
;
2321 else if (gfc_match ("private") == MATCH_YES
)
2322 c
->default_sharing
= OMP_DEFAULT_PRIVATE
;
2323 else if (gfc_match ("shared") == MATCH_YES
)
2324 c
->default_sharing
= OMP_DEFAULT_SHARED
;
2326 if (c
->default_sharing
== OMP_DEFAULT_UNKNOWN
)
2329 gfc_error ("Expected NONE or PRESENT in DEFAULT clause "
2332 gfc_error ("Expected NONE, FIRSTPRIVATE, PRIVATE or SHARED "
2333 "in DEFAULT clause at %C");
2336 if (gfc_match (" )") != MATCH_YES
)
2340 if ((mask
& OMP_CLAUSE_DELETE
)
2341 && gfc_match ("delete ( ") == MATCH_YES
2342 && gfc_match_omp_map_clause (&c
->lists
[OMP_LIST_MAP
],
2343 OMP_MAP_RELEASE
, true,
2346 /* DOACROSS: match 'doacross' and 'depend' with sink/source.
2347 DEPEND: match 'depend' but not sink/source. */
2349 if (((mask
& OMP_CLAUSE_DOACROSS
)
2350 && gfc_match ("doacross ( ") == MATCH_YES
)
2351 || (((mask
& OMP_CLAUSE_DEPEND
) || (mask
& OMP_CLAUSE_DOACROSS
))
2352 && (m
= gfc_match ("depend ( ")) == MATCH_YES
))
2354 bool has_omp_all_memory
;
2355 bool is_depend
= m
== MATCH_YES
;
2356 gfc_namespace
*ns_iter
= NULL
, *ns_curr
= gfc_current_ns
;
2357 match m_it
= MATCH_NO
;
2359 m_it
= gfc_match_iterator (&ns_iter
, false);
2360 if (m_it
== MATCH_ERROR
)
2362 if (m_it
== MATCH_YES
&& gfc_match (" , ") != MATCH_YES
)
2365 gfc_omp_depend_doacross_op depend_op
= OMP_DEPEND_OUT
;
2366 if (gfc_match ("inoutset") == MATCH_YES
)
2367 depend_op
= OMP_DEPEND_INOUTSET
;
2368 else if (gfc_match ("inout") == MATCH_YES
)
2369 depend_op
= OMP_DEPEND_INOUT
;
2370 else if (gfc_match ("in") == MATCH_YES
)
2371 depend_op
= OMP_DEPEND_IN
;
2372 else if (gfc_match ("out") == MATCH_YES
)
2373 depend_op
= OMP_DEPEND_OUT
;
2374 else if (gfc_match ("mutexinoutset") == MATCH_YES
)
2375 depend_op
= OMP_DEPEND_MUTEXINOUTSET
;
2376 else if (gfc_match ("depobj") == MATCH_YES
)
2377 depend_op
= OMP_DEPEND_DEPOBJ
;
2378 else if (gfc_match ("source") == MATCH_YES
)
2380 if (m_it
== MATCH_YES
)
2382 gfc_error ("ITERATOR may not be combined with SOURCE "
2386 if (!(mask
& OMP_CLAUSE_DOACROSS
))
2388 gfc_error ("SOURCE at %C not permitted as dependence-type"
2389 " for this directive");
2392 if (c
->doacross_source
)
2394 gfc_error ("Duplicated clause with SOURCE dependence-type"
2398 gfc_gobble_whitespace ();
2399 m
= gfc_match (": ");
2400 if (m
!= MATCH_YES
&& !is_depend
)
2402 gfc_error ("Expected %<:%> at %C");
2405 if (gfc_match (")") != MATCH_YES
2407 && gfc_match ("omp_cur_iteration )") == MATCH_YES
))
2409 gfc_error ("Expected %<)%> or %<omp_cur_iteration)%> "
2413 c
->doacross_source
= true;
2414 c
->depend_source
= is_depend
;
2417 else if (gfc_match ("sink ") == MATCH_YES
)
2419 if (!(mask
& OMP_CLAUSE_DOACROSS
))
2421 gfc_error ("SINK at %C not permitted as dependence-type "
2422 "for this directive");
2425 if (gfc_match (": ") != MATCH_YES
)
2427 gfc_error ("Expected %<:%> at %C");
2430 if (m_it
== MATCH_YES
)
2432 gfc_error ("ITERATOR may not be combined with SINK "
2436 m
= gfc_match_omp_doacross_sink (&c
->lists
[OMP_LIST_DEPEND
],
2444 if (!(mask
& OMP_CLAUSE_DEPEND
))
2446 gfc_error ("Expected dependence-type SINK or SOURCE at %C");
2451 gfc_current_ns
= ns_iter
;
2453 m
= gfc_match_omp_variable_list (" : ",
2454 &c
->lists
[OMP_LIST_DEPEND
],
2455 false, NULL
, &head
, true,
2456 false, &has_omp_all_memory
);
2459 gfc_current_ns
= ns_curr
;
2460 if (has_omp_all_memory
&& depend_op
!= OMP_DEPEND_INOUT
2461 && depend_op
!= OMP_DEPEND_OUT
)
2463 gfc_error ("%<omp_all_memory%> used with DEPEND kind "
2464 "other than OUT or INOUT at %C");
2467 gfc_omp_namelist
*n
;
2468 for (n
= *head
; n
; n
= n
->next
)
2470 n
->u
.depend_doacross_op
= depend_op
;
2477 if ((mask
& OMP_CLAUSE_DETACH
)
2480 && gfc_match_omp_detach (&c
->detach
) == MATCH_YES
)
2482 if ((mask
& OMP_CLAUSE_DETACH
)
2484 && gfc_match ("detach ( ") == MATCH_YES
2485 && gfc_match_omp_map_clause (&c
->lists
[OMP_LIST_MAP
],
2486 OMP_MAP_DETACH
, false,
2489 if ((mask
& OMP_CLAUSE_DEVICE
)
2491 && ((m
= gfc_match_dupl_check (!c
->device
, "device", true))
2494 if (m
== MATCH_ERROR
)
2496 c
->ancestor
= false;
2497 if (gfc_match ("device_num : ") == MATCH_YES
)
2499 if (gfc_match ("%e )", &c
->device
) != MATCH_YES
)
2501 gfc_error ("Expected integer expression at %C");
2505 else if (gfc_match ("ancestor : ") == MATCH_YES
)
2507 bool has_requires
= false;
2509 for (gfc_namespace
*ns
= gfc_current_ns
; ns
; ns
= ns
->parent
)
2510 if (ns
->omp_requires
& OMP_REQ_REVERSE_OFFLOAD
)
2512 has_requires
= true;
2517 gfc_error ("%<ancestor%> device modifier not "
2518 "preceded by %<requires%> directive "
2519 "with %<reverse_offload%> clause at %C");
2522 locus old_loc2
= gfc_current_locus
;
2523 if (gfc_match ("%e )", &c
->device
) == MATCH_YES
)
2526 if (!gfc_extract_int (c
->device
, &device
) && device
!= 1)
2528 gfc_current_locus
= old_loc2
;
2529 gfc_error ("the %<device%> clause expression must "
2530 "evaluate to %<1%> at %C");
2536 gfc_error ("Expected integer expression at %C");
2540 else if (gfc_match ("%e )", &c
->device
) != MATCH_YES
)
2542 gfc_error ("Expected integer expression or a single device-"
2543 "modifier %<device_num%> or %<ancestor%> at %C");
2548 if ((mask
& OMP_CLAUSE_DEVICE
)
2550 && gfc_match ("device ( ") == MATCH_YES
2551 && gfc_match_omp_map_clause (&c
->lists
[OMP_LIST_MAP
],
2552 OMP_MAP_FORCE_TO
, true,
2553 /* allow_derived = */ true))
2555 if ((mask
& OMP_CLAUSE_DEVICEPTR
)
2556 && gfc_match ("deviceptr ( ") == MATCH_YES
2557 && gfc_match_omp_map_clause (&c
->lists
[OMP_LIST_MAP
],
2558 OMP_MAP_FORCE_DEVICEPTR
, false,
2561 if ((mask
& OMP_CLAUSE_DEVICE_TYPE
)
2562 && gfc_match ("device_type ( ") == MATCH_YES
)
2564 if (gfc_match ("host") == MATCH_YES
)
2565 c
->device_type
= OMP_DEVICE_TYPE_HOST
;
2566 else if (gfc_match ("nohost") == MATCH_YES
)
2567 c
->device_type
= OMP_DEVICE_TYPE_NOHOST
;
2568 else if (gfc_match ("any") == MATCH_YES
)
2569 c
->device_type
= OMP_DEVICE_TYPE_ANY
;
2572 gfc_error ("Expected HOST, NOHOST or ANY at %C");
2575 if (gfc_match (" )") != MATCH_YES
)
2579 if ((mask
& OMP_CLAUSE_DEVICE_RESIDENT
)
2580 && gfc_match_omp_variable_list
2581 ("device_resident (",
2582 &c
->lists
[OMP_LIST_DEVICE_RESIDENT
], true) == MATCH_YES
)
2584 if ((mask
& OMP_CLAUSE_DIST_SCHEDULE
)
2585 && c
->dist_sched_kind
== OMP_SCHED_NONE
2586 && gfc_match ("dist_schedule ( static") == MATCH_YES
)
2589 c
->dist_sched_kind
= OMP_SCHED_STATIC
;
2590 m
= gfc_match (" , %e )", &c
->dist_chunk_size
);
2592 m
= gfc_match_char (')');
2595 c
->dist_sched_kind
= OMP_SCHED_NONE
;
2596 gfc_current_locus
= old_loc
;
2603 if ((mask
& OMP_CLAUSE_ENTER
))
2605 m
= gfc_match_omp_to_link ("enter (", &c
->lists
[OMP_LIST_ENTER
]);
2606 if (m
== MATCH_ERROR
)
2613 if ((mask
& OMP_CLAUSE_FAIL
)
2614 && (m
= gfc_match_dupl_check (c
->fail
== OMP_MEMORDER_UNSET
,
2615 "fail", true)) != MATCH_NO
)
2617 if (m
== MATCH_ERROR
)
2619 if (gfc_match ("seq_cst") == MATCH_YES
)
2620 c
->fail
= OMP_MEMORDER_SEQ_CST
;
2621 else if (gfc_match ("acquire") == MATCH_YES
)
2622 c
->fail
= OMP_MEMORDER_ACQUIRE
;
2623 else if (gfc_match ("relaxed") == MATCH_YES
)
2624 c
->fail
= OMP_MEMORDER_RELAXED
;
2627 gfc_error ("Expected SEQ_CST, ACQUIRE or RELAXED at %C");
2630 if (gfc_match (" )") != MATCH_YES
)
2634 if ((mask
& OMP_CLAUSE_FILTER
)
2635 && (m
= gfc_match_dupl_check (!c
->filter
, "filter", true,
2636 &c
->filter
)) != MATCH_NO
)
2638 if (m
== MATCH_ERROR
)
2642 if ((mask
& OMP_CLAUSE_FINAL
)
2643 && (m
= gfc_match_dupl_check (!c
->final_expr
, "final", true,
2644 &c
->final_expr
)) != MATCH_NO
)
2646 if (m
== MATCH_ERROR
)
2650 if ((mask
& OMP_CLAUSE_FINALIZE
)
2651 && (m
= gfc_match_dupl_check (!c
->finalize
, "finalize"))
2654 if (m
== MATCH_ERROR
)
2660 if ((mask
& OMP_CLAUSE_FIRSTPRIVATE
)
2661 && gfc_match_omp_variable_list ("firstprivate (",
2662 &c
->lists
[OMP_LIST_FIRSTPRIVATE
],
2665 if ((mask
& OMP_CLAUSE_FROM
)
2666 && gfc_match_motion_var_list ("from (", &c
->lists
[OMP_LIST_FROM
],
2667 &head
) == MATCH_YES
)
2671 if ((mask
& OMP_CLAUSE_GANG
)
2672 && (m
= gfc_match_dupl_check (!c
->gang
, "gang")) != MATCH_NO
)
2674 if (m
== MATCH_ERROR
)
2677 m
= match_oacc_clause_gwv (c
, GOMP_DIM_GANG
);
2678 if (m
== MATCH_ERROR
)
2680 gfc_current_locus
= old_loc
;
2683 else if (m
== MATCH_NO
)
2687 if ((mask
& OMP_CLAUSE_GRAINSIZE
)
2688 && (m
= gfc_match_dupl_check (!c
->grainsize
, "grainsize", true))
2691 if (m
== MATCH_ERROR
)
2693 if (gfc_match ("strict : ") == MATCH_YES
)
2694 c
->grainsize_strict
= true;
2695 if (gfc_match (" %e )", &c
->grainsize
) != MATCH_YES
)
2701 if ((mask
& OMP_CLAUSE_HAS_DEVICE_ADDR
)
2702 && gfc_match_omp_variable_list
2703 ("has_device_addr (", &c
->lists
[OMP_LIST_HAS_DEVICE_ADDR
],
2704 false, NULL
, NULL
, true) == MATCH_YES
)
2706 if ((mask
& OMP_CLAUSE_HINT
)
2707 && (m
= gfc_match_dupl_check (!c
->hint
, "hint", true, &c
->hint
))
2710 if (m
== MATCH_ERROR
)
2714 if ((mask
& OMP_CLAUSE_ASSUMPTIONS
)
2715 && gfc_match ("holds ( ") == MATCH_YES
)
2718 if (gfc_match ("%e )", &e
) != MATCH_YES
)
2720 if (c
->assume
== NULL
)
2721 c
->assume
= gfc_get_omp_assumptions ();
2722 gfc_expr_list
*el
= XCNEW (gfc_expr_list
);
2724 el
->next
= c
->assume
->holds
;
2725 c
->assume
->holds
= el
;
2728 if ((mask
& OMP_CLAUSE_HOST
)
2729 && gfc_match ("host ( ") == MATCH_YES
2730 && gfc_match_omp_map_clause (&c
->lists
[OMP_LIST_MAP
],
2731 OMP_MAP_FORCE_FROM
, true,
2732 /* allow_derived = */ true))
2736 if ((mask
& OMP_CLAUSE_IF_PRESENT
)
2737 && (m
= gfc_match_dupl_check (!c
->if_present
, "if_present"))
2740 if (m
== MATCH_ERROR
)
2742 c
->if_present
= true;
2746 if ((mask
& OMP_CLAUSE_IF
)
2747 && (m
= gfc_match_dupl_check (!c
->if_expr
, "if", true))
2750 if (m
== MATCH_ERROR
)
2754 /* This should match the enum gfc_omp_if_kind order. */
2755 static const char *ifs
[OMP_IF_LAST
] = {
2762 "target data : %e )",
2763 "target update : %e )",
2764 "target enter data : %e )",
2765 "target exit data : %e )" };
2767 for (i
= 0; i
< OMP_IF_LAST
; i
++)
2768 if (c
->if_exprs
[i
] == NULL
2769 && gfc_match (ifs
[i
], &c
->if_exprs
[i
]) == MATCH_YES
)
2771 if (i
< OMP_IF_LAST
)
2774 if (gfc_match (" %e )", &c
->if_expr
) == MATCH_YES
)
2778 if ((mask
& OMP_CLAUSE_IN_REDUCTION
)
2779 && gfc_match_omp_clause_reduction (pc
, c
, openacc
, allow_derived
,
2780 openmp_target
) == MATCH_YES
)
2782 if ((mask
& OMP_CLAUSE_INBRANCH
)
2783 && (m
= gfc_match_dupl_check (!c
->inbranch
&& !c
->notinbranch
,
2784 "inbranch")) != MATCH_NO
)
2786 if (m
== MATCH_ERROR
)
2788 c
->inbranch
= needs_space
= true;
2791 if ((mask
& OMP_CLAUSE_INDEPENDENT
)
2792 && (m
= gfc_match_dupl_check (!c
->independent
, "independent"))
2795 if (m
== MATCH_ERROR
)
2797 c
->independent
= true;
2801 if ((mask
& OMP_CLAUSE_IS_DEVICE_PTR
)
2802 && gfc_match_omp_variable_list
2804 &c
->lists
[OMP_LIST_IS_DEVICE_PTR
], false) == MATCH_YES
)
2808 if ((mask
& OMP_CLAUSE_LASTPRIVATE
)
2809 && gfc_match ("lastprivate ( ") == MATCH_YES
)
2811 bool conditional
= gfc_match ("conditional : ") == MATCH_YES
;
2813 if (gfc_match_omp_variable_list ("",
2814 &c
->lists
[OMP_LIST_LASTPRIVATE
],
2815 false, NULL
, &head
) == MATCH_YES
)
2817 gfc_omp_namelist
*n
;
2818 for (n
= *head
; n
; n
= n
->next
)
2819 n
->u
.lastprivate_conditional
= conditional
;
2822 gfc_current_locus
= old_loc
;
2827 if ((mask
& OMP_CLAUSE_LINEAR
)
2828 && gfc_match ("linear (") == MATCH_YES
)
2830 bool old_linear_modifier
= false;
2831 gfc_omp_linear_op linear_op
= OMP_LINEAR_DEFAULT
;
2832 gfc_expr
*step
= NULL
;
2834 if (gfc_match_omp_variable_list (" ref (",
2835 &c
->lists
[OMP_LIST_LINEAR
],
2839 linear_op
= OMP_LINEAR_REF
;
2840 old_linear_modifier
= true;
2842 else if (gfc_match_omp_variable_list (" val (",
2843 &c
->lists
[OMP_LIST_LINEAR
],
2847 linear_op
= OMP_LINEAR_VAL
;
2848 old_linear_modifier
= true;
2850 else if (gfc_match_omp_variable_list (" uval (",
2851 &c
->lists
[OMP_LIST_LINEAR
],
2855 linear_op
= OMP_LINEAR_UVAL
;
2856 old_linear_modifier
= true;
2858 else if (gfc_match_omp_variable_list ("",
2859 &c
->lists
[OMP_LIST_LINEAR
],
2860 false, &end_colon
, &head
)
2862 linear_op
= OMP_LINEAR_DEFAULT
;
2865 gfc_current_locus
= old_loc
;
2868 if (linear_op
!= OMP_LINEAR_DEFAULT
)
2870 if (gfc_match (" :") == MATCH_YES
)
2872 else if (gfc_match (" )") != MATCH_YES
)
2874 gfc_free_omp_namelist (*head
, false, false, false);
2875 gfc_current_locus
= old_loc
;
2880 gfc_gobble_whitespace ();
2881 if (old_linear_modifier
&& end_colon
)
2883 if (gfc_match (" %e )", &step
) != MATCH_YES
)
2885 gfc_free_omp_namelist (*head
, false, false, false);
2886 gfc_current_locus
= old_loc
;
2893 bool has_error
= false;
2894 bool has_modifiers
= false;
2895 bool has_step
= false;
2896 bool duplicate_step
= false;
2897 bool duplicate_mod
= false;
2900 old_loc
= gfc_current_locus
;
2901 bool close_paren
= gfc_match ("val )") == MATCH_YES
;
2902 if (close_paren
|| gfc_match ("val , ") == MATCH_YES
)
2904 if (linear_op
!= OMP_LINEAR_DEFAULT
)
2906 duplicate_mod
= true;
2909 linear_op
= OMP_LINEAR_VAL
;
2910 has_modifiers
= true;
2915 close_paren
= gfc_match ("uval )") == MATCH_YES
;
2916 if (close_paren
|| gfc_match ("uval , ") == MATCH_YES
)
2918 if (linear_op
!= OMP_LINEAR_DEFAULT
)
2920 duplicate_mod
= true;
2923 linear_op
= OMP_LINEAR_UVAL
;
2924 has_modifiers
= true;
2929 close_paren
= gfc_match ("ref )") == MATCH_YES
;
2930 if (close_paren
|| gfc_match ("ref , ") == MATCH_YES
)
2932 if (linear_op
!= OMP_LINEAR_DEFAULT
)
2934 duplicate_mod
= true;
2937 linear_op
= OMP_LINEAR_REF
;
2938 has_modifiers
= true;
2943 close_paren
= (gfc_match ("step ( %e ) )", &step
)
2946 || gfc_match ("step ( %e ) , ", &step
) == MATCH_YES
)
2950 duplicate_step
= true;
2953 has_modifiers
= has_step
= true;
2959 && gfc_match ("%e )", &step
) == MATCH_YES
)
2961 if ((step
->expr_type
== EXPR_FUNCTION
2962 || step
->expr_type
== EXPR_VARIABLE
)
2963 && strcmp (step
->symtree
->name
, "step") == 0)
2965 gfc_current_locus
= old_loc
;
2966 gfc_match ("step (");
2974 if (duplicate_mod
|| duplicate_step
)
2976 gfc_error ("Multiple %qs modifiers specified at %C",
2977 duplicate_mod
? "linear" : "step");
2982 gfc_free_omp_namelist (*head
, false, false, false);
2989 step
= gfc_get_constant_expr (BT_INTEGER
,
2990 gfc_default_integer_kind
,
2992 mpz_set_si (step
->value
.integer
, 1);
2994 (*head
)->expr
= step
;
2995 if (linear_op
!= OMP_LINEAR_DEFAULT
|| old_linear_modifier
)
2996 for (gfc_omp_namelist
*n
= *head
; n
; n
= n
->next
)
2998 n
->u
.linear
.op
= linear_op
;
2999 n
->u
.linear
.old_modifier
= old_linear_modifier
;
3003 if ((mask
& OMP_CLAUSE_LINK
)
3005 && (gfc_match_oacc_clause_link ("link (",
3006 &c
->lists
[OMP_LIST_LINK
])
3009 else if ((mask
& OMP_CLAUSE_LINK
)
3011 && (gfc_match_omp_to_link ("link (",
3012 &c
->lists
[OMP_LIST_LINK
])
3017 if ((mask
& OMP_CLAUSE_MAP
)
3018 && gfc_match ("map ( ") == MATCH_YES
)
3020 locus old_loc2
= gfc_current_locus
;
3021 int always_modifier
= 0;
3022 int close_modifier
= 0;
3023 int present_modifier
= 0;
3024 locus second_always_locus
= old_loc2
;
3025 locus second_close_locus
= old_loc2
;
3026 locus second_present_locus
= old_loc2
;
3030 locus current_locus
= gfc_current_locus
;
3031 if (gfc_match ("always ") == MATCH_YES
)
3033 if (always_modifier
++ == 1)
3034 second_always_locus
= current_locus
;
3036 else if (gfc_match ("close ") == MATCH_YES
)
3038 if (close_modifier
++ == 1)
3039 second_close_locus
= current_locus
;
3041 else if (gfc_match ("present ") == MATCH_YES
)
3043 if (present_modifier
++ == 1)
3044 second_present_locus
= current_locus
;
3051 gfc_omp_map_op map_op
= OMP_MAP_TOFROM
;
3052 int always_present_modifier
3053 = always_modifier
&& present_modifier
;
3055 if (gfc_match ("alloc : ") == MATCH_YES
)
3056 map_op
= (present_modifier
? OMP_MAP_PRESENT_ALLOC
3058 else if (gfc_match ("tofrom : ") == MATCH_YES
)
3059 map_op
= (always_present_modifier
? OMP_MAP_ALWAYS_PRESENT_TOFROM
3060 : present_modifier
? OMP_MAP_PRESENT_TOFROM
3061 : always_modifier
? OMP_MAP_ALWAYS_TOFROM
3063 else if (gfc_match ("to : ") == MATCH_YES
)
3064 map_op
= (always_present_modifier
? OMP_MAP_ALWAYS_PRESENT_TO
3065 : present_modifier
? OMP_MAP_PRESENT_TO
3066 : always_modifier
? OMP_MAP_ALWAYS_TO
3068 else if (gfc_match ("from : ") == MATCH_YES
)
3069 map_op
= (always_present_modifier
? OMP_MAP_ALWAYS_PRESENT_FROM
3070 : present_modifier
? OMP_MAP_PRESENT_FROM
3071 : always_modifier
? OMP_MAP_ALWAYS_FROM
3073 else if (gfc_match ("release : ") == MATCH_YES
)
3074 map_op
= OMP_MAP_RELEASE
;
3075 else if (gfc_match ("delete : ") == MATCH_YES
)
3076 map_op
= OMP_MAP_DELETE
;
3079 gfc_current_locus
= old_loc2
;
3080 always_modifier
= 0;
3084 if (always_modifier
> 1)
3086 gfc_error ("too many %<always%> modifiers at %L",
3087 &second_always_locus
);
3090 if (close_modifier
> 1)
3092 gfc_error ("too many %<close%> modifiers at %L",
3093 &second_close_locus
);
3096 if (present_modifier
> 1)
3098 gfc_error ("too many %<present%> modifiers at %L",
3099 &second_present_locus
);
3104 if (gfc_match_omp_variable_list ("", &c
->lists
[OMP_LIST_MAP
],
3106 true, true) == MATCH_YES
)
3108 gfc_omp_namelist
*n
;
3109 for (n
= *head
; n
; n
= n
->next
)
3110 n
->u
.map_op
= map_op
;
3113 gfc_current_locus
= old_loc
;
3116 if ((mask
& OMP_CLAUSE_MERGEABLE
)
3117 && (m
= gfc_match_dupl_check (!c
->mergeable
, "mergeable"))
3120 if (m
== MATCH_ERROR
)
3122 c
->mergeable
= needs_space
= true;
3125 if ((mask
& OMP_CLAUSE_MESSAGE
)
3126 && (m
= gfc_match_dupl_check (!c
->message
, "message", true,
3127 &c
->message
)) != MATCH_NO
)
3129 if (m
== MATCH_ERROR
)
3135 if ((mask
& OMP_CLAUSE_NO_CREATE
)
3136 && gfc_match ("no_create ( ") == MATCH_YES
3137 && gfc_match_omp_map_clause (&c
->lists
[OMP_LIST_MAP
],
3138 OMP_MAP_IF_PRESENT
, true,
3141 if ((mask
& OMP_CLAUSE_ASSUMPTIONS
)
3142 && (m
= gfc_match_dupl_check (!c
->assume
3143 || !c
->assume
->no_openmp_routines
,
3144 "no_openmp_routines")) == MATCH_YES
)
3146 if (m
== MATCH_ERROR
)
3148 if (c
->assume
== NULL
)
3149 c
->assume
= gfc_get_omp_assumptions ();
3150 c
->assume
->no_openmp_routines
= needs_space
= true;
3153 if ((mask
& OMP_CLAUSE_ASSUMPTIONS
)
3154 && (m
= gfc_match_dupl_check (!c
->assume
|| !c
->assume
->no_openmp
,
3155 "no_openmp")) == MATCH_YES
)
3157 if (m
== MATCH_ERROR
)
3159 if (c
->assume
== NULL
)
3160 c
->assume
= gfc_get_omp_assumptions ();
3161 c
->assume
->no_openmp
= needs_space
= true;
3164 if ((mask
& OMP_CLAUSE_ASSUMPTIONS
)
3165 && (m
= gfc_match_dupl_check (!c
->assume
3166 || !c
->assume
->no_parallelism
,
3167 "no_parallelism")) == MATCH_YES
)
3169 if (m
== MATCH_ERROR
)
3171 if (c
->assume
== NULL
)
3172 c
->assume
= gfc_get_omp_assumptions ();
3173 c
->assume
->no_parallelism
= needs_space
= true;
3176 if ((mask
& OMP_CLAUSE_NOGROUP
)
3177 && (m
= gfc_match_dupl_check (!c
->nogroup
, "nogroup"))
3180 if (m
== MATCH_ERROR
)
3182 c
->nogroup
= needs_space
= true;
3185 if ((mask
& OMP_CLAUSE_NOHOST
)
3186 && (m
= gfc_match_dupl_check (!c
->nohost
, "nohost")) != MATCH_NO
)
3188 if (m
== MATCH_ERROR
)
3190 c
->nohost
= needs_space
= true;
3193 if ((mask
& OMP_CLAUSE_NOTEMPORAL
)
3194 && gfc_match_omp_variable_list ("nontemporal (",
3195 &c
->lists
[OMP_LIST_NONTEMPORAL
],
3198 if ((mask
& OMP_CLAUSE_NOTINBRANCH
)
3199 && (m
= gfc_match_dupl_check (!c
->notinbranch
&& !c
->inbranch
,
3200 "notinbranch")) != MATCH_NO
)
3202 if (m
== MATCH_ERROR
)
3204 c
->notinbranch
= needs_space
= true;
3207 if ((mask
& OMP_CLAUSE_NOWAIT
)
3208 && (m
= gfc_match_dupl_check (!c
->nowait
, "nowait")) != MATCH_NO
)
3210 if (m
== MATCH_ERROR
)
3212 c
->nowait
= needs_space
= true;
3215 if ((mask
& OMP_CLAUSE_NUM_GANGS
)
3216 && (m
= gfc_match_dupl_check (!c
->num_gangs_expr
, "num_gangs",
3219 if (m
== MATCH_ERROR
)
3221 if (gfc_match (" %e )", &c
->num_gangs_expr
) != MATCH_YES
)
3225 if ((mask
& OMP_CLAUSE_NUM_TASKS
)
3226 && (m
= gfc_match_dupl_check (!c
->num_tasks
, "num_tasks", true))
3229 if (m
== MATCH_ERROR
)
3231 if (gfc_match ("strict : ") == MATCH_YES
)
3232 c
->num_tasks_strict
= true;
3233 if (gfc_match (" %e )", &c
->num_tasks
) != MATCH_YES
)
3237 if ((mask
& OMP_CLAUSE_NUM_TEAMS
)
3238 && (m
= gfc_match_dupl_check (!c
->num_teams_upper
, "num_teams",
3241 if (m
== MATCH_ERROR
)
3243 if (gfc_match ("%e ", &c
->num_teams_upper
) != MATCH_YES
)
3245 if (gfc_peek_ascii_char () == ':')
3247 c
->num_teams_lower
= c
->num_teams_upper
;
3248 c
->num_teams_upper
= NULL
;
3249 if (gfc_match (": %e ", &c
->num_teams_upper
) != MATCH_YES
)
3252 if (gfc_match (") ") != MATCH_YES
)
3256 if ((mask
& OMP_CLAUSE_NUM_THREADS
)
3257 && (m
= gfc_match_dupl_check (!c
->num_threads
, "num_threads", true,
3258 &c
->num_threads
)) != MATCH_NO
)
3260 if (m
== MATCH_ERROR
)
3264 if ((mask
& OMP_CLAUSE_NUM_WORKERS
)
3265 && (m
= gfc_match_dupl_check (!c
->num_workers_expr
, "num_workers",
3266 true, &c
->num_workers_expr
))
3269 if (m
== MATCH_ERROR
)
3275 if ((mask
& OMP_CLAUSE_ORDER
)
3276 && (m
= gfc_match_dupl_check (!c
->order_concurrent
, "order ("))
3279 if (m
== MATCH_ERROR
)
3281 if (gfc_match (" reproducible : concurrent )") == MATCH_YES
)
3282 c
->order_reproducible
= true;
3283 else if (gfc_match (" concurrent )") == MATCH_YES
)
3285 else if (gfc_match (" unconstrained : concurrent )") == MATCH_YES
)
3286 c
->order_unconstrained
= true;
3289 gfc_error ("Expected ORDER(CONCURRENT) at %C "
3290 "with optional %<reproducible%> or "
3291 "%<unconstrained%> modifier");
3294 c
->order_concurrent
= true;
3297 if ((mask
& OMP_CLAUSE_ORDERED
)
3298 && (m
= gfc_match_dupl_check (!c
->ordered
, "ordered"))
3301 if (m
== MATCH_ERROR
)
3303 gfc_expr
*cexpr
= NULL
;
3304 m
= gfc_match (" ( %e )", &cexpr
);
3310 if (gfc_extract_int (cexpr
, &ordered
, -1))
3312 else if (ordered
<= 0)
3314 gfc_error_now ("ORDERED clause argument not"
3315 " constant positive integer at %C");
3318 c
->orderedc
= ordered
;
3319 gfc_free_expr (cexpr
);
3328 if ((mask
& OMP_CLAUSE_COPY
)
3329 && gfc_match ("pcopy ( ") == MATCH_YES
3330 && gfc_match_omp_map_clause (&c
->lists
[OMP_LIST_MAP
],
3331 OMP_MAP_TOFROM
, true, allow_derived
))
3333 if ((mask
& OMP_CLAUSE_COPYIN
)
3334 && gfc_match ("pcopyin ( ") == MATCH_YES
3335 && gfc_match_omp_map_clause (&c
->lists
[OMP_LIST_MAP
],
3336 OMP_MAP_TO
, true, allow_derived
))
3338 if ((mask
& OMP_CLAUSE_COPYOUT
)
3339 && gfc_match ("pcopyout ( ") == MATCH_YES
3340 && gfc_match_omp_map_clause (&c
->lists
[OMP_LIST_MAP
],
3341 OMP_MAP_FROM
, true, allow_derived
))
3343 if ((mask
& OMP_CLAUSE_CREATE
)
3344 && gfc_match ("pcreate ( ") == MATCH_YES
3345 && gfc_match_omp_map_clause (&c
->lists
[OMP_LIST_MAP
],
3346 OMP_MAP_ALLOC
, true, allow_derived
))
3348 if ((mask
& OMP_CLAUSE_PRESENT
)
3349 && gfc_match ("present ( ") == MATCH_YES
3350 && gfc_match_omp_map_clause (&c
->lists
[OMP_LIST_MAP
],
3351 OMP_MAP_FORCE_PRESENT
, false,
3354 if ((mask
& OMP_CLAUSE_COPY
)
3355 && gfc_match ("present_or_copy ( ") == MATCH_YES
3356 && gfc_match_omp_map_clause (&c
->lists
[OMP_LIST_MAP
],
3357 OMP_MAP_TOFROM
, true,
3360 if ((mask
& OMP_CLAUSE_COPYIN
)
3361 && gfc_match ("present_or_copyin ( ") == MATCH_YES
3362 && gfc_match_omp_map_clause (&c
->lists
[OMP_LIST_MAP
],
3363 OMP_MAP_TO
, true, allow_derived
))
3365 if ((mask
& OMP_CLAUSE_COPYOUT
)
3366 && gfc_match ("present_or_copyout ( ") == MATCH_YES
3367 && gfc_match_omp_map_clause (&c
->lists
[OMP_LIST_MAP
],
3368 OMP_MAP_FROM
, true, allow_derived
))
3370 if ((mask
& OMP_CLAUSE_CREATE
)
3371 && gfc_match ("present_or_create ( ") == MATCH_YES
3372 && gfc_match_omp_map_clause (&c
->lists
[OMP_LIST_MAP
],
3373 OMP_MAP_ALLOC
, true, allow_derived
))
3375 if ((mask
& OMP_CLAUSE_PRIORITY
)
3376 && (m
= gfc_match_dupl_check (!c
->priority
, "priority", true,
3377 &c
->priority
)) != MATCH_NO
)
3379 if (m
== MATCH_ERROR
)
3383 if ((mask
& OMP_CLAUSE_PRIVATE
)
3384 && gfc_match_omp_variable_list ("private (",
3385 &c
->lists
[OMP_LIST_PRIVATE
],
3388 if ((mask
& OMP_CLAUSE_PROC_BIND
)
3389 && (m
= gfc_match_dupl_check ((c
->proc_bind
3390 == OMP_PROC_BIND_UNKNOWN
),
3391 "proc_bind", true)) != MATCH_NO
)
3393 if (m
== MATCH_ERROR
)
3395 if (gfc_match ("primary )") == MATCH_YES
)
3396 c
->proc_bind
= OMP_PROC_BIND_PRIMARY
;
3397 else if (gfc_match ("master )") == MATCH_YES
)
3398 c
->proc_bind
= OMP_PROC_BIND_MASTER
;
3399 else if (gfc_match ("spread )") == MATCH_YES
)
3400 c
->proc_bind
= OMP_PROC_BIND_SPREAD
;
3401 else if (gfc_match ("close )") == MATCH_YES
)
3402 c
->proc_bind
= OMP_PROC_BIND_CLOSE
;
3409 if ((mask
& OMP_CLAUSE_ATOMIC
)
3410 && (m
= gfc_match_dupl_atomic ((c
->atomic_op
3411 == GFC_OMP_ATOMIC_UNSET
),
3412 "read")) != MATCH_NO
)
3414 if (m
== MATCH_ERROR
)
3416 c
->atomic_op
= GFC_OMP_ATOMIC_READ
;
3420 if ((mask
& OMP_CLAUSE_REDUCTION
)
3421 && gfc_match_omp_clause_reduction (pc
, c
, openacc
,
3422 allow_derived
) == MATCH_YES
)
3424 if ((mask
& OMP_CLAUSE_MEMORDER
)
3425 && (m
= gfc_match_dupl_memorder ((c
->memorder
3426 == OMP_MEMORDER_UNSET
),
3427 "relaxed")) != MATCH_NO
)
3429 if (m
== MATCH_ERROR
)
3431 c
->memorder
= OMP_MEMORDER_RELAXED
;
3435 if ((mask
& OMP_CLAUSE_MEMORDER
)
3436 && (m
= gfc_match_dupl_memorder ((c
->memorder
3437 == OMP_MEMORDER_UNSET
),
3438 "release")) != MATCH_NO
)
3440 if (m
== MATCH_ERROR
)
3442 c
->memorder
= OMP_MEMORDER_RELEASE
;
3448 if ((mask
& OMP_CLAUSE_SAFELEN
)
3449 && (m
= gfc_match_dupl_check (!c
->safelen_expr
, "safelen",
3450 true, &c
->safelen_expr
))
3453 if (m
== MATCH_ERROR
)
3457 if ((mask
& OMP_CLAUSE_SCHEDULE
)
3458 && (m
= gfc_match_dupl_check (c
->sched_kind
== OMP_SCHED_NONE
,
3459 "schedule", true)) != MATCH_NO
)
3461 if (m
== MATCH_ERROR
)
3464 locus old_loc2
= gfc_current_locus
;
3467 if (gfc_match ("simd") == MATCH_YES
)
3469 c
->sched_simd
= true;
3472 else if (gfc_match ("monotonic") == MATCH_YES
)
3474 c
->sched_monotonic
= true;
3477 else if (gfc_match ("nonmonotonic") == MATCH_YES
)
3479 c
->sched_nonmonotonic
= true;
3485 gfc_current_locus
= old_loc2
;
3489 && gfc_match (" , ") == MATCH_YES
)
3491 else if (gfc_match (" : ") == MATCH_YES
)
3493 gfc_current_locus
= old_loc2
;
3497 if (gfc_match ("static") == MATCH_YES
)
3498 c
->sched_kind
= OMP_SCHED_STATIC
;
3499 else if (gfc_match ("dynamic") == MATCH_YES
)
3500 c
->sched_kind
= OMP_SCHED_DYNAMIC
;
3501 else if (gfc_match ("guided") == MATCH_YES
)
3502 c
->sched_kind
= OMP_SCHED_GUIDED
;
3503 else if (gfc_match ("runtime") == MATCH_YES
)
3504 c
->sched_kind
= OMP_SCHED_RUNTIME
;
3505 else if (gfc_match ("auto") == MATCH_YES
)
3506 c
->sched_kind
= OMP_SCHED_AUTO
;
3507 if (c
->sched_kind
!= OMP_SCHED_NONE
)
3510 if (c
->sched_kind
!= OMP_SCHED_RUNTIME
3511 && c
->sched_kind
!= OMP_SCHED_AUTO
)
3512 m
= gfc_match (" , %e )", &c
->chunk_size
);
3514 m
= gfc_match_char (')');
3516 c
->sched_kind
= OMP_SCHED_NONE
;
3518 if (c
->sched_kind
!= OMP_SCHED_NONE
)
3521 gfc_current_locus
= old_loc
;
3523 if ((mask
& OMP_CLAUSE_SELF
)
3524 && !(mask
& OMP_CLAUSE_HOST
) /* OpenACC compute construct */
3525 && (m
= gfc_match_dupl_check (!c
->self_expr
, "self"))
3528 if (m
== MATCH_ERROR
)
3530 m
= gfc_match (" ( %e )", &c
->self_expr
);
3531 if (m
== MATCH_ERROR
)
3533 gfc_current_locus
= old_loc
;
3536 else if (m
== MATCH_NO
)
3538 c
->self_expr
= gfc_get_logical_expr (gfc_default_logical_kind
,
3544 if ((mask
& OMP_CLAUSE_SELF
)
3545 && (mask
& OMP_CLAUSE_HOST
) /* OpenACC 'update' directive */
3546 && gfc_match ("self ( ") == MATCH_YES
3547 && gfc_match_omp_map_clause (&c
->lists
[OMP_LIST_MAP
],
3548 OMP_MAP_FORCE_FROM
, true,
3549 /* allow_derived = */ true))
3551 if ((mask
& OMP_CLAUSE_SEQ
)
3552 && (m
= gfc_match_dupl_check (!c
->seq
, "seq")) != MATCH_NO
)
3554 if (m
== MATCH_ERROR
)
3560 if ((mask
& OMP_CLAUSE_MEMORDER
)
3561 && (m
= gfc_match_dupl_memorder ((c
->memorder
3562 == OMP_MEMORDER_UNSET
),
3563 "seq_cst")) != MATCH_NO
)
3565 if (m
== MATCH_ERROR
)
3567 c
->memorder
= OMP_MEMORDER_SEQ_CST
;
3571 if ((mask
& OMP_CLAUSE_SHARED
)
3572 && gfc_match_omp_variable_list ("shared (",
3573 &c
->lists
[OMP_LIST_SHARED
],
3576 if ((mask
& OMP_CLAUSE_SIMDLEN
)
3577 && (m
= gfc_match_dupl_check (!c
->simdlen_expr
, "simdlen", true,
3578 &c
->simdlen_expr
)) != MATCH_NO
)
3580 if (m
== MATCH_ERROR
)
3584 if ((mask
& OMP_CLAUSE_SIMD
)
3585 && (m
= gfc_match_dupl_check (!c
->simd
, "simd")) != MATCH_NO
)
3587 if (m
== MATCH_ERROR
)
3589 c
->simd
= needs_space
= true;
3592 if ((mask
& OMP_CLAUSE_SEVERITY
)
3593 && (m
= gfc_match_dupl_check (!c
->severity
, "severity", true))
3596 if (m
== MATCH_ERROR
)
3598 if (gfc_match ("fatal )") == MATCH_YES
)
3599 c
->severity
= OMP_SEVERITY_FATAL
;
3600 else if (gfc_match ("warning )") == MATCH_YES
)
3601 c
->severity
= OMP_SEVERITY_WARNING
;
3604 gfc_error ("Expected FATAL or WARNING in SEVERITY clause "
3612 if ((mask
& OMP_CLAUSE_TASK_REDUCTION
)
3613 && gfc_match_omp_clause_reduction (pc
, c
, openacc
,
3614 allow_derived
) == MATCH_YES
)
3616 if ((mask
& OMP_CLAUSE_THREAD_LIMIT
)
3617 && (m
= gfc_match_dupl_check (!c
->thread_limit
, "thread_limit",
3618 true, &c
->thread_limit
))
3621 if (m
== MATCH_ERROR
)
3625 if ((mask
& OMP_CLAUSE_THREADS
)
3626 && (m
= gfc_match_dupl_check (!c
->threads
, "threads"))
3629 if (m
== MATCH_ERROR
)
3631 c
->threads
= needs_space
= true;
3634 if ((mask
& OMP_CLAUSE_TILE
)
3636 && match_oacc_expr_list ("tile (", &c
->tile_list
,
3639 if ((mask
& OMP_CLAUSE_TO
) && (mask
& OMP_CLAUSE_LINK
))
3641 /* Declare target: 'to' is an alias for 'enter';
3642 'to' is deprecated since 5.2. */
3643 m
= gfc_match_omp_to_link ("to (", &c
->lists
[OMP_LIST_TO
]);
3644 if (m
== MATCH_ERROR
)
3649 else if ((mask
& OMP_CLAUSE_TO
)
3650 && gfc_match_motion_var_list ("to (", &c
->lists
[OMP_LIST_TO
],
3651 &head
) == MATCH_YES
)
3655 if ((mask
& OMP_CLAUSE_UNIFORM
)
3656 && gfc_match_omp_variable_list ("uniform (",
3657 &c
->lists
[OMP_LIST_UNIFORM
],
3658 false) == MATCH_YES
)
3660 if ((mask
& OMP_CLAUSE_UNTIED
)
3661 && (m
= gfc_match_dupl_check (!c
->untied
, "untied")) != MATCH_NO
)
3663 if (m
== MATCH_ERROR
)
3665 c
->untied
= needs_space
= true;
3668 if ((mask
& OMP_CLAUSE_ATOMIC
)
3669 && (m
= gfc_match_dupl_atomic ((c
->atomic_op
3670 == GFC_OMP_ATOMIC_UNSET
),
3671 "update")) != MATCH_NO
)
3673 if (m
== MATCH_ERROR
)
3675 c
->atomic_op
= GFC_OMP_ATOMIC_UPDATE
;
3679 if ((mask
& OMP_CLAUSE_USE_DEVICE
)
3680 && gfc_match_omp_variable_list ("use_device (",
3681 &c
->lists
[OMP_LIST_USE_DEVICE
],
3684 if ((mask
& OMP_CLAUSE_USE_DEVICE_PTR
)
3685 && gfc_match_omp_variable_list
3686 ("use_device_ptr (",
3687 &c
->lists
[OMP_LIST_USE_DEVICE_PTR
], false) == MATCH_YES
)
3689 if ((mask
& OMP_CLAUSE_USE_DEVICE_ADDR
)
3690 && gfc_match_omp_variable_list
3691 ("use_device_addr (", &c
->lists
[OMP_LIST_USE_DEVICE_ADDR
],
3692 false, NULL
, NULL
, true) == MATCH_YES
)
3694 if ((mask
& OMP_CLAUSE_USES_ALLOCATORS
)
3695 && (gfc_match ("uses_allocators ( ") == MATCH_YES
))
3697 if (gfc_match_omp_clause_uses_allocators (c
) != MATCH_YES
)
3703 /* VECTOR_LENGTH must be matched before VECTOR, because the latter
3704 doesn't unconditionally match '('. */
3705 if ((mask
& OMP_CLAUSE_VECTOR_LENGTH
)
3706 && (m
= gfc_match_dupl_check (!c
->vector_length_expr
,
3707 "vector_length", true,
3708 &c
->vector_length_expr
))
3711 if (m
== MATCH_ERROR
)
3715 if ((mask
& OMP_CLAUSE_VECTOR
)
3716 && (m
= gfc_match_dupl_check (!c
->vector
, "vector")) != MATCH_NO
)
3718 if (m
== MATCH_ERROR
)
3721 m
= match_oacc_clause_gwv (c
, GOMP_DIM_VECTOR
);
3722 if (m
== MATCH_ERROR
)
3730 if ((mask
& OMP_CLAUSE_WAIT
)
3731 && gfc_match ("wait") == MATCH_YES
)
3733 m
= match_oacc_expr_list (" (", &c
->wait_list
, false);
3734 if (m
== MATCH_ERROR
)
3736 else if (m
== MATCH_NO
)
3739 = gfc_get_constant_expr (BT_INTEGER
,
3740 gfc_default_integer_kind
,
3741 &gfc_current_locus
);
3742 mpz_set_si (expr
->value
.integer
, GOMP_ASYNC_NOVAL
);
3743 gfc_expr_list
**expr_list
= &c
->wait_list
;
3745 expr_list
= &(*expr_list
)->next
;
3746 *expr_list
= gfc_get_expr_list ();
3747 (*expr_list
)->expr
= expr
;
3752 if ((mask
& OMP_CLAUSE_WEAK
)
3753 && (m
= gfc_match_dupl_check (!c
->weak
, "weak"))
3756 if (m
== MATCH_ERROR
)
3762 if ((mask
& OMP_CLAUSE_WORKER
)
3763 && (m
= gfc_match_dupl_check (!c
->worker
, "worker")) != MATCH_NO
)
3765 if (m
== MATCH_ERROR
)
3768 m
= match_oacc_clause_gwv (c
, GOMP_DIM_WORKER
);
3769 if (m
== MATCH_ERROR
)
3771 else if (m
== MATCH_NO
)
3775 if ((mask
& OMP_CLAUSE_ATOMIC
)
3776 && (m
= gfc_match_dupl_atomic ((c
->atomic_op
3777 == GFC_OMP_ATOMIC_UNSET
),
3778 "write")) != MATCH_NO
)
3780 if (m
== MATCH_ERROR
)
3782 c
->atomic_op
= GFC_OMP_ATOMIC_WRITE
;
3793 || (context_selector
&& gfc_peek_ascii_char () != ')')
3794 || (!context_selector
&& gfc_match_omp_eos () != MATCH_YES
))
3796 if (!gfc_error_flag_test ())
3797 gfc_error ("Failed to match clause at %C");
3798 gfc_free_omp_clauses (c
);
3811 #define OACC_PARALLEL_CLAUSES \
3812 (omp_mask (OMP_CLAUSE_IF) | OMP_CLAUSE_ASYNC | OMP_CLAUSE_NUM_GANGS \
3813 | OMP_CLAUSE_NUM_WORKERS | OMP_CLAUSE_VECTOR_LENGTH | OMP_CLAUSE_REDUCTION \
3814 | OMP_CLAUSE_COPY | OMP_CLAUSE_COPYIN | OMP_CLAUSE_COPYOUT \
3815 | OMP_CLAUSE_CREATE | OMP_CLAUSE_NO_CREATE | OMP_CLAUSE_PRESENT \
3816 | OMP_CLAUSE_DEVICEPTR | OMP_CLAUSE_PRIVATE | OMP_CLAUSE_FIRSTPRIVATE \
3817 | OMP_CLAUSE_DEFAULT | OMP_CLAUSE_WAIT | OMP_CLAUSE_ATTACH \
3819 #define OACC_KERNELS_CLAUSES \
3820 (omp_mask (OMP_CLAUSE_IF) | OMP_CLAUSE_ASYNC | OMP_CLAUSE_NUM_GANGS \
3821 | OMP_CLAUSE_NUM_WORKERS | OMP_CLAUSE_VECTOR_LENGTH | OMP_CLAUSE_DEVICEPTR \
3822 | OMP_CLAUSE_COPY | OMP_CLAUSE_COPYIN | OMP_CLAUSE_COPYOUT \
3823 | OMP_CLAUSE_CREATE | OMP_CLAUSE_NO_CREATE | OMP_CLAUSE_PRESENT \
3824 | OMP_CLAUSE_DEFAULT | OMP_CLAUSE_WAIT | OMP_CLAUSE_ATTACH \
3826 #define OACC_SERIAL_CLAUSES \
3827 (omp_mask (OMP_CLAUSE_IF) | OMP_CLAUSE_ASYNC | OMP_CLAUSE_REDUCTION \
3828 | OMP_CLAUSE_COPY | OMP_CLAUSE_COPYIN | OMP_CLAUSE_COPYOUT \
3829 | OMP_CLAUSE_CREATE | OMP_CLAUSE_NO_CREATE | OMP_CLAUSE_PRESENT \
3830 | OMP_CLAUSE_DEVICEPTR | OMP_CLAUSE_PRIVATE | OMP_CLAUSE_FIRSTPRIVATE \
3831 | OMP_CLAUSE_DEFAULT | OMP_CLAUSE_WAIT | OMP_CLAUSE_ATTACH \
3833 #define OACC_DATA_CLAUSES \
3834 (omp_mask (OMP_CLAUSE_IF) | OMP_CLAUSE_DEVICEPTR | OMP_CLAUSE_COPY \
3835 | OMP_CLAUSE_COPYIN | OMP_CLAUSE_COPYOUT | OMP_CLAUSE_CREATE \
3836 | OMP_CLAUSE_NO_CREATE | OMP_CLAUSE_PRESENT | OMP_CLAUSE_ATTACH \
3837 | OMP_CLAUSE_DEFAULT)
3838 #define OACC_LOOP_CLAUSES \
3839 (omp_mask (OMP_CLAUSE_COLLAPSE) | OMP_CLAUSE_GANG | OMP_CLAUSE_WORKER \
3840 | OMP_CLAUSE_VECTOR | OMP_CLAUSE_SEQ | OMP_CLAUSE_INDEPENDENT \
3841 | OMP_CLAUSE_PRIVATE | OMP_CLAUSE_REDUCTION | OMP_CLAUSE_AUTO \
3843 #define OACC_PARALLEL_LOOP_CLAUSES \
3844 (OACC_LOOP_CLAUSES | OACC_PARALLEL_CLAUSES)
3845 #define OACC_KERNELS_LOOP_CLAUSES \
3846 (OACC_LOOP_CLAUSES | OACC_KERNELS_CLAUSES)
3847 #define OACC_SERIAL_LOOP_CLAUSES \
3848 (OACC_LOOP_CLAUSES | OACC_SERIAL_CLAUSES)
3849 #define OACC_HOST_DATA_CLAUSES \
3850 (omp_mask (OMP_CLAUSE_USE_DEVICE) \
3852 | OMP_CLAUSE_IF_PRESENT)
3853 #define OACC_DECLARE_CLAUSES \
3854 (omp_mask (OMP_CLAUSE_COPY) | OMP_CLAUSE_COPYIN | OMP_CLAUSE_COPYOUT \
3855 | OMP_CLAUSE_CREATE | OMP_CLAUSE_DEVICEPTR | OMP_CLAUSE_DEVICE_RESIDENT \
3856 | OMP_CLAUSE_PRESENT \
3858 #define OACC_UPDATE_CLAUSES \
3859 (omp_mask (OMP_CLAUSE_IF) | OMP_CLAUSE_ASYNC | OMP_CLAUSE_HOST \
3860 | OMP_CLAUSE_DEVICE | OMP_CLAUSE_WAIT | OMP_CLAUSE_IF_PRESENT \
3862 #define OACC_ENTER_DATA_CLAUSES \
3863 (omp_mask (OMP_CLAUSE_IF) | OMP_CLAUSE_ASYNC | OMP_CLAUSE_WAIT \
3864 | OMP_CLAUSE_COPYIN | OMP_CLAUSE_CREATE | OMP_CLAUSE_ATTACH)
3865 #define OACC_EXIT_DATA_CLAUSES \
3866 (omp_mask (OMP_CLAUSE_IF) | OMP_CLAUSE_ASYNC | OMP_CLAUSE_WAIT \
3867 | OMP_CLAUSE_COPYOUT | OMP_CLAUSE_DELETE | OMP_CLAUSE_FINALIZE \
3868 | OMP_CLAUSE_DETACH)
3869 #define OACC_WAIT_CLAUSES \
3870 omp_mask (OMP_CLAUSE_ASYNC)
3871 #define OACC_ROUTINE_CLAUSES \
3872 (omp_mask (OMP_CLAUSE_GANG) | OMP_CLAUSE_WORKER | OMP_CLAUSE_VECTOR \
3874 | OMP_CLAUSE_NOHOST)
3878 match_acc (gfc_exec_op op
, const omp_mask mask
)
3881 if (gfc_match_omp_clauses (&c
, mask
, false, false, true) != MATCH_YES
)
3884 new_st
.ext
.omp_clauses
= c
;
3889 gfc_match_oacc_parallel_loop (void)
3891 return match_acc (EXEC_OACC_PARALLEL_LOOP
, OACC_PARALLEL_LOOP_CLAUSES
);
3896 gfc_match_oacc_parallel (void)
3898 return match_acc (EXEC_OACC_PARALLEL
, OACC_PARALLEL_CLAUSES
);
3903 gfc_match_oacc_kernels_loop (void)
3905 return match_acc (EXEC_OACC_KERNELS_LOOP
, OACC_KERNELS_LOOP_CLAUSES
);
3910 gfc_match_oacc_kernels (void)
3912 return match_acc (EXEC_OACC_KERNELS
, OACC_KERNELS_CLAUSES
);
3917 gfc_match_oacc_serial_loop (void)
3919 return match_acc (EXEC_OACC_SERIAL_LOOP
, OACC_SERIAL_LOOP_CLAUSES
);
3924 gfc_match_oacc_serial (void)
3926 return match_acc (EXEC_OACC_SERIAL
, OACC_SERIAL_CLAUSES
);
3931 gfc_match_oacc_data (void)
3933 return match_acc (EXEC_OACC_DATA
, OACC_DATA_CLAUSES
);
3938 gfc_match_oacc_host_data (void)
3940 return match_acc (EXEC_OACC_HOST_DATA
, OACC_HOST_DATA_CLAUSES
);
3945 gfc_match_oacc_loop (void)
3947 return match_acc (EXEC_OACC_LOOP
, OACC_LOOP_CLAUSES
);
3952 gfc_match_oacc_declare (void)
3955 gfc_omp_namelist
*n
;
3956 gfc_namespace
*ns
= gfc_current_ns
;
3957 gfc_oacc_declare
*new_oc
;
3958 bool module_var
= false;
3959 locus where
= gfc_current_locus
;
3961 if (gfc_match_omp_clauses (&c
, OACC_DECLARE_CLAUSES
, false, false, true)
3965 for (n
= c
->lists
[OMP_LIST_DEVICE_RESIDENT
]; n
!= NULL
; n
= n
->next
)
3966 n
->sym
->attr
.oacc_declare_device_resident
= 1;
3968 for (n
= c
->lists
[OMP_LIST_LINK
]; n
!= NULL
; n
= n
->next
)
3969 n
->sym
->attr
.oacc_declare_link
= 1;
3971 for (n
= c
->lists
[OMP_LIST_MAP
]; n
!= NULL
; n
= n
->next
)
3973 gfc_symbol
*s
= n
->sym
;
3975 if (gfc_current_ns
->proc_name
3976 && gfc_current_ns
->proc_name
->attr
.flavor
== FL_MODULE
)
3978 if (n
->u
.map_op
!= OMP_MAP_ALLOC
&& n
->u
.map_op
!= OMP_MAP_TO
)
3980 gfc_error ("Invalid clause in module with !$ACC DECLARE at %L",
3988 if (s
->attr
.use_assoc
)
3990 gfc_error ("Variable is USE-associated with !$ACC DECLARE at %L",
3995 if ((s
->result
== s
&& s
->ns
->contained
!= gfc_current_ns
)
3996 || ((s
->attr
.flavor
== FL_UNKNOWN
|| s
->attr
.flavor
== FL_VARIABLE
)
3997 && s
->ns
!= gfc_current_ns
))
3999 gfc_error ("Variable %qs shall be declared in the same scoping unit "
4000 "as !$ACC DECLARE at %L", s
->name
, &where
);
4004 if ((s
->attr
.dimension
|| s
->attr
.codimension
)
4005 && s
->attr
.dummy
&& s
->as
->type
!= AS_EXPLICIT
)
4007 gfc_error ("Assumed-size dummy array with !$ACC DECLARE at %L",
4012 switch (n
->u
.map_op
)
4014 case OMP_MAP_FORCE_ALLOC
:
4016 s
->attr
.oacc_declare_create
= 1;
4019 case OMP_MAP_FORCE_TO
:
4021 s
->attr
.oacc_declare_copyin
= 1;
4024 case OMP_MAP_FORCE_DEVICEPTR
:
4025 s
->attr
.oacc_declare_deviceptr
= 1;
4033 new_oc
= gfc_get_oacc_declare ();
4034 new_oc
->next
= ns
->oacc_declare
;
4035 new_oc
->module_var
= module_var
;
4036 new_oc
->clauses
= c
;
4037 new_oc
->loc
= gfc_current_locus
;
4038 ns
->oacc_declare
= new_oc
;
4045 gfc_match_oacc_update (void)
4048 locus here
= gfc_current_locus
;
4050 if (gfc_match_omp_clauses (&c
, OACC_UPDATE_CLAUSES
, false, false, true)
4054 if (!c
->lists
[OMP_LIST_MAP
])
4056 gfc_error ("%<acc update%> must contain at least one "
4057 "%<device%> or %<host%> or %<self%> clause at %L", &here
);
4061 new_st
.op
= EXEC_OACC_UPDATE
;
4062 new_st
.ext
.omp_clauses
= c
;
4068 gfc_match_oacc_enter_data (void)
4070 return match_acc (EXEC_OACC_ENTER_DATA
, OACC_ENTER_DATA_CLAUSES
);
4075 gfc_match_oacc_exit_data (void)
4077 return match_acc (EXEC_OACC_EXIT_DATA
, OACC_EXIT_DATA_CLAUSES
);
4082 gfc_match_oacc_wait (void)
4084 gfc_omp_clauses
*c
= gfc_get_omp_clauses ();
4085 gfc_expr_list
*wait_list
= NULL
, *el
;
4089 m
= match_oacc_expr_list (" (", &wait_list
, true);
4090 if (m
== MATCH_ERROR
)
4092 else if (m
== MATCH_YES
)
4095 if (gfc_match_omp_clauses (&c
, OACC_WAIT_CLAUSES
, space
, space
, true)
4100 for (el
= wait_list
; el
; el
= el
->next
)
4102 if (el
->expr
== NULL
)
4104 gfc_error ("Invalid argument to !$ACC WAIT at %C");
4108 if (!gfc_resolve_expr (el
->expr
)
4109 || el
->expr
->ts
.type
!= BT_INTEGER
|| el
->expr
->rank
!= 0)
4111 gfc_error ("WAIT clause at %L requires a scalar INTEGER expression",
4117 c
->wait_list
= wait_list
;
4118 new_st
.op
= EXEC_OACC_WAIT
;
4119 new_st
.ext
.omp_clauses
= c
;
4125 gfc_match_oacc_cache (void)
4127 gfc_omp_clauses
*c
= gfc_get_omp_clauses ();
4128 /* The OpenACC cache directive explicitly only allows "array elements or
4129 subarrays", which we're currently not checking here. Either check this
4130 after the call of gfc_match_omp_variable_list, or add something like a
4131 only_sections variant next to its allow_sections parameter. */
4132 match m
= gfc_match_omp_variable_list (" (",
4133 &c
->lists
[OMP_LIST_CACHE
], true,
4137 gfc_free_omp_clauses(c
);
4141 if (gfc_current_state() != COMP_DO
4142 && gfc_current_state() != COMP_DO_CONCURRENT
)
4144 gfc_error ("ACC CACHE directive must be inside of loop %C");
4145 gfc_free_omp_clauses(c
);
4149 new_st
.op
= EXEC_OACC_CACHE
;
4150 new_st
.ext
.omp_clauses
= c
;
4154 /* Determine the OpenACC 'routine' directive's level of parallelism. */
4156 static oacc_routine_lop
4157 gfc_oacc_routine_lop (gfc_omp_clauses
*clauses
)
4159 oacc_routine_lop ret
= OACC_ROUTINE_LOP_SEQ
;
4163 unsigned n_lop_clauses
= 0;
4168 ret
= OACC_ROUTINE_LOP_GANG
;
4170 if (clauses
->worker
)
4173 ret
= OACC_ROUTINE_LOP_WORKER
;
4175 if (clauses
->vector
)
4178 ret
= OACC_ROUTINE_LOP_VECTOR
;
4183 ret
= OACC_ROUTINE_LOP_SEQ
;
4186 if (n_lop_clauses
> 1)
4187 ret
= OACC_ROUTINE_LOP_ERROR
;
4194 gfc_match_oacc_routine (void)
4198 gfc_intrinsic_sym
*isym
= NULL
;
4199 gfc_symbol
*sym
= NULL
;
4200 gfc_omp_clauses
*c
= NULL
;
4201 gfc_oacc_routine_name
*n
= NULL
;
4202 oacc_routine_lop lop
= OACC_ROUTINE_LOP_NONE
;
4205 old_loc
= gfc_current_locus
;
4207 m
= gfc_match (" (");
4209 if (gfc_current_ns
->proc_name
4210 && gfc_current_ns
->proc_name
->attr
.if_source
== IFSRC_IFBODY
4213 gfc_error ("Only the !$ACC ROUTINE form without "
4214 "list is allowed in interface block at %C");
4220 char buffer
[GFC_MAX_SYMBOL_LEN
+ 1];
4222 m
= gfc_match_name (buffer
);
4225 gfc_symtree
*st
= NULL
;
4227 /* First look for an intrinsic symbol. */
4228 isym
= gfc_find_function (buffer
);
4230 isym
= gfc_find_subroutine (buffer
);
4231 /* If no intrinsic symbol found, search the current namespace. */
4233 st
= gfc_find_symtree (gfc_current_ns
->sym_root
, buffer
);
4237 /* If the name in a 'routine' directive refers to the containing
4238 subroutine or function, then make sure that we'll later handle
4239 this accordingly. */
4240 if (gfc_current_ns
->proc_name
!= NULL
4241 && strcmp (sym
->name
, gfc_current_ns
->proc_name
->name
) == 0)
4245 if (isym
== NULL
&& st
== NULL
)
4247 gfc_error ("Invalid NAME %qs in !$ACC ROUTINE ( NAME ) at %C",
4249 gfc_current_locus
= old_loc
;
4255 gfc_error ("Syntax error in !$ACC ROUTINE ( NAME ) at %C");
4256 gfc_current_locus
= old_loc
;
4260 if (gfc_match_char (')') != MATCH_YES
)
4262 gfc_error ("Syntax error in !$ACC ROUTINE ( NAME ) at %C, expecting"
4263 " %<)%> after NAME");
4264 gfc_current_locus
= old_loc
;
4269 if (gfc_match_omp_eos () != MATCH_YES
4270 && (gfc_match_omp_clauses (&c
, OACC_ROUTINE_CLAUSES
, false, false, true)
4274 lop
= gfc_oacc_routine_lop (c
);
4275 if (lop
== OACC_ROUTINE_LOP_ERROR
)
4277 gfc_error ("Multiple loop axes specified for routine at %C");
4280 nohost
= c
? c
->nohost
: false;
4284 /* Diagnose any OpenACC 'routine' directive that doesn't match the
4285 (implicit) one with a 'seq' clause. */
4286 if (c
&& (c
->gang
|| c
->worker
|| c
->vector
))
4288 gfc_error ("Intrinsic symbol specified in !$ACC ROUTINE ( NAME )"
4289 " at %C marked with incompatible GANG, WORKER, or VECTOR"
4293 /* ..., and no 'nohost' clause. */
4296 gfc_error ("Intrinsic symbol specified in !$ACC ROUTINE ( NAME )"
4297 " at %C marked with incompatible NOHOST clause");
4301 else if (sym
!= NULL
)
4305 /* For a repeated OpenACC 'routine' directive, diagnose if it doesn't
4306 match the first one. */
4307 for (gfc_oacc_routine_name
*n_p
= gfc_current_ns
->oacc_routine_names
;
4310 if (n_p
->sym
== sym
)
4313 bool nohost_p
= n_p
->clauses
? n_p
->clauses
->nohost
: false;
4314 if (lop
!= gfc_oacc_routine_lop (n_p
->clauses
)
4315 || nohost
!= nohost_p
)
4317 gfc_error ("!$ACC ROUTINE already applied at %C");
4324 sym
->attr
.oacc_routine_lop
= lop
;
4325 sym
->attr
.oacc_routine_nohost
= nohost
;
4327 n
= gfc_get_oacc_routine_name ();
4330 n
->next
= gfc_current_ns
->oacc_routine_names
;
4332 gfc_current_ns
->oacc_routine_names
= n
;
4335 else if (gfc_current_ns
->proc_name
)
4337 /* For a repeated OpenACC 'routine' directive, diagnose if it doesn't
4338 match the first one. */
4339 oacc_routine_lop lop_p
= gfc_current_ns
->proc_name
->attr
.oacc_routine_lop
;
4340 bool nohost_p
= gfc_current_ns
->proc_name
->attr
.oacc_routine_nohost
;
4341 if (lop_p
!= OACC_ROUTINE_LOP_NONE
4343 || nohost
!= nohost_p
))
4345 gfc_error ("!$ACC ROUTINE already applied at %C");
4349 if (!gfc_add_omp_declare_target (&gfc_current_ns
->proc_name
->attr
,
4350 gfc_current_ns
->proc_name
->name
,
4353 gfc_current_ns
->proc_name
->attr
.oacc_routine_lop
= lop
;
4354 gfc_current_ns
->proc_name
->attr
.oacc_routine_nohost
= nohost
;
4357 /* Something has gone wrong, possibly a syntax error. */
4360 if (gfc_pure (NULL
) && c
&& (c
->gang
|| c
->worker
|| c
->vector
))
4362 gfc_error ("!$ACC ROUTINE with GANG, WORKER, or VECTOR clause is not "
4363 "permitted in PURE procedure at %C");
4370 else if (gfc_current_ns
->oacc_routine
)
4371 gfc_current_ns
->oacc_routine_clauses
= c
;
4373 new_st
.op
= EXEC_OACC_ROUTINE
;
4374 new_st
.ext
.omp_clauses
= c
;
4378 gfc_current_locus
= old_loc
;
4383 #define OMP_PARALLEL_CLAUSES \
4384 (omp_mask (OMP_CLAUSE_PRIVATE) | OMP_CLAUSE_FIRSTPRIVATE \
4385 | OMP_CLAUSE_SHARED | OMP_CLAUSE_COPYIN | OMP_CLAUSE_REDUCTION \
4386 | OMP_CLAUSE_IF | OMP_CLAUSE_NUM_THREADS | OMP_CLAUSE_DEFAULT \
4387 | OMP_CLAUSE_PROC_BIND | OMP_CLAUSE_ALLOCATE)
4388 #define OMP_DECLARE_SIMD_CLAUSES \
4389 (omp_mask (OMP_CLAUSE_SIMDLEN) | OMP_CLAUSE_LINEAR \
4390 | OMP_CLAUSE_UNIFORM | OMP_CLAUSE_ALIGNED | OMP_CLAUSE_INBRANCH \
4391 | OMP_CLAUSE_NOTINBRANCH)
4392 #define OMP_DO_CLAUSES \
4393 (omp_mask (OMP_CLAUSE_PRIVATE) | OMP_CLAUSE_FIRSTPRIVATE \
4394 | OMP_CLAUSE_LASTPRIVATE | OMP_CLAUSE_REDUCTION \
4395 | OMP_CLAUSE_SCHEDULE | OMP_CLAUSE_ORDERED | OMP_CLAUSE_COLLAPSE \
4396 | OMP_CLAUSE_LINEAR | OMP_CLAUSE_ORDER | OMP_CLAUSE_ALLOCATE \
4397 | OMP_CLAUSE_NOWAIT)
4398 #define OMP_LOOP_CLAUSES \
4399 (omp_mask (OMP_CLAUSE_BIND) | OMP_CLAUSE_COLLAPSE | OMP_CLAUSE_ORDER \
4400 | OMP_CLAUSE_PRIVATE | OMP_CLAUSE_LASTPRIVATE | OMP_CLAUSE_REDUCTION)
4402 #define OMP_SCOPE_CLAUSES \
4403 (omp_mask (OMP_CLAUSE_PRIVATE) |OMP_CLAUSE_FIRSTPRIVATE \
4404 | OMP_CLAUSE_REDUCTION | OMP_CLAUSE_ALLOCATE | OMP_CLAUSE_NOWAIT)
4405 #define OMP_SECTIONS_CLAUSES \
4406 (omp_mask (OMP_CLAUSE_PRIVATE) | OMP_CLAUSE_FIRSTPRIVATE \
4407 | OMP_CLAUSE_LASTPRIVATE | OMP_CLAUSE_REDUCTION \
4408 | OMP_CLAUSE_ALLOCATE | OMP_CLAUSE_NOWAIT)
4409 #define OMP_SIMD_CLAUSES \
4410 (omp_mask (OMP_CLAUSE_PRIVATE) | OMP_CLAUSE_LASTPRIVATE \
4411 | OMP_CLAUSE_REDUCTION | OMP_CLAUSE_COLLAPSE | OMP_CLAUSE_SAFELEN \
4412 | OMP_CLAUSE_LINEAR | OMP_CLAUSE_ALIGNED | OMP_CLAUSE_SIMDLEN \
4413 | OMP_CLAUSE_IF | OMP_CLAUSE_ORDER | OMP_CLAUSE_NOTEMPORAL)
4414 #define OMP_TASK_CLAUSES \
4415 (omp_mask (OMP_CLAUSE_PRIVATE) | OMP_CLAUSE_FIRSTPRIVATE \
4416 | OMP_CLAUSE_SHARED | OMP_CLAUSE_IF | OMP_CLAUSE_DEFAULT \
4417 | OMP_CLAUSE_UNTIED | OMP_CLAUSE_FINAL | OMP_CLAUSE_MERGEABLE \
4418 | OMP_CLAUSE_DEPEND | OMP_CLAUSE_PRIORITY | OMP_CLAUSE_IN_REDUCTION \
4419 | OMP_CLAUSE_DETACH | OMP_CLAUSE_AFFINITY | OMP_CLAUSE_ALLOCATE)
4420 #define OMP_TASKLOOP_CLAUSES \
4421 (omp_mask (OMP_CLAUSE_PRIVATE) | OMP_CLAUSE_FIRSTPRIVATE \
4422 | OMP_CLAUSE_LASTPRIVATE | OMP_CLAUSE_SHARED | OMP_CLAUSE_IF \
4423 | OMP_CLAUSE_DEFAULT | OMP_CLAUSE_UNTIED | OMP_CLAUSE_FINAL \
4424 | OMP_CLAUSE_MERGEABLE | OMP_CLAUSE_PRIORITY | OMP_CLAUSE_GRAINSIZE \
4425 | OMP_CLAUSE_NUM_TASKS | OMP_CLAUSE_COLLAPSE | OMP_CLAUSE_NOGROUP \
4426 | OMP_CLAUSE_REDUCTION | OMP_CLAUSE_IN_REDUCTION | OMP_CLAUSE_ALLOCATE)
4427 #define OMP_TASKGROUP_CLAUSES \
4428 (omp_mask (OMP_CLAUSE_TASK_REDUCTION) | OMP_CLAUSE_ALLOCATE)
4429 #define OMP_TARGET_CLAUSES \
4430 (omp_mask (OMP_CLAUSE_DEVICE) | OMP_CLAUSE_MAP | OMP_CLAUSE_IF \
4431 | OMP_CLAUSE_DEPEND | OMP_CLAUSE_NOWAIT | OMP_CLAUSE_PRIVATE \
4432 | OMP_CLAUSE_FIRSTPRIVATE | OMP_CLAUSE_DEFAULTMAP \
4433 | OMP_CLAUSE_IS_DEVICE_PTR | OMP_CLAUSE_IN_REDUCTION \
4434 | OMP_CLAUSE_THREAD_LIMIT | OMP_CLAUSE_ALLOCATE \
4435 | OMP_CLAUSE_HAS_DEVICE_ADDR | OMP_CLAUSE_USES_ALLOCATORS)
4436 #define OMP_TARGET_DATA_CLAUSES \
4437 (omp_mask (OMP_CLAUSE_DEVICE) | OMP_CLAUSE_MAP | OMP_CLAUSE_IF \
4438 | OMP_CLAUSE_USE_DEVICE_PTR | OMP_CLAUSE_USE_DEVICE_ADDR)
4439 #define OMP_TARGET_ENTER_DATA_CLAUSES \
4440 (omp_mask (OMP_CLAUSE_DEVICE) | OMP_CLAUSE_MAP | OMP_CLAUSE_IF \
4441 | OMP_CLAUSE_DEPEND | OMP_CLAUSE_NOWAIT)
4442 #define OMP_TARGET_EXIT_DATA_CLAUSES \
4443 (omp_mask (OMP_CLAUSE_DEVICE) | OMP_CLAUSE_MAP | OMP_CLAUSE_IF \
4444 | OMP_CLAUSE_DEPEND | OMP_CLAUSE_NOWAIT)
4445 #define OMP_TARGET_UPDATE_CLAUSES \
4446 (omp_mask (OMP_CLAUSE_DEVICE) | OMP_CLAUSE_IF | OMP_CLAUSE_TO \
4447 | OMP_CLAUSE_FROM | OMP_CLAUSE_DEPEND | OMP_CLAUSE_NOWAIT)
4448 #define OMP_TEAMS_CLAUSES \
4449 (omp_mask (OMP_CLAUSE_NUM_TEAMS) | OMP_CLAUSE_THREAD_LIMIT \
4450 | OMP_CLAUSE_DEFAULT | OMP_CLAUSE_PRIVATE | OMP_CLAUSE_FIRSTPRIVATE \
4451 | OMP_CLAUSE_SHARED | OMP_CLAUSE_REDUCTION | OMP_CLAUSE_ALLOCATE)
4452 #define OMP_DISTRIBUTE_CLAUSES \
4453 (omp_mask (OMP_CLAUSE_PRIVATE) | OMP_CLAUSE_FIRSTPRIVATE \
4454 | OMP_CLAUSE_LASTPRIVATE | OMP_CLAUSE_COLLAPSE | OMP_CLAUSE_DIST_SCHEDULE \
4455 | OMP_CLAUSE_ORDER | OMP_CLAUSE_ALLOCATE)
4456 #define OMP_SINGLE_CLAUSES \
4457 (omp_mask (OMP_CLAUSE_PRIVATE) | OMP_CLAUSE_FIRSTPRIVATE \
4458 | OMP_CLAUSE_ALLOCATE | OMP_CLAUSE_NOWAIT | OMP_CLAUSE_COPYPRIVATE)
4459 #define OMP_ORDERED_CLAUSES \
4460 (omp_mask (OMP_CLAUSE_THREADS) | OMP_CLAUSE_SIMD)
4461 #define OMP_DECLARE_TARGET_CLAUSES \
4462 (omp_mask (OMP_CLAUSE_ENTER) | OMP_CLAUSE_LINK | OMP_CLAUSE_DEVICE_TYPE \
4464 #define OMP_ATOMIC_CLAUSES \
4465 (omp_mask (OMP_CLAUSE_ATOMIC) | OMP_CLAUSE_CAPTURE | OMP_CLAUSE_HINT \
4466 | OMP_CLAUSE_MEMORDER | OMP_CLAUSE_COMPARE | OMP_CLAUSE_FAIL \
4468 #define OMP_MASKED_CLAUSES \
4469 (omp_mask (OMP_CLAUSE_FILTER))
4470 #define OMP_ERROR_CLAUSES \
4471 (omp_mask (OMP_CLAUSE_AT) | OMP_CLAUSE_MESSAGE | OMP_CLAUSE_SEVERITY)
4472 #define OMP_WORKSHARE_CLAUSES \
4473 omp_mask (OMP_CLAUSE_NOWAIT)
4474 #define OMP_ALLOCATORS_CLAUSES \
4475 omp_mask (OMP_CLAUSE_ALLOCATE)
4479 match_omp (gfc_exec_op op
, const omp_mask mask
)
4482 if (gfc_match_omp_clauses (&c
, mask
, true, true, false, false,
4483 op
== EXEC_OMP_TARGET
) != MATCH_YES
)
4486 new_st
.ext
.omp_clauses
= c
;
4490 /* Handles both declarative and (deprecated) executable ALLOCATE directive;
4491 accepts optional list (for executable) and common blocks.
4492 If no variables have been provided, the single omp namelist has sym == NULL.
4494 Note that the executable ALLOCATE directive permits structure elements only
4495 in OpenMP 5.0 and 5.1 but not longer in 5.2. See also the comment on the
4496 'omp allocators' directive below. The accidental change was reverted for
4497 OpenMP TR12, permitting them again. See also gfc_match_omp_allocators.
4499 Hence, structure elements are rejected for now, also to make resolving
4500 OMP_LIST_ALLOCATE simpler (check for duplicates, same symbol in
4501 Fortran allocate stmt). TODO: Permit structure elements. */
4504 gfc_match_omp_allocate (void)
4508 gfc_omp_namelist
*vars
= NULL
;
4509 gfc_expr
*align
= NULL
;
4510 gfc_expr
*allocator
= NULL
;
4511 locus loc
= gfc_current_locus
;
4513 m
= gfc_match_omp_variable_list (" (", &vars
, true, NULL
, NULL
, true, true,
4516 if (m
== MATCH_ERROR
)
4521 gfc_gobble_whitespace ();
4522 if (gfc_match_omp_eos () == MATCH_YES
)
4527 if ((m
= gfc_match_dupl_check (!align
, "align", true, &align
))
4530 if (m
== MATCH_ERROR
)
4534 if ((m
= gfc_match_dupl_check (!allocator
, "allocator",
4535 true, &allocator
)) != MATCH_NO
)
4537 if (m
== MATCH_ERROR
)
4541 gfc_error ("Expected ALIGN or ALLOCATOR clause at %C");
4544 for (gfc_omp_namelist
*n
= vars
; n
; n
= n
->next
)
4547 if ((n
->expr
->ref
&& n
->expr
->ref
->type
== REF_COMPONENT
)
4548 || (n
->expr
->ref
->next
&& n
->expr
->ref
->type
== REF_COMPONENT
))
4549 gfc_error ("Sorry, structure-element list item at %L in ALLOCATE "
4550 "directive is not yet supported", &n
->expr
->where
);
4552 gfc_error ("Unexpected expression as list item at %L in ALLOCATE "
4553 "directive", &n
->expr
->where
);
4555 gfc_free_omp_namelist (vars
, false, true, false);
4559 new_st
.op
= EXEC_OMP_ALLOCATE
;
4560 new_st
.ext
.omp_clauses
= gfc_get_omp_clauses ();
4563 vars
= gfc_get_omp_namelist ();
4565 vars
->u
.align
= align
;
4566 vars
->u2
.allocator
= allocator
;
4567 new_st
.ext
.omp_clauses
->lists
[OMP_LIST_ALLOCATE
] = vars
;
4571 new_st
.ext
.omp_clauses
->lists
[OMP_LIST_ALLOCATE
] = vars
;
4572 for (; vars
; vars
= vars
->next
)
4574 vars
->u
.align
= (align
) ? gfc_copy_expr (align
) : NULL
;
4575 vars
->u2
.allocator
= allocator
;
4577 gfc_free_expr (align
);
4582 gfc_free_expr (align
);
4583 gfc_free_expr (allocator
);
4587 /* In line with OpenMP 5.2 derived-type components are rejected.
4588 See also comment before gfc_match_omp_allocate. */
4591 gfc_match_omp_allocators (void)
4593 return match_omp (EXEC_OMP_ALLOCATORS
, OMP_ALLOCATORS_CLAUSES
);
4598 gfc_match_omp_assume (void)
4601 locus loc
= gfc_current_locus
;
4602 if ((gfc_match_omp_clauses (&c
, omp_mask (OMP_CLAUSE_ASSUMPTIONS
))
4604 || (omp_verify_merge_absent_contains (ST_OMP_ASSUME
, c
->assume
, NULL
,
4605 &loc
) != MATCH_YES
))
4607 new_st
.op
= EXEC_OMP_ASSUME
;
4608 new_st
.ext
.omp_clauses
= c
;
4614 gfc_match_omp_assumes (void)
4617 locus loc
= gfc_current_locus
;
4618 if (!gfc_current_ns
->proc_name
4619 || (gfc_current_ns
->proc_name
->attr
.flavor
!= FL_MODULE
4620 && !gfc_current_ns
->proc_name
->attr
.subroutine
4621 && !gfc_current_ns
->proc_name
->attr
.function
))
4623 gfc_error ("!$OMP ASSUMES at %C must be in the specification part of a "
4624 "subprogram or module");
4627 if ((gfc_match_omp_clauses (&c
, omp_mask (OMP_CLAUSE_ASSUMPTIONS
))
4629 || (omp_verify_merge_absent_contains (ST_OMP_ASSUMES
, c
->assume
,
4630 gfc_current_ns
->omp_assumes
, &loc
)
4633 if (gfc_current_ns
->omp_assumes
== NULL
)
4635 gfc_current_ns
->omp_assumes
= c
->assume
;
4638 else if (gfc_current_ns
->omp_assumes
&& c
->assume
)
4640 gfc_current_ns
->omp_assumes
->no_openmp
|= c
->assume
->no_openmp
;
4641 gfc_current_ns
->omp_assumes
->no_openmp_routines
4642 |= c
->assume
->no_openmp_routines
;
4643 gfc_current_ns
->omp_assumes
->no_parallelism
|= c
->assume
->no_parallelism
;
4644 if (gfc_current_ns
->omp_assumes
->holds
&& c
->assume
->holds
)
4646 gfc_expr_list
*el
= gfc_current_ns
->omp_assumes
->holds
;
4647 for ( ; el
->next
; el
= el
->next
)
4649 el
->next
= c
->assume
->holds
;
4651 else if (c
->assume
->holds
)
4652 gfc_current_ns
->omp_assumes
->holds
= c
->assume
->holds
;
4653 c
->assume
->holds
= NULL
;
4655 gfc_free_omp_clauses (c
);
4661 gfc_match_omp_critical (void)
4663 char n
[GFC_MAX_SYMBOL_LEN
+1];
4664 gfc_omp_clauses
*c
= NULL
;
4666 if (gfc_match (" ( %n )", n
) != MATCH_YES
)
4669 if (gfc_match_omp_clauses (&c
, omp_mask (OMP_CLAUSE_HINT
),
4670 /* first = */ n
[0] == '\0') != MATCH_YES
)
4673 new_st
.op
= EXEC_OMP_CRITICAL
;
4674 new_st
.ext
.omp_clauses
= c
;
4676 c
->critical_name
= xstrdup (n
);
4682 gfc_match_omp_end_critical (void)
4684 char n
[GFC_MAX_SYMBOL_LEN
+1];
4686 if (gfc_match (" ( %n )", n
) != MATCH_YES
)
4688 if (gfc_match_omp_eos () != MATCH_YES
)
4690 gfc_error ("Unexpected junk after $OMP CRITICAL statement at %C");
4694 new_st
.op
= EXEC_OMP_END_CRITICAL
;
4695 new_st
.ext
.omp_name
= n
[0] ? xstrdup (n
) : NULL
;
4699 /* depobj(depobj) depend(dep-type:loc)|destroy|update(dep-type)
4700 dep-type = in/out/inout/mutexinoutset/depobj/source/sink
4701 depend: !source, !sink
4702 update: !source, !sink, !depobj
4703 locator = exactly one list item .*/
4705 gfc_match_omp_depobj (void)
4707 gfc_omp_clauses
*c
= NULL
;
4710 if (gfc_match (" ( %v ) ", &depobj
) != MATCH_YES
)
4712 gfc_error ("Expected %<( depobj )%> at %C");
4715 if (gfc_match ("update ( ") == MATCH_YES
)
4717 c
= gfc_get_omp_clauses ();
4718 if (gfc_match ("inoutset )") == MATCH_YES
)
4719 c
->depobj_update
= OMP_DEPEND_INOUTSET
;
4720 else if (gfc_match ("inout )") == MATCH_YES
)
4721 c
->depobj_update
= OMP_DEPEND_INOUT
;
4722 else if (gfc_match ("in )") == MATCH_YES
)
4723 c
->depobj_update
= OMP_DEPEND_IN
;
4724 else if (gfc_match ("out )") == MATCH_YES
)
4725 c
->depobj_update
= OMP_DEPEND_OUT
;
4726 else if (gfc_match ("mutexinoutset )") == MATCH_YES
)
4727 c
->depobj_update
= OMP_DEPEND_MUTEXINOUTSET
;
4730 gfc_error ("Expected IN, OUT, INOUT, INOUTSET or MUTEXINOUTSET "
4731 "followed by %<)%> at %C");
4735 else if (gfc_match ("destroy ") == MATCH_YES
)
4737 gfc_expr
*destroyobj
= NULL
;
4738 c
= gfc_get_omp_clauses ();
4741 if (gfc_match (" ( %v ) ", &destroyobj
) == MATCH_YES
)
4743 if (destroyobj
->symtree
!= depobj
->symtree
)
4744 gfc_warning (0, "The same depend object should be used as DEPOBJ "
4745 "argument at %L and as DESTROY argument at %L",
4746 &depobj
->where
, &destroyobj
->where
);
4747 gfc_free_expr (destroyobj
);
4750 else if (gfc_match_omp_clauses (&c
, omp_mask (OMP_CLAUSE_DEPEND
), true, false)
4754 if (c
->depobj_update
== OMP_DEPEND_UNSET
&& !c
->destroy
)
4756 if (!c
->doacross_source
&& !c
->lists
[OMP_LIST_DEPEND
])
4758 gfc_error ("Expected DEPEND, UPDATE, or DESTROY clause at %C");
4761 if (c
->lists
[OMP_LIST_DEPEND
]->u
.depend_doacross_op
== OMP_DEPEND_DEPOBJ
)
4763 gfc_error ("DEPEND clause at %L of OMP DEPOBJ construct shall not "
4764 "have dependence-type DEPOBJ",
4765 c
->lists
[OMP_LIST_DEPEND
]
4766 ? &c
->lists
[OMP_LIST_DEPEND
]->where
: &gfc_current_locus
);
4769 if (c
->lists
[OMP_LIST_DEPEND
]->next
)
4771 gfc_error ("DEPEND clause at %L of OMP DEPOBJ construct shall have "
4772 "only a single locator",
4773 &c
->lists
[OMP_LIST_DEPEND
]->next
->where
);
4779 new_st
.op
= EXEC_OMP_DEPOBJ
;
4780 new_st
.ext
.omp_clauses
= c
;
4784 gfc_free_expr (depobj
);
4785 gfc_free_omp_clauses (c
);
4790 gfc_match_omp_distribute (void)
4792 return match_omp (EXEC_OMP_DISTRIBUTE
, OMP_DISTRIBUTE_CLAUSES
);
4797 gfc_match_omp_distribute_parallel_do (void)
4799 return match_omp (EXEC_OMP_DISTRIBUTE_PARALLEL_DO
,
4800 (OMP_DISTRIBUTE_CLAUSES
| OMP_PARALLEL_CLAUSES
4802 & ~(omp_mask (OMP_CLAUSE_ORDERED
)
4803 | OMP_CLAUSE_LINEAR
| OMP_CLAUSE_NOWAIT
));
4808 gfc_match_omp_distribute_parallel_do_simd (void)
4810 return match_omp (EXEC_OMP_DISTRIBUTE_PARALLEL_DO_SIMD
,
4811 (OMP_DISTRIBUTE_CLAUSES
| OMP_PARALLEL_CLAUSES
4812 | OMP_DO_CLAUSES
| OMP_SIMD_CLAUSES
)
4813 & ~(omp_mask (OMP_CLAUSE_ORDERED
) | OMP_CLAUSE_NOWAIT
));
4818 gfc_match_omp_distribute_simd (void)
4820 return match_omp (EXEC_OMP_DISTRIBUTE_SIMD
,
4821 OMP_DISTRIBUTE_CLAUSES
| OMP_SIMD_CLAUSES
);
4826 gfc_match_omp_do (void)
4828 return match_omp (EXEC_OMP_DO
, OMP_DO_CLAUSES
);
4833 gfc_match_omp_do_simd (void)
4835 return match_omp (EXEC_OMP_DO_SIMD
, OMP_DO_CLAUSES
| OMP_SIMD_CLAUSES
);
4840 gfc_match_omp_loop (void)
4842 return match_omp (EXEC_OMP_LOOP
, OMP_LOOP_CLAUSES
);
4847 gfc_match_omp_teams_loop (void)
4849 return match_omp (EXEC_OMP_TEAMS_LOOP
, OMP_TEAMS_CLAUSES
| OMP_LOOP_CLAUSES
);
4854 gfc_match_omp_target_teams_loop (void)
4856 return match_omp (EXEC_OMP_TARGET_TEAMS_LOOP
,
4857 OMP_TARGET_CLAUSES
| OMP_TEAMS_CLAUSES
| OMP_LOOP_CLAUSES
);
4862 gfc_match_omp_parallel_loop (void)
4864 return match_omp (EXEC_OMP_PARALLEL_LOOP
,
4865 OMP_PARALLEL_CLAUSES
| OMP_LOOP_CLAUSES
);
4870 gfc_match_omp_target_parallel_loop (void)
4872 return match_omp (EXEC_OMP_TARGET_PARALLEL_LOOP
,
4873 (OMP_TARGET_CLAUSES
| OMP_PARALLEL_CLAUSES
4874 | OMP_LOOP_CLAUSES
));
4879 gfc_match_omp_error (void)
4881 locus loc
= gfc_current_locus
;
4882 match m
= match_omp (EXEC_OMP_ERROR
, OMP_ERROR_CLAUSES
);
4886 gfc_omp_clauses
*c
= new_st
.ext
.omp_clauses
;
4887 if (c
->severity
== OMP_SEVERITY_UNSET
)
4888 c
->severity
= OMP_SEVERITY_FATAL
;
4889 if (new_st
.ext
.omp_clauses
->at
== OMP_AT_EXECUTION
)
4892 && (!gfc_resolve_expr (c
->message
)
4893 || c
->message
->ts
.type
!= BT_CHARACTER
4894 || c
->message
->ts
.kind
!= gfc_default_character_kind
4895 || c
->message
->rank
!= 0))
4897 gfc_error ("MESSAGE clause at %L requires a scalar default-kind "
4898 "CHARACTER expression",
4899 &new_st
.ext
.omp_clauses
->message
->where
);
4902 if (c
->message
&& !gfc_is_constant_expr (c
->message
))
4904 gfc_error ("Constant character expression required in MESSAGE clause "
4905 "at %L", &new_st
.ext
.omp_clauses
->message
->where
);
4910 const char *msg
= G_("$OMP ERROR encountered at %L: %s");
4911 gcc_assert (c
->message
->expr_type
== EXPR_CONSTANT
);
4912 gfc_charlen_t slen
= c
->message
->value
.character
.length
;
4913 int i
= gfc_validate_kind (BT_CHARACTER
, gfc_default_character_kind
,
4915 size_t size
= slen
* gfc_character_kinds
[i
].bit_size
/ 8;
4916 unsigned char *s
= XCNEWVAR (unsigned char, size
+ 1);
4917 gfc_encode_character (gfc_default_character_kind
, slen
,
4918 c
->message
->value
.character
.string
,
4919 (unsigned char *) s
, size
);
4921 if (c
->severity
== OMP_SEVERITY_WARNING
)
4922 gfc_warning_now (0, msg
, &loc
, s
);
4924 gfc_error_now (msg
, &loc
, s
);
4929 const char *msg
= G_("$OMP ERROR encountered at %L");
4930 if (c
->severity
== OMP_SEVERITY_WARNING
)
4931 gfc_warning_now (0, msg
, &loc
);
4933 gfc_error_now (msg
, &loc
);
4939 gfc_match_omp_flush (void)
4941 gfc_omp_namelist
*list
= NULL
;
4942 gfc_omp_clauses
*c
= NULL
;
4943 gfc_gobble_whitespace ();
4944 enum gfc_omp_memorder mo
= OMP_MEMORDER_UNSET
;
4945 if (gfc_match_omp_eos () == MATCH_NO
&& gfc_peek_ascii_char () != '(')
4947 if (gfc_match ("seq_cst") == MATCH_YES
)
4948 mo
= OMP_MEMORDER_SEQ_CST
;
4949 else if (gfc_match ("acq_rel") == MATCH_YES
)
4950 mo
= OMP_MEMORDER_ACQ_REL
;
4951 else if (gfc_match ("release") == MATCH_YES
)
4952 mo
= OMP_MEMORDER_RELEASE
;
4953 else if (gfc_match ("acquire") == MATCH_YES
)
4954 mo
= OMP_MEMORDER_ACQUIRE
;
4957 gfc_error ("Expected SEQ_CST, AQC_REL, RELEASE, or ACQUIRE at %C");
4960 c
= gfc_get_omp_clauses ();
4963 gfc_match_omp_variable_list (" (", &list
, true);
4964 if (list
&& mo
!= OMP_MEMORDER_UNSET
)
4966 gfc_error ("List specified together with memory order clause in FLUSH "
4968 gfc_free_omp_namelist (list
, false, false, false);
4969 gfc_free_omp_clauses (c
);
4972 if (gfc_match_omp_eos () != MATCH_YES
)
4974 gfc_error ("Unexpected junk after $OMP FLUSH statement at %C");
4975 gfc_free_omp_namelist (list
, false, false, false);
4976 gfc_free_omp_clauses (c
);
4979 new_st
.op
= EXEC_OMP_FLUSH
;
4980 new_st
.ext
.omp_namelist
= list
;
4981 new_st
.ext
.omp_clauses
= c
;
4987 gfc_match_omp_declare_simd (void)
4989 locus where
= gfc_current_locus
;
4990 gfc_symbol
*proc_name
;
4992 gfc_omp_declare_simd
*ods
;
4993 bool needs_space
= false;
4995 switch (gfc_match (" ( "))
4998 if (gfc_match_symbol (&proc_name
, /* host assoc = */ true) != MATCH_YES
4999 || gfc_match (" ) ") != MATCH_YES
)
5002 case MATCH_NO
: proc_name
= NULL
; needs_space
= true; break;
5003 case MATCH_ERROR
: return MATCH_ERROR
;
5006 if (gfc_match_omp_clauses (&c
, OMP_DECLARE_SIMD_CLAUSES
, true,
5007 needs_space
) != MATCH_YES
)
5010 if (gfc_current_ns
->is_block_data
)
5012 gfc_free_omp_clauses (c
);
5016 ods
= gfc_get_omp_declare_simd ();
5018 ods
->proc_name
= proc_name
;
5020 ods
->next
= gfc_current_ns
->omp_declare_simd
;
5021 gfc_current_ns
->omp_declare_simd
= ods
;
5027 match_udr_expr (gfc_symtree
*omp_sym1
, gfc_symtree
*omp_sym2
)
5030 locus old_loc
= gfc_current_locus
;
5031 char sname
[GFC_MAX_SYMBOL_LEN
+ 1];
5033 gfc_namespace
*ns
= gfc_current_ns
;
5034 gfc_expr
*lvalue
= NULL
, *rvalue
= NULL
;
5036 gfc_actual_arglist
*arglist
;
5038 m
= gfc_match (" %v =", &lvalue
);
5040 gfc_current_locus
= old_loc
;
5043 m
= gfc_match (" %e )", &rvalue
);
5046 ns
->code
= gfc_get_code (EXEC_ASSIGN
);
5047 ns
->code
->expr1
= lvalue
;
5048 ns
->code
->expr2
= rvalue
;
5049 ns
->code
->loc
= old_loc
;
5053 gfc_current_locus
= old_loc
;
5054 gfc_free_expr (lvalue
);
5057 m
= gfc_match (" %n", sname
);
5061 if (strcmp (sname
, omp_sym1
->name
) == 0
5062 || strcmp (sname
, omp_sym2
->name
) == 0)
5065 gfc_current_ns
= ns
->parent
;
5066 if (gfc_get_ha_sym_tree (sname
, &st
))
5070 if (sym
->attr
.flavor
!= FL_PROCEDURE
5071 && sym
->attr
.flavor
!= FL_UNKNOWN
)
5074 if (!sym
->attr
.generic
5075 && !sym
->attr
.subroutine
5076 && !sym
->attr
.function
)
5078 if (!(sym
->attr
.external
&& !sym
->attr
.referenced
))
5080 /* ...create a symbol in this scope... */
5081 if (sym
->ns
!= gfc_current_ns
5082 && gfc_get_sym_tree (sname
, NULL
, &st
, false) == 1)
5085 if (sym
!= st
->n
.sym
)
5089 /* ...and then to try to make the symbol into a subroutine. */
5090 if (!gfc_add_subroutine (&sym
->attr
, sym
->name
, NULL
))
5094 gfc_set_sym_referenced (sym
);
5095 gfc_gobble_whitespace ();
5096 if (gfc_peek_ascii_char () != '(')
5099 gfc_current_ns
= ns
;
5100 m
= gfc_match_actual_arglist (1, &arglist
);
5104 if (gfc_match_char (')') != MATCH_YES
)
5107 ns
->code
= gfc_get_code (EXEC_CALL
);
5108 ns
->code
->symtree
= st
;
5109 ns
->code
->ext
.actual
= arglist
;
5110 ns
->code
->loc
= old_loc
;
5115 gfc_omp_udr_predef (gfc_omp_reduction_op rop
, const char *name
,
5116 gfc_typespec
*ts
, const char **n
)
5118 if (!gfc_numeric_ts (ts
) && ts
->type
!= BT_LOGICAL
)
5123 case OMP_REDUCTION_PLUS
:
5124 case OMP_REDUCTION_MINUS
:
5125 case OMP_REDUCTION_TIMES
:
5126 return ts
->type
!= BT_LOGICAL
;
5127 case OMP_REDUCTION_AND
:
5128 case OMP_REDUCTION_OR
:
5129 case OMP_REDUCTION_EQV
:
5130 case OMP_REDUCTION_NEQV
:
5131 return ts
->type
== BT_LOGICAL
;
5132 case OMP_REDUCTION_USER
:
5133 if (name
[0] != '.' && (ts
->type
== BT_INTEGER
|| ts
->type
== BT_REAL
))
5137 gfc_find_symbol (name
, NULL
, 1, &sym
);
5140 if (sym
->attr
.intrinsic
)
5142 else if ((sym
->attr
.flavor
!= FL_UNKNOWN
5143 && sym
->attr
.flavor
!= FL_PROCEDURE
)
5144 || sym
->attr
.external
5145 || sym
->attr
.generic
5149 || sym
->attr
.subroutine
5150 || sym
->attr
.pointer
5152 || sym
->attr
.cray_pointer
5153 || sym
->attr
.cray_pointee
5154 || (sym
->attr
.proc
!= PROC_UNKNOWN
5155 && sym
->attr
.proc
!= PROC_INTRINSIC
)
5156 || sym
->attr
.if_source
!= IFSRC_UNKNOWN
5157 || sym
== sym
->ns
->proc_name
)
5165 && (strcmp (*n
, "max") == 0 || strcmp (*n
, "min") == 0))
5168 && ts
->type
== BT_INTEGER
5169 && (strcmp (*n
, "iand") == 0
5170 || strcmp (*n
, "ior") == 0
5171 || strcmp (*n
, "ieor") == 0))
5182 gfc_omp_udr_find (gfc_symtree
*st
, gfc_typespec
*ts
)
5184 gfc_omp_udr
*omp_udr
;
5189 for (omp_udr
= st
->n
.omp_udr
; omp_udr
; omp_udr
= omp_udr
->next
)
5190 if (omp_udr
->ts
.type
== ts
->type
5191 || ((omp_udr
->ts
.type
== BT_DERIVED
|| omp_udr
->ts
.type
== BT_CLASS
)
5192 && (ts
->type
== BT_DERIVED
|| ts
->type
== BT_CLASS
)))
5194 if (omp_udr
->ts
.type
== BT_DERIVED
|| omp_udr
->ts
.type
== BT_CLASS
)
5196 if (strcmp (omp_udr
->ts
.u
.derived
->name
, ts
->u
.derived
->name
) == 0)
5199 else if (omp_udr
->ts
.kind
== ts
->kind
)
5201 if (omp_udr
->ts
.type
== BT_CHARACTER
)
5203 if (omp_udr
->ts
.u
.cl
->length
== NULL
5204 || ts
->u
.cl
->length
== NULL
)
5206 if (omp_udr
->ts
.u
.cl
->length
->expr_type
!= EXPR_CONSTANT
)
5208 if (ts
->u
.cl
->length
->expr_type
!= EXPR_CONSTANT
)
5210 if (omp_udr
->ts
.u
.cl
->length
->ts
.type
!= BT_INTEGER
)
5212 if (ts
->u
.cl
->length
->ts
.type
!= BT_INTEGER
)
5214 if (gfc_compare_expr (omp_udr
->ts
.u
.cl
->length
,
5215 ts
->u
.cl
->length
, INTRINSIC_EQ
) != 0)
5225 gfc_match_omp_declare_reduction (void)
5228 gfc_intrinsic_op op
;
5229 char name
[GFC_MAX_SYMBOL_LEN
+ 3];
5230 auto_vec
<gfc_typespec
, 5> tss
;
5234 locus where
= gfc_current_locus
;
5235 locus end_loc
= gfc_current_locus
;
5236 bool end_loc_set
= false;
5237 gfc_omp_reduction_op rop
= OMP_REDUCTION_NONE
;
5239 if (gfc_match_char ('(') != MATCH_YES
)
5242 m
= gfc_match (" %o : ", &op
);
5243 if (m
== MATCH_ERROR
)
5247 snprintf (name
, sizeof name
, "operator %s", gfc_op2string (op
));
5248 rop
= (gfc_omp_reduction_op
) op
;
5252 m
= gfc_match_defined_op_name (name
+ 1, 1);
5253 if (m
== MATCH_ERROR
)
5259 if (gfc_match (" : ") != MATCH_YES
)
5264 if (gfc_match (" %n : ", name
) != MATCH_YES
)
5267 rop
= OMP_REDUCTION_USER
;
5270 m
= gfc_match_type_spec (&ts
);
5273 /* Treat len=: the same as len=*. */
5274 if (ts
.type
== BT_CHARACTER
)
5275 ts
.deferred
= false;
5278 while (gfc_match_char (',') == MATCH_YES
)
5280 m
= gfc_match_type_spec (&ts
);
5285 if (gfc_match_char (':') != MATCH_YES
)
5288 st
= gfc_find_symtree (gfc_current_ns
->omp_udr_root
, name
);
5289 for (i
= 0; i
< tss
.length (); i
++)
5291 gfc_symtree
*omp_out
, *omp_in
;
5292 gfc_symtree
*omp_priv
= NULL
, *omp_orig
= NULL
;
5293 gfc_namespace
*combiner_ns
, *initializer_ns
= NULL
;
5294 gfc_omp_udr
*prev_udr
, *omp_udr
;
5295 const char *predef_name
= NULL
;
5297 omp_udr
= gfc_get_omp_udr ();
5298 omp_udr
->name
= gfc_get_string ("%s", name
);
5300 omp_udr
->ts
= tss
[i
];
5301 omp_udr
->where
= where
;
5303 gfc_current_ns
= combiner_ns
= gfc_get_namespace (gfc_current_ns
, 1);
5304 combiner_ns
->proc_name
= combiner_ns
->parent
->proc_name
;
5306 gfc_get_sym_tree ("omp_out", combiner_ns
, &omp_out
, false);
5307 gfc_get_sym_tree ("omp_in", combiner_ns
, &omp_in
, false);
5308 combiner_ns
->omp_udr_ns
= 1;
5309 omp_out
->n
.sym
->ts
= tss
[i
];
5310 omp_in
->n
.sym
->ts
= tss
[i
];
5311 omp_out
->n
.sym
->attr
.omp_udr_artificial_var
= 1;
5312 omp_in
->n
.sym
->attr
.omp_udr_artificial_var
= 1;
5313 omp_out
->n
.sym
->attr
.flavor
= FL_VARIABLE
;
5314 omp_in
->n
.sym
->attr
.flavor
= FL_VARIABLE
;
5315 gfc_commit_symbols ();
5316 omp_udr
->combiner_ns
= combiner_ns
;
5317 omp_udr
->omp_out
= omp_out
->n
.sym
;
5318 omp_udr
->omp_in
= omp_in
->n
.sym
;
5320 locus old_loc
= gfc_current_locus
;
5322 if (!match_udr_expr (omp_out
, omp_in
))
5325 gfc_current_locus
= old_loc
;
5326 gfc_current_ns
= combiner_ns
->parent
;
5327 gfc_undo_symbols ();
5328 gfc_free_omp_udr (omp_udr
);
5332 if (gfc_match (" initializer ( ") == MATCH_YES
)
5334 gfc_current_ns
= combiner_ns
->parent
;
5335 initializer_ns
= gfc_get_namespace (gfc_current_ns
, 1);
5336 gfc_current_ns
= initializer_ns
;
5337 initializer_ns
->proc_name
= initializer_ns
->parent
->proc_name
;
5339 gfc_get_sym_tree ("omp_priv", initializer_ns
, &omp_priv
, false);
5340 gfc_get_sym_tree ("omp_orig", initializer_ns
, &omp_orig
, false);
5341 initializer_ns
->omp_udr_ns
= 1;
5342 omp_priv
->n
.sym
->ts
= tss
[i
];
5343 omp_orig
->n
.sym
->ts
= tss
[i
];
5344 omp_priv
->n
.sym
->attr
.omp_udr_artificial_var
= 1;
5345 omp_orig
->n
.sym
->attr
.omp_udr_artificial_var
= 1;
5346 omp_priv
->n
.sym
->attr
.flavor
= FL_VARIABLE
;
5347 omp_orig
->n
.sym
->attr
.flavor
= FL_VARIABLE
;
5348 gfc_commit_symbols ();
5349 omp_udr
->initializer_ns
= initializer_ns
;
5350 omp_udr
->omp_priv
= omp_priv
->n
.sym
;
5351 omp_udr
->omp_orig
= omp_orig
->n
.sym
;
5353 if (!match_udr_expr (omp_priv
, omp_orig
))
5357 gfc_current_ns
= combiner_ns
->parent
;
5361 end_loc
= gfc_current_locus
;
5363 gfc_current_locus
= old_loc
;
5365 prev_udr
= gfc_omp_udr_find (st
, &tss
[i
]);
5366 if (gfc_omp_udr_predef (rop
, name
, &tss
[i
], &predef_name
)
5367 /* Don't error on !$omp declare reduction (min : integer : ...)
5368 just yet, there could be integer :: min afterwards,
5369 making it valid. When the UDR is resolved, we'll get
5371 && (rop
!= OMP_REDUCTION_USER
|| name
[0] == '.'))
5374 gfc_error_now ("Redefinition of predefined %s "
5375 "!$OMP DECLARE REDUCTION at %L",
5376 predef_name
, &where
);
5378 gfc_error_now ("Redefinition of predefined "
5379 "!$OMP DECLARE REDUCTION at %L", &where
);
5383 gfc_error_now ("Redefinition of !$OMP DECLARE REDUCTION at %L",
5385 gfc_error_now ("Previous !$OMP DECLARE REDUCTION at %L",
5390 omp_udr
->next
= st
->n
.omp_udr
;
5391 st
->n
.omp_udr
= omp_udr
;
5395 st
= gfc_new_symtree (&gfc_current_ns
->omp_udr_root
, name
);
5396 st
->n
.omp_udr
= omp_udr
;
5402 gfc_current_locus
= end_loc
;
5403 if (gfc_match_omp_eos () != MATCH_YES
)
5405 gfc_error ("Unexpected junk after !$OMP DECLARE REDUCTION at %C");
5406 gfc_current_locus
= where
;
5418 gfc_match_omp_declare_target (void)
5422 gfc_omp_clauses
*c
= NULL
;
5424 gfc_omp_namelist
*n
;
5427 old_loc
= gfc_current_locus
;
5429 if (gfc_current_ns
->proc_name
5430 && gfc_match_omp_eos () == MATCH_YES
)
5432 if (!gfc_add_omp_declare_target (&gfc_current_ns
->proc_name
->attr
,
5433 gfc_current_ns
->proc_name
->name
,
5439 if (gfc_current_ns
->proc_name
5440 && gfc_current_ns
->proc_name
->attr
.if_source
== IFSRC_IFBODY
)
5442 gfc_error ("Only the !$OMP DECLARE TARGET form without "
5443 "clauses is allowed in interface block at %C");
5447 m
= gfc_match (" (");
5450 c
= gfc_get_omp_clauses ();
5451 gfc_current_locus
= old_loc
;
5452 m
= gfc_match_omp_to_link (" (", &c
->lists
[OMP_LIST_ENTER
]);
5455 if (gfc_match_omp_eos () != MATCH_YES
)
5457 gfc_error ("Unexpected junk after !$OMP DECLARE TARGET at %C");
5461 else if (gfc_match_omp_clauses (&c
, OMP_DECLARE_TARGET_CLAUSES
) != MATCH_YES
)
5464 gfc_buffer_error (false);
5466 static const int to_enter_link_lists
[]
5467 = { OMP_LIST_TO
, OMP_LIST_ENTER
, OMP_LIST_LINK
};
5468 for (size_t listn
= 0; listn
< ARRAY_SIZE (to_enter_link_lists
)
5469 && (list
= to_enter_link_lists
[listn
], true); ++listn
)
5470 for (n
= c
->lists
[list
]; n
; n
= n
->next
)
5473 else if (n
->u
.common
->head
)
5474 n
->u
.common
->head
->mark
= 0;
5476 for (size_t listn
= 0; listn
< ARRAY_SIZE (to_enter_link_lists
)
5477 && (list
= to_enter_link_lists
[listn
], true); ++listn
)
5478 for (n
= c
->lists
[list
]; n
; n
= n
->next
)
5481 if (n
->sym
->attr
.in_common
)
5482 gfc_error_now ("OMP DECLARE TARGET variable at %L is an "
5483 "element of a COMMON block", &n
->where
);
5484 else if (n
->sym
->mark
)
5485 gfc_error_now ("Variable at %L mentioned multiple times in "
5486 "clauses of the same OMP DECLARE TARGET directive",
5488 else if (n
->sym
->attr
.omp_declare_target
5489 && n
->sym
->attr
.omp_declare_target_link
5490 && list
!= OMP_LIST_LINK
)
5491 gfc_error_now ("OMP DECLARE TARGET variable at %L previously "
5492 "mentioned in LINK clause and later in %s clause",
5493 &n
->where
, list
== OMP_LIST_TO
? "TO" : "ENTER");
5494 else if (n
->sym
->attr
.omp_declare_target
5495 && !n
->sym
->attr
.omp_declare_target_link
5496 && list
== OMP_LIST_LINK
)
5497 gfc_error_now ("OMP DECLARE TARGET variable at %L previously "
5498 "mentioned in TO or ENTER clause and later in "
5499 "LINK clause", &n
->where
);
5500 else if (gfc_add_omp_declare_target (&n
->sym
->attr
, n
->sym
->name
,
5501 &n
->sym
->declared_at
))
5503 if (list
== OMP_LIST_LINK
)
5504 gfc_add_omp_declare_target_link (&n
->sym
->attr
, n
->sym
->name
,
5505 &n
->sym
->declared_at
);
5507 if (c
->device_type
!= OMP_DEVICE_TYPE_UNSET
)
5509 if (n
->sym
->attr
.omp_device_type
!= OMP_DEVICE_TYPE_UNSET
5510 && n
->sym
->attr
.omp_device_type
!= c
->device_type
)
5511 gfc_error_now ("List item %qs at %L set in previous OMP DECLARE "
5512 "TARGET directive to a different DEVICE_TYPE",
5513 n
->sym
->name
, &n
->where
);
5514 n
->sym
->attr
.omp_device_type
= c
->device_type
;
5518 else if (n
->u
.common
->omp_declare_target
5519 && n
->u
.common
->omp_declare_target_link
5520 && list
!= OMP_LIST_LINK
)
5521 gfc_error_now ("OMP DECLARE TARGET COMMON at %L previously "
5522 "mentioned in LINK clause and later in %s clause",
5523 &n
->where
, list
== OMP_LIST_TO
? "TO" : "ENTER");
5524 else if (n
->u
.common
->omp_declare_target
5525 && !n
->u
.common
->omp_declare_target_link
5526 && list
== OMP_LIST_LINK
)
5527 gfc_error_now ("OMP DECLARE TARGET COMMON at %L previously "
5528 "mentioned in TO or ENTER clause and later in "
5529 "LINK clause", &n
->where
);
5530 else if (n
->u
.common
->head
&& n
->u
.common
->head
->mark
)
5531 gfc_error_now ("COMMON at %L mentioned multiple times in "
5532 "clauses of the same OMP DECLARE TARGET directive",
5536 n
->u
.common
->omp_declare_target
= 1;
5537 n
->u
.common
->omp_declare_target_link
= (list
== OMP_LIST_LINK
);
5538 if (n
->u
.common
->omp_device_type
!= OMP_DEVICE_TYPE_UNSET
5539 && n
->u
.common
->omp_device_type
!= c
->device_type
)
5540 gfc_error_now ("COMMON at %L set in previous OMP DECLARE "
5541 "TARGET directive to a different DEVICE_TYPE",
5543 n
->u
.common
->omp_device_type
= c
->device_type
;
5545 for (s
= n
->u
.common
->head
; s
; s
= s
->common_next
)
5548 if (gfc_add_omp_declare_target (&s
->attr
, s
->name
,
5551 if (list
== OMP_LIST_LINK
)
5552 gfc_add_omp_declare_target_link (&s
->attr
, s
->name
,
5555 if (s
->attr
.omp_device_type
!= OMP_DEVICE_TYPE_UNSET
5556 && s
->attr
.omp_device_type
!= c
->device_type
)
5557 gfc_error_now ("List item %qs at %L set in previous OMP DECLARE"
5558 " TARGET directive to a different DEVICE_TYPE",
5559 s
->name
, &n
->where
);
5560 s
->attr
.omp_device_type
= c
->device_type
;
5564 && !c
->lists
[OMP_LIST_ENTER
]
5565 && !c
->lists
[OMP_LIST_TO
]
5566 && !c
->lists
[OMP_LIST_LINK
])
5567 gfc_warning_now (OPT_Wopenmp
,
5568 "OMP DECLARE TARGET directive at %L with only "
5569 "DEVICE_TYPE clause is ignored", &old_loc
);
5571 gfc_buffer_error (true);
5574 gfc_free_omp_clauses (c
);
5578 gfc_error ("Syntax error in !$OMP DECLARE TARGET list at %C");
5581 gfc_current_locus
= old_loc
;
5583 gfc_free_omp_clauses (c
);
5588 static const char *const omp_construct_selectors
[] = {
5589 "simd", "target", "teams", "parallel", "do", NULL
};
5590 static const char *const omp_device_selectors
[] = {
5591 "kind", "isa", "arch", NULL
};
5592 static const char *const omp_implementation_selectors
[] = {
5593 "vendor", "extension", "atomic_default_mem_order", "unified_address",
5594 "unified_shared_memory", "dynamic_allocators", "reverse_offload", NULL
};
5595 static const char *const omp_user_selectors
[] = {
5596 "condition", NULL
};
5602 trait-selector-name[([trait-score:]trait-property[,trait-property[,...]])]
5605 score(score-expression) */
5608 gfc_match_omp_context_selector (gfc_omp_set_selector
*oss
)
5612 char selector
[GFC_MAX_SYMBOL_LEN
+ 1];
5614 if (gfc_match_name (selector
) != MATCH_YES
)
5616 gfc_error ("expected trait selector name at %C");
5620 gfc_omp_selector
*os
= gfc_get_omp_selector ();
5621 os
->trait_selector_name
= XNEWVEC (char, strlen (selector
) + 1);
5622 strcpy (os
->trait_selector_name
, selector
);
5623 os
->next
= oss
->trait_selectors
;
5624 oss
->trait_selectors
= os
;
5626 const char *const *selectors
= NULL
;
5627 bool allow_score
= true;
5628 bool allow_user
= false;
5629 int property_limit
= 0;
5630 enum gfc_omp_trait_property_kind property_kind
= CTX_PROPERTY_NONE
;
5631 switch (oss
->trait_set_selector_name
[0])
5633 case 'c': /* construct */
5634 selectors
= omp_construct_selectors
;
5635 allow_score
= false;
5637 property_kind
= CTX_PROPERTY_SIMD
;
5639 case 'd': /* device */
5640 selectors
= omp_device_selectors
;
5641 allow_score
= false;
5644 property_kind
= CTX_PROPERTY_NAME_LIST
;
5646 case 'i': /* implementation */
5647 selectors
= omp_implementation_selectors
;
5650 property_kind
= CTX_PROPERTY_NAME_LIST
;
5652 case 'u': /* user */
5653 selectors
= omp_user_selectors
;
5655 property_kind
= CTX_PROPERTY_EXPR
;
5660 for (int i
= 0; ; i
++)
5662 if (selectors
[i
] == NULL
)
5666 property_kind
= CTX_PROPERTY_USER
;
5671 gfc_error ("selector %qs not allowed for context selector "
5673 selector
, oss
->trait_set_selector_name
);
5677 if (i
== property_limit
)
5678 property_kind
= CTX_PROPERTY_NONE
;
5679 if (strcmp (selectors
[i
], selector
) == 0)
5682 if (property_kind
== CTX_PROPERTY_NAME_LIST
5683 && oss
->trait_set_selector_name
[0] == 'i'
5684 && strcmp (selector
, "atomic_default_mem_order") == 0)
5685 property_kind
= CTX_PROPERTY_ID
;
5687 if (gfc_match (" (") == MATCH_YES
)
5689 if (property_kind
== CTX_PROPERTY_NONE
)
5691 gfc_error ("selector %qs does not accept any properties at %C",
5696 if (allow_score
&& gfc_match (" score") == MATCH_YES
)
5698 if (gfc_match (" (") != MATCH_YES
)
5700 gfc_error ("expected %<(%> at %C");
5703 if (gfc_match_expr (&os
->score
) != MATCH_YES
5704 || !gfc_resolve_expr (os
->score
)
5705 || os
->score
->ts
.type
!= BT_INTEGER
5706 || os
->score
->rank
!= 0)
5708 gfc_error ("score argument must be constant integer "
5709 "expression at %C");
5713 if (os
->score
->expr_type
== EXPR_CONSTANT
5714 && mpz_sgn (os
->score
->value
.integer
) < 0)
5716 gfc_error ("score argument must be non-negative at %C");
5720 if (gfc_match (" )") != MATCH_YES
)
5722 gfc_error ("expected %<)%> at %C");
5726 if (gfc_match (" :") != MATCH_YES
)
5728 gfc_error ("expected : at %C");
5733 gfc_omp_trait_property
*otp
= gfc_get_omp_trait_property ();
5734 otp
->property_kind
= property_kind
;
5735 otp
->next
= os
->properties
;
5736 os
->properties
= otp
;
5738 switch (property_kind
)
5740 case CTX_PROPERTY_USER
:
5743 if (gfc_match_expr (&otp
->expr
) != MATCH_YES
)
5745 gfc_error ("property must be constant integer "
5746 "expression or string literal at %C");
5750 if (gfc_match (" ,") != MATCH_YES
)
5755 case CTX_PROPERTY_ID
:
5757 char buf
[GFC_MAX_SYMBOL_LEN
+ 1];
5758 if (gfc_match_name (buf
) == MATCH_YES
)
5760 otp
->name
= XNEWVEC (char, strlen (buf
) + 1);
5761 strcpy (otp
->name
, buf
);
5765 gfc_error ("expected identifier at %C");
5770 case CTX_PROPERTY_NAME_LIST
:
5773 char buf
[GFC_MAX_SYMBOL_LEN
+ 1];
5774 if (gfc_match_name (buf
) == MATCH_YES
)
5776 otp
->name
= XNEWVEC (char, strlen (buf
) + 1);
5777 strcpy (otp
->name
, buf
);
5778 otp
->is_name
= true;
5780 else if (gfc_match_literal_constant (&otp
->expr
, 0)
5782 || otp
->expr
->ts
.type
!= BT_CHARACTER
)
5784 gfc_error ("expected identifier or string literal "
5789 if (gfc_match (" ,") == MATCH_YES
)
5791 otp
= gfc_get_omp_trait_property ();
5792 otp
->property_kind
= property_kind
;
5793 otp
->next
= os
->properties
;
5794 os
->properties
= otp
;
5801 case CTX_PROPERTY_EXPR
:
5802 if (gfc_match_expr (&otp
->expr
) != MATCH_YES
)
5804 gfc_error ("expected expression at %C");
5807 if (!gfc_resolve_expr (otp
->expr
)
5808 || (otp
->expr
->ts
.type
!= BT_LOGICAL
5809 && otp
->expr
->ts
.type
!= BT_INTEGER
)
5810 || otp
->expr
->rank
!= 0)
5812 gfc_error ("property must be constant integer or logical "
5813 "expression at %C");
5817 case CTX_PROPERTY_SIMD
:
5819 if (gfc_match_omp_clauses (&otp
->clauses
,
5820 OMP_DECLARE_SIMD_CLAUSES
,
5821 true, false, false, true)
5824 gfc_error ("expected simd clause at %C");
5833 if (gfc_match (" )") != MATCH_YES
)
5835 gfc_error ("expected %<)%> at %C");
5839 else if (property_kind
== CTX_PROPERTY_NAME_LIST
5840 || property_kind
== CTX_PROPERTY_ID
5841 || property_kind
== CTX_PROPERTY_EXPR
)
5843 if (gfc_match (" (") != MATCH_YES
)
5845 gfc_error ("expected %<(%> at %C");
5850 if (gfc_match (" ,") != MATCH_YES
)
5860 trait-set-selector[,trait-set-selector[,...]]
5863 trait-set-selector-name = { trait-selector[, trait-selector[, ...]] }
5865 trait-set-selector-name:
5872 gfc_match_omp_context_selector_specification (gfc_omp_declare_variant
*odv
)
5877 const char *selector_sets
[] = { "construct", "device",
5878 "implementation", "user" };
5879 const int selector_set_count
= ARRAY_SIZE (selector_sets
);
5881 char buf
[GFC_MAX_SYMBOL_LEN
+ 1];
5883 m
= gfc_match_name (buf
);
5885 for (i
= 0; i
< selector_set_count
; i
++)
5886 if (strcmp (buf
, selector_sets
[i
]) == 0)
5889 if (m
!= MATCH_YES
|| i
== selector_set_count
)
5891 gfc_error ("expected %<construct%>, %<device%>, %<implementation%> "
5892 "or %<user%> at %C");
5896 m
= gfc_match (" =");
5899 gfc_error ("expected %<=%> at %C");
5903 m
= gfc_match (" {");
5906 gfc_error ("expected %<{%> at %C");
5910 gfc_omp_set_selector
*oss
= gfc_get_omp_set_selector ();
5911 oss
->next
= odv
->set_selectors
;
5912 oss
->trait_set_selector_name
= selector_sets
[i
];
5913 odv
->set_selectors
= oss
;
5915 if (gfc_match_omp_context_selector (oss
) != MATCH_YES
)
5918 m
= gfc_match (" }");
5921 gfc_error ("expected %<}%> at %C");
5925 m
= gfc_match (" ,");
5936 gfc_match_omp_declare_variant (void)
5938 bool first_p
= true;
5939 char buf
[GFC_MAX_SYMBOL_LEN
+ 1];
5941 if (gfc_match (" (") != MATCH_YES
)
5943 gfc_error ("expected %<(%> at %C");
5947 gfc_symtree
*base_proc_st
, *variant_proc_st
;
5948 if (gfc_match_name (buf
) != MATCH_YES
)
5950 gfc_error ("expected name at %C");
5954 if (gfc_get_ha_sym_tree (buf
, &base_proc_st
))
5957 if (gfc_match (" :") == MATCH_YES
)
5959 if (gfc_match_name (buf
) != MATCH_YES
)
5961 gfc_error ("expected variant name at %C");
5965 if (gfc_get_ha_sym_tree (buf
, &variant_proc_st
))
5970 /* Base procedure not specified. */
5971 variant_proc_st
= base_proc_st
;
5972 base_proc_st
= NULL
;
5975 gfc_omp_declare_variant
*odv
;
5976 odv
= gfc_get_omp_declare_variant ();
5977 odv
->where
= gfc_current_locus
;
5978 odv
->variant_proc_symtree
= variant_proc_st
;
5979 odv
->base_proc_symtree
= base_proc_st
;
5981 odv
->error_p
= false;
5983 /* Add the new declare variant to the end of the list. */
5984 gfc_omp_declare_variant
**prev_next
= &gfc_current_ns
->omp_declare_variant
;
5986 prev_next
= &((*prev_next
)->next
);
5989 if (gfc_match (" )") != MATCH_YES
)
5991 gfc_error ("expected %<)%> at %C");
5997 if (gfc_match (" match") != MATCH_YES
)
6001 gfc_error ("expected %<match%> at %C");
6008 if (gfc_match (" (") != MATCH_YES
)
6010 gfc_error ("expected %<(%> at %C");
6014 if (gfc_match_omp_context_selector_specification (odv
) != MATCH_YES
)
6017 if (gfc_match (" )") != MATCH_YES
)
6019 gfc_error ("expected %<)%> at %C");
6031 gfc_match_omp_threadprivate (void)
6034 char n
[GFC_MAX_SYMBOL_LEN
+1];
6039 old_loc
= gfc_current_locus
;
6041 m
= gfc_match (" (");
6047 m
= gfc_match_symbol (&sym
, 0);
6051 if (sym
->attr
.in_common
)
6052 gfc_error_now ("Threadprivate variable at %C is an element of "
6054 else if (!gfc_add_threadprivate (&sym
->attr
, sym
->name
, &sym
->declared_at
))
6063 m
= gfc_match (" / %n /", n
);
6064 if (m
== MATCH_ERROR
)
6066 if (m
== MATCH_NO
|| n
[0] == '\0')
6069 st
= gfc_find_symtree (gfc_current_ns
->common_root
, n
);
6072 gfc_error ("COMMON block /%s/ not found at %C", n
);
6075 st
->n
.common
->threadprivate
= 1;
6076 for (sym
= st
->n
.common
->head
; sym
; sym
= sym
->common_next
)
6077 if (!gfc_add_threadprivate (&sym
->attr
, sym
->name
, &sym
->declared_at
))
6081 if (gfc_match_char (')') == MATCH_YES
)
6083 if (gfc_match_char (',') != MATCH_YES
)
6087 if (gfc_match_omp_eos () != MATCH_YES
)
6089 gfc_error ("Unexpected junk after OMP THREADPRIVATE at %C");
6096 gfc_error ("Syntax error in !$OMP THREADPRIVATE list at %C");
6099 gfc_current_locus
= old_loc
;
6105 gfc_match_omp_parallel (void)
6107 return match_omp (EXEC_OMP_PARALLEL
, OMP_PARALLEL_CLAUSES
);
6112 gfc_match_omp_parallel_do (void)
6114 return match_omp (EXEC_OMP_PARALLEL_DO
,
6115 (OMP_PARALLEL_CLAUSES
| OMP_DO_CLAUSES
)
6116 & ~(omp_mask (OMP_CLAUSE_NOWAIT
)));
6121 gfc_match_omp_parallel_do_simd (void)
6123 return match_omp (EXEC_OMP_PARALLEL_DO_SIMD
,
6124 (OMP_PARALLEL_CLAUSES
| OMP_DO_CLAUSES
| OMP_SIMD_CLAUSES
)
6125 & ~(omp_mask (OMP_CLAUSE_NOWAIT
)));
6130 gfc_match_omp_parallel_masked (void)
6132 return match_omp (EXEC_OMP_PARALLEL_MASKED
,
6133 OMP_PARALLEL_CLAUSES
| OMP_MASKED_CLAUSES
);
6137 gfc_match_omp_parallel_masked_taskloop (void)
6139 return match_omp (EXEC_OMP_PARALLEL_MASKED_TASKLOOP
,
6140 (OMP_PARALLEL_CLAUSES
| OMP_MASKED_CLAUSES
6141 | OMP_TASKLOOP_CLAUSES
)
6142 & ~(omp_mask (OMP_CLAUSE_IN_REDUCTION
)));
6146 gfc_match_omp_parallel_masked_taskloop_simd (void)
6148 return match_omp (EXEC_OMP_PARALLEL_MASKED_TASKLOOP_SIMD
,
6149 (OMP_PARALLEL_CLAUSES
| OMP_MASKED_CLAUSES
6150 | OMP_TASKLOOP_CLAUSES
| OMP_SIMD_CLAUSES
)
6151 & ~(omp_mask (OMP_CLAUSE_IN_REDUCTION
)));
6155 gfc_match_omp_parallel_master (void)
6157 return match_omp (EXEC_OMP_PARALLEL_MASTER
, OMP_PARALLEL_CLAUSES
);
6161 gfc_match_omp_parallel_master_taskloop (void)
6163 return match_omp (EXEC_OMP_PARALLEL_MASTER_TASKLOOP
,
6164 (OMP_PARALLEL_CLAUSES
| OMP_TASKLOOP_CLAUSES
)
6165 & ~(omp_mask (OMP_CLAUSE_IN_REDUCTION
)));
6169 gfc_match_omp_parallel_master_taskloop_simd (void)
6171 return match_omp (EXEC_OMP_PARALLEL_MASTER_TASKLOOP_SIMD
,
6172 (OMP_PARALLEL_CLAUSES
| OMP_TASKLOOP_CLAUSES
6174 & ~(omp_mask (OMP_CLAUSE_IN_REDUCTION
)));
6178 gfc_match_omp_parallel_sections (void)
6180 return match_omp (EXEC_OMP_PARALLEL_SECTIONS
,
6181 (OMP_PARALLEL_CLAUSES
| OMP_SECTIONS_CLAUSES
)
6182 & ~(omp_mask (OMP_CLAUSE_NOWAIT
)));
6187 gfc_match_omp_parallel_workshare (void)
6189 return match_omp (EXEC_OMP_PARALLEL_WORKSHARE
, OMP_PARALLEL_CLAUSES
);
6193 gfc_check_omp_requires (gfc_namespace
*ns
, int ref_omp_requires
)
6195 if (ns
->omp_target_seen
6196 && (ns
->omp_requires
& OMP_REQ_TARGET_MASK
)
6197 != (ref_omp_requires
& OMP_REQ_TARGET_MASK
))
6199 gcc_assert (ns
->proc_name
);
6200 if ((ref_omp_requires
& OMP_REQ_REVERSE_OFFLOAD
)
6201 && !(ns
->omp_requires
& OMP_REQ_REVERSE_OFFLOAD
))
6202 gfc_error ("Program unit at %L has OpenMP device constructs/routines "
6203 "but does not set !$OMP REQUIRES REVERSE_OFFLOAD but other "
6204 "program units do", &ns
->proc_name
->declared_at
);
6205 if ((ref_omp_requires
& OMP_REQ_UNIFIED_ADDRESS
)
6206 && !(ns
->omp_requires
& OMP_REQ_UNIFIED_ADDRESS
))
6207 gfc_error ("Program unit at %L has OpenMP device constructs/routines "
6208 "but does not set !$OMP REQUIRES UNIFIED_ADDRESS but other "
6209 "program units do", &ns
->proc_name
->declared_at
);
6210 if ((ref_omp_requires
& OMP_REQ_UNIFIED_SHARED_MEMORY
)
6211 && !(ns
->omp_requires
& OMP_REQ_UNIFIED_SHARED_MEMORY
))
6212 gfc_error ("Program unit at %L has OpenMP device constructs/routines "
6213 "but does not set !$OMP REQUIRES UNIFIED_SHARED_MEMORY but "
6214 "other program units do", &ns
->proc_name
->declared_at
);
6219 gfc_omp_requires_add_clause (gfc_omp_requires_kind clause
,
6220 const char *clause_name
, locus
*loc
,
6221 const char *module_name
)
6223 gfc_namespace
*prog_unit
= gfc_current_ns
;
6224 while (prog_unit
->parent
)
6226 if (gfc_state_stack
->previous
6227 && gfc_state_stack
->previous
->state
== COMP_INTERFACE
)
6229 prog_unit
= prog_unit
->parent
;
6232 /* Requires added after use. */
6233 if (prog_unit
->omp_target_seen
6234 && (clause
& OMP_REQ_TARGET_MASK
)
6235 && !(prog_unit
->omp_requires
& clause
))
6238 gfc_error ("!$OMP REQUIRES clause %qs specified via module %qs use "
6239 "at %L comes after using a device construct/routine",
6240 clause_name
, module_name
, loc
);
6242 gfc_error ("!$OMP REQUIRES clause %qs specified at %L comes after "
6243 "using a device construct/routine", clause_name
, loc
);
6247 /* Overriding atomic_default_mem_order clause value. */
6248 if ((clause
& OMP_REQ_ATOMIC_MEM_ORDER_MASK
)
6249 && (prog_unit
->omp_requires
& OMP_REQ_ATOMIC_MEM_ORDER_MASK
)
6250 && (prog_unit
->omp_requires
& OMP_REQ_ATOMIC_MEM_ORDER_MASK
)
6254 switch (prog_unit
->omp_requires
& OMP_REQ_ATOMIC_MEM_ORDER_MASK
)
6256 case OMP_REQ_ATOMIC_MEM_ORDER_SEQ_CST
: other
= "seq_cst"; break;
6257 case OMP_REQ_ATOMIC_MEM_ORDER_ACQ_REL
: other
= "acq_rel"; break;
6258 case OMP_REQ_ATOMIC_MEM_ORDER_ACQUIRE
: other
= "acquire"; break;
6259 case OMP_REQ_ATOMIC_MEM_ORDER_RELAXED
: other
= "relaxed"; break;
6260 case OMP_REQ_ATOMIC_MEM_ORDER_RELEASE
: other
= "release"; break;
6261 default: gcc_unreachable ();
6265 gfc_error ("!$OMP REQUIRES clause %<atomic_default_mem_order(%s)%> "
6266 "specified via module %qs use at %L overrides a previous "
6267 "%<atomic_default_mem_order(%s)%> (which might be through "
6268 "using a module)", clause_name
, module_name
, loc
, other
);
6270 gfc_error ("!$OMP REQUIRES clause %<atomic_default_mem_order(%s)%> "
6271 "specified at %L overrides a previous "
6272 "%<atomic_default_mem_order(%s)%> (which might be through "
6273 "using a module)", clause_name
, loc
, other
);
6277 /* Requires via module not at program-unit level and not repeating clause. */
6278 if (prog_unit
!= gfc_current_ns
&& !(prog_unit
->omp_requires
& clause
))
6280 if (clause
& OMP_REQ_ATOMIC_MEM_ORDER_MASK
)
6281 gfc_error ("!$OMP REQUIRES clause %<atomic_default_mem_order(%s)%> "
6282 "specified via module %qs use at %L but same clause is "
6283 "not specified for the program unit", clause_name
,
6286 gfc_error ("!$OMP REQUIRES clause %qs specified via module %qs use at "
6287 "%L but same clause is not specified for the program unit",
6288 clause_name
, module_name
, loc
);
6292 if (!gfc_state_stack
->previous
6293 || gfc_state_stack
->previous
->state
!= COMP_INTERFACE
)
6294 prog_unit
->omp_requires
|= clause
;
6299 gfc_match_omp_requires (void)
6301 static const char *clauses
[] = {"reverse_offload",
6303 "unified_shared_memory",
6304 "dynamic_allocators",
6306 const char *clause
= NULL
;
6307 int requires_clauses
= 0;
6311 if (gfc_current_ns
->parent
6312 && (!gfc_state_stack
->previous
6313 || gfc_state_stack
->previous
->state
!= COMP_INTERFACE
))
6315 gfc_error ("!$OMP REQUIRES at %C must appear in the specification part "
6316 "of a program unit");
6322 old_loc
= gfc_current_locus
;
6323 gfc_omp_requires_kind requires_clause
;
6324 if ((first
|| gfc_match_char (',') != MATCH_YES
)
6325 && (first
&& gfc_match_space () != MATCH_YES
))
6328 gfc_gobble_whitespace ();
6329 old_loc
= gfc_current_locus
;
6331 if (gfc_match_omp_eos () != MATCH_NO
)
6333 if (gfc_match (clauses
[0]) == MATCH_YES
)
6335 clause
= clauses
[0];
6336 requires_clause
= OMP_REQ_REVERSE_OFFLOAD
;
6337 if (requires_clauses
& OMP_REQ_REVERSE_OFFLOAD
)
6338 goto duplicate_clause
;
6340 else if (gfc_match (clauses
[1]) == MATCH_YES
)
6342 clause
= clauses
[1];
6343 requires_clause
= OMP_REQ_UNIFIED_ADDRESS
;
6344 if (requires_clauses
& OMP_REQ_UNIFIED_ADDRESS
)
6345 goto duplicate_clause
;
6347 else if (gfc_match (clauses
[2]) == MATCH_YES
)
6349 clause
= clauses
[2];
6350 requires_clause
= OMP_REQ_UNIFIED_SHARED_MEMORY
;
6351 if (requires_clauses
& OMP_REQ_UNIFIED_SHARED_MEMORY
)
6352 goto duplicate_clause
;
6354 else if (gfc_match (clauses
[3]) == MATCH_YES
)
6356 clause
= clauses
[3];
6357 requires_clause
= OMP_REQ_DYNAMIC_ALLOCATORS
;
6358 if (requires_clauses
& OMP_REQ_DYNAMIC_ALLOCATORS
)
6359 goto duplicate_clause
;
6361 else if (gfc_match ("atomic_default_mem_order (") == MATCH_YES
)
6363 clause
= clauses
[4];
6364 if (requires_clauses
& OMP_REQ_ATOMIC_MEM_ORDER_MASK
)
6365 goto duplicate_clause
;
6366 if (gfc_match (" seq_cst )") == MATCH_YES
)
6369 requires_clause
= OMP_REQ_ATOMIC_MEM_ORDER_SEQ_CST
;
6371 else if (gfc_match (" acq_rel )") == MATCH_YES
)
6374 requires_clause
= OMP_REQ_ATOMIC_MEM_ORDER_ACQ_REL
;
6376 else if (gfc_match (" acquire )") == MATCH_YES
)
6379 requires_clause
= OMP_REQ_ATOMIC_MEM_ORDER_ACQUIRE
;
6381 else if (gfc_match (" relaxed )") == MATCH_YES
)
6384 requires_clause
= OMP_REQ_ATOMIC_MEM_ORDER_RELAXED
;
6386 else if (gfc_match (" release )") == MATCH_YES
)
6389 requires_clause
= OMP_REQ_ATOMIC_MEM_ORDER_RELEASE
;
6393 gfc_error ("Expected ACQ_REL, ACQUIRE, RELAXED, RELEASE or "
6394 "SEQ_CST for ATOMIC_DEFAULT_MEM_ORDER clause at %C");
6401 if (!gfc_omp_requires_add_clause (requires_clause
, clause
, &old_loc
, NULL
))
6403 requires_clauses
|= requires_clause
;
6406 if (requires_clauses
== 0)
6408 if (!gfc_error_flag_test ())
6409 gfc_error ("Clause expected at %C");
6415 gfc_error ("%qs clause at %L specified more than once", clause
, &old_loc
);
6417 if (!gfc_error_flag_test ())
6418 gfc_error ("Expected UNIFIED_ADDRESS, UNIFIED_SHARED_MEMORY, "
6419 "DYNAMIC_ALLOCATORS, REVERSE_OFFLOAD, or "
6420 "ATOMIC_DEFAULT_MEM_ORDER clause at %L", &old_loc
);
6426 gfc_match_omp_scan (void)
6429 gfc_omp_clauses
*c
= gfc_get_omp_clauses ();
6430 gfc_gobble_whitespace ();
6431 if ((incl
= (gfc_match ("inclusive") == MATCH_YES
))
6432 || gfc_match ("exclusive") == MATCH_YES
)
6434 if (gfc_match_omp_variable_list (" (", &c
->lists
[incl
? OMP_LIST_SCAN_IN
6435 : OMP_LIST_SCAN_EX
],
6436 false) != MATCH_YES
)
6438 gfc_free_omp_clauses (c
);
6444 gfc_error ("Expected INCLUSIVE or EXCLUSIVE clause at %C");
6445 gfc_free_omp_clauses (c
);
6448 if (gfc_match_omp_eos () != MATCH_YES
)
6450 gfc_error ("Unexpected junk after !$OMP SCAN at %C");
6451 gfc_free_omp_clauses (c
);
6455 new_st
.op
= EXEC_OMP_SCAN
;
6456 new_st
.ext
.omp_clauses
= c
;
6462 gfc_match_omp_scope (void)
6464 return match_omp (EXEC_OMP_SCOPE
, OMP_SCOPE_CLAUSES
);
6469 gfc_match_omp_sections (void)
6471 return match_omp (EXEC_OMP_SECTIONS
, OMP_SECTIONS_CLAUSES
);
6476 gfc_match_omp_simd (void)
6478 return match_omp (EXEC_OMP_SIMD
, OMP_SIMD_CLAUSES
);
6483 gfc_match_omp_single (void)
6485 return match_omp (EXEC_OMP_SINGLE
, OMP_SINGLE_CLAUSES
);
6490 gfc_match_omp_target (void)
6492 return match_omp (EXEC_OMP_TARGET
, OMP_TARGET_CLAUSES
);
6497 gfc_match_omp_target_data (void)
6499 return match_omp (EXEC_OMP_TARGET_DATA
, OMP_TARGET_DATA_CLAUSES
);
6504 gfc_match_omp_target_enter_data (void)
6506 return match_omp (EXEC_OMP_TARGET_ENTER_DATA
, OMP_TARGET_ENTER_DATA_CLAUSES
);
6511 gfc_match_omp_target_exit_data (void)
6513 return match_omp (EXEC_OMP_TARGET_EXIT_DATA
, OMP_TARGET_EXIT_DATA_CLAUSES
);
6518 gfc_match_omp_target_parallel (void)
6520 return match_omp (EXEC_OMP_TARGET_PARALLEL
,
6521 (OMP_TARGET_CLAUSES
| OMP_PARALLEL_CLAUSES
)
6522 & ~(omp_mask (OMP_CLAUSE_COPYIN
)));
6527 gfc_match_omp_target_parallel_do (void)
6529 return match_omp (EXEC_OMP_TARGET_PARALLEL_DO
,
6530 (OMP_TARGET_CLAUSES
| OMP_PARALLEL_CLAUSES
6531 | OMP_DO_CLAUSES
) & ~(omp_mask (OMP_CLAUSE_COPYIN
)));
6536 gfc_match_omp_target_parallel_do_simd (void)
6538 return match_omp (EXEC_OMP_TARGET_PARALLEL_DO_SIMD
,
6539 (OMP_TARGET_CLAUSES
| OMP_PARALLEL_CLAUSES
| OMP_DO_CLAUSES
6540 | OMP_SIMD_CLAUSES
) & ~(omp_mask (OMP_CLAUSE_COPYIN
)));
6545 gfc_match_omp_target_simd (void)
6547 return match_omp (EXEC_OMP_TARGET_SIMD
,
6548 OMP_TARGET_CLAUSES
| OMP_SIMD_CLAUSES
);
6553 gfc_match_omp_target_teams (void)
6555 return match_omp (EXEC_OMP_TARGET_TEAMS
,
6556 OMP_TARGET_CLAUSES
| OMP_TEAMS_CLAUSES
);
6561 gfc_match_omp_target_teams_distribute (void)
6563 return match_omp (EXEC_OMP_TARGET_TEAMS_DISTRIBUTE
,
6564 OMP_TARGET_CLAUSES
| OMP_TEAMS_CLAUSES
6565 | OMP_DISTRIBUTE_CLAUSES
);
6570 gfc_match_omp_target_teams_distribute_parallel_do (void)
6572 return match_omp (EXEC_OMP_TARGET_TEAMS_DISTRIBUTE_PARALLEL_DO
,
6573 (OMP_TARGET_CLAUSES
| OMP_TEAMS_CLAUSES
6574 | OMP_DISTRIBUTE_CLAUSES
| OMP_PARALLEL_CLAUSES
6576 & ~(omp_mask (OMP_CLAUSE_ORDERED
))
6577 & ~(omp_mask (OMP_CLAUSE_LINEAR
)));
6582 gfc_match_omp_target_teams_distribute_parallel_do_simd (void)
6584 return match_omp (EXEC_OMP_TARGET_TEAMS_DISTRIBUTE_PARALLEL_DO_SIMD
,
6585 (OMP_TARGET_CLAUSES
| OMP_TEAMS_CLAUSES
6586 | OMP_DISTRIBUTE_CLAUSES
| OMP_PARALLEL_CLAUSES
6587 | OMP_DO_CLAUSES
| OMP_SIMD_CLAUSES
)
6588 & ~(omp_mask (OMP_CLAUSE_ORDERED
)));
6593 gfc_match_omp_target_teams_distribute_simd (void)
6595 return match_omp (EXEC_OMP_TARGET_TEAMS_DISTRIBUTE_SIMD
,
6596 OMP_TARGET_CLAUSES
| OMP_TEAMS_CLAUSES
6597 | OMP_DISTRIBUTE_CLAUSES
| OMP_SIMD_CLAUSES
);
6602 gfc_match_omp_target_update (void)
6604 return match_omp (EXEC_OMP_TARGET_UPDATE
, OMP_TARGET_UPDATE_CLAUSES
);
6609 gfc_match_omp_task (void)
6611 return match_omp (EXEC_OMP_TASK
, OMP_TASK_CLAUSES
);
6616 gfc_match_omp_taskloop (void)
6618 return match_omp (EXEC_OMP_TASKLOOP
, OMP_TASKLOOP_CLAUSES
);
6623 gfc_match_omp_taskloop_simd (void)
6625 return match_omp (EXEC_OMP_TASKLOOP_SIMD
,
6626 OMP_TASKLOOP_CLAUSES
| OMP_SIMD_CLAUSES
);
6631 gfc_match_omp_taskwait (void)
6633 if (gfc_match_omp_eos () == MATCH_YES
)
6635 new_st
.op
= EXEC_OMP_TASKWAIT
;
6636 new_st
.ext
.omp_clauses
= NULL
;
6639 return match_omp (EXEC_OMP_TASKWAIT
,
6640 omp_mask (OMP_CLAUSE_DEPEND
) | OMP_CLAUSE_NOWAIT
);
6645 gfc_match_omp_taskyield (void)
6647 if (gfc_match_omp_eos () != MATCH_YES
)
6649 gfc_error ("Unexpected junk after TASKYIELD clause at %C");
6652 new_st
.op
= EXEC_OMP_TASKYIELD
;
6653 new_st
.ext
.omp_clauses
= NULL
;
6659 gfc_match_omp_teams (void)
6661 return match_omp (EXEC_OMP_TEAMS
, OMP_TEAMS_CLAUSES
);
6666 gfc_match_omp_teams_distribute (void)
6668 return match_omp (EXEC_OMP_TEAMS_DISTRIBUTE
,
6669 OMP_TEAMS_CLAUSES
| OMP_DISTRIBUTE_CLAUSES
);
6674 gfc_match_omp_teams_distribute_parallel_do (void)
6676 return match_omp (EXEC_OMP_TEAMS_DISTRIBUTE_PARALLEL_DO
,
6677 (OMP_TEAMS_CLAUSES
| OMP_DISTRIBUTE_CLAUSES
6678 | OMP_PARALLEL_CLAUSES
| OMP_DO_CLAUSES
)
6679 & ~(omp_mask (OMP_CLAUSE_ORDERED
)
6680 | OMP_CLAUSE_LINEAR
| OMP_CLAUSE_NOWAIT
));
6685 gfc_match_omp_teams_distribute_parallel_do_simd (void)
6687 return match_omp (EXEC_OMP_TEAMS_DISTRIBUTE_PARALLEL_DO_SIMD
,
6688 (OMP_TEAMS_CLAUSES
| OMP_DISTRIBUTE_CLAUSES
6689 | OMP_PARALLEL_CLAUSES
| OMP_DO_CLAUSES
6691 & ~(omp_mask (OMP_CLAUSE_ORDERED
) | OMP_CLAUSE_NOWAIT
));
6696 gfc_match_omp_teams_distribute_simd (void)
6698 return match_omp (EXEC_OMP_TEAMS_DISTRIBUTE_SIMD
,
6699 OMP_TEAMS_CLAUSES
| OMP_DISTRIBUTE_CLAUSES
6700 | OMP_SIMD_CLAUSES
);
6705 gfc_match_omp_workshare (void)
6707 return match_omp (EXEC_OMP_WORKSHARE
, OMP_WORKSHARE_CLAUSES
);
6712 gfc_match_omp_masked (void)
6714 return match_omp (EXEC_OMP_MASKED
, OMP_MASKED_CLAUSES
);
6718 gfc_match_omp_masked_taskloop (void)
6720 return match_omp (EXEC_OMP_MASKED_TASKLOOP
,
6721 OMP_MASKED_CLAUSES
| OMP_TASKLOOP_CLAUSES
);
6725 gfc_match_omp_masked_taskloop_simd (void)
6727 return match_omp (EXEC_OMP_MASKED_TASKLOOP_SIMD
,
6728 (OMP_MASKED_CLAUSES
| OMP_TASKLOOP_CLAUSES
6729 | OMP_SIMD_CLAUSES
));
6733 gfc_match_omp_master (void)
6735 if (gfc_match_omp_eos () != MATCH_YES
)
6737 gfc_error ("Unexpected junk after $OMP MASTER statement at %C");
6740 new_st
.op
= EXEC_OMP_MASTER
;
6741 new_st
.ext
.omp_clauses
= NULL
;
6746 gfc_match_omp_master_taskloop (void)
6748 return match_omp (EXEC_OMP_MASTER_TASKLOOP
, OMP_TASKLOOP_CLAUSES
);
6752 gfc_match_omp_master_taskloop_simd (void)
6754 return match_omp (EXEC_OMP_MASTER_TASKLOOP_SIMD
,
6755 OMP_TASKLOOP_CLAUSES
| OMP_SIMD_CLAUSES
);
6759 gfc_match_omp_ordered (void)
6761 return match_omp (EXEC_OMP_ORDERED
, OMP_ORDERED_CLAUSES
);
6765 gfc_match_omp_nothing (void)
6767 if (gfc_match_omp_eos () != MATCH_YES
)
6769 gfc_error ("Unexpected junk after $OMP NOTHING statement at %C");
6772 /* Will use ST_NONE; therefore, no EXEC_OMP_ is needed. */
6777 gfc_match_omp_ordered_depend (void)
6779 return match_omp (EXEC_OMP_ORDERED
, omp_mask (OMP_CLAUSE_DOACROSS
));
6783 /* omp atomic [clause-list]
6784 - atomic-clause: read | write | update
6786 - memory-order-clause: seq_cst | acq_rel | release | acquire | relaxed
6788 - OpenMP 5.1: compare | fail (seq_cst | acquire | relaxed ) | weak
6792 gfc_match_omp_atomic (void)
6795 locus loc
= gfc_current_locus
;
6797 if (gfc_match_omp_clauses (&c
, OMP_ATOMIC_CLAUSES
, true, true) != MATCH_YES
)
6800 if (c
->atomic_op
== GFC_OMP_ATOMIC_UNSET
)
6801 c
->atomic_op
= GFC_OMP_ATOMIC_UPDATE
;
6803 if (c
->capture
&& c
->atomic_op
!= GFC_OMP_ATOMIC_UPDATE
)
6804 gfc_error ("!$OMP ATOMIC at %L with %s clause is incompatible with "
6805 "READ or WRITE", &loc
, "CAPTURE");
6806 if (c
->compare
&& c
->atomic_op
!= GFC_OMP_ATOMIC_UPDATE
)
6807 gfc_error ("!$OMP ATOMIC at %L with %s clause is incompatible with "
6808 "READ or WRITE", &loc
, "COMPARE");
6809 if (c
->fail
!= OMP_MEMORDER_UNSET
&& c
->atomic_op
!= GFC_OMP_ATOMIC_UPDATE
)
6810 gfc_error ("!$OMP ATOMIC at %L with %s clause is incompatible with "
6811 "READ or WRITE", &loc
, "FAIL");
6812 if (c
->weak
&& !c
->compare
)
6814 gfc_error ("!$OMP ATOMIC at %L with %s clause requires %s clause", &loc
,
6819 if (c
->memorder
== OMP_MEMORDER_UNSET
)
6821 gfc_namespace
*prog_unit
= gfc_current_ns
;
6822 while (prog_unit
->parent
)
6823 prog_unit
= prog_unit
->parent
;
6824 switch (prog_unit
->omp_requires
& OMP_REQ_ATOMIC_MEM_ORDER_MASK
)
6827 case OMP_REQ_ATOMIC_MEM_ORDER_RELAXED
:
6828 c
->memorder
= OMP_MEMORDER_RELAXED
;
6830 case OMP_REQ_ATOMIC_MEM_ORDER_SEQ_CST
:
6831 c
->memorder
= OMP_MEMORDER_SEQ_CST
;
6833 case OMP_REQ_ATOMIC_MEM_ORDER_ACQ_REL
:
6835 c
->memorder
= OMP_MEMORDER_ACQ_REL
;
6836 else if (c
->atomic_op
== GFC_OMP_ATOMIC_READ
)
6837 c
->memorder
= OMP_MEMORDER_ACQUIRE
;
6839 c
->memorder
= OMP_MEMORDER_RELEASE
;
6841 case OMP_REQ_ATOMIC_MEM_ORDER_ACQUIRE
:
6842 if (c
->atomic_op
== GFC_OMP_ATOMIC_WRITE
)
6844 gfc_error ("!$OMP ATOMIC WRITE at %L incompatible with "
6845 "ACQUIRES clause implicitly provided by a "
6846 "REQUIRES directive", &loc
);
6847 c
->memorder
= OMP_MEMORDER_SEQ_CST
;
6850 c
->memorder
= OMP_MEMORDER_ACQUIRE
;
6852 case OMP_REQ_ATOMIC_MEM_ORDER_RELEASE
:
6853 if (c
->atomic_op
== GFC_OMP_ATOMIC_READ
)
6855 gfc_error ("!$OMP ATOMIC READ at %L incompatible with "
6856 "RELEASE clause implicitly provided by a "
6857 "REQUIRES directive", &loc
);
6858 c
->memorder
= OMP_MEMORDER_SEQ_CST
;
6861 c
->memorder
= OMP_MEMORDER_RELEASE
;
6868 switch (c
->atomic_op
)
6870 case GFC_OMP_ATOMIC_READ
:
6871 if (c
->memorder
== OMP_MEMORDER_RELEASE
)
6873 gfc_error ("!$OMP ATOMIC READ at %L incompatible with "
6874 "RELEASE clause", &loc
);
6875 c
->memorder
= OMP_MEMORDER_SEQ_CST
;
6877 else if (c
->memorder
== OMP_MEMORDER_ACQ_REL
)
6878 c
->memorder
= OMP_MEMORDER_ACQUIRE
;
6880 case GFC_OMP_ATOMIC_WRITE
:
6881 if (c
->memorder
== OMP_MEMORDER_ACQUIRE
)
6883 gfc_error ("!$OMP ATOMIC WRITE at %L incompatible with "
6884 "ACQUIRE clause", &loc
);
6885 c
->memorder
= OMP_MEMORDER_SEQ_CST
;
6887 else if (c
->memorder
== OMP_MEMORDER_ACQ_REL
)
6888 c
->memorder
= OMP_MEMORDER_RELEASE
;
6894 new_st
.ext
.omp_clauses
= c
;
6895 new_st
.op
= EXEC_OMP_ATOMIC
;
6900 /* acc atomic [ read | write | update | capture] */
6903 gfc_match_oacc_atomic (void)
6905 gfc_omp_clauses
*c
= gfc_get_omp_clauses ();
6906 c
->atomic_op
= GFC_OMP_ATOMIC_UPDATE
;
6907 c
->memorder
= OMP_MEMORDER_RELAXED
;
6908 gfc_gobble_whitespace ();
6909 if (gfc_match ("update") == MATCH_YES
)
6911 else if (gfc_match ("read") == MATCH_YES
)
6912 c
->atomic_op
= GFC_OMP_ATOMIC_READ
;
6913 else if (gfc_match ("write") == MATCH_YES
)
6914 c
->atomic_op
= GFC_OMP_ATOMIC_WRITE
;
6915 else if (gfc_match ("capture") == MATCH_YES
)
6917 gfc_gobble_whitespace ();
6918 if (gfc_match_omp_eos () != MATCH_YES
)
6920 gfc_error ("Unexpected junk after !$ACC ATOMIC statement at %C");
6921 gfc_free_omp_clauses (c
);
6924 new_st
.ext
.omp_clauses
= c
;
6925 new_st
.op
= EXEC_OACC_ATOMIC
;
6931 gfc_match_omp_barrier (void)
6933 if (gfc_match_omp_eos () != MATCH_YES
)
6935 gfc_error ("Unexpected junk after $OMP BARRIER statement at %C");
6938 new_st
.op
= EXEC_OMP_BARRIER
;
6939 new_st
.ext
.omp_clauses
= NULL
;
6945 gfc_match_omp_taskgroup (void)
6947 return match_omp (EXEC_OMP_TASKGROUP
, OMP_TASKGROUP_CLAUSES
);
6951 static enum gfc_omp_cancel_kind
6952 gfc_match_omp_cancel_kind (void)
6954 if (gfc_match_space () != MATCH_YES
)
6955 return OMP_CANCEL_UNKNOWN
;
6956 if (gfc_match ("parallel") == MATCH_YES
)
6957 return OMP_CANCEL_PARALLEL
;
6958 if (gfc_match ("sections") == MATCH_YES
)
6959 return OMP_CANCEL_SECTIONS
;
6960 if (gfc_match ("do") == MATCH_YES
)
6961 return OMP_CANCEL_DO
;
6962 if (gfc_match ("taskgroup") == MATCH_YES
)
6963 return OMP_CANCEL_TASKGROUP
;
6964 return OMP_CANCEL_UNKNOWN
;
6969 gfc_match_omp_cancel (void)
6972 enum gfc_omp_cancel_kind kind
= gfc_match_omp_cancel_kind ();
6973 if (kind
== OMP_CANCEL_UNKNOWN
)
6975 if (gfc_match_omp_clauses (&c
, omp_mask (OMP_CLAUSE_IF
), false) != MATCH_YES
)
6978 new_st
.op
= EXEC_OMP_CANCEL
;
6979 new_st
.ext
.omp_clauses
= c
;
6985 gfc_match_omp_cancellation_point (void)
6988 enum gfc_omp_cancel_kind kind
= gfc_match_omp_cancel_kind ();
6989 if (kind
== OMP_CANCEL_UNKNOWN
)
6991 gfc_error ("Expected construct-type PARALLEL, SECTIONS, DO or TASKGROUP "
6992 "in $OMP CANCELLATION POINT statement at %C");
6995 if (gfc_match_omp_eos () != MATCH_YES
)
6997 gfc_error ("Unexpected junk after $OMP CANCELLATION POINT statement "
7001 c
= gfc_get_omp_clauses ();
7003 new_st
.op
= EXEC_OMP_CANCELLATION_POINT
;
7004 new_st
.ext
.omp_clauses
= c
;
7010 gfc_match_omp_end_nowait (void)
7012 bool nowait
= false;
7013 if (gfc_match ("% nowait") == MATCH_YES
)
7015 if (gfc_match_omp_eos () != MATCH_YES
)
7018 gfc_error ("Unexpected junk after NOWAIT clause at %C");
7020 gfc_error ("Unexpected junk at %C");
7023 new_st
.op
= EXEC_OMP_END_NOWAIT
;
7024 new_st
.ext
.omp_bool
= nowait
;
7030 gfc_match_omp_end_single (void)
7033 if (gfc_match_omp_clauses (&c
, omp_mask (OMP_CLAUSE_COPYPRIVATE
)
7034 | OMP_CLAUSE_NOWAIT
) != MATCH_YES
)
7036 new_st
.op
= EXEC_OMP_END_SINGLE
;
7037 new_st
.ext
.omp_clauses
= c
;
7043 oacc_is_loop (gfc_code
*code
)
7045 return code
->op
== EXEC_OACC_PARALLEL_LOOP
7046 || code
->op
== EXEC_OACC_KERNELS_LOOP
7047 || code
->op
== EXEC_OACC_SERIAL_LOOP
7048 || code
->op
== EXEC_OACC_LOOP
;
7052 resolve_scalar_int_expr (gfc_expr
*expr
, const char *clause
)
7054 if (!gfc_resolve_expr (expr
)
7055 || expr
->ts
.type
!= BT_INTEGER
7057 gfc_error ("%s clause at %L requires a scalar INTEGER expression",
7058 clause
, &expr
->where
);
7062 resolve_positive_int_expr (gfc_expr
*expr
, const char *clause
)
7064 resolve_scalar_int_expr (expr
, clause
);
7065 if (expr
->expr_type
== EXPR_CONSTANT
7066 && expr
->ts
.type
== BT_INTEGER
7067 && mpz_sgn (expr
->value
.integer
) <= 0)
7068 gfc_warning ((flag_openmp
|| flag_openmp_simd
) ? OPT_Wopenmp
: 0,
7069 "INTEGER expression of %s clause at %L must be positive",
7070 clause
, &expr
->where
);
7074 resolve_nonnegative_int_expr (gfc_expr
*expr
, const char *clause
)
7076 resolve_scalar_int_expr (expr
, clause
);
7077 if (expr
->expr_type
== EXPR_CONSTANT
7078 && expr
->ts
.type
== BT_INTEGER
7079 && mpz_sgn (expr
->value
.integer
) < 0)
7080 gfc_warning ((flag_openmp
|| flag_openmp_simd
) ? OPT_Wopenmp
: 0,
7081 "INTEGER expression of %s clause at %L must be non-negative",
7082 clause
, &expr
->where
);
7085 /* Emits error when symbol is pointer, cray pointer or cray pointee
7086 of derived of polymorphic type. */
7089 check_symbol_not_pointer (gfc_symbol
*sym
, locus loc
, const char *name
)
7091 if (sym
->ts
.type
== BT_DERIVED
&& sym
->attr
.cray_pointer
)
7092 gfc_error ("Cray pointer object %qs of derived type in %s clause at %L",
7093 sym
->name
, name
, &loc
);
7094 if (sym
->ts
.type
== BT_DERIVED
&& sym
->attr
.cray_pointee
)
7095 gfc_error ("Cray pointee object %qs of derived type in %s clause at %L",
7096 sym
->name
, name
, &loc
);
7098 if ((sym
->ts
.type
== BT_ASSUMED
&& sym
->attr
.pointer
)
7099 || (sym
->ts
.type
== BT_CLASS
&& CLASS_DATA (sym
)
7100 && CLASS_DATA (sym
)->attr
.pointer
))
7101 gfc_error ("POINTER object %qs of polymorphic type in %s clause at %L",
7102 sym
->name
, name
, &loc
);
7103 if ((sym
->ts
.type
== BT_ASSUMED
&& sym
->attr
.cray_pointer
)
7104 || (sym
->ts
.type
== BT_CLASS
&& CLASS_DATA (sym
)
7105 && CLASS_DATA (sym
)->attr
.cray_pointer
))
7106 gfc_error ("Cray pointer object %qs of polymorphic type in %s clause at %L",
7107 sym
->name
, name
, &loc
);
7108 if ((sym
->ts
.type
== BT_ASSUMED
&& sym
->attr
.cray_pointee
)
7109 || (sym
->ts
.type
== BT_CLASS
&& CLASS_DATA (sym
)
7110 && CLASS_DATA (sym
)->attr
.cray_pointee
))
7111 gfc_error ("Cray pointee object %qs of polymorphic type in %s clause at %L",
7112 sym
->name
, name
, &loc
);
7115 /* Emits error when symbol represents assumed size/rank array. */
7118 check_array_not_assumed (gfc_symbol
*sym
, locus loc
, const char *name
)
7120 if (sym
->as
&& sym
->as
->type
== AS_ASSUMED_SIZE
)
7121 gfc_error ("Assumed size array %qs in %s clause at %L",
7122 sym
->name
, name
, &loc
);
7123 if (sym
->as
&& sym
->as
->type
== AS_ASSUMED_RANK
)
7124 gfc_error ("Assumed rank array %qs in %s clause at %L",
7125 sym
->name
, name
, &loc
);
7129 resolve_oacc_data_clauses (gfc_symbol
*sym
, locus loc
, const char *name
)
7131 check_array_not_assumed (sym
, loc
, name
);
7135 resolve_oacc_deviceptr_clause (gfc_symbol
*sym
, locus loc
, const char *name
)
7137 if (sym
->attr
.pointer
7138 || (sym
->ts
.type
== BT_CLASS
&& CLASS_DATA (sym
)
7139 && CLASS_DATA (sym
)->attr
.class_pointer
))
7140 gfc_error ("POINTER object %qs in %s clause at %L",
7141 sym
->name
, name
, &loc
);
7142 if (sym
->attr
.cray_pointer
7143 || (sym
->ts
.type
== BT_CLASS
&& CLASS_DATA (sym
)
7144 && CLASS_DATA (sym
)->attr
.cray_pointer
))
7145 gfc_error ("Cray pointer object %qs in %s clause at %L",
7146 sym
->name
, name
, &loc
);
7147 if (sym
->attr
.cray_pointee
7148 || (sym
->ts
.type
== BT_CLASS
&& CLASS_DATA (sym
)
7149 && CLASS_DATA (sym
)->attr
.cray_pointee
))
7150 gfc_error ("Cray pointee object %qs in %s clause at %L",
7151 sym
->name
, name
, &loc
);
7152 if (sym
->attr
.allocatable
7153 || (sym
->ts
.type
== BT_CLASS
&& CLASS_DATA (sym
)
7154 && CLASS_DATA (sym
)->attr
.allocatable
))
7155 gfc_error ("ALLOCATABLE object %qs in %s clause at %L",
7156 sym
->name
, name
, &loc
);
7157 if (sym
->attr
.value
)
7158 gfc_error ("VALUE object %qs in %s clause at %L",
7159 sym
->name
, name
, &loc
);
7160 check_array_not_assumed (sym
, loc
, name
);
7164 struct resolve_omp_udr_callback_data
7166 gfc_symbol
*sym1
, *sym2
;
7171 resolve_omp_udr_callback (gfc_expr
**e
, int *, void *data
)
7173 struct resolve_omp_udr_callback_data
*rcd
7174 = (struct resolve_omp_udr_callback_data
*) data
;
7175 if ((*e
)->expr_type
== EXPR_VARIABLE
7176 && ((*e
)->symtree
->n
.sym
== rcd
->sym1
7177 || (*e
)->symtree
->n
.sym
== rcd
->sym2
))
7179 gfc_ref
*ref
= gfc_get_ref ();
7180 ref
->type
= REF_ARRAY
;
7181 ref
->u
.ar
.where
= (*e
)->where
;
7182 ref
->u
.ar
.as
= (*e
)->symtree
->n
.sym
->as
;
7183 ref
->u
.ar
.type
= AR_FULL
;
7184 ref
->u
.ar
.dimen
= 0;
7185 ref
->next
= (*e
)->ref
;
7193 resolve_omp_udr_callback2 (gfc_expr
**e
, int *, void *)
7195 if ((*e
)->expr_type
== EXPR_FUNCTION
7196 && (*e
)->value
.function
.isym
== NULL
)
7198 gfc_symbol
*sym
= (*e
)->symtree
->n
.sym
;
7199 if (!sym
->attr
.intrinsic
7200 && sym
->attr
.if_source
== IFSRC_UNKNOWN
)
7201 gfc_error ("Implicitly declared function %s used in "
7202 "!$OMP DECLARE REDUCTION at %L", sym
->name
, &(*e
)->where
);
7209 resolve_omp_udr_clause (gfc_omp_namelist
*n
, gfc_namespace
*ns
,
7210 gfc_symbol
*sym1
, gfc_symbol
*sym2
)
7213 gfc_symbol sym1_copy
, sym2_copy
;
7215 if (ns
->code
->op
== EXEC_ASSIGN
)
7217 copy
= gfc_get_code (EXEC_ASSIGN
);
7218 copy
->expr1
= gfc_copy_expr (ns
->code
->expr1
);
7219 copy
->expr2
= gfc_copy_expr (ns
->code
->expr2
);
7223 copy
= gfc_get_code (EXEC_CALL
);
7224 copy
->symtree
= ns
->code
->symtree
;
7225 copy
->ext
.actual
= gfc_copy_actual_arglist (ns
->code
->ext
.actual
);
7227 copy
->loc
= ns
->code
->loc
;
7232 sym1
->name
= sym1_copy
.name
;
7233 sym2
->name
= sym2_copy
.name
;
7234 ns
->proc_name
= ns
->parent
->proc_name
;
7235 if (n
->sym
->attr
.dimension
)
7237 struct resolve_omp_udr_callback_data rcd
;
7240 gfc_code_walker (©
, gfc_dummy_code_callback
,
7241 resolve_omp_udr_callback
, &rcd
);
7243 gfc_resolve_code (copy
, gfc_current_ns
);
7244 if (copy
->op
== EXEC_CALL
&& copy
->resolved_isym
== NULL
)
7246 gfc_symbol
*sym
= copy
->resolved_sym
;
7248 && !sym
->attr
.intrinsic
7249 && sym
->attr
.if_source
== IFSRC_UNKNOWN
)
7250 gfc_error ("Implicitly declared subroutine %s used in "
7251 "!$OMP DECLARE REDUCTION at %L", sym
->name
,
7254 gfc_code_walker (©
, gfc_dummy_code_callback
,
7255 resolve_omp_udr_callback2
, NULL
);
7261 /* Assume that a constant expression in the range 1 (omp_default_mem_alloc)
7262 to 8 (omp_thread_mem_alloc) range is fine. The original symbol name is
7263 already lost during matching via gfc_match_expr. */
7265 is_predefined_allocator (gfc_expr
*expr
)
7267 return (gfc_resolve_expr (expr
)
7269 && expr
->ts
.type
== BT_INTEGER
7270 && expr
->ts
.kind
== gfc_c_intptr_kind
7271 && expr
->expr_type
== EXPR_CONSTANT
7272 && mpz_sgn (expr
->value
.integer
) > 0
7273 && mpz_cmp_si (expr
->value
.integer
, 8) <= 0);
7276 /* Resolve declarative ALLOCATE statement. Note: Common block vars only appear
7277 as /block/ not individual, which is ensured during parsing. */
7280 gfc_resolve_omp_allocate (gfc_namespace
*ns
, gfc_omp_namelist
*list
)
7282 for (gfc_omp_namelist
*n
= list
; n
; n
= n
->next
)
7284 if (n
->sym
->attr
.result
|| n
->sym
->result
== n
->sym
)
7286 gfc_error ("Unexpected function-result variable %qs at %L in "
7287 "declarative !$OMP ALLOCATE", n
->sym
->name
, &n
->where
);
7290 if (ns
->omp_allocate
->sym
->attr
.proc_pointer
)
7292 gfc_error ("Procedure pointer %qs not supported with !$OMP "
7293 "ALLOCATE at %L", n
->sym
->name
, &n
->where
);
7296 if (n
->sym
->attr
.flavor
!= FL_VARIABLE
)
7298 gfc_error ("Argument %qs at %L to declarative !$OMP ALLOCATE "
7299 "directive must be a variable", n
->sym
->name
,
7303 if (ns
!= n
->sym
->ns
|| n
->sym
->attr
.use_assoc
|| n
->sym
->attr
.imported
)
7305 gfc_error ("Argument %qs at %L to declarative !$OMP ALLOCATE shall be"
7306 " in the same scope as the variable declaration",
7307 n
->sym
->name
, &n
->where
);
7310 if (n
->sym
->attr
.dummy
)
7312 gfc_error ("Unexpected dummy argument %qs as argument at %L to "
7313 "declarative !$OMP ALLOCATE", n
->sym
->name
, &n
->where
);
7316 if (n
->sym
->attr
.codimension
)
7318 gfc_error ("Unexpected coarray argument %qs as argument at %L to "
7319 "declarative !$OMP ALLOCATE", n
->sym
->name
, &n
->where
);
7322 if (n
->sym
->attr
.omp_allocate
)
7324 if (n
->sym
->attr
.in_common
)
7326 gfc_error ("Duplicated common block %</%s/%> in !$OMP ALLOCATE "
7327 "at %L", n
->sym
->common_head
->name
, &n
->where
);
7328 while (n
->next
&& n
->next
->sym
7329 && n
->sym
->common_head
== n
->next
->sym
->common_head
)
7333 gfc_error ("Duplicated variable %qs in !$OMP ALLOCATE at %L",
7334 n
->sym
->name
, &n
->where
);
7337 /* For 'equivalence(a,b)', a 'union_type {<type> a,b} equiv.0' is created
7338 with a value expression for 'a' as 'equiv.0.a' (likewise for b); while
7339 this can be handled, EQUIVALENCE is marked as obsolescent since Fortran
7340 2018 and also not widely used. However, it could be supported,
7342 if (n
->sym
->attr
.in_equivalence
)
7344 gfc_error ("Sorry, EQUIVALENCE object %qs not supported with !$OMP "
7345 "ALLOCATE at %L", n
->sym
->name
, &n
->where
);
7348 /* Similar for Cray pointer/pointee - they could be implemented but as
7349 common vendor extension but nowadays rarely used and requiring
7350 -fcray-pointer, there is no need to support them. */
7351 if (n
->sym
->attr
.cray_pointer
|| n
->sym
->attr
.cray_pointee
)
7353 gfc_error ("Sorry, Cray pointers and pointees such as %qs are not "
7354 "supported with !$OMP ALLOCATE at %L",
7355 n
->sym
->name
, &n
->where
);
7358 n
->sym
->attr
.omp_allocate
= 1;
7359 if ((n
->sym
->ts
.type
== BT_CLASS
&& n
->sym
->attr
.class_ok
7360 && CLASS_DATA (n
->sym
)->attr
.allocatable
)
7361 || (n
->sym
->ts
.type
!= BT_CLASS
&& n
->sym
->attr
.allocatable
))
7362 gfc_error ("Unexpected allocatable variable %qs at %L in declarative "
7363 "!$OMP ALLOCATE directive", n
->sym
->name
, &n
->where
);
7364 else if ((n
->sym
->ts
.type
== BT_CLASS
&& n
->sym
->attr
.class_ok
7365 && CLASS_DATA (n
->sym
)->attr
.class_pointer
)
7366 || (n
->sym
->ts
.type
!= BT_CLASS
&& n
->sym
->attr
.pointer
))
7367 gfc_error ("Unexpected pointer variable %qs at %L in declarative "
7368 "!$OMP ALLOCATE directive", n
->sym
->name
, &n
->where
);
7369 HOST_WIDE_INT alignment
= 0;
7371 && (!gfc_resolve_expr (n
->u
.align
)
7372 || n
->u
.align
->ts
.type
!= BT_INTEGER
7373 || n
->u
.align
->rank
!= 0
7374 || n
->u
.align
->expr_type
!= EXPR_CONSTANT
7375 || gfc_extract_hwi (n
->u
.align
, &alignment
)
7376 || !pow2p_hwi (alignment
)))
7378 gfc_error ("ALIGN requires a scalar positive constant integer "
7379 "alignment expression at %L that is a power of two",
7380 &n
->u
.align
->where
);
7381 while (n
->sym
->attr
.in_common
&& n
->next
&& n
->next
->sym
7382 && n
->sym
->common_head
== n
->next
->sym
->common_head
)
7386 if (n
->sym
->attr
.in_common
|| n
->sym
->attr
.save
|| n
->sym
->ns
->save_all
7387 || (n
->sym
->ns
->proc_name
7388 && (n
->sym
->ns
->proc_name
->attr
.flavor
== FL_PROGRAM
7389 || n
->sym
->ns
->proc_name
->attr
.flavor
== FL_MODULE
)))
7391 bool com
= n
->sym
->attr
.in_common
;
7392 if (!n
->u2
.allocator
)
7393 gfc_error ("An ALLOCATOR clause is required as the list item "
7394 "%<%s%s%s%> at %L has the SAVE attribute", com
? "/" : "",
7395 com
? n
->sym
->common_head
->name
: n
->sym
->name
,
7396 com
? "/" : "", &n
->where
);
7397 else if (!is_predefined_allocator (n
->u2
.allocator
))
7398 gfc_error ("Predefined allocator required in ALLOCATOR clause at %L"
7399 " as the list item %<%s%s%s%> at %L has the SAVE attribute",
7400 &n
->u2
.allocator
->where
, com
? "/" : "",
7401 com
? n
->sym
->common_head
->name
: n
->sym
->name
,
7402 com
? "/" : "", &n
->where
);
7403 while (n
->sym
->attr
.in_common
&& n
->next
&& n
->next
->sym
7404 && n
->sym
->common_head
== n
->next
->sym
->common_head
)
7407 else if (n
->u2
.allocator
7408 && (!gfc_resolve_expr (n
->u2
.allocator
)
7409 || n
->u2
.allocator
->ts
.type
!= BT_INTEGER
7410 || n
->u2
.allocator
->rank
!= 0
7411 || n
->u2
.allocator
->ts
.kind
!= gfc_c_intptr_kind
))
7412 gfc_error ("Expected integer expression of the "
7413 "%<omp_allocator_handle_kind%> kind at %L",
7414 &n
->u2
.allocator
->where
);
7418 /* Resolve ASSUME's and ASSUMES' assumption clauses. Note that absent/contains
7419 is handled during parse time in omp_verify_merge_absent_contains. */
7422 gfc_resolve_omp_assumptions (gfc_omp_assumptions
*assume
)
7424 for (gfc_expr_list
*el
= assume
->holds
; el
; el
= el
->next
)
7425 if (!gfc_resolve_expr (el
->expr
)
7426 || el
->expr
->ts
.type
!= BT_LOGICAL
7427 || el
->expr
->rank
!= 0)
7428 gfc_error ("HOLDS expression at %L must be a scalar logical expression",
7433 /* OpenMP directive resolving routines. */
7436 resolve_omp_clauses (gfc_code
*code
, gfc_omp_clauses
*omp_clauses
,
7437 gfc_namespace
*ns
, bool openacc
= false)
7439 gfc_omp_namelist
*n
, *last
;
7443 bool if_without_mod
= false;
7444 gfc_omp_linear_op linear_op
= OMP_LINEAR_DEFAULT
;
7445 static const char *clause_names
[]
7446 = { "PRIVATE", "FIRSTPRIVATE", "LASTPRIVATE", "COPYPRIVATE", "SHARED",
7447 "COPYIN", "UNIFORM", "AFFINITY", "ALIGNED", "LINEAR", "DEPEND", "MAP",
7448 "TO", "FROM", "INCLUSIVE", "EXCLUSIVE",
7449 "REDUCTION", "REDUCTION" /*inscan*/, "REDUCTION" /*task*/,
7450 "IN_REDUCTION", "TASK_REDUCTION",
7451 "DEVICE_RESIDENT", "LINK", "USE_DEVICE",
7452 "CACHE", "IS_DEVICE_PTR", "USE_DEVICE_PTR", "USE_DEVICE_ADDR",
7453 "NONTEMPORAL", "ALLOCATE", "HAS_DEVICE_ADDR", "ENTER",
7454 "USES_ALLOCATORS" };
7455 STATIC_ASSERT (ARRAY_SIZE (clause_names
) == OMP_LIST_NUM
);
7457 if (omp_clauses
== NULL
)
7461 ns
= gfc_current_ns
;
7463 if (omp_clauses
->orderedc
&& omp_clauses
->orderedc
< omp_clauses
->collapse
)
7464 gfc_error ("ORDERED clause parameter is less than COLLAPSE at %L",
7466 if (omp_clauses
->order_concurrent
&& omp_clauses
->ordered
)
7467 gfc_error ("ORDER clause must not be used together ORDERED at %L",
7469 if (omp_clauses
->if_expr
)
7471 gfc_expr
*expr
= omp_clauses
->if_expr
;
7472 if (!gfc_resolve_expr (expr
)
7473 || expr
->ts
.type
!= BT_LOGICAL
|| expr
->rank
!= 0)
7474 gfc_error ("IF clause at %L requires a scalar LOGICAL expression",
7476 if_without_mod
= true;
7478 for (ifc
= 0; ifc
< OMP_IF_LAST
; ifc
++)
7479 if (omp_clauses
->if_exprs
[ifc
])
7481 gfc_expr
*expr
= omp_clauses
->if_exprs
[ifc
];
7483 if (!gfc_resolve_expr (expr
)
7484 || expr
->ts
.type
!= BT_LOGICAL
|| expr
->rank
!= 0)
7485 gfc_error ("IF clause at %L requires a scalar LOGICAL expression",
7487 else if (if_without_mod
)
7489 gfc_error ("IF clause without modifier at %L used together with "
7490 "IF clauses with modifiers",
7491 &omp_clauses
->if_expr
->where
);
7492 if_without_mod
= false;
7497 case EXEC_OMP_CANCEL
:
7498 ok
= ifc
== OMP_IF_CANCEL
;
7501 case EXEC_OMP_PARALLEL
:
7502 case EXEC_OMP_PARALLEL_DO
:
7503 case EXEC_OMP_PARALLEL_LOOP
:
7504 case EXEC_OMP_PARALLEL_MASKED
:
7505 case EXEC_OMP_PARALLEL_MASTER
:
7506 case EXEC_OMP_PARALLEL_SECTIONS
:
7507 case EXEC_OMP_PARALLEL_WORKSHARE
:
7508 case EXEC_OMP_DISTRIBUTE_PARALLEL_DO
:
7509 case EXEC_OMP_TEAMS_DISTRIBUTE_PARALLEL_DO
:
7510 ok
= ifc
== OMP_IF_PARALLEL
;
7513 case EXEC_OMP_PARALLEL_DO_SIMD
:
7514 case EXEC_OMP_DISTRIBUTE_PARALLEL_DO_SIMD
:
7515 case EXEC_OMP_TEAMS_DISTRIBUTE_PARALLEL_DO_SIMD
:
7516 ok
= ifc
== OMP_IF_PARALLEL
|| ifc
== OMP_IF_SIMD
;
7519 case EXEC_OMP_PARALLEL_MASKED_TASKLOOP
:
7520 case EXEC_OMP_PARALLEL_MASTER_TASKLOOP
:
7521 ok
= ifc
== OMP_IF_PARALLEL
|| ifc
== OMP_IF_TASKLOOP
;
7524 case EXEC_OMP_PARALLEL_MASKED_TASKLOOP_SIMD
:
7525 case EXEC_OMP_PARALLEL_MASTER_TASKLOOP_SIMD
:
7526 ok
= (ifc
== OMP_IF_PARALLEL
7527 || ifc
== OMP_IF_TASKLOOP
7528 || ifc
== OMP_IF_SIMD
);
7532 case EXEC_OMP_DO_SIMD
:
7533 case EXEC_OMP_DISTRIBUTE_SIMD
:
7534 case EXEC_OMP_TEAMS_DISTRIBUTE_SIMD
:
7535 ok
= ifc
== OMP_IF_SIMD
;
7539 ok
= ifc
== OMP_IF_TASK
;
7542 case EXEC_OMP_TASKLOOP
:
7543 case EXEC_OMP_MASKED_TASKLOOP
:
7544 case EXEC_OMP_MASTER_TASKLOOP
:
7545 ok
= ifc
== OMP_IF_TASKLOOP
;
7548 case EXEC_OMP_TASKLOOP_SIMD
:
7549 case EXEC_OMP_MASKED_TASKLOOP_SIMD
:
7550 case EXEC_OMP_MASTER_TASKLOOP_SIMD
:
7551 ok
= ifc
== OMP_IF_TASKLOOP
|| ifc
== OMP_IF_SIMD
;
7554 case EXEC_OMP_TARGET
:
7555 case EXEC_OMP_TARGET_TEAMS
:
7556 case EXEC_OMP_TARGET_TEAMS_DISTRIBUTE
:
7557 case EXEC_OMP_TARGET_TEAMS_LOOP
:
7558 ok
= ifc
== OMP_IF_TARGET
;
7561 case EXEC_OMP_TARGET_TEAMS_DISTRIBUTE_SIMD
:
7562 case EXEC_OMP_TARGET_SIMD
:
7563 ok
= ifc
== OMP_IF_TARGET
|| ifc
== OMP_IF_SIMD
;
7566 case EXEC_OMP_TARGET_DATA
:
7567 ok
= ifc
== OMP_IF_TARGET_DATA
;
7570 case EXEC_OMP_TARGET_UPDATE
:
7571 ok
= ifc
== OMP_IF_TARGET_UPDATE
;
7574 case EXEC_OMP_TARGET_ENTER_DATA
:
7575 ok
= ifc
== OMP_IF_TARGET_ENTER_DATA
;
7578 case EXEC_OMP_TARGET_EXIT_DATA
:
7579 ok
= ifc
== OMP_IF_TARGET_EXIT_DATA
;
7582 case EXEC_OMP_TARGET_TEAMS_DISTRIBUTE_PARALLEL_DO
:
7583 case EXEC_OMP_TARGET_PARALLEL
:
7584 case EXEC_OMP_TARGET_PARALLEL_DO
:
7585 case EXEC_OMP_TARGET_PARALLEL_LOOP
:
7586 ok
= ifc
== OMP_IF_TARGET
|| ifc
== OMP_IF_PARALLEL
;
7589 case EXEC_OMP_TARGET_PARALLEL_DO_SIMD
:
7590 case EXEC_OMP_TARGET_TEAMS_DISTRIBUTE_PARALLEL_DO_SIMD
:
7591 ok
= (ifc
== OMP_IF_TARGET
7592 || ifc
== OMP_IF_PARALLEL
7593 || ifc
== OMP_IF_SIMD
);
7602 static const char *ifs
[] = {
7611 "TARGET ENTER DATA",
7614 gfc_error ("IF clause modifier %s at %L not appropriate for "
7615 "the current OpenMP construct", ifs
[ifc
], &expr
->where
);
7619 if (omp_clauses
->self_expr
)
7621 gfc_expr
*expr
= omp_clauses
->self_expr
;
7622 if (!gfc_resolve_expr (expr
)
7623 || expr
->ts
.type
!= BT_LOGICAL
|| expr
->rank
!= 0)
7624 gfc_error ("SELF clause at %L requires a scalar LOGICAL expression",
7628 if (omp_clauses
->final_expr
)
7630 gfc_expr
*expr
= omp_clauses
->final_expr
;
7631 if (!gfc_resolve_expr (expr
)
7632 || expr
->ts
.type
!= BT_LOGICAL
|| expr
->rank
!= 0)
7633 gfc_error ("FINAL clause at %L requires a scalar LOGICAL expression",
7636 if (omp_clauses
->num_threads
)
7637 resolve_positive_int_expr (omp_clauses
->num_threads
, "NUM_THREADS");
7638 if (omp_clauses
->chunk_size
)
7640 gfc_expr
*expr
= omp_clauses
->chunk_size
;
7641 if (!gfc_resolve_expr (expr
)
7642 || expr
->ts
.type
!= BT_INTEGER
|| expr
->rank
!= 0)
7643 gfc_error ("SCHEDULE clause's chunk_size at %L requires "
7644 "a scalar INTEGER expression", &expr
->where
);
7645 else if (expr
->expr_type
== EXPR_CONSTANT
7646 && expr
->ts
.type
== BT_INTEGER
7647 && mpz_sgn (expr
->value
.integer
) <= 0)
7648 gfc_warning (OPT_Wopenmp
, "INTEGER expression of SCHEDULE clause's "
7649 "chunk_size at %L must be positive", &expr
->where
);
7651 if (omp_clauses
->sched_kind
!= OMP_SCHED_NONE
7652 && omp_clauses
->sched_nonmonotonic
)
7654 if (omp_clauses
->sched_monotonic
)
7655 gfc_error ("Both MONOTONIC and NONMONOTONIC schedule modifiers "
7656 "specified at %L", &code
->loc
);
7657 else if (omp_clauses
->ordered
)
7658 gfc_error ("NONMONOTONIC schedule modifier specified with ORDERED "
7659 "clause at %L", &code
->loc
);
7662 if (omp_clauses
->depobj
7663 && (!gfc_resolve_expr (omp_clauses
->depobj
)
7664 || omp_clauses
->depobj
->ts
.type
!= BT_INTEGER
7665 || omp_clauses
->depobj
->ts
.kind
!= 2 * gfc_index_integer_kind
7666 || omp_clauses
->depobj
->rank
!= 0))
7667 gfc_error ("DEPOBJ in DEPOBJ construct at %L shall be a scalar integer "
7668 "of OMP_DEPEND_KIND kind", &omp_clauses
->depobj
->where
);
7670 /* Check that no symbol appears on multiple clauses, except that
7671 a symbol can appear on both firstprivate and lastprivate. */
7672 for (list
= 0; list
< OMP_LIST_NUM
; list
++)
7673 for (n
= omp_clauses
->lists
[list
]; n
; n
= n
->next
)
7675 if (!n
->sym
) /* omp_all_memory. */
7678 n
->sym
->comp_mark
= 0;
7679 n
->sym
->data_mark
= 0;
7680 n
->sym
->dev_mark
= 0;
7681 n
->sym
->gen_mark
= 0;
7682 n
->sym
->reduc_mark
= 0;
7683 if (n
->sym
->attr
.flavor
== FL_VARIABLE
7684 || n
->sym
->attr
.proc_pointer
7685 || (!code
&& (!n
->sym
->attr
.dummy
|| n
->sym
->ns
!= ns
)))
7687 if (!code
&& (!n
->sym
->attr
.dummy
|| n
->sym
->ns
!= ns
))
7688 gfc_error ("Variable %qs is not a dummy argument at %L",
7689 n
->sym
->name
, &n
->where
);
7692 if (n
->sym
->attr
.flavor
== FL_PROCEDURE
7693 && n
->sym
->result
== n
->sym
7694 && n
->sym
->attr
.function
)
7696 if (ns
->proc_name
== n
->sym
7697 || (ns
->parent
&& ns
->parent
->proc_name
== n
->sym
))
7699 if (ns
->proc_name
->attr
.entry_master
)
7701 gfc_entry_list
*el
= ns
->entries
;
7702 for (; el
; el
= el
->next
)
7703 if (el
->sym
== n
->sym
)
7709 && ns
->parent
->proc_name
->attr
.entry_master
)
7711 gfc_entry_list
*el
= ns
->parent
->entries
;
7712 for (; el
; el
= el
->next
)
7713 if (el
->sym
== n
->sym
)
7719 if (list
== OMP_LIST_MAP
7720 && n
->sym
->attr
.flavor
== FL_PARAMETER
)
7723 gfc_error ("Object %qs is not a variable at %L; parameters"
7724 " cannot be and need not be copied", n
->sym
->name
,
7727 gfc_error ("Object %qs is not a variable at %L; parameters"
7728 " cannot be and need not be mapped", n
->sym
->name
,
7731 else if (list
!= OMP_LIST_USES_ALLOCATORS
)
7732 gfc_error ("Object %qs is not a variable at %L", n
->sym
->name
,
7735 if (omp_clauses
->lists
[OMP_LIST_REDUCTION_INSCAN
])
7737 locus
*loc
= &omp_clauses
->lists
[OMP_LIST_REDUCTION_INSCAN
]->where
;
7738 if (code
->op
!= EXEC_OMP_DO
7739 && code
->op
!= EXEC_OMP_SIMD
7740 && code
->op
!= EXEC_OMP_DO_SIMD
7741 && code
->op
!= EXEC_OMP_PARALLEL_DO
7742 && code
->op
!= EXEC_OMP_PARALLEL_DO_SIMD
)
7743 gfc_error ("%<inscan%> REDUCTION clause on construct other than DO, "
7744 "SIMD, DO SIMD, PARALLEL DO, PARALLEL DO SIMD at %L",
7746 if (omp_clauses
->ordered
)
7747 gfc_error ("ORDERED clause specified together with %<inscan%> "
7748 "REDUCTION clause at %L", loc
);
7749 if (omp_clauses
->sched_kind
!= OMP_SCHED_NONE
)
7750 gfc_error ("SCHEDULE clause specified together with %<inscan%> "
7751 "REDUCTION clause at %L", loc
);
7754 for (list
= 0; list
< OMP_LIST_NUM
; list
++)
7755 if (list
!= OMP_LIST_FIRSTPRIVATE
7756 && list
!= OMP_LIST_LASTPRIVATE
7757 && list
!= OMP_LIST_ALIGNED
7758 && list
!= OMP_LIST_DEPEND
7759 && list
!= OMP_LIST_FROM
7760 && list
!= OMP_LIST_TO
7761 && (list
!= OMP_LIST_REDUCTION
|| !openacc
)
7762 && list
!= OMP_LIST_ALLOCATE
)
7763 for (n
= omp_clauses
->lists
[list
]; n
; n
= n
->next
)
7765 bool component_ref_p
= false;
7767 /* Allow multiple components of the same (e.g. derived-type)
7768 variable here. Duplicate components are detected elsewhere. */
7769 if (n
->expr
&& n
->expr
->expr_type
== EXPR_VARIABLE
)
7770 for (gfc_ref
*ref
= n
->expr
->ref
; ref
; ref
= ref
->next
)
7771 if (ref
->type
== REF_COMPONENT
)
7772 component_ref_p
= true;
7773 if ((list
== OMP_LIST_IS_DEVICE_PTR
7774 || list
== OMP_LIST_HAS_DEVICE_ADDR
)
7775 && !component_ref_p
)
7777 if (n
->sym
->gen_mark
7779 || n
->sym
->reduc_mark
7781 gfc_error ("Symbol %qs present on multiple clauses at %L",
7782 n
->sym
->name
, &n
->where
);
7784 n
->sym
->dev_mark
= 1;
7786 else if ((list
== OMP_LIST_USE_DEVICE_PTR
7787 || list
== OMP_LIST_USE_DEVICE_ADDR
7788 || list
== OMP_LIST_PRIVATE
7789 || list
== OMP_LIST_SHARED
)
7790 && !component_ref_p
)
7792 if (n
->sym
->gen_mark
|| n
->sym
->dev_mark
|| n
->sym
->reduc_mark
)
7793 gfc_error ("Symbol %qs present on multiple clauses at %L",
7794 n
->sym
->name
, &n
->where
);
7797 n
->sym
->gen_mark
= 1;
7798 /* Set both generic and device bits if we have
7799 use_device_*(x) or shared(x). This allows us to diagnose
7800 "map(x) private(x)" below. */
7801 if (list
!= OMP_LIST_PRIVATE
)
7802 n
->sym
->dev_mark
= 1;
7805 else if ((list
== OMP_LIST_REDUCTION
7806 || list
== OMP_LIST_REDUCTION_TASK
7807 || list
== OMP_LIST_REDUCTION_INSCAN
7808 || list
== OMP_LIST_IN_REDUCTION
7809 || list
== OMP_LIST_TASK_REDUCTION
)
7810 && !component_ref_p
)
7812 /* Attempts to mix reduction types are diagnosed below. */
7813 if (n
->sym
->gen_mark
|| n
->sym
->dev_mark
)
7814 gfc_error ("Symbol %qs present on multiple clauses at %L",
7815 n
->sym
->name
, &n
->where
);
7816 n
->sym
->reduc_mark
= 1;
7818 else if ((!component_ref_p
&& n
->sym
->comp_mark
)
7819 || (component_ref_p
&& n
->sym
->mark
))
7822 gfc_error ("Symbol %qs has mixed component and non-component "
7823 "accesses at %L", n
->sym
->name
, &n
->where
);
7825 else if (n
->sym
->mark
)
7826 gfc_error ("Symbol %qs present on multiple clauses at %L",
7827 n
->sym
->name
, &n
->where
);
7830 if (component_ref_p
)
7831 n
->sym
->comp_mark
= 1;
7837 /* Detect specifically the case where we have "map(x) private(x)" and raise
7838 an error. If we have "...simd" combined directives though, the "private"
7839 applies to the simd part, so this is permitted though. */
7840 for (n
= omp_clauses
->lists
[OMP_LIST_PRIVATE
]; n
; n
= n
->next
)
7843 && !n
->sym
->dev_mark
7844 && !n
->sym
->reduc_mark
7845 && code
->op
!= EXEC_OMP_TARGET_SIMD
7846 && code
->op
!= EXEC_OMP_TARGET_PARALLEL_DO_SIMD
7847 && code
->op
!= EXEC_OMP_TARGET_TEAMS_DISTRIBUTE_SIMD
7848 && code
->op
!= EXEC_OMP_TARGET_TEAMS_DISTRIBUTE_PARALLEL_DO_SIMD
)
7849 gfc_error ("Symbol %qs present on multiple clauses at %L",
7850 n
->sym
->name
, &n
->where
);
7852 gcc_assert (OMP_LIST_LASTPRIVATE
== OMP_LIST_FIRSTPRIVATE
+ 1);
7853 for (list
= OMP_LIST_FIRSTPRIVATE
; list
<= OMP_LIST_LASTPRIVATE
; list
++)
7854 for (n
= omp_clauses
->lists
[list
]; n
; n
= n
->next
)
7855 if (n
->sym
->data_mark
|| n
->sym
->gen_mark
|| n
->sym
->dev_mark
)
7857 gfc_error ("Symbol %qs present on multiple clauses at %L",
7858 n
->sym
->name
, &n
->where
);
7859 n
->sym
->data_mark
= n
->sym
->gen_mark
= n
->sym
->dev_mark
= 0;
7861 else if (n
->sym
->mark
7862 && code
->op
!= EXEC_OMP_TARGET_TEAMS
7863 && code
->op
!= EXEC_OMP_TARGET_TEAMS_DISTRIBUTE
7864 && code
->op
!= EXEC_OMP_TARGET_TEAMS_LOOP
7865 && code
->op
!= EXEC_OMP_TARGET_TEAMS_DISTRIBUTE_SIMD
7866 && code
->op
!= EXEC_OMP_TARGET_TEAMS_DISTRIBUTE_PARALLEL_DO
7867 && code
->op
!= EXEC_OMP_TARGET_PARALLEL
7868 && code
->op
!= EXEC_OMP_TARGET_PARALLEL_DO
7869 && code
->op
!= EXEC_OMP_TARGET_PARALLEL_LOOP
7870 && code
->op
!= EXEC_OMP_TARGET_PARALLEL_DO_SIMD
7871 && code
->op
!= EXEC_OMP_TARGET_TEAMS_DISTRIBUTE_PARALLEL_DO_SIMD
)
7872 gfc_error ("Symbol %qs present on both data and map clauses "
7873 "at %L", n
->sym
->name
, &n
->where
);
7875 for (n
= omp_clauses
->lists
[OMP_LIST_FIRSTPRIVATE
]; n
; n
= n
->next
)
7877 if (n
->sym
->data_mark
|| n
->sym
->gen_mark
|| n
->sym
->dev_mark
)
7878 gfc_error ("Symbol %qs present on multiple clauses at %L",
7879 n
->sym
->name
, &n
->where
);
7881 n
->sym
->data_mark
= 1;
7883 for (n
= omp_clauses
->lists
[OMP_LIST_LASTPRIVATE
]; n
; n
= n
->next
)
7884 n
->sym
->data_mark
= 0;
7886 for (n
= omp_clauses
->lists
[OMP_LIST_LASTPRIVATE
]; n
; n
= n
->next
)
7888 if (n
->sym
->data_mark
|| n
->sym
->gen_mark
|| n
->sym
->dev_mark
)
7889 gfc_error ("Symbol %qs present on multiple clauses at %L",
7890 n
->sym
->name
, &n
->where
);
7892 n
->sym
->data_mark
= 1;
7895 for (n
= omp_clauses
->lists
[OMP_LIST_ALIGNED
]; n
; n
= n
->next
)
7898 for (n
= omp_clauses
->lists
[OMP_LIST_ALIGNED
]; n
; n
= n
->next
)
7901 gfc_error ("Symbol %qs present on multiple clauses at %L",
7902 n
->sym
->name
, &n
->where
);
7907 if (omp_clauses
->lists
[OMP_LIST_ALLOCATE
])
7909 for (n
= omp_clauses
->lists
[OMP_LIST_ALLOCATE
]; n
; n
= n
->next
)
7912 && (!gfc_resolve_expr (n
->u2
.allocator
)
7913 || n
->u2
.allocator
->ts
.type
!= BT_INTEGER
7914 || n
->u2
.allocator
->rank
!= 0
7915 || n
->u2
.allocator
->ts
.kind
!= gfc_c_intptr_kind
))
7917 gfc_error ("Expected integer expression of the "
7918 "%<omp_allocator_handle_kind%> kind at %L",
7919 &n
->u2
.allocator
->where
);
7924 HOST_WIDE_INT alignment
= 0;
7925 if (!gfc_resolve_expr (n
->u
.align
)
7926 || n
->u
.align
->ts
.type
!= BT_INTEGER
7927 || n
->u
.align
->rank
!= 0
7928 || n
->u
.align
->expr_type
!= EXPR_CONSTANT
7929 || gfc_extract_hwi (n
->u
.align
, &alignment
)
7931 || !pow2p_hwi (alignment
))
7933 gfc_error ("ALIGN requires a scalar positive constant integer "
7934 "alignment expression at %L that is a power of two",
7935 &n
->u
.align
->where
);
7940 /* Check for 2 things here.
7941 1. There is no duplication of variable in allocate clause.
7942 2. Variable in allocate clause are also present in some
7943 privatization clase (non-composite case). */
7944 for (n
= omp_clauses
->lists
[OMP_LIST_ALLOCATE
]; n
; n
= n
->next
)
7948 gfc_omp_namelist
*prev
= NULL
;
7949 for (n
= omp_clauses
->lists
[OMP_LIST_ALLOCATE
]; n
; )
7956 if (n
->sym
->mark
== 1)
7958 gfc_warning (OPT_Wopenmp
, "%qs appears more than once in "
7959 "%<allocate%> at %L" , n
->sym
->name
, &n
->where
);
7960 /* We have already seen this variable so it is a duplicate.
7962 if (prev
!= NULL
&& prev
->next
== n
)
7964 prev
->next
= n
->next
;
7966 gfc_free_omp_namelist (n
, false, true, false);
7976 /* Non-composite constructs. */
7977 if (code
&& code
->op
< EXEC_OMP_DO_SIMD
)
7979 for (list
= 0; list
< OMP_LIST_NUM
; list
++)
7982 case OMP_LIST_PRIVATE
:
7983 case OMP_LIST_FIRSTPRIVATE
:
7984 case OMP_LIST_LASTPRIVATE
:
7985 case OMP_LIST_REDUCTION
:
7986 case OMP_LIST_REDUCTION_INSCAN
:
7987 case OMP_LIST_REDUCTION_TASK
:
7988 case OMP_LIST_IN_REDUCTION
:
7989 case OMP_LIST_TASK_REDUCTION
:
7990 case OMP_LIST_LINEAR
:
7991 for (n
= omp_clauses
->lists
[list
]; n
; n
= n
->next
)
7998 for (n
= omp_clauses
->lists
[OMP_LIST_ALLOCATE
]; n
; n
= n
->next
)
7999 if (n
->sym
->mark
== 1)
8000 gfc_error ("%qs specified in %<allocate%> clause at %L but not "
8001 "in an explicit privatization clause",
8002 n
->sym
->name
, &n
->where
);
8005 && (code
->op
== EXEC_OMP_ALLOCATORS
|| code
->op
== EXEC_OMP_ALLOCATE
)
8007 && code
->block
->next
8008 && code
->block
->next
->op
== EXEC_ALLOCATE
)
8011 gfc_omp_namelist
*n_null
= NULL
;
8012 bool missing_allocator
= false;
8013 gfc_symbol
*missing_allocator_sym
= NULL
;
8014 for (n
= omp_clauses
->lists
[OMP_LIST_ALLOCATE
]; n
; n
= n
->next
)
8016 if (n
->u2
.allocator
== NULL
)
8018 if (!missing_allocator_sym
)
8019 missing_allocator_sym
= n
->sym
;
8020 missing_allocator
= true;
8027 if (n
->sym
->attr
.codimension
)
8028 gfc_error ("Unexpected coarray %qs in %<allocate%> at %L",
8029 n
->sym
->name
, &n
->where
);
8030 for (a
= code
->block
->next
->ext
.alloc
.list
; a
; a
= a
->next
)
8031 if (a
->expr
->expr_type
== EXPR_VARIABLE
8032 && a
->expr
->symtree
->n
.sym
== n
->sym
)
8035 for (ref
= a
->expr
->ref
; ref
; ref
= ref
->next
)
8036 if (ref
->type
== REF_COMPONENT
)
8042 gfc_error ("%qs specified in %<allocate%> at %L but not "
8043 "in the associated ALLOCATE statement",
8044 n
->sym
->name
, &n
->where
);
8046 /* If there is an ALLOCATE directive without list argument, a
8047 namelist with its allocator/align clauses and n->sym = NULL is
8048 created during parsing; here, we add all not otherwise specified
8049 items from the Fortran allocate to that list.
8050 For an ALLOCATORS directive, not listed items use the normal
8052 The behavior of an ALLOCATE directive that does not list all
8053 arguments but there is no directive without list argument is not
8054 well specified. Thus, we reject such code below. In OpenMP 5.2
8055 the executable ALLOCATE directive is deprecated and in 6.0
8056 deleted such that no spec clarification is to be expected. */
8057 for (a
= code
->block
->next
->ext
.alloc
.list
; a
; a
= a
->next
)
8058 if (a
->expr
->expr_type
== EXPR_VARIABLE
)
8060 for (n
= omp_clauses
->lists
[OMP_LIST_ALLOCATE
]; n
; n
= n
->next
)
8061 if (a
->expr
->symtree
->n
.sym
== n
->sym
)
8064 for (ref
= a
->expr
->ref
; ref
; ref
= ref
->next
)
8065 if (ref
->type
== REF_COMPONENT
)
8070 if (n
== NULL
&& n_null
== NULL
)
8072 /* OK for ALLOCATORS but for ALLOCATE: Unspecified whether
8073 that should use the default allocator of OpenMP or the
8074 Fortran allocator. Thus, just reject it. */
8075 if (code
->op
== EXEC_OMP_ALLOCATE
)
8076 gfc_error ("%qs listed in %<allocate%> statement at %L "
8077 "but it is neither explicitly in listed in "
8078 "the %<!$OMP ALLOCATE%> directive nor exists"
8079 " a directive without argument list",
8080 a
->expr
->symtree
->n
.sym
->name
,
8086 if (a
->expr
->symtree
->n
.sym
->attr
.codimension
)
8087 gfc_error ("Unexpected coarray %qs in %<allocate%> at "
8088 "%L, implicitly listed in %<!$OMP ALLOCATE%>"
8089 " at %L", a
->expr
->symtree
->n
.sym
->name
,
8090 &a
->expr
->where
, &n_null
->where
);
8094 gfc_namespace
*prog_unit
= ns
;
8095 while (prog_unit
->parent
)
8096 prog_unit
= prog_unit
->parent
;
8097 gfc_namespace
*fn_ns
= ns
;
8101 && (ns
->proc_name
->attr
.subroutine
8102 || ns
->proc_name
->attr
.function
))
8104 fn_ns
= fn_ns
->parent
;
8106 if (missing_allocator
8107 && !(prog_unit
->omp_requires
& OMP_REQ_DYNAMIC_ALLOCATORS
)
8108 && ((fn_ns
&& fn_ns
->proc_name
->attr
.omp_declare_target
)
8109 || omp_clauses
->contained_in_target_construct
))
8111 if (code
->op
== EXEC_OMP_ALLOCATORS
)
8112 gfc_error ("ALLOCATORS directive at %L inside a target region "
8113 "must specify an ALLOCATOR modifier for %qs",
8114 &code
->loc
, missing_allocator_sym
->name
);
8115 else if (missing_allocator_sym
)
8116 gfc_error ("ALLOCATE directive at %L inside a target region "
8117 "must specify an ALLOCATOR clause for %qs",
8118 &code
->loc
, missing_allocator_sym
->name
);
8120 gfc_error ("ALLOCATE directive at %L inside a target region "
8121 "must specify an ALLOCATOR clause", &code
->loc
);
8127 /* OpenACC reductions. */
8130 for (n
= omp_clauses
->lists
[OMP_LIST_REDUCTION
]; n
; n
= n
->next
)
8133 for (n
= omp_clauses
->lists
[OMP_LIST_REDUCTION
]; n
; n
= n
->next
)
8136 gfc_error ("Symbol %qs present on multiple clauses at %L",
8137 n
->sym
->name
, &n
->where
);
8141 /* OpenACC does not support reductions on arrays. */
8143 gfc_error ("Array %qs is not permitted in reduction at %L",
8144 n
->sym
->name
, &n
->where
);
8148 for (n
= omp_clauses
->lists
[OMP_LIST_TO
]; n
; n
= n
->next
)
8150 for (n
= omp_clauses
->lists
[OMP_LIST_FROM
]; n
; n
= n
->next
)
8151 if (n
->expr
== NULL
)
8153 for (n
= omp_clauses
->lists
[OMP_LIST_TO
]; n
; n
= n
->next
)
8155 if (n
->expr
== NULL
&& n
->sym
->mark
)
8156 gfc_error ("Symbol %qs present on both FROM and TO clauses at %L",
8157 n
->sym
->name
, &n
->where
);
8162 bool has_inscan
= false, has_notinscan
= false;
8163 for (list
= 0; list
< OMP_LIST_NUM
; list
++)
8164 if ((n
= omp_clauses
->lists
[list
]) != NULL
)
8166 const char *name
= clause_names
[list
];
8170 case OMP_LIST_COPYIN
:
8171 for (; n
!= NULL
; n
= n
->next
)
8173 if (!n
->sym
->attr
.threadprivate
)
8174 gfc_error ("Non-THREADPRIVATE object %qs in COPYIN clause"
8175 " at %L", n
->sym
->name
, &n
->where
);
8178 case OMP_LIST_COPYPRIVATE
:
8179 if (omp_clauses
->nowait
)
8180 gfc_error ("NOWAIT clause must not be used with COPYPRIVATE "
8181 "clause at %L", &n
->where
);
8182 for (; n
!= NULL
; n
= n
->next
)
8184 if (n
->sym
->as
&& n
->sym
->as
->type
== AS_ASSUMED_SIZE
)
8185 gfc_error ("Assumed size array %qs in COPYPRIVATE clause "
8186 "at %L", n
->sym
->name
, &n
->where
);
8187 if (n
->sym
->attr
.pointer
&& n
->sym
->attr
.intent
== INTENT_IN
)
8188 gfc_error ("INTENT(IN) POINTER %qs in COPYPRIVATE clause "
8189 "at %L", n
->sym
->name
, &n
->where
);
8192 case OMP_LIST_SHARED
:
8193 for (; n
!= NULL
; n
= n
->next
)
8195 if (n
->sym
->attr
.threadprivate
)
8196 gfc_error ("THREADPRIVATE object %qs in SHARED clause at "
8197 "%L", n
->sym
->name
, &n
->where
);
8198 if (n
->sym
->attr
.cray_pointee
)
8199 gfc_error ("Cray pointee %qs in SHARED clause at %L",
8200 n
->sym
->name
, &n
->where
);
8201 if (n
->sym
->attr
.associate_var
)
8202 gfc_error ("Associate name %qs in SHARED clause at %L",
8203 n
->sym
->attr
.select_type_temporary
8204 ? n
->sym
->assoc
->target
->symtree
->n
.sym
->name
8205 : n
->sym
->name
, &n
->where
);
8206 if (omp_clauses
->detach
8207 && n
->sym
== omp_clauses
->detach
->symtree
->n
.sym
)
8208 gfc_error ("DETACH event handle %qs in SHARED clause at %L",
8209 n
->sym
->name
, &n
->where
);
8212 case OMP_LIST_ALIGNED
:
8213 for (; n
!= NULL
; n
= n
->next
)
8215 if (!n
->sym
->attr
.pointer
8216 && !n
->sym
->attr
.allocatable
8217 && !n
->sym
->attr
.cray_pointer
8218 && (n
->sym
->ts
.type
!= BT_DERIVED
8219 || (n
->sym
->ts
.u
.derived
->from_intmod
8220 != INTMOD_ISO_C_BINDING
)
8221 || (n
->sym
->ts
.u
.derived
->intmod_sym_id
8222 != ISOCBINDING_PTR
)))
8223 gfc_error ("%qs in ALIGNED clause must be POINTER, "
8224 "ALLOCATABLE, Cray pointer or C_PTR at %L",
8225 n
->sym
->name
, &n
->where
);
8228 if (!gfc_resolve_expr (n
->expr
)
8229 || n
->expr
->ts
.type
!= BT_INTEGER
8230 || n
->expr
->rank
!= 0
8231 || n
->expr
->expr_type
!= EXPR_CONSTANT
8232 || mpz_sgn (n
->expr
->value
.integer
) <= 0)
8233 gfc_error ("%qs in ALIGNED clause at %L requires a scalar"
8234 " positive constant integer alignment "
8235 "expression", n
->sym
->name
, &n
->where
);
8239 case OMP_LIST_AFFINITY
:
8240 case OMP_LIST_DEPEND
:
8244 case OMP_LIST_CACHE
:
8245 for (; n
!= NULL
; n
= n
->next
)
8247 if ((list
== OMP_LIST_DEPEND
|| list
== OMP_LIST_AFFINITY
)
8248 && n
->u2
.ns
&& !n
->u2
.ns
->resolved
)
8250 n
->u2
.ns
->resolved
= 1;
8251 for (gfc_symbol
*sym
= n
->u2
.ns
->omp_affinity_iterators
;
8252 sym
; sym
= sym
->tlink
)
8255 c
= gfc_constructor_first (sym
->value
->value
.constructor
);
8256 if (!gfc_resolve_expr (c
->expr
)
8257 || c
->expr
->ts
.type
!= BT_INTEGER
8258 || c
->expr
->rank
!= 0)
8259 gfc_error ("Scalar integer expression for range begin"
8260 " expected at %L", &c
->expr
->where
);
8261 c
= gfc_constructor_next (c
);
8262 if (!gfc_resolve_expr (c
->expr
)
8263 || c
->expr
->ts
.type
!= BT_INTEGER
8264 || c
->expr
->rank
!= 0)
8265 gfc_error ("Scalar integer expression for range end "
8266 "expected at %L", &c
->expr
->where
);
8267 c
= gfc_constructor_next (c
);
8268 if (c
&& (!gfc_resolve_expr (c
->expr
)
8269 || c
->expr
->ts
.type
!= BT_INTEGER
8270 || c
->expr
->rank
!= 0))
8271 gfc_error ("Scalar integer expression for range step "
8272 "expected at %L", &c
->expr
->where
);
8274 && c
->expr
->expr_type
== EXPR_CONSTANT
8275 && mpz_cmp_si (c
->expr
->value
.integer
, 0) == 0)
8276 gfc_error ("Nonzero range step expected at %L",
8281 if (list
== OMP_LIST_DEPEND
)
8283 if (n
->u
.depend_doacross_op
== OMP_DEPEND_SINK_FIRST
8284 || n
->u
.depend_doacross_op
== OMP_DOACROSS_SINK_FIRST
8285 || n
->u
.depend_doacross_op
== OMP_DOACROSS_SINK
)
8287 if (omp_clauses
->doacross_source
)
8289 gfc_error ("Dependence-type SINK used together with"
8290 " SOURCE on the same construct at %L",
8292 omp_clauses
->doacross_source
= false;
8296 if (!gfc_resolve_expr (n
->expr
)
8297 || n
->expr
->ts
.type
!= BT_INTEGER
8298 || n
->expr
->rank
!= 0)
8299 gfc_error ("SINK addend not a constant integer "
8300 "at %L", &n
->where
);
8304 || mpz_cmp_si (n
->expr
->value
.integer
, -1) != 0))
8305 gfc_error ("omp_cur_iteration at %L requires %<-1%> "
8306 "as logical offset", &n
->where
);
8309 else if (n
->u
.depend_doacross_op
== OMP_DEPEND_DEPOBJ
8311 && (n
->sym
->ts
.type
!= BT_INTEGER
8313 != 2 * gfc_index_integer_kind
8314 || n
->sym
->attr
.dimension
))
8315 gfc_error ("Locator %qs at %L in DEPEND clause of depobj "
8316 "type shall be a scalar integer of "
8317 "OMP_DEPEND_KIND kind", n
->sym
->name
,
8319 else if (n
->u
.depend_doacross_op
== OMP_DEPEND_DEPOBJ
8321 && (!gfc_resolve_expr (n
->expr
)
8322 || n
->expr
->ts
.type
!= BT_INTEGER
8324 != 2 * gfc_index_integer_kind
8325 || n
->expr
->rank
!= 0))
8326 gfc_error ("Locator at %L in DEPEND clause of depobj "
8327 "type shall be a scalar integer of "
8328 "OMP_DEPEND_KIND kind", &n
->expr
->where
);
8330 gfc_ref
*lastref
= NULL
, *lastslice
= NULL
;
8331 bool resolved
= false;
8334 lastref
= n
->expr
->ref
;
8335 resolved
= gfc_resolve_expr (n
->expr
);
8337 /* Look through component refs to find last array
8341 for (gfc_ref
*ref
= n
->expr
->ref
; ref
; ref
= ref
->next
)
8342 if (ref
->type
== REF_COMPONENT
8343 || ref
->type
== REF_SUBSTRING
8344 || ref
->type
== REF_INQUIRY
)
8346 else if (ref
->type
== REF_ARRAY
)
8348 for (int i
= 0; i
< ref
->u
.ar
.dimen
; i
++)
8349 if (ref
->u
.ar
.dimen_type
[i
] == DIMEN_RANGE
)
8355 /* The "!$acc cache" directive allows rectangular
8356 subarrays to be specified, with some restrictions
8357 on the form of bounds (not implemented).
8358 Only raise an error here if we're really sure the
8359 array isn't contiguous. An expression such as
8360 arr(-n:n,-n:n) could be contiguous even if it looks
8361 like it may not be. */
8362 if (code
->op
!= EXEC_OACC_UPDATE
8363 && list
!= OMP_LIST_CACHE
8364 && list
!= OMP_LIST_DEPEND
8365 && !gfc_is_simply_contiguous (n
->expr
, false, true)
8366 && gfc_is_not_contiguous (n
->expr
)
8369 || lastslice
->type
!= REF_ARRAY
)))
8370 gfc_error ("Array is not contiguous at %L",
8375 && list
== OMP_LIST_MAP
8376 && (n
->u
.map_op
== OMP_MAP_ATTACH
8377 || n
->u
.map_op
== OMP_MAP_DETACH
))
8379 symbol_attribute attr
;
8381 attr
= gfc_expr_attr (n
->expr
);
8383 attr
= n
->sym
->attr
;
8384 if (!attr
.pointer
&& !attr
.allocatable
)
8385 gfc_error ("%qs clause argument must be ALLOCATABLE or "
8387 (n
->u
.map_op
== OMP_MAP_ATTACH
) ? "attach"
8388 : "detach", &n
->where
);
8392 && (!resolved
|| n
->expr
->expr_type
!= EXPR_VARIABLE
)))
8396 && lastref
->type
== REF_SUBSTRING
)
8397 gfc_error ("Unexpected substring reference in %s clause "
8398 "at %L", name
, &n
->where
);
8401 && lastref
->type
== REF_INQUIRY
)
8403 gcc_assert (lastref
->u
.i
== INQUIRY_RE
8404 || lastref
->u
.i
== INQUIRY_IM
);
8405 gfc_error ("Unexpected complex-parts designator "
8406 "reference in %s clause at %L",
8410 || n
->expr
->expr_type
!= EXPR_VARIABLE
8413 || lastslice
->type
!= REF_ARRAY
)))
8414 gfc_error ("%qs in %s clause at %L is not a proper "
8415 "array section", n
->sym
->name
, name
,
8420 gfc_array_ref
*ar
= &lastslice
->u
.ar
;
8421 for (i
= 0; i
< ar
->dimen
; i
++)
8422 if (ar
->stride
[i
] && code
->op
!= EXEC_OACC_UPDATE
)
8424 gfc_error ("Stride should not be specified for "
8425 "array section in %s clause at %L",
8429 else if (ar
->dimen_type
[i
] != DIMEN_ELEMENT
8430 && ar
->dimen_type
[i
] != DIMEN_RANGE
)
8432 gfc_error ("%qs in %s clause at %L is not a "
8433 "proper array section",
8434 n
->sym
->name
, name
, &n
->where
);
8437 else if ((list
== OMP_LIST_DEPEND
8438 || list
== OMP_LIST_AFFINITY
)
8440 && ar
->start
[i
]->expr_type
== EXPR_CONSTANT
8442 && ar
->end
[i
]->expr_type
== EXPR_CONSTANT
8443 && mpz_cmp (ar
->start
[i
]->value
.integer
,
8444 ar
->end
[i
]->value
.integer
) > 0)
8446 gfc_error ("%qs in %s clause at %L is a "
8447 "zero size array section",
8449 list
== OMP_LIST_DEPEND
8450 ? "DEPEND" : "AFFINITY", &n
->where
);
8457 if (list
== OMP_LIST_MAP
8458 && n
->u
.map_op
== OMP_MAP_FORCE_DEVICEPTR
)
8459 resolve_oacc_deviceptr_clause (n
->sym
, n
->where
, name
);
8461 resolve_oacc_data_clauses (n
->sym
, n
->where
, name
);
8463 else if (list
!= OMP_LIST_DEPEND
8465 && n
->sym
->as
->type
== AS_ASSUMED_SIZE
)
8466 gfc_error ("Assumed size array %qs in %s clause at %L",
8467 n
->sym
->name
, name
, &n
->where
);
8469 && list
== OMP_LIST_MAP
8470 && n
->sym
->ts
.type
== BT_DERIVED
8471 && n
->sym
->ts
.u
.derived
->attr
.alloc_comp
)
8472 gfc_error ("List item %qs with allocatable components is not "
8473 "permitted in map clause at %L", n
->sym
->name
,
8475 if (list
== OMP_LIST_MAP
&& !openacc
)
8478 case EXEC_OMP_TARGET
:
8479 case EXEC_OMP_TARGET_DATA
:
8480 switch (n
->u
.map_op
)
8483 case OMP_MAP_ALWAYS_TO
:
8484 case OMP_MAP_PRESENT_TO
:
8485 case OMP_MAP_ALWAYS_PRESENT_TO
:
8487 case OMP_MAP_ALWAYS_FROM
:
8488 case OMP_MAP_PRESENT_FROM
:
8489 case OMP_MAP_ALWAYS_PRESENT_FROM
:
8490 case OMP_MAP_TOFROM
:
8491 case OMP_MAP_ALWAYS_TOFROM
:
8492 case OMP_MAP_PRESENT_TOFROM
:
8493 case OMP_MAP_ALWAYS_PRESENT_TOFROM
:
8495 case OMP_MAP_PRESENT_ALLOC
:
8498 gfc_error ("TARGET%s with map-type other than TO, "
8499 "FROM, TOFROM, or ALLOC on MAP clause "
8501 code
->op
== EXEC_OMP_TARGET
8502 ? "" : " DATA", &n
->where
);
8506 case EXEC_OMP_TARGET_ENTER_DATA
:
8507 switch (n
->u
.map_op
)
8510 case OMP_MAP_ALWAYS_TO
:
8511 case OMP_MAP_PRESENT_TO
:
8512 case OMP_MAP_ALWAYS_PRESENT_TO
:
8514 case OMP_MAP_PRESENT_ALLOC
:
8516 case OMP_MAP_TOFROM
:
8517 n
->u
.map_op
= OMP_MAP_TO
;
8519 case OMP_MAP_ALWAYS_TOFROM
:
8520 n
->u
.map_op
= OMP_MAP_ALWAYS_TO
;
8522 case OMP_MAP_PRESENT_TOFROM
:
8523 n
->u
.map_op
= OMP_MAP_PRESENT_TO
;
8525 case OMP_MAP_ALWAYS_PRESENT_TOFROM
:
8526 n
->u
.map_op
= OMP_MAP_ALWAYS_PRESENT_TO
;
8529 gfc_error ("TARGET ENTER DATA with map-type other "
8530 "than TO, TOFROM or ALLOC on MAP clause "
8531 "at %L", &n
->where
);
8535 case EXEC_OMP_TARGET_EXIT_DATA
:
8536 switch (n
->u
.map_op
)
8539 case OMP_MAP_ALWAYS_FROM
:
8540 case OMP_MAP_PRESENT_FROM
:
8541 case OMP_MAP_ALWAYS_PRESENT_FROM
:
8542 case OMP_MAP_RELEASE
:
8543 case OMP_MAP_DELETE
:
8545 case OMP_MAP_TOFROM
:
8546 n
->u
.map_op
= OMP_MAP_FROM
;
8548 case OMP_MAP_ALWAYS_TOFROM
:
8549 n
->u
.map_op
= OMP_MAP_ALWAYS_FROM
;
8551 case OMP_MAP_PRESENT_TOFROM
:
8552 n
->u
.map_op
= OMP_MAP_PRESENT_FROM
;
8554 case OMP_MAP_ALWAYS_PRESENT_TOFROM
:
8555 n
->u
.map_op
= OMP_MAP_ALWAYS_PRESENT_FROM
;
8558 gfc_error ("TARGET EXIT DATA with map-type other "
8559 "than FROM, TOFROM, RELEASE, or DELETE on "
8560 "MAP clause at %L", &n
->where
);
8569 if (list
!= OMP_LIST_DEPEND
)
8570 for (n
= omp_clauses
->lists
[list
]; n
!= NULL
; n
= n
->next
)
8572 n
->sym
->attr
.referenced
= 1;
8573 if (n
->sym
->attr
.threadprivate
)
8574 gfc_error ("THREADPRIVATE object %qs in %s clause at %L",
8575 n
->sym
->name
, name
, &n
->where
);
8576 if (n
->sym
->attr
.cray_pointee
)
8577 gfc_error ("Cray pointee %qs in %s clause at %L",
8578 n
->sym
->name
, name
, &n
->where
);
8581 case OMP_LIST_IS_DEVICE_PTR
:
8583 for (n
= omp_clauses
->lists
[list
]; n
!= NULL
; )
8585 if (n
->sym
->ts
.type
== BT_DERIVED
8586 && n
->sym
->ts
.u
.derived
->ts
.is_iso_c
8587 && code
->op
!= EXEC_OMP_TARGET
)
8588 /* Non-TARGET (i.e. DISPATCH) requires a C_PTR. */
8589 gfc_error ("List item %qs in %s clause at %L must be of "
8590 "TYPE(C_PTR)", n
->sym
->name
, name
, &n
->where
);
8591 else if (n
->sym
->ts
.type
!= BT_DERIVED
8592 || !n
->sym
->ts
.u
.derived
->ts
.is_iso_c
)
8594 /* For TARGET, non-C_PTR are deprecated and handled as
8596 gfc_omp_namelist
*n2
= n
;
8601 omp_clauses
->lists
[list
] = n
;
8602 n2
->next
= omp_clauses
->lists
[OMP_LIST_HAS_DEVICE_ADDR
];
8603 omp_clauses
->lists
[OMP_LIST_HAS_DEVICE_ADDR
] = n2
;
8610 case OMP_LIST_HAS_DEVICE_ADDR
:
8611 case OMP_LIST_USE_DEVICE_ADDR
:
8613 case OMP_LIST_USE_DEVICE_PTR
:
8614 /* Non-C_PTR are deprecated and handled as use_device_ADDR. */
8616 for (n
= omp_clauses
->lists
[list
]; n
!= NULL
; )
8618 gfc_omp_namelist
*n2
= n
;
8619 if (n
->sym
->ts
.type
!= BT_DERIVED
8620 || !n
->sym
->ts
.u
.derived
->ts
.is_iso_c
)
8626 omp_clauses
->lists
[list
] = n
;
8627 n2
->next
= omp_clauses
->lists
[OMP_LIST_USE_DEVICE_ADDR
];
8628 omp_clauses
->lists
[OMP_LIST_USE_DEVICE_ADDR
] = n2
;
8635 case OMP_LIST_USES_ALLOCATORS
:
8638 && n
->u
.memspace_sym
8639 && (n
->u
.memspace_sym
->attr
.flavor
!= FL_PARAMETER
8640 || n
->u
.memspace_sym
->ts
.type
!= BT_INTEGER
8641 || n
->u
.memspace_sym
->ts
.kind
!= gfc_c_intptr_kind
8642 || n
->u
.memspace_sym
->attr
.dimension
8643 || (!startswith (n
->u
.memspace_sym
->name
, "omp_")
8644 && !startswith (n
->u
.memspace_sym
->name
, "ompx_"))
8645 || !endswith (n
->u
.memspace_sym
->name
, "_mem_space")))
8646 gfc_error ("Memspace %qs at %L in USES_ALLOCATORS must be "
8647 "a predefined memory space",
8648 n
->u
.memspace_sym
->name
, &n
->where
);
8649 for (; n
!= NULL
; n
= n
->next
)
8651 if (n
->sym
->ts
.type
!= BT_INTEGER
8652 || n
->sym
->ts
.kind
!= gfc_c_intptr_kind
8653 || n
->sym
->attr
.dimension
)
8654 gfc_error ("Allocator %qs at %L in USES_ALLOCATORS must "
8655 "be a scalar integer of kind "
8656 "%<omp_allocator_handle_kind%>", n
->sym
->name
,
8658 else if (n
->sym
->attr
.flavor
!= FL_VARIABLE
8659 && ((!startswith (n
->sym
->name
, "omp_")
8660 && !startswith (n
->sym
->name
, "ompx_"))
8661 || !endswith (n
->sym
->name
, "_mem_alloc")))
8662 gfc_error ("Allocator %qs at %L in USES_ALLOCATORS must "
8663 "either a variable or a predefined allocator",
8664 n
->sym
->name
, &n
->where
);
8665 else if ((n
->u
.memspace_sym
|| n
->u2
.traits_sym
)
8666 && n
->sym
->attr
.flavor
!= FL_VARIABLE
)
8667 gfc_error ("A memory space or traits array may not be "
8668 "specified for predefined allocator %qs at %L",
8669 n
->sym
->name
, &n
->where
);
8670 if (n
->u2
.traits_sym
8671 && (n
->u2
.traits_sym
->attr
.flavor
!= FL_PARAMETER
8672 || !n
->u2
.traits_sym
->attr
.dimension
8673 || n
->u2
.traits_sym
->as
->rank
!= 1
8674 || n
->u2
.traits_sym
->ts
.type
!= BT_DERIVED
8675 || strcmp (n
->u2
.traits_sym
->ts
.u
.derived
->name
,
8676 "omp_alloctrait") != 0))
8678 gfc_error ("Traits array %qs in USES_ALLOCATORS %L must "
8679 "be a one-dimensional named constant array of "
8680 "type %<omp_alloctrait%>",
8681 n
->u2
.traits_sym
->name
, &n
->where
);
8688 for (; n
!= NULL
; n
= n
->next
)
8692 gcc_assert (code
->op
== EXEC_OMP_ALLOCATORS
8693 || code
->op
== EXEC_OMP_ALLOCATE
);
8697 bool is_reduction
= (list
== OMP_LIST_REDUCTION
8698 || list
== OMP_LIST_REDUCTION_INSCAN
8699 || list
== OMP_LIST_REDUCTION_TASK
8700 || list
== OMP_LIST_IN_REDUCTION
8701 || list
== OMP_LIST_TASK_REDUCTION
);
8702 if (list
== OMP_LIST_REDUCTION_INSCAN
)
8704 else if (is_reduction
)
8705 has_notinscan
= true;
8706 if (has_inscan
&& has_notinscan
&& is_reduction
)
8708 gfc_error ("%<inscan%> and non-%<inscan%> %<reduction%> "
8709 "clauses on the same construct at %L",
8713 if (n
->sym
->attr
.threadprivate
)
8714 gfc_error ("THREADPRIVATE object %qs in %s clause at %L",
8715 n
->sym
->name
, name
, &n
->where
);
8716 if (n
->sym
->attr
.cray_pointee
)
8717 gfc_error ("Cray pointee %qs in %s clause at %L",
8718 n
->sym
->name
, name
, &n
->where
);
8719 if (n
->sym
->attr
.associate_var
)
8720 gfc_error ("Associate name %qs in %s clause at %L",
8721 n
->sym
->attr
.select_type_temporary
8722 ? n
->sym
->assoc
->target
->symtree
->n
.sym
->name
8723 : n
->sym
->name
, name
, &n
->where
);
8724 if (list
!= OMP_LIST_PRIVATE
&& is_reduction
)
8726 if (n
->sym
->attr
.proc_pointer
)
8727 gfc_error ("Procedure pointer %qs in %s clause at %L",
8728 n
->sym
->name
, name
, &n
->where
);
8729 if (n
->sym
->attr
.pointer
)
8730 gfc_error ("POINTER object %qs in %s clause at %L",
8731 n
->sym
->name
, name
, &n
->where
);
8732 if (n
->sym
->attr
.cray_pointer
)
8733 gfc_error ("Cray pointer %qs in %s clause at %L",
8734 n
->sym
->name
, name
, &n
->where
);
8737 && (oacc_is_loop (code
)
8738 || code
->op
== EXEC_OACC_PARALLEL
8739 || code
->op
== EXEC_OACC_SERIAL
))
8740 check_array_not_assumed (n
->sym
, n
->where
, name
);
8741 else if (list
!= OMP_LIST_UNIFORM
8742 && n
->sym
->as
&& n
->sym
->as
->type
== AS_ASSUMED_SIZE
)
8743 gfc_error ("Assumed size array %qs in %s clause at %L",
8744 n
->sym
->name
, name
, &n
->where
);
8745 if (n
->sym
->attr
.in_namelist
&& !is_reduction
)
8746 gfc_error ("Variable %qs in %s clause is used in "
8747 "NAMELIST statement at %L",
8748 n
->sym
->name
, name
, &n
->where
);
8749 if (n
->sym
->attr
.pointer
&& n
->sym
->attr
.intent
== INTENT_IN
)
8752 case OMP_LIST_PRIVATE
:
8753 case OMP_LIST_LASTPRIVATE
:
8754 case OMP_LIST_LINEAR
:
8755 /* case OMP_LIST_REDUCTION: */
8756 gfc_error ("INTENT(IN) POINTER %qs in %s clause at %L",
8757 n
->sym
->name
, name
, &n
->where
);
8762 if (omp_clauses
->detach
8763 && (list
== OMP_LIST_PRIVATE
8764 || list
== OMP_LIST_FIRSTPRIVATE
8765 || list
== OMP_LIST_LASTPRIVATE
)
8766 && n
->sym
== omp_clauses
->detach
->symtree
->n
.sym
)
8767 gfc_error ("DETACH event handle %qs in %s clause at %L",
8768 n
->sym
->name
, name
, &n
->where
);
8771 case OMP_LIST_REDUCTION_TASK
:
8773 && (code
->op
== EXEC_OMP_LOOP
8774 || code
->op
== EXEC_OMP_TASKLOOP
8775 || code
->op
== EXEC_OMP_TASKLOOP_SIMD
8776 || code
->op
== EXEC_OMP_MASKED_TASKLOOP
8777 || code
->op
== EXEC_OMP_MASKED_TASKLOOP_SIMD
8778 || code
->op
== EXEC_OMP_MASTER_TASKLOOP
8779 || code
->op
== EXEC_OMP_MASTER_TASKLOOP_SIMD
8780 || code
->op
== EXEC_OMP_PARALLEL_LOOP
8781 || code
->op
== EXEC_OMP_PARALLEL_MASKED_TASKLOOP
8782 || code
->op
== EXEC_OMP_PARALLEL_MASKED_TASKLOOP_SIMD
8783 || code
->op
== EXEC_OMP_PARALLEL_MASTER_TASKLOOP
8784 || code
->op
== EXEC_OMP_PARALLEL_MASTER_TASKLOOP_SIMD
8785 || code
->op
== EXEC_OMP_TARGET_PARALLEL_LOOP
8786 || code
->op
== EXEC_OMP_TARGET_TEAMS_LOOP
8787 || code
->op
== EXEC_OMP_TEAMS
8788 || code
->op
== EXEC_OMP_TEAMS_DISTRIBUTE
8789 || code
->op
== EXEC_OMP_TEAMS_LOOP
))
8791 gfc_error ("Only DEFAULT permitted as reduction-"
8792 "modifier in REDUCTION clause at %L",
8797 case OMP_LIST_REDUCTION
:
8798 case OMP_LIST_IN_REDUCTION
:
8799 case OMP_LIST_TASK_REDUCTION
:
8800 case OMP_LIST_REDUCTION_INSCAN
:
8801 switch (n
->u
.reduction_op
)
8803 case OMP_REDUCTION_PLUS
:
8804 case OMP_REDUCTION_TIMES
:
8805 case OMP_REDUCTION_MINUS
:
8806 if (!gfc_numeric_ts (&n
->sym
->ts
))
8809 case OMP_REDUCTION_AND
:
8810 case OMP_REDUCTION_OR
:
8811 case OMP_REDUCTION_EQV
:
8812 case OMP_REDUCTION_NEQV
:
8813 if (n
->sym
->ts
.type
!= BT_LOGICAL
)
8816 case OMP_REDUCTION_MAX
:
8817 case OMP_REDUCTION_MIN
:
8818 if (n
->sym
->ts
.type
!= BT_INTEGER
8819 && n
->sym
->ts
.type
!= BT_REAL
)
8822 case OMP_REDUCTION_IAND
:
8823 case OMP_REDUCTION_IOR
:
8824 case OMP_REDUCTION_IEOR
:
8825 if (n
->sym
->ts
.type
!= BT_INTEGER
)
8828 case OMP_REDUCTION_USER
:
8838 const char *udr_name
= NULL
;
8841 udr_name
= n
->u2
.udr
->udr
->name
;
8843 = gfc_find_omp_udr (NULL
, udr_name
,
8845 if (n
->u2
.udr
->udr
== NULL
)
8851 if (n
->u2
.udr
== NULL
)
8853 if (udr_name
== NULL
)
8854 switch (n
->u
.reduction_op
)
8856 case OMP_REDUCTION_PLUS
:
8857 case OMP_REDUCTION_TIMES
:
8858 case OMP_REDUCTION_MINUS
:
8859 case OMP_REDUCTION_AND
:
8860 case OMP_REDUCTION_OR
:
8861 case OMP_REDUCTION_EQV
:
8862 case OMP_REDUCTION_NEQV
:
8863 udr_name
= gfc_op2string ((gfc_intrinsic_op
)
8866 case OMP_REDUCTION_MAX
:
8869 case OMP_REDUCTION_MIN
:
8872 case OMP_REDUCTION_IAND
:
8875 case OMP_REDUCTION_IOR
:
8878 case OMP_REDUCTION_IEOR
:
8884 gfc_error ("!$OMP DECLARE REDUCTION %s not found "
8885 "for type %s at %L", udr_name
,
8886 gfc_typename (&n
->sym
->ts
), &n
->where
);
8890 gfc_omp_udr
*udr
= n
->u2
.udr
->udr
;
8891 n
->u
.reduction_op
= OMP_REDUCTION_USER
;
8893 = resolve_omp_udr_clause (n
, udr
->combiner_ns
,
8896 if (udr
->initializer_ns
)
8897 n
->u2
.udr
->initializer
8898 = resolve_omp_udr_clause (n
,
8899 udr
->initializer_ns
,
8905 case OMP_LIST_LINEAR
:
8907 && n
->u
.linear
.op
!= OMP_LINEAR_DEFAULT
8908 && n
->u
.linear
.op
!= linear_op
)
8910 if (n
->u
.linear
.old_modifier
)
8912 gfc_error ("LINEAR clause modifier used on DO or "
8913 "SIMD construct at %L", &n
->where
);
8914 linear_op
= n
->u
.linear
.op
;
8916 else if (n
->u
.linear
.op
!= OMP_LINEAR_VAL
)
8918 gfc_error ("LINEAR clause modifier other than VAL "
8919 "used on DO or SIMD construct at %L",
8921 linear_op
= n
->u
.linear
.op
;
8924 else if (n
->u
.linear
.op
!= OMP_LINEAR_REF
8925 && n
->sym
->ts
.type
!= BT_INTEGER
)
8926 gfc_error ("LINEAR variable %qs must be INTEGER "
8927 "at %L", n
->sym
->name
, &n
->where
);
8928 else if ((n
->u
.linear
.op
== OMP_LINEAR_REF
8929 || n
->u
.linear
.op
== OMP_LINEAR_UVAL
)
8930 && n
->sym
->attr
.value
)
8931 gfc_error ("LINEAR dummy argument %qs with VALUE "
8932 "attribute with %s modifier at %L",
8934 n
->u
.linear
.op
== OMP_LINEAR_REF
8935 ? "REF" : "UVAL", &n
->where
);
8938 gfc_expr
*expr
= n
->expr
;
8939 if (!gfc_resolve_expr (expr
)
8940 || expr
->ts
.type
!= BT_INTEGER
8942 gfc_error ("%qs in LINEAR clause at %L requires "
8943 "a scalar integer linear-step expression",
8944 n
->sym
->name
, &n
->where
);
8945 else if (!code
&& expr
->expr_type
!= EXPR_CONSTANT
)
8947 if (expr
->expr_type
== EXPR_VARIABLE
8948 && expr
->symtree
->n
.sym
->attr
.dummy
8949 && expr
->symtree
->n
.sym
->ns
== ns
)
8951 gfc_omp_namelist
*n2
;
8952 for (n2
= omp_clauses
->lists
[OMP_LIST_UNIFORM
];
8954 if (n2
->sym
== expr
->symtree
->n
.sym
)
8959 gfc_error ("%qs in LINEAR clause at %L requires "
8960 "a constant integer linear-step "
8961 "expression or dummy argument "
8962 "specified in UNIFORM clause",
8963 n
->sym
->name
, &n
->where
);
8967 /* Workaround for PR middle-end/26316, nothing really needs
8968 to be done here for OMP_LIST_PRIVATE. */
8969 case OMP_LIST_PRIVATE
:
8970 gcc_assert (code
&& code
->op
!= EXEC_NOP
);
8972 case OMP_LIST_USE_DEVICE
:
8973 if (n
->sym
->attr
.allocatable
8974 || (n
->sym
->ts
.type
== BT_CLASS
&& CLASS_DATA (n
->sym
)
8975 && CLASS_DATA (n
->sym
)->attr
.allocatable
))
8976 gfc_error ("ALLOCATABLE object %qs in %s clause at %L",
8977 n
->sym
->name
, name
, &n
->where
);
8978 if (n
->sym
->ts
.type
== BT_CLASS
8979 && CLASS_DATA (n
->sym
)
8980 && CLASS_DATA (n
->sym
)->attr
.class_pointer
)
8981 gfc_error ("POINTER object %qs of polymorphic type in "
8982 "%s clause at %L", n
->sym
->name
, name
,
8984 if (n
->sym
->attr
.cray_pointer
)
8985 gfc_error ("Cray pointer object %qs in %s clause at %L",
8986 n
->sym
->name
, name
, &n
->where
);
8987 else if (n
->sym
->attr
.cray_pointee
)
8988 gfc_error ("Cray pointee object %qs in %s clause at %L",
8989 n
->sym
->name
, name
, &n
->where
);
8990 else if (n
->sym
->attr
.flavor
== FL_VARIABLE
8992 && !n
->sym
->attr
.pointer
)
8993 gfc_error ("%s clause variable %qs at %L is neither "
8994 "a POINTER nor an array", name
,
8995 n
->sym
->name
, &n
->where
);
8997 case OMP_LIST_DEVICE_RESIDENT
:
8998 check_symbol_not_pointer (n
->sym
, n
->where
, name
);
8999 check_array_not_assumed (n
->sym
, n
->where
, name
);
9008 /* OpenMP 5.1: use_device_ptr acts like use_device_addr, except for
9010 if (omp_clauses
->lists
[OMP_LIST_USE_DEVICE_PTR
])
9012 gfc_omp_namelist
*n_prev
, *n_next
, *n_addr
;
9013 n_addr
= omp_clauses
->lists
[OMP_LIST_USE_DEVICE_ADDR
];
9014 for (; n_addr
&& n_addr
->next
; n_addr
= n_addr
->next
)
9017 n
= omp_clauses
->lists
[OMP_LIST_USE_DEVICE_PTR
];
9021 if (n
->sym
->ts
.type
!= BT_DERIVED
9022 || n
->sym
->ts
.u
.derived
->ts
.f90_type
!= BT_VOID
)
9028 omp_clauses
->lists
[OMP_LIST_USE_DEVICE_ADDR
] = n
;
9031 n_prev
->next
= n_next
;
9033 omp_clauses
->lists
[OMP_LIST_USE_DEVICE_PTR
] = n_next
;
9040 if (omp_clauses
->safelen_expr
)
9041 resolve_positive_int_expr (omp_clauses
->safelen_expr
, "SAFELEN");
9042 if (omp_clauses
->simdlen_expr
)
9043 resolve_positive_int_expr (omp_clauses
->simdlen_expr
, "SIMDLEN");
9044 if (omp_clauses
->num_teams_lower
)
9045 resolve_positive_int_expr (omp_clauses
->num_teams_lower
, "NUM_TEAMS");
9046 if (omp_clauses
->num_teams_upper
)
9047 resolve_positive_int_expr (omp_clauses
->num_teams_upper
, "NUM_TEAMS");
9048 if (omp_clauses
->num_teams_lower
9049 && omp_clauses
->num_teams_lower
->expr_type
== EXPR_CONSTANT
9050 && omp_clauses
->num_teams_upper
->expr_type
== EXPR_CONSTANT
9051 && mpz_cmp (omp_clauses
->num_teams_lower
->value
.integer
,
9052 omp_clauses
->num_teams_upper
->value
.integer
) > 0)
9053 gfc_warning (OPT_Wopenmp
, "NUM_TEAMS lower bound at %L larger than upper "
9054 "bound at %L", &omp_clauses
->num_teams_lower
->where
,
9055 &omp_clauses
->num_teams_upper
->where
);
9056 if (omp_clauses
->device
)
9057 resolve_scalar_int_expr (omp_clauses
->device
, "DEVICE");
9058 if (omp_clauses
->filter
)
9059 resolve_nonnegative_int_expr (omp_clauses
->filter
, "FILTER");
9060 if (omp_clauses
->hint
)
9062 resolve_scalar_int_expr (omp_clauses
->hint
, "HINT");
9063 if (omp_clauses
->hint
->ts
.type
!= BT_INTEGER
9064 || omp_clauses
->hint
->expr_type
!= EXPR_CONSTANT
9065 || mpz_sgn (omp_clauses
->hint
->value
.integer
) < 0)
9066 gfc_error ("Value of HINT clause at %L shall be a valid "
9067 "constant hint expression", &omp_clauses
->hint
->where
);
9069 if (omp_clauses
->priority
)
9070 resolve_nonnegative_int_expr (omp_clauses
->priority
, "PRIORITY");
9071 if (omp_clauses
->dist_chunk_size
)
9073 gfc_expr
*expr
= omp_clauses
->dist_chunk_size
;
9074 if (!gfc_resolve_expr (expr
)
9075 || expr
->ts
.type
!= BT_INTEGER
|| expr
->rank
!= 0)
9076 gfc_error ("DIST_SCHEDULE clause's chunk_size at %L requires "
9077 "a scalar INTEGER expression", &expr
->where
);
9079 if (omp_clauses
->thread_limit
)
9080 resolve_positive_int_expr (omp_clauses
->thread_limit
, "THREAD_LIMIT");
9081 if (omp_clauses
->grainsize
)
9082 resolve_positive_int_expr (omp_clauses
->grainsize
, "GRAINSIZE");
9083 if (omp_clauses
->num_tasks
)
9084 resolve_positive_int_expr (omp_clauses
->num_tasks
, "NUM_TASKS");
9085 if (omp_clauses
->async
)
9086 if (omp_clauses
->async_expr
)
9087 resolve_scalar_int_expr (omp_clauses
->async_expr
, "ASYNC");
9088 if (omp_clauses
->num_gangs_expr
)
9089 resolve_positive_int_expr (omp_clauses
->num_gangs_expr
, "NUM_GANGS");
9090 if (omp_clauses
->num_workers_expr
)
9091 resolve_positive_int_expr (omp_clauses
->num_workers_expr
, "NUM_WORKERS");
9092 if (omp_clauses
->vector_length_expr
)
9093 resolve_positive_int_expr (omp_clauses
->vector_length_expr
,
9095 if (omp_clauses
->gang_num_expr
)
9096 resolve_positive_int_expr (omp_clauses
->gang_num_expr
, "GANG");
9097 if (omp_clauses
->gang_static_expr
)
9098 resolve_positive_int_expr (omp_clauses
->gang_static_expr
, "GANG");
9099 if (omp_clauses
->worker_expr
)
9100 resolve_positive_int_expr (omp_clauses
->worker_expr
, "WORKER");
9101 if (omp_clauses
->vector_expr
)
9102 resolve_positive_int_expr (omp_clauses
->vector_expr
, "VECTOR");
9103 for (el
= omp_clauses
->wait_list
; el
; el
= el
->next
)
9104 resolve_scalar_int_expr (el
->expr
, "WAIT");
9105 if (omp_clauses
->collapse
&& omp_clauses
->tile_list
)
9106 gfc_error ("Incompatible use of TILE and COLLAPSE at %L", &code
->loc
);
9107 if (omp_clauses
->message
)
9109 gfc_expr
*expr
= omp_clauses
->message
;
9110 if (!gfc_resolve_expr (expr
)
9111 || expr
->ts
.kind
!= gfc_default_character_kind
9112 || expr
->ts
.type
!= BT_CHARACTER
|| expr
->rank
!= 0)
9113 gfc_error ("MESSAGE clause at %L requires a scalar default-kind "
9114 "CHARACTER expression", &expr
->where
);
9118 && omp_clauses
->lists
[OMP_LIST_MAP
] == NULL
9119 && omp_clauses
->lists
[OMP_LIST_USE_DEVICE_PTR
] == NULL
9120 && omp_clauses
->lists
[OMP_LIST_USE_DEVICE_ADDR
] == NULL
)
9122 const char *p
= NULL
;
9125 case EXEC_OMP_TARGET_ENTER_DATA
: p
= "TARGET ENTER DATA"; break;
9126 case EXEC_OMP_TARGET_EXIT_DATA
: p
= "TARGET EXIT DATA"; break;
9129 if (code
->op
== EXEC_OMP_TARGET_DATA
)
9130 gfc_error ("TARGET DATA must contain at least one MAP, USE_DEVICE_PTR, "
9131 "or USE_DEVICE_ADDR clause at %L", &code
->loc
);
9133 gfc_error ("%s must contain at least one MAP clause at %L",
9137 if (!openacc
&& omp_clauses
->detach
)
9139 if (!gfc_resolve_expr (omp_clauses
->detach
)
9140 || omp_clauses
->detach
->ts
.type
!= BT_INTEGER
9141 || omp_clauses
->detach
->ts
.kind
!= gfc_c_intptr_kind
9142 || omp_clauses
->detach
->rank
!= 0)
9143 gfc_error ("%qs at %L should be a scalar of type "
9144 "integer(kind=omp_event_handle_kind)",
9145 omp_clauses
->detach
->symtree
->n
.sym
->name
,
9146 &omp_clauses
->detach
->where
);
9147 else if (omp_clauses
->detach
->symtree
->n
.sym
->attr
.dimension
> 0)
9148 gfc_error ("The event handle at %L must not be an array element",
9149 &omp_clauses
->detach
->where
);
9150 else if (omp_clauses
->detach
->symtree
->n
.sym
->ts
.type
== BT_DERIVED
9151 || omp_clauses
->detach
->symtree
->n
.sym
->ts
.type
== BT_CLASS
)
9152 gfc_error ("The event handle at %L must not be part of "
9153 "a derived type or class", &omp_clauses
->detach
->where
);
9155 if (omp_clauses
->mergeable
)
9156 gfc_error ("%<DETACH%> clause at %L must not be used together with "
9157 "%<MERGEABLE%> clause", &omp_clauses
->detach
->where
);
9161 && code
->op
== EXEC_OACC_HOST_DATA
9162 && omp_clauses
->lists
[OMP_LIST_USE_DEVICE
] == NULL
)
9163 gfc_error ("%<host_data%> construct at %L requires %<use_device%> clause",
9166 if (omp_clauses
->assume
)
9167 gfc_resolve_omp_assumptions (omp_clauses
->assume
);
9171 /* Return true if SYM is ever referenced in EXPR except in the SE node. */
9174 expr_references_sym (gfc_expr
*e
, gfc_symbol
*s
, gfc_expr
*se
)
9176 gfc_actual_arglist
*arg
;
9177 if (e
== NULL
|| e
== se
)
9179 switch (e
->expr_type
)
9184 case EXPR_STRUCTURE
:
9186 if (e
->symtree
!= NULL
9187 && e
->symtree
->n
.sym
== s
)
9190 case EXPR_SUBSTRING
:
9192 && (expr_references_sym (e
->ref
->u
.ss
.start
, s
, se
)
9193 || expr_references_sym (e
->ref
->u
.ss
.end
, s
, se
)))
9197 if (expr_references_sym (e
->value
.op
.op2
, s
, se
))
9199 return expr_references_sym (e
->value
.op
.op1
, s
, se
);
9201 for (arg
= e
->value
.function
.actual
; arg
; arg
= arg
->next
)
9202 if (expr_references_sym (arg
->expr
, s
, se
))
9211 /* If EXPR is a conversion function that widens the type
9212 if WIDENING is true or narrows the type if NARROW is true,
9213 return the inner expression, otherwise return NULL. */
9216 is_conversion (gfc_expr
*expr
, bool narrowing
, bool widening
)
9218 gfc_typespec
*ts1
, *ts2
;
9220 if (expr
->expr_type
!= EXPR_FUNCTION
9221 || expr
->value
.function
.isym
== NULL
9222 || expr
->value
.function
.esym
!= NULL
9223 || expr
->value
.function
.isym
->id
!= GFC_ISYM_CONVERSION
9224 || (!narrowing
&& !widening
))
9227 if (narrowing
&& widening
)
9228 return expr
->value
.function
.actual
->expr
;
9233 ts2
= &expr
->value
.function
.actual
->expr
->ts
;
9237 ts1
= &expr
->value
.function
.actual
->expr
->ts
;
9241 if (ts1
->type
> ts2
->type
9242 || (ts1
->type
== ts2
->type
&& ts1
->kind
> ts2
->kind
))
9243 return expr
->value
.function
.actual
->expr
;
9249 is_scalar_intrinsic_expr (gfc_expr
*expr
, bool must_be_var
, bool conv_ok
)
9252 && (expr
->expr_type
!= EXPR_VARIABLE
|| !expr
->symtree
))
9256 gfc_expr
*conv
= is_conversion (expr
, true, true);
9259 if (conv
->expr_type
!= EXPR_VARIABLE
|| !conv
->symtree
)
9262 return (expr
->rank
== 0
9263 && !gfc_is_coindexed (expr
)
9264 && (expr
->ts
.type
== BT_INTEGER
9265 || expr
->ts
.type
== BT_REAL
9266 || expr
->ts
.type
== BT_COMPLEX
9267 || expr
->ts
.type
== BT_LOGICAL
));
9271 resolve_omp_atomic (gfc_code
*code
)
9273 gfc_code
*atomic_code
= code
->block
;
9275 gfc_expr
*stmt_expr2
, *capt_expr2
;
9276 gfc_omp_atomic_op aop
9277 = (gfc_omp_atomic_op
) (atomic_code
->ext
.omp_clauses
->atomic_op
9278 & GFC_OMP_ATOMIC_MASK
);
9279 gfc_code
*stmt
= NULL
, *capture_stmt
= NULL
, *tailing_stmt
= NULL
;
9280 gfc_expr
*comp_cond
= NULL
;
9283 code
= code
->block
->next
;
9284 /* resolve_blocks asserts this is initially EXEC_ASSIGN or EXEC_IF
9285 If it changed to EXEC_NOP, assume an error has been emitted already. */
9286 if (code
->op
== EXEC_NOP
)
9289 if (atomic_code
->ext
.omp_clauses
->compare
9290 && atomic_code
->ext
.omp_clauses
->capture
)
9292 /* Must be either "if (x == e) then; x = d; else; v = x; end if"
9293 or "v = expr" followed/preceded by
9294 "if (x == e) then; x = d; end if" or "if (x == e) x = d". */
9295 gfc_code
*next
= code
;
9296 if (code
->op
== EXEC_ASSIGN
)
9298 capture_stmt
= code
;
9301 if (next
->op
== EXEC_IF
9303 && next
->block
->op
== EXEC_IF
9304 && next
->block
->next
9305 && next
->block
->next
->op
== EXEC_ASSIGN
)
9307 comp_cond
= next
->block
->expr1
;
9308 stmt
= next
->block
->next
;
9315 else if (capture_stmt
)
9317 gfc_error ("Expected IF at %L in atomic compare capture",
9321 if (stmt
&& !capture_stmt
&& next
->block
->block
)
9323 if (next
->block
->block
->expr1
)
9325 gfc_error ("Expected ELSE at %L in atomic compare capture",
9326 &next
->block
->block
->expr1
->where
);
9329 if (!code
->block
->block
->next
9330 || code
->block
->block
->next
->op
!= EXEC_ASSIGN
)
9332 loc
= (code
->block
->block
->next
? &code
->block
->block
->next
->loc
9333 : &code
->block
->block
->loc
);
9336 capture_stmt
= code
->block
->block
->next
;
9337 if (capture_stmt
->next
)
9339 loc
= &capture_stmt
->next
->loc
;
9343 if (stmt
&& !capture_stmt
&& next
->next
->op
== EXEC_ASSIGN
)
9344 capture_stmt
= next
->next
;
9345 else if (!capture_stmt
)
9351 else if (atomic_code
->ext
.omp_clauses
->compare
)
9353 /* Must be: "if (x == e) then; x = d; end if" or "if (x == e) x = d". */
9354 if (code
->op
== EXEC_IF
9356 && code
->block
->op
== EXEC_IF
9357 && code
->block
->next
9358 && code
->block
->next
->op
== EXEC_ASSIGN
)
9360 comp_cond
= code
->block
->expr1
;
9361 stmt
= code
->block
->next
;
9362 if (stmt
->next
|| code
->block
->block
)
9364 loc
= stmt
->next
? &stmt
->next
->loc
: &code
->block
->block
->loc
;
9374 else if (atomic_code
->ext
.omp_clauses
->capture
)
9376 /* Must be: "v = x" followed/preceded by "x = ...". */
9377 if (code
->op
!= EXEC_ASSIGN
)
9379 if (code
->next
->op
!= EXEC_ASSIGN
)
9381 loc
= &code
->next
->loc
;
9384 gfc_expr
*expr2
, *expr2_next
;
9385 expr2
= is_conversion (code
->expr2
, true, true);
9387 expr2
= code
->expr2
;
9388 expr2_next
= is_conversion (code
->next
->expr2
, true, true);
9389 if (expr2_next
== NULL
)
9390 expr2_next
= code
->next
->expr2
;
9391 if (code
->expr1
->expr_type
== EXPR_VARIABLE
9392 && code
->next
->expr1
->expr_type
== EXPR_VARIABLE
9393 && expr2
->expr_type
== EXPR_VARIABLE
9394 && expr2_next
->expr_type
== EXPR_VARIABLE
)
9396 if (code
->expr1
->symtree
->n
.sym
== expr2_next
->symtree
->n
.sym
)
9399 capture_stmt
= code
->next
;
9403 capture_stmt
= code
;
9407 else if (expr2
->expr_type
== EXPR_VARIABLE
)
9409 capture_stmt
= code
;
9415 capture_stmt
= code
->next
;
9417 /* Shall be NULL but can happen for invalid code. */
9418 tailing_stmt
= code
->next
->next
;
9424 if (!atomic_code
->ext
.omp_clauses
->compare
&& stmt
->op
!= EXEC_ASSIGN
)
9426 /* Shall be NULL but can happen for invalid code. */
9427 tailing_stmt
= code
->next
;
9432 if (comp_cond
->expr_type
!= EXPR_OP
9433 || (comp_cond
->value
.op
.op
!= INTRINSIC_EQ
9434 && comp_cond
->value
.op
.op
!= INTRINSIC_EQ_OS
9435 && comp_cond
->value
.op
.op
!= INTRINSIC_EQV
))
9437 gfc_error ("Expected %<==%>, %<.EQ.%> or %<.EQV.%> atomic comparison "
9438 "expression at %L", &comp_cond
->where
);
9441 if (!is_scalar_intrinsic_expr (comp_cond
->value
.op
.op1
, true, true))
9443 gfc_error ("Expected scalar intrinsic variable at %L in atomic "
9444 "comparison", &comp_cond
->value
.op
.op1
->where
);
9447 if (!gfc_resolve_expr (comp_cond
->value
.op
.op2
))
9449 if (!is_scalar_intrinsic_expr (comp_cond
->value
.op
.op2
, false, false))
9451 gfc_error ("Expected scalar intrinsic expression at %L in atomic "
9452 "comparison", &comp_cond
->value
.op
.op1
->where
);
9457 if (!is_scalar_intrinsic_expr (stmt
->expr1
, true, false))
9459 gfc_error ("!$OMP ATOMIC statement must set a scalar variable of "
9460 "intrinsic type at %L", &stmt
->expr1
->where
);
9464 if (!gfc_resolve_expr (stmt
->expr2
))
9466 if (!is_scalar_intrinsic_expr (stmt
->expr2
, false, false))
9468 gfc_error ("!$OMP ATOMIC statement must assign an expression of "
9469 "intrinsic type at %L", &stmt
->expr2
->where
);
9473 if (gfc_expr_attr (stmt
->expr1
).allocatable
)
9475 gfc_error ("!$OMP ATOMIC with ALLOCATABLE variable at %L",
9476 &stmt
->expr1
->where
);
9480 /* Should be diagnosed above already. */
9481 gcc_assert (tailing_stmt
== NULL
);
9483 var
= stmt
->expr1
->symtree
->n
.sym
;
9484 stmt_expr2
= is_conversion (stmt
->expr2
, true, true);
9485 if (stmt_expr2
== NULL
)
9486 stmt_expr2
= stmt
->expr2
;
9490 case GFC_OMP_ATOMIC_READ
:
9491 if (stmt_expr2
->expr_type
!= EXPR_VARIABLE
)
9492 gfc_error ("!$OMP ATOMIC READ statement must read from a scalar "
9493 "variable of intrinsic type at %L", &stmt_expr2
->where
);
9495 case GFC_OMP_ATOMIC_WRITE
:
9496 if (expr_references_sym (stmt_expr2
, var
, NULL
))
9497 gfc_error ("expr in !$OMP ATOMIC WRITE assignment var = expr "
9498 "must be scalar and cannot reference var at %L",
9499 &stmt_expr2
->where
);
9505 if (atomic_code
->ext
.omp_clauses
->capture
)
9507 if (!is_scalar_intrinsic_expr (capture_stmt
->expr1
, true, false))
9509 gfc_error ("!$OMP ATOMIC capture-statement must set a scalar "
9510 "variable of intrinsic type at %L",
9511 &capture_stmt
->expr1
->where
);
9515 if (!is_scalar_intrinsic_expr (capture_stmt
->expr2
, true, true))
9517 gfc_error ("!$OMP ATOMIC capture-statement requires a scalar variable"
9518 " of intrinsic type at %L", &capture_stmt
->expr2
->where
);
9521 capt_expr2
= is_conversion (capture_stmt
->expr2
, true, true);
9522 if (capt_expr2
== NULL
)
9523 capt_expr2
= capture_stmt
->expr2
;
9525 if (capt_expr2
->symtree
->n
.sym
!= var
)
9527 gfc_error ("!$OMP ATOMIC CAPTURE capture statement reads from "
9528 "different variable than update statement writes "
9529 "into at %L", &capture_stmt
->expr2
->where
);
9534 if (atomic_code
->ext
.omp_clauses
->compare
)
9537 if (comp_cond
->value
.op
.op1
->expr_type
== EXPR_VARIABLE
)
9538 var_expr
= comp_cond
->value
.op
.op1
;
9540 var_expr
= comp_cond
->value
.op
.op1
->value
.function
.actual
->expr
;
9541 if (var_expr
->symtree
->n
.sym
!= var
)
9543 gfc_error ("For !$OMP ATOMIC COMPARE, the first operand in comparison"
9544 " at %L must be the variable %qs that the update statement"
9545 " writes into at %L", &var_expr
->where
, var
->name
,
9546 &stmt
->expr1
->where
);
9549 if (stmt_expr2
->rank
!= 0 || expr_references_sym (stmt_expr2
, var
, NULL
))
9551 gfc_error ("expr in !$OMP ATOMIC COMPARE assignment var = expr "
9552 "must be scalar and cannot reference var at %L",
9553 &stmt_expr2
->where
);
9557 else if (atomic_code
->ext
.omp_clauses
->capture
9558 && !expr_references_sym (stmt_expr2
, var
, NULL
))
9559 atomic_code
->ext
.omp_clauses
->atomic_op
9560 = (gfc_omp_atomic_op
) (atomic_code
->ext
.omp_clauses
->atomic_op
9561 | GFC_OMP_ATOMIC_SWAP
);
9562 else if (stmt_expr2
->expr_type
== EXPR_OP
)
9564 gfc_expr
*v
= NULL
, *e
, *c
;
9565 gfc_intrinsic_op op
= stmt_expr2
->value
.op
.op
;
9566 gfc_intrinsic_op alt_op
= INTRINSIC_NONE
;
9568 if (atomic_code
->ext
.omp_clauses
->fail
!= OMP_MEMORDER_UNSET
)
9569 gfc_error ("!$OMP ATOMIC UPDATE at %L with FAIL clause requiries either"
9570 " the COMPARE clause or using the intrinsic MIN/MAX "
9571 "procedure", &atomic_code
->loc
);
9574 case INTRINSIC_PLUS
:
9575 alt_op
= INTRINSIC_MINUS
;
9577 case INTRINSIC_TIMES
:
9578 alt_op
= INTRINSIC_DIVIDE
;
9580 case INTRINSIC_MINUS
:
9581 alt_op
= INTRINSIC_PLUS
;
9583 case INTRINSIC_DIVIDE
:
9584 alt_op
= INTRINSIC_TIMES
;
9590 alt_op
= INTRINSIC_NEQV
;
9592 case INTRINSIC_NEQV
:
9593 alt_op
= INTRINSIC_EQV
;
9596 gfc_error ("!$OMP ATOMIC assignment operator must be binary "
9597 "+, *, -, /, .AND., .OR., .EQV. or .NEQV. at %L",
9598 &stmt_expr2
->where
);
9602 /* Check for var = var op expr resp. var = expr op var where
9603 expr doesn't reference var and var op expr is mathematically
9604 equivalent to var op (expr) resp. expr op var equivalent to
9605 (expr) op var. We rely here on the fact that the matcher
9606 for x op1 y op2 z where op1 and op2 have equal precedence
9607 returns (x op1 y) op2 z. */
9608 e
= stmt_expr2
->value
.op
.op2
;
9609 if (e
->expr_type
== EXPR_VARIABLE
9610 && e
->symtree
!= NULL
9611 && e
->symtree
->n
.sym
== var
)
9613 else if ((c
= is_conversion (e
, false, true)) != NULL
9614 && c
->expr_type
== EXPR_VARIABLE
9615 && c
->symtree
!= NULL
9616 && c
->symtree
->n
.sym
== var
)
9620 gfc_expr
**p
= NULL
, **q
;
9621 for (q
= &stmt_expr2
->value
.op
.op1
; (e
= *q
) != NULL
; )
9622 if (e
->expr_type
== EXPR_VARIABLE
9623 && e
->symtree
!= NULL
9624 && e
->symtree
->n
.sym
== var
)
9629 else if ((c
= is_conversion (e
, false, true)) != NULL
)
9630 q
= &e
->value
.function
.actual
->expr
;
9631 else if (e
->expr_type
!= EXPR_OP
9632 || (e
->value
.op
.op
!= op
9633 && e
->value
.op
.op
!= alt_op
)
9639 q
= &e
->value
.op
.op1
;
9644 gfc_error ("!$OMP ATOMIC assignment must be var = var op expr "
9645 "or var = expr op var at %L", &stmt_expr2
->where
);
9652 switch (e
->value
.op
.op
)
9654 case INTRINSIC_MINUS
:
9655 case INTRINSIC_DIVIDE
:
9657 case INTRINSIC_NEQV
:
9658 gfc_error ("!$OMP ATOMIC var = var op expr not "
9659 "mathematically equivalent to var = var op "
9660 "(expr) at %L", &stmt_expr2
->where
);
9666 /* Canonicalize into var = var op (expr). */
9667 *p
= e
->value
.op
.op2
;
9668 e
->value
.op
.op2
= stmt_expr2
;
9669 e
->ts
= stmt_expr2
->ts
;
9670 if (stmt
->expr2
== stmt_expr2
)
9671 stmt
->expr2
= stmt_expr2
= e
;
9673 stmt
->expr2
->value
.function
.actual
->expr
= stmt_expr2
= e
;
9675 if (!gfc_compare_types (&stmt_expr2
->value
.op
.op1
->ts
,
9678 for (p
= &stmt_expr2
->value
.op
.op1
; *p
!= v
;
9679 p
= &(*p
)->value
.function
.actual
->expr
)
9682 gfc_free_expr (stmt_expr2
->value
.op
.op1
);
9683 stmt_expr2
->value
.op
.op1
= v
;
9684 gfc_convert_type (v
, &stmt_expr2
->ts
, 2);
9689 if (e
->rank
!= 0 || expr_references_sym (stmt
->expr2
, var
, v
))
9691 gfc_error ("expr in !$OMP ATOMIC assignment var = var op expr "
9692 "must be scalar and cannot reference var at %L",
9693 &stmt_expr2
->where
);
9697 else if (stmt_expr2
->expr_type
== EXPR_FUNCTION
9698 && stmt_expr2
->value
.function
.isym
!= NULL
9699 && stmt_expr2
->value
.function
.esym
== NULL
9700 && stmt_expr2
->value
.function
.actual
!= NULL
9701 && stmt_expr2
->value
.function
.actual
->next
!= NULL
)
9703 gfc_actual_arglist
*arg
, *var_arg
;
9705 switch (stmt_expr2
->value
.function
.isym
->id
)
9713 if (stmt_expr2
->value
.function
.actual
->next
->next
!= NULL
)
9715 gfc_error ("!$OMP ATOMIC assignment intrinsic IAND, IOR "
9716 "or IEOR must have two arguments at %L",
9717 &stmt_expr2
->where
);
9722 gfc_error ("!$OMP ATOMIC assignment intrinsic must be "
9723 "MIN, MAX, IAND, IOR or IEOR at %L",
9724 &stmt_expr2
->where
);
9729 for (arg
= stmt_expr2
->value
.function
.actual
; arg
; arg
= arg
->next
)
9732 if (arg
== stmt_expr2
->value
.function
.actual
9733 || (var_arg
== NULL
&& arg
->next
== NULL
))
9735 e
= is_conversion (arg
->expr
, false, true);
9738 if (e
->expr_type
== EXPR_VARIABLE
9739 && e
->symtree
!= NULL
9740 && e
->symtree
->n
.sym
== var
)
9743 if ((!var_arg
|| !e
) && expr_references_sym (arg
->expr
, var
, NULL
))
9745 gfc_error ("!$OMP ATOMIC intrinsic arguments except one must "
9746 "not reference %qs at %L",
9747 var
->name
, &arg
->expr
->where
);
9750 if (arg
->expr
->rank
!= 0)
9752 gfc_error ("!$OMP ATOMIC intrinsic arguments must be scalar "
9753 "at %L", &arg
->expr
->where
);
9758 if (var_arg
== NULL
)
9760 gfc_error ("First or last !$OMP ATOMIC intrinsic argument must "
9761 "be %qs at %L", var
->name
, &stmt_expr2
->where
);
9765 if (var_arg
!= stmt_expr2
->value
.function
.actual
)
9767 /* Canonicalize, so that var comes first. */
9768 gcc_assert (var_arg
->next
== NULL
);
9769 for (arg
= stmt_expr2
->value
.function
.actual
;
9770 arg
->next
!= var_arg
; arg
= arg
->next
)
9772 var_arg
->next
= stmt_expr2
->value
.function
.actual
;
9773 stmt_expr2
->value
.function
.actual
= var_arg
;
9778 gfc_error ("!$OMP ATOMIC assignment must have an operator or "
9779 "intrinsic on right hand side at %L", &stmt_expr2
->where
);
9783 gfc_error ("unexpected !$OMP ATOMIC expression at %L",
9784 loc
? loc
: &code
->loc
);
9789 static struct fortran_omp_context
9792 hash_set
<gfc_symbol
*> *sharing_clauses
;
9793 hash_set
<gfc_symbol
*> *private_iterators
;
9794 struct fortran_omp_context
*previous
;
9797 static gfc_code
*omp_current_do_code
;
9798 static int omp_current_do_collapse
;
9800 /* Forward declaration for mutually recursive functions. */
9802 find_nested_loop_in_block (gfc_code
*block
);
9804 /* Return the first nested DO loop in CHAIN, or NULL if there
9805 isn't one. Does no error checking on intervening code. */
9808 find_nested_loop_in_chain (gfc_code
*chain
)
9815 for (code
= chain
; code
; code
= code
->next
)
9817 if (code
->op
== EXEC_DO
)
9819 else if (code
->op
== EXEC_BLOCK
)
9821 gfc_code
*c
= find_nested_loop_in_block (code
);
9829 /* Return the first nested DO loop in BLOCK, or NULL if there
9830 isn't one. Does no error checking on intervening code. */
9832 find_nested_loop_in_block (gfc_code
*block
)
9835 gcc_assert (block
->op
== EXEC_BLOCK
);
9836 ns
= block
->ext
.block
.ns
;
9838 return find_nested_loop_in_chain (ns
->code
);
9842 gfc_resolve_omp_do_blocks (gfc_code
*code
, gfc_namespace
*ns
)
9844 if (code
->block
->next
&& code
->block
->next
->op
== EXEC_DO
)
9848 omp_current_do_code
= code
->block
->next
;
9849 if (code
->ext
.omp_clauses
->orderedc
)
9850 omp_current_do_collapse
= code
->ext
.omp_clauses
->orderedc
;
9851 else if (code
->ext
.omp_clauses
->collapse
)
9852 omp_current_do_collapse
= code
->ext
.omp_clauses
->collapse
;
9854 omp_current_do_collapse
= 1;
9855 if (code
->ext
.omp_clauses
->lists
[OMP_LIST_REDUCTION_INSCAN
])
9857 /* Checking that there is a matching EXEC_OMP_SCAN in the
9858 innermost body cannot be deferred to resolve_omp_do because
9859 we process directives nested in the loop before we get
9862 = &code
->ext
.omp_clauses
->lists
[OMP_LIST_REDUCTION_INSCAN
]->where
;
9865 for (i
= 1, c
= omp_current_do_code
;
9866 i
< omp_current_do_collapse
; i
++)
9868 c
= find_nested_loop_in_chain (c
->block
->next
);
9869 if (!c
|| c
->op
!= EXEC_DO
|| c
->block
== NULL
)
9873 /* Skip this if we don't have enough nested loops. That
9874 problem will be diagnosed elsewhere. */
9875 if (c
&& c
->op
== EXEC_DO
)
9877 gfc_code
*block
= c
->block
? c
->block
->next
: NULL
;
9878 if (block
&& block
->op
!= EXEC_OMP_SCAN
)
9879 while (block
&& block
->next
9880 && block
->next
->op
!= EXEC_OMP_SCAN
)
9881 block
= block
->next
;
9883 || (block
->op
!= EXEC_OMP_SCAN
9884 && (!block
->next
|| block
->next
->op
!= EXEC_OMP_SCAN
)))
9885 gfc_error ("With INSCAN at %L, expected loop body with "
9886 "!$OMP SCAN between two "
9887 "structured block sequences", loc
);
9890 if (block
->op
== EXEC_OMP_SCAN
)
9891 gfc_warning (OPT_Wopenmp
,
9892 "!$OMP SCAN at %L with zero executable "
9893 "statements in preceding structured block "
9894 "sequence", &block
->loc
);
9895 if ((block
->op
== EXEC_OMP_SCAN
&& !block
->next
)
9896 || (block
->next
&& block
->next
->op
== EXEC_OMP_SCAN
9897 && !block
->next
->next
))
9898 gfc_warning (OPT_Wopenmp
,
9899 "!$OMP SCAN at %L with zero executable "
9900 "statements in succeeding structured block "
9901 "sequence", block
->op
== EXEC_OMP_SCAN
9902 ? &block
->loc
: &block
->next
->loc
);
9904 if (block
&& block
->op
!= EXEC_OMP_SCAN
)
9905 block
= block
->next
;
9906 if (block
&& block
->op
== EXEC_OMP_SCAN
)
9907 /* Mark 'omp scan' as checked; flag will be unset later. */
9908 block
->ext
.omp_clauses
->if_present
= true;
9912 gfc_resolve_blocks (code
->block
, ns
);
9913 omp_current_do_collapse
= 0;
9914 omp_current_do_code
= NULL
;
9919 gfc_resolve_omp_parallel_blocks (gfc_code
*code
, gfc_namespace
*ns
)
9921 struct fortran_omp_context ctx
;
9922 gfc_omp_clauses
*omp_clauses
= code
->ext
.omp_clauses
;
9923 gfc_omp_namelist
*n
;
9927 ctx
.sharing_clauses
= new hash_set
<gfc_symbol
*>;
9928 ctx
.private_iterators
= new hash_set
<gfc_symbol
*>;
9929 ctx
.previous
= omp_current_ctx
;
9930 ctx
.is_openmp
= true;
9931 omp_current_ctx
= &ctx
;
9933 for (list
= 0; list
< OMP_LIST_NUM
; list
++)
9936 case OMP_LIST_SHARED
:
9937 case OMP_LIST_PRIVATE
:
9938 case OMP_LIST_FIRSTPRIVATE
:
9939 case OMP_LIST_LASTPRIVATE
:
9940 case OMP_LIST_REDUCTION
:
9941 case OMP_LIST_REDUCTION_INSCAN
:
9942 case OMP_LIST_REDUCTION_TASK
:
9943 case OMP_LIST_IN_REDUCTION
:
9944 case OMP_LIST_TASK_REDUCTION
:
9945 case OMP_LIST_LINEAR
:
9946 for (n
= omp_clauses
->lists
[list
]; n
; n
= n
->next
)
9947 ctx
.sharing_clauses
->add (n
->sym
);
9955 case EXEC_OMP_DISTRIBUTE_PARALLEL_DO
:
9956 case EXEC_OMP_DISTRIBUTE_PARALLEL_DO_SIMD
:
9957 case EXEC_OMP_MASKED_TASKLOOP
:
9958 case EXEC_OMP_MASKED_TASKLOOP_SIMD
:
9959 case EXEC_OMP_MASTER_TASKLOOP
:
9960 case EXEC_OMP_MASTER_TASKLOOP_SIMD
:
9961 case EXEC_OMP_PARALLEL_DO
:
9962 case EXEC_OMP_PARALLEL_DO_SIMD
:
9963 case EXEC_OMP_PARALLEL_LOOP
:
9964 case EXEC_OMP_PARALLEL_MASKED_TASKLOOP
:
9965 case EXEC_OMP_PARALLEL_MASKED_TASKLOOP_SIMD
:
9966 case EXEC_OMP_PARALLEL_MASTER_TASKLOOP
:
9967 case EXEC_OMP_PARALLEL_MASTER_TASKLOOP_SIMD
:
9968 case EXEC_OMP_TARGET_PARALLEL_DO
:
9969 case EXEC_OMP_TARGET_PARALLEL_DO_SIMD
:
9970 case EXEC_OMP_TARGET_PARALLEL_LOOP
:
9971 case EXEC_OMP_TARGET_TEAMS_DISTRIBUTE
:
9972 case EXEC_OMP_TARGET_TEAMS_DISTRIBUTE_PARALLEL_DO
:
9973 case EXEC_OMP_TARGET_TEAMS_DISTRIBUTE_PARALLEL_DO_SIMD
:
9974 case EXEC_OMP_TARGET_TEAMS_DISTRIBUTE_SIMD
:
9975 case EXEC_OMP_TARGET_TEAMS_LOOP
:
9976 case EXEC_OMP_TASKLOOP
:
9977 case EXEC_OMP_TASKLOOP_SIMD
:
9978 case EXEC_OMP_TEAMS_DISTRIBUTE
:
9979 case EXEC_OMP_TEAMS_DISTRIBUTE_PARALLEL_DO
:
9980 case EXEC_OMP_TEAMS_DISTRIBUTE_PARALLEL_DO_SIMD
:
9981 case EXEC_OMP_TEAMS_DISTRIBUTE_SIMD
:
9982 case EXEC_OMP_TEAMS_LOOP
:
9983 gfc_resolve_omp_do_blocks (code
, ns
);
9986 gfc_resolve_blocks (code
->block
, ns
);
9989 omp_current_ctx
= ctx
.previous
;
9990 delete ctx
.sharing_clauses
;
9991 delete ctx
.private_iterators
;
9995 /* Save and clear openmp.cc private state. */
9998 gfc_omp_save_and_clear_state (struct gfc_omp_saved_state
*state
)
10000 state
->ptrs
[0] = omp_current_ctx
;
10001 state
->ptrs
[1] = omp_current_do_code
;
10002 state
->ints
[0] = omp_current_do_collapse
;
10003 omp_current_ctx
= NULL
;
10004 omp_current_do_code
= NULL
;
10005 omp_current_do_collapse
= 0;
10009 /* Restore openmp.cc private state from the saved state. */
10012 gfc_omp_restore_state (struct gfc_omp_saved_state
*state
)
10014 omp_current_ctx
= (struct fortran_omp_context
*) state
->ptrs
[0];
10015 omp_current_do_code
= (gfc_code
*) state
->ptrs
[1];
10016 omp_current_do_collapse
= state
->ints
[0];
10020 /* Note a DO iterator variable. This is special in !$omp parallel
10021 construct, where they are predetermined private. */
10024 gfc_resolve_do_iterator (gfc_code
*code
, gfc_symbol
*sym
, bool add_clause
)
10026 if (omp_current_ctx
== NULL
)
10029 int i
= omp_current_do_collapse
;
10030 gfc_code
*c
= omp_current_do_code
;
10032 if (sym
->attr
.threadprivate
)
10035 /* !$omp do and !$omp parallel do iteration variable is predetermined
10036 private just in the !$omp do resp. !$omp parallel do construct,
10037 with no implications for the outer parallel constructs. */
10039 while (i
-- >= 1 && c
)
10043 c
= find_nested_loop_in_chain (c
->block
->next
);
10046 /* An openacc context may represent a data clause. Abort if so. */
10047 if (!omp_current_ctx
->is_openmp
&& !oacc_is_loop (omp_current_ctx
->code
))
10050 if (omp_current_ctx
->sharing_clauses
->contains (sym
))
10053 if (! omp_current_ctx
->private_iterators
->add (sym
) && add_clause
)
10055 gfc_omp_clauses
*omp_clauses
= omp_current_ctx
->code
->ext
.omp_clauses
;
10056 gfc_omp_namelist
*p
;
10058 p
= gfc_get_omp_namelist ();
10060 p
->where
= omp_current_ctx
->code
->loc
;
10061 p
->next
= omp_clauses
->lists
[OMP_LIST_PRIVATE
];
10062 omp_clauses
->lists
[OMP_LIST_PRIVATE
] = p
;
10067 handle_local_var (gfc_symbol
*sym
)
10069 if (sym
->attr
.flavor
!= FL_VARIABLE
10071 || (sym
->ts
.type
!= BT_INTEGER
&& sym
->ts
.type
!= BT_REAL
))
10073 gfc_resolve_do_iterator (sym
->ns
->code
, sym
, false);
10077 gfc_resolve_omp_local_vars (gfc_namespace
*ns
)
10079 if (omp_current_ctx
)
10080 gfc_traverse_ns (ns
, handle_local_var
);
10084 /* Error checking on intervening code uses a code walker. */
10086 struct icode_error_state
10095 icode_code_error_callback (gfc_code
**codep
,
10096 int *walk_subtrees ATTRIBUTE_UNUSED
, void *opaque
)
10098 gfc_code
*code
= *codep
;
10099 icode_error_state
*state
= (icode_error_state
*)opaque
;
10101 /* gfc_code_walker walks down CODE's next chain as well as
10102 walking things that are actually nested in CODE. We need to
10103 special-case traversal of outer blocks, so stop immediately if we
10104 are heading down such a next chain. */
10105 if (code
== state
->next
)
10111 case EXEC_DO_WHILE
:
10112 case EXEC_DO_CONCURRENT
:
10113 gfc_error ("%s cannot contain loop in intervening code at %L",
10114 state
->name
, &code
->loc
);
10115 state
->errorp
= true;
10119 /* Errors have already been diagnosed in match_exit_cycle. */
10120 state
->errorp
= true;
10122 case EXEC_OMP_CRITICAL
:
10124 case EXEC_OMP_FLUSH
:
10125 case EXEC_OMP_MASTER
:
10126 case EXEC_OMP_ORDERED
:
10127 case EXEC_OMP_PARALLEL
:
10128 case EXEC_OMP_PARALLEL_DO
:
10129 case EXEC_OMP_PARALLEL_SECTIONS
:
10130 case EXEC_OMP_PARALLEL_WORKSHARE
:
10131 case EXEC_OMP_SECTIONS
:
10132 case EXEC_OMP_SINGLE
:
10133 case EXEC_OMP_WORKSHARE
:
10134 case EXEC_OMP_ATOMIC
:
10135 case EXEC_OMP_BARRIER
:
10136 case EXEC_OMP_END_NOWAIT
:
10137 case EXEC_OMP_END_SINGLE
:
10138 case EXEC_OMP_TASK
:
10139 case EXEC_OMP_TASKWAIT
:
10140 case EXEC_OMP_TASKYIELD
:
10141 case EXEC_OMP_CANCEL
:
10142 case EXEC_OMP_CANCELLATION_POINT
:
10143 case EXEC_OMP_TASKGROUP
:
10144 case EXEC_OMP_SIMD
:
10145 case EXEC_OMP_DO_SIMD
:
10146 case EXEC_OMP_PARALLEL_DO_SIMD
:
10147 case EXEC_OMP_TARGET
:
10148 case EXEC_OMP_TARGET_DATA
:
10149 case EXEC_OMP_TEAMS
:
10150 case EXEC_OMP_DISTRIBUTE
:
10151 case EXEC_OMP_DISTRIBUTE_SIMD
:
10152 case EXEC_OMP_DISTRIBUTE_PARALLEL_DO
:
10153 case EXEC_OMP_DISTRIBUTE_PARALLEL_DO_SIMD
:
10154 case EXEC_OMP_TARGET_TEAMS
:
10155 case EXEC_OMP_TEAMS_DISTRIBUTE
:
10156 case EXEC_OMP_TEAMS_DISTRIBUTE_SIMD
:
10157 case EXEC_OMP_TARGET_TEAMS_DISTRIBUTE
:
10158 case EXEC_OMP_TARGET_TEAMS_DISTRIBUTE_SIMD
:
10159 case EXEC_OMP_TEAMS_DISTRIBUTE_PARALLEL_DO
:
10160 case EXEC_OMP_TARGET_TEAMS_DISTRIBUTE_PARALLEL_DO
:
10161 case EXEC_OMP_TEAMS_DISTRIBUTE_PARALLEL_DO_SIMD
:
10162 case EXEC_OMP_TARGET_TEAMS_DISTRIBUTE_PARALLEL_DO_SIMD
:
10163 case EXEC_OMP_TARGET_UPDATE
:
10164 case EXEC_OMP_END_CRITICAL
:
10165 case EXEC_OMP_TARGET_ENTER_DATA
:
10166 case EXEC_OMP_TARGET_EXIT_DATA
:
10167 case EXEC_OMP_TARGET_PARALLEL
:
10168 case EXEC_OMP_TARGET_PARALLEL_DO
:
10169 case EXEC_OMP_TARGET_PARALLEL_DO_SIMD
:
10170 case EXEC_OMP_TARGET_SIMD
:
10171 case EXEC_OMP_TASKLOOP
:
10172 case EXEC_OMP_TASKLOOP_SIMD
:
10173 case EXEC_OMP_SCAN
:
10174 case EXEC_OMP_DEPOBJ
:
10175 case EXEC_OMP_PARALLEL_MASTER
:
10176 case EXEC_OMP_PARALLEL_MASTER_TASKLOOP
:
10177 case EXEC_OMP_PARALLEL_MASTER_TASKLOOP_SIMD
:
10178 case EXEC_OMP_MASTER_TASKLOOP
:
10179 case EXEC_OMP_MASTER_TASKLOOP_SIMD
:
10180 case EXEC_OMP_LOOP
:
10181 case EXEC_OMP_PARALLEL_LOOP
:
10182 case EXEC_OMP_TEAMS_LOOP
:
10183 case EXEC_OMP_TARGET_PARALLEL_LOOP
:
10184 case EXEC_OMP_TARGET_TEAMS_LOOP
:
10185 case EXEC_OMP_MASKED
:
10186 case EXEC_OMP_PARALLEL_MASKED
:
10187 case EXEC_OMP_PARALLEL_MASKED_TASKLOOP
:
10188 case EXEC_OMP_PARALLEL_MASKED_TASKLOOP_SIMD
:
10189 case EXEC_OMP_MASKED_TASKLOOP
:
10190 case EXEC_OMP_MASKED_TASKLOOP_SIMD
:
10191 case EXEC_OMP_SCOPE
:
10192 case EXEC_OMP_ERROR
:
10193 gfc_error ("%s cannot contain OpenMP directive in intervening code "
10195 state
->name
, &code
->loc
);
10196 state
->errorp
= true;
10199 /* Per OpenMP 5.2, the "omp_" prefix is reserved, so we don't have to
10200 consider the possibility that some locally-bound definition
10201 overrides the runtime routine. */
10202 if (code
->resolved_sym
10203 && omp_runtime_api_procname (code
->resolved_sym
->name
))
10205 gfc_error ("%s cannot contain OpenMP API call in intervening code "
10207 state
->name
, &code
->loc
);
10208 state
->errorp
= true;
10218 icode_expr_error_callback (gfc_expr
**expr
,
10219 int *walk_subtrees ATTRIBUTE_UNUSED
, void *opaque
)
10221 icode_error_state
*state
= (icode_error_state
*)opaque
;
10223 switch ((*expr
)->expr_type
)
10225 /* As for EXPR_CALL with "omp_"-prefixed symbols. */
10226 case EXPR_FUNCTION
:
10228 gfc_symbol
*sym
= (*expr
)->value
.function
.esym
;
10229 if (sym
&& omp_runtime_api_procname (sym
->name
))
10231 gfc_error ("%s cannot contain OpenMP API call in intervening code "
10233 state
->name
, &((*expr
)->where
));
10234 state
->errorp
= true;
10243 /* FIXME: The description of canonical loop form in the OpenMP standard
10244 also says "array expressions" are not permitted in intervening code.
10245 That term is not defined in either the OpenMP spec or the Fortran
10246 standard, although the latter uses it informally to refer to any
10247 expression that is not scalar-valued. It is also apparently not the
10248 thing GCC internally calls EXPR_ARRAY. It seems the intent of the
10249 OpenMP restriction is to disallow elemental operations/intrinsics
10250 (including things that are not expressions, like assignment
10251 statements) that generate implicit loops over array operands
10252 (even if the result is a scalar), but even if the spec said
10253 that there is no list of all the cases that would be forbidden.
10254 This is OpenMP issue 3326. */
10260 diagnose_intervening_code_errors_1 (gfc_code
*chain
,
10261 struct icode_error_state
*state
)
10264 for (code
= chain
; code
; code
= code
->next
)
10266 if (code
== state
->nested
)
10267 /* Do not walk the nested loop or its body, we are only
10268 interested in intervening code. */
10270 else if (code
->op
== EXEC_BLOCK
10271 && find_nested_loop_in_block (code
) == state
->nested
)
10272 /* This block contains the nested loop, recurse on its
10275 gfc_namespace
* ns
= code
->ext
.block
.ns
;
10276 diagnose_intervening_code_errors_1 (ns
->code
, state
);
10279 /* Treat the whole statement as a unit. */
10281 gfc_code
*temp
= state
->next
;
10282 state
->next
= code
->next
;
10283 gfc_code_walker (&code
, icode_code_error_callback
,
10284 icode_expr_error_callback
, state
);
10285 state
->next
= temp
;
10290 /* Diagnose intervening code errors in BLOCK with nested loop NESTED.
10291 NAME is the user-friendly name of the OMP directive, used for error
10292 messages. Returns true if any error was found. */
10294 diagnose_intervening_code_errors (gfc_code
*chain
, const char *name
,
10297 struct icode_error_state state
;
10299 state
.errorp
= false;
10300 state
.nested
= nested
;
10302 diagnose_intervening_code_errors_1 (chain
, &state
);
10303 return state
.errorp
;
10306 /* Helper function for restructure_intervening_code: wrap CHAIN in
10307 a marker to indicate that it is a structured block sequence. That
10308 information will be used later on (in omp-low.cc) for error checking. */
10310 make_structured_block (gfc_code
*chain
)
10312 gcc_assert (chain
);
10313 gfc_namespace
*ns
= gfc_build_block_ns (gfc_current_ns
);
10314 gfc_code
*result
= gfc_get_code (EXEC_BLOCK
);
10315 result
->op
= EXEC_BLOCK
;
10316 result
->ext
.block
.ns
= ns
;
10317 result
->ext
.block
.assoc
= NULL
;
10318 result
->loc
= chain
->loc
;
10319 ns
->omp_structured_block
= 1;
10324 /* Push intervening code surrounding a loop, including nested scopes,
10325 into the body of the loop. CHAINP is the pointer to the head of
10326 the next-chain to scan, OUTER_LOOP is the EXEC_DO for the next outer
10327 loop level, and COLLAPSE is the number of nested loops we need to
10329 Note that CHAINP may point at outer_loop->block->next when we
10330 are scanning the body of a loop, but if there is an intervening block
10331 CHAINP points into the block's chain rather than its enclosing outer
10332 loop. This is why OUTER_LOOP is passed separately. */
10334 restructure_intervening_code (gfc_code
**chainp
, gfc_code
*outer_loop
,
10338 gfc_code
*head
= *chainp
;
10339 gfc_code
*tail
= NULL
;
10340 gfc_code
*innermost_loop
= NULL
;
10342 for (code
= *chainp
; code
; code
= code
->next
, chainp
= &((*chainp
)->next
))
10344 if (code
->op
== EXEC_DO
)
10346 /* Cut CODE free from its chain, leaving the ends dangling. */
10352 innermost_loop
= code
;
10355 = restructure_intervening_code (&(code
->block
->next
),
10359 else if (code
->op
== EXEC_BLOCK
10360 && find_nested_loop_in_block (code
))
10362 gfc_namespace
*ns
= code
->ext
.block
.ns
;
10364 /* Cut CODE free from its chain, leaving the ends dangling. */
10370 = restructure_intervening_code (&(ns
->code
), outer_loop
,
10373 /* At this point we have already pulled out the nested loop and
10374 pointed outer_loop at it, and moved the intervening code that
10375 was previously in the block into the body of innermost_loop.
10376 Now we want to move the BLOCK itself so it wraps the entire
10377 current body of innermost_loop. */
10378 ns
->code
= innermost_loop
->block
->next
;
10379 innermost_loop
->block
->next
= code
;
10384 gcc_assert (innermost_loop
);
10386 /* Now we have split the intervening code into two parts:
10387 head is the start of the part before the loop/block, terminating
10388 at *chainp, and tail is the part after it. Mark each part as
10389 a structured block sequence, and splice the two parts around the
10390 existing body of the innermost loop. */
10393 gfc_code
*block
= make_structured_block (head
);
10394 if (innermost_loop
->block
->next
)
10395 gfc_append_code (block
, innermost_loop
->block
->next
);
10396 innermost_loop
->block
->next
= block
;
10400 gfc_code
*block
= make_structured_block (tail
);
10401 if (innermost_loop
->block
->next
)
10402 gfc_append_code (innermost_loop
->block
->next
, block
);
10404 innermost_loop
->block
->next
= block
;
10407 /* For loops, finally splice CODE into OUTER_LOOP. We already handled
10408 relinking EXEC_BLOCK above. */
10409 if (code
->op
== EXEC_DO
&& outer_loop
)
10410 outer_loop
->block
->next
= code
;
10412 return innermost_loop
;
10415 /* CODE is an OMP loop construct. Return true if VAR matches an iteration
10416 variable outer to level DEPTH. */
10418 is_outer_iteration_variable (gfc_code
*code
, int depth
, gfc_symbol
*var
)
10421 gfc_code
*do_code
= code
;
10423 for (i
= 1; i
< depth
; i
++)
10425 do_code
= find_nested_loop_in_chain (do_code
->block
->next
);
10426 gcc_assert (do_code
);
10427 gfc_symbol
*ivar
= do_code
->ext
.iterator
->var
->symtree
->n
.sym
;
10434 /* Forward declaration for recursive functions. */
10436 check_nested_loop_in_block (gfc_code
*block
, gfc_expr
*expr
, gfc_symbol
*sym
,
10439 /* Like find_nested_loop_in_chain, but additionally check that EXPR
10440 does not reference any variables bound in intervening EXEC_BLOCKs
10441 and that SYM is not bound in such intervening blocks. Either EXPR or SYM
10442 may be null. Sets *BAD to true if either test fails. */
10444 check_nested_loop_in_chain (gfc_code
*chain
, gfc_expr
*expr
, gfc_symbol
*sym
,
10447 for (gfc_code
*code
= chain
; code
; code
= code
->next
)
10449 if (code
->op
== EXEC_DO
)
10451 else if (code
->op
== EXEC_BLOCK
)
10453 gfc_code
*c
= check_nested_loop_in_block (code
, expr
, sym
, bad
);
10461 /* Code walker for block symtrees. It doesn't take any kind of state
10462 argument, so use a static variable. */
10463 static struct check_nested_loop_in_block_state_t
{
10467 } check_nested_loop_in_block_state
;
10470 check_nested_loop_in_block_symbol (gfc_symbol
*sym
)
10472 if (sym
== check_nested_loop_in_block_state
.sym
10473 || (check_nested_loop_in_block_state
.expr
10474 && gfc_find_sym_in_expr (sym
,
10475 check_nested_loop_in_block_state
.expr
)))
10476 *check_nested_loop_in_block_state
.bad
= true;
10479 /* Return the first nested DO loop in BLOCK, or NULL if there
10480 isn't one. Set *BAD to true if EXPR references any variables in BLOCK, or
10481 SYM is bound in BLOCK. Either EXPR or SYM may be null. */
10483 check_nested_loop_in_block (gfc_code
*block
, gfc_expr
*expr
,
10484 gfc_symbol
*sym
, bool *bad
)
10487 gcc_assert (block
->op
== EXEC_BLOCK
);
10488 ns
= block
->ext
.block
.ns
;
10491 /* Skip the check if this block doesn't contain the nested loop, or
10492 if we already know it's bad. */
10493 gfc_code
*result
= check_nested_loop_in_chain (ns
->code
, expr
, sym
, bad
);
10494 if (result
&& !*bad
)
10496 check_nested_loop_in_block_state
.expr
= expr
;
10497 check_nested_loop_in_block_state
.sym
= sym
;
10498 check_nested_loop_in_block_state
.bad
= bad
;
10499 gfc_traverse_ns (ns
, check_nested_loop_in_block_symbol
);
10500 check_nested_loop_in_block_state
.expr
= NULL
;
10501 check_nested_loop_in_block_state
.sym
= NULL
;
10502 check_nested_loop_in_block_state
.bad
= NULL
;
10507 /* CODE is an OMP loop construct. Return true if EXPR references
10508 any variables bound in intervening code, to level DEPTH. */
10510 expr_uses_intervening_var (gfc_code
*code
, int depth
, gfc_expr
*expr
)
10513 gfc_code
*do_code
= code
;
10515 for (i
= 0; i
< depth
; i
++)
10518 do_code
= check_nested_loop_in_chain (do_code
->block
->next
,
10526 /* CODE is an OMP loop construct. Return true if SYM is bound in
10527 intervening code, to level DEPTH. */
10529 is_intervening_var (gfc_code
*code
, int depth
, gfc_symbol
*sym
)
10532 gfc_code
*do_code
= code
;
10534 for (i
= 0; i
< depth
; i
++)
10537 do_code
= check_nested_loop_in_chain (do_code
->block
->next
,
10545 /* CODE is an OMP loop construct. Return true if EXPR does not reference
10546 any iteration variables outer to level DEPTH. */
10548 expr_is_invariant (gfc_code
*code
, int depth
, gfc_expr
*expr
)
10551 gfc_code
*do_code
= code
;
10553 for (i
= 1; i
< depth
; i
++)
10555 do_code
= find_nested_loop_in_chain (do_code
->block
->next
);
10556 gcc_assert (do_code
);
10557 gfc_symbol
*ivar
= do_code
->ext
.iterator
->var
->symtree
->n
.sym
;
10558 if (gfc_find_sym_in_expr (ivar
, expr
))
10564 /* CODE is an OMP loop construct. Return true if EXPR matches one of the
10565 canonical forms for a bound expression. It may include references to
10566 an iteration variable outer to level DEPTH; set OUTER_VARP if so. */
10568 bound_expr_is_canonical (gfc_code
*code
, int depth
, gfc_expr
*expr
,
10569 gfc_symbol
**outer_varp
)
10571 gfc_expr
*expr2
= NULL
;
10573 /* Rectangular case. */
10574 if (depth
== 0 || expr_is_invariant (code
, depth
, expr
))
10577 /* Any simple variable that didn't pass expr_is_invariant must be
10579 if (expr
->expr_type
== EXPR_VARIABLE
&& expr
->rank
== 0)
10581 *outer_varp
= expr
->symtree
->n
.sym
;
10585 /* All other permitted forms are binary operators. */
10586 if (expr
->expr_type
!= EXPR_OP
)
10589 /* Check for plus/minus a loop invariant expr. */
10590 if (expr
->value
.op
.op
== INTRINSIC_PLUS
10591 || expr
->value
.op
.op
== INTRINSIC_MINUS
)
10593 if (expr_is_invariant (code
, depth
, expr
->value
.op
.op1
))
10594 expr2
= expr
->value
.op
.op2
;
10595 else if (expr_is_invariant (code
, depth
, expr
->value
.op
.op2
))
10596 expr2
= expr
->value
.op
.op1
;
10603 /* Check for a product with a loop-invariant expr. */
10604 if (expr2
->expr_type
== EXPR_OP
10605 && expr2
->value
.op
.op
== INTRINSIC_TIMES
)
10607 if (expr_is_invariant (code
, depth
, expr2
->value
.op
.op1
))
10608 expr2
= expr2
->value
.op
.op2
;
10609 else if (expr_is_invariant (code
, depth
, expr2
->value
.op
.op2
))
10610 expr2
= expr2
->value
.op
.op1
;
10615 /* What's left must be a reference to an outer loop variable. */
10616 if (expr2
->expr_type
== EXPR_VARIABLE
10617 && expr2
->rank
== 0
10618 && is_outer_iteration_variable (code
, depth
, expr2
->symtree
->n
.sym
))
10620 *outer_varp
= expr2
->symtree
->n
.sym
;
10628 resolve_omp_do (gfc_code
*code
)
10630 gfc_code
*do_code
, *next
;
10631 int list
, i
, count
;
10632 gfc_omp_namelist
*n
;
10635 bool is_simd
= false;
10636 bool errorp
= false;
10637 bool perfect_nesting_errorp
= false;
10641 case EXEC_OMP_DISTRIBUTE
: name
= "!$OMP DISTRIBUTE"; break;
10642 case EXEC_OMP_DISTRIBUTE_PARALLEL_DO
:
10643 name
= "!$OMP DISTRIBUTE PARALLEL DO";
10645 case EXEC_OMP_DISTRIBUTE_PARALLEL_DO_SIMD
:
10646 name
= "!$OMP DISTRIBUTE PARALLEL DO SIMD";
10649 case EXEC_OMP_DISTRIBUTE_SIMD
:
10650 name
= "!$OMP DISTRIBUTE SIMD";
10653 case EXEC_OMP_DO
: name
= "!$OMP DO"; break;
10654 case EXEC_OMP_DO_SIMD
: name
= "!$OMP DO SIMD"; is_simd
= true; break;
10655 case EXEC_OMP_LOOP
: name
= "!$OMP LOOP"; break;
10656 case EXEC_OMP_PARALLEL_DO
: name
= "!$OMP PARALLEL DO"; break;
10657 case EXEC_OMP_PARALLEL_DO_SIMD
:
10658 name
= "!$OMP PARALLEL DO SIMD";
10661 case EXEC_OMP_PARALLEL_LOOP
: name
= "!$OMP PARALLEL LOOP"; break;
10662 case EXEC_OMP_PARALLEL_MASKED_TASKLOOP
:
10663 name
= "!$OMP PARALLEL MASKED TASKLOOP";
10665 case EXEC_OMP_PARALLEL_MASKED_TASKLOOP_SIMD
:
10666 name
= "!$OMP PARALLEL MASKED TASKLOOP SIMD";
10669 case EXEC_OMP_PARALLEL_MASTER_TASKLOOP
:
10670 name
= "!$OMP PARALLEL MASTER TASKLOOP";
10672 case EXEC_OMP_PARALLEL_MASTER_TASKLOOP_SIMD
:
10673 name
= "!$OMP PARALLEL MASTER TASKLOOP SIMD";
10676 case EXEC_OMP_MASKED_TASKLOOP
: name
= "!$OMP MASKED TASKLOOP"; break;
10677 case EXEC_OMP_MASKED_TASKLOOP_SIMD
:
10678 name
= "!$OMP MASKED TASKLOOP SIMD";
10681 case EXEC_OMP_MASTER_TASKLOOP
: name
= "!$OMP MASTER TASKLOOP"; break;
10682 case EXEC_OMP_MASTER_TASKLOOP_SIMD
:
10683 name
= "!$OMP MASTER TASKLOOP SIMD";
10686 case EXEC_OMP_SIMD
: name
= "!$OMP SIMD"; is_simd
= true; break;
10687 case EXEC_OMP_TARGET_PARALLEL_DO
: name
= "!$OMP TARGET PARALLEL DO"; break;
10688 case EXEC_OMP_TARGET_PARALLEL_DO_SIMD
:
10689 name
= "!$OMP TARGET PARALLEL DO SIMD";
10692 case EXEC_OMP_TARGET_PARALLEL_LOOP
:
10693 name
= "!$OMP TARGET PARALLEL LOOP";
10695 case EXEC_OMP_TARGET_SIMD
:
10696 name
= "!$OMP TARGET SIMD";
10699 case EXEC_OMP_TARGET_TEAMS_DISTRIBUTE
:
10700 name
= "!$OMP TARGET TEAMS DISTRIBUTE";
10702 case EXEC_OMP_TARGET_TEAMS_DISTRIBUTE_PARALLEL_DO
:
10703 name
= "!$OMP TARGET TEAMS DISTRIBUTE PARALLEL DO";
10705 case EXEC_OMP_TARGET_TEAMS_DISTRIBUTE_PARALLEL_DO_SIMD
:
10706 name
= "!$OMP TARGET TEAMS DISTRIBUTE PARALLEL DO SIMD";
10709 case EXEC_OMP_TARGET_TEAMS_DISTRIBUTE_SIMD
:
10710 name
= "!$OMP TARGET TEAMS DISTRIBUTE SIMD";
10713 case EXEC_OMP_TARGET_TEAMS_LOOP
: name
= "!$OMP TARGET TEAMS LOOP"; break;
10714 case EXEC_OMP_TASKLOOP
: name
= "!$OMP TASKLOOP"; break;
10715 case EXEC_OMP_TASKLOOP_SIMD
:
10716 name
= "!$OMP TASKLOOP SIMD";
10719 case EXEC_OMP_TEAMS_DISTRIBUTE
: name
= "!$OMP TEAMS DISTRIBUTE"; break;
10720 case EXEC_OMP_TEAMS_DISTRIBUTE_PARALLEL_DO
:
10721 name
= "!$OMP TEAMS DISTRIBUTE PARALLEL DO";
10723 case EXEC_OMP_TEAMS_DISTRIBUTE_PARALLEL_DO_SIMD
:
10724 name
= "!$OMP TEAMS DISTRIBUTE PARALLEL DO SIMD";
10727 case EXEC_OMP_TEAMS_DISTRIBUTE_SIMD
:
10728 name
= "!$OMP TEAMS DISTRIBUTE SIMD";
10731 case EXEC_OMP_TEAMS_LOOP
: name
= "!$OMP TEAMS LOOP"; break;
10732 default: gcc_unreachable ();
10735 if (code
->ext
.omp_clauses
)
10736 resolve_omp_clauses (code
, code
->ext
.omp_clauses
, NULL
);
10738 do_code
= code
->block
->next
;
10739 if (code
->ext
.omp_clauses
->orderedc
)
10740 count
= code
->ext
.omp_clauses
->orderedc
;
10743 count
= code
->ext
.omp_clauses
->collapse
;
10748 /* While the spec defines the loop nest depth independently of the COLLAPSE
10749 clause, in practice the middle end only pays attention to the COLLAPSE
10750 depth and treats any further inner loops as the final-loop-body. So
10751 here we also check canonical loop nest form only for the number of
10752 outer loops specified by the COLLAPSE clause too. */
10753 for (i
= 1; i
<= count
; i
++)
10755 gfc_symbol
*start_var
= NULL
, *end_var
= NULL
;
10756 /* Parse errors are not recoverable. */
10757 if (do_code
->op
== EXEC_DO_WHILE
)
10759 gfc_error ("%s cannot be a DO WHILE or DO without loop control "
10760 "at %L", name
, &do_code
->loc
);
10763 if (do_code
->op
== EXEC_DO_CONCURRENT
)
10765 gfc_error ("%s cannot be a DO CONCURRENT loop at %L", name
,
10769 gcc_assert (do_code
->op
== EXEC_DO
);
10770 if (do_code
->ext
.iterator
->var
->ts
.type
!= BT_INTEGER
)
10772 gfc_error ("%s iteration variable must be of type integer at %L",
10773 name
, &do_code
->loc
);
10776 dovar
= do_code
->ext
.iterator
->var
->symtree
->n
.sym
;
10777 if (dovar
->attr
.threadprivate
)
10779 gfc_error ("%s iteration variable must not be THREADPRIVATE "
10780 "at %L", name
, &do_code
->loc
);
10783 if (code
->ext
.omp_clauses
)
10784 for (list
= 0; list
< OMP_LIST_NUM
; list
++)
10785 if (!is_simd
|| code
->ext
.omp_clauses
->collapse
> 1
10786 ? (list
!= OMP_LIST_PRIVATE
&& list
!= OMP_LIST_LASTPRIVATE
10787 && list
!= OMP_LIST_ALLOCATE
)
10788 : (list
!= OMP_LIST_PRIVATE
&& list
!= OMP_LIST_LASTPRIVATE
10789 && list
!= OMP_LIST_ALLOCATE
&& list
!= OMP_LIST_LINEAR
))
10790 for (n
= code
->ext
.omp_clauses
->lists
[list
]; n
; n
= n
->next
)
10791 if (dovar
== n
->sym
)
10793 if (!is_simd
|| code
->ext
.omp_clauses
->collapse
> 1)
10794 gfc_error ("%s iteration variable present on clause "
10795 "other than PRIVATE, LASTPRIVATE or "
10796 "ALLOCATE at %L", name
, &do_code
->loc
);
10798 gfc_error ("%s iteration variable present on clause "
10799 "other than PRIVATE, LASTPRIVATE, ALLOCATE or "
10800 "LINEAR at %L", name
, &do_code
->loc
);
10803 if (is_outer_iteration_variable (code
, i
, dovar
))
10805 gfc_error ("%s iteration variable used in more than one loop at %L",
10806 name
, &do_code
->loc
);
10809 else if (is_intervening_var (code
, i
, dovar
))
10811 gfc_error ("%s iteration variable at %L is bound in "
10812 "intervening code",
10813 name
, &do_code
->loc
);
10816 else if (!bound_expr_is_canonical (code
, i
,
10817 do_code
->ext
.iterator
->start
,
10820 gfc_error ("%s loop start expression not in canonical form at %L",
10821 name
, &do_code
->loc
);
10824 else if (expr_uses_intervening_var (code
, i
,
10825 do_code
->ext
.iterator
->start
))
10827 gfc_error ("%s loop start expression at %L uses variable bound in "
10828 "intervening code",
10829 name
, &do_code
->loc
);
10832 else if (!bound_expr_is_canonical (code
, i
,
10833 do_code
->ext
.iterator
->end
,
10836 gfc_error ("%s loop end expression not in canonical form at %L",
10837 name
, &do_code
->loc
);
10840 else if (expr_uses_intervening_var (code
, i
,
10841 do_code
->ext
.iterator
->end
))
10843 gfc_error ("%s loop end expression at %L uses variable bound in "
10844 "intervening code",
10845 name
, &do_code
->loc
);
10848 else if (start_var
&& end_var
&& start_var
!= end_var
)
10850 gfc_error ("%s loop bounds reference different "
10851 "iteration variables at %L", name
, &do_code
->loc
);
10854 else if (!expr_is_invariant (code
, i
, do_code
->ext
.iterator
->step
))
10856 gfc_error ("%s loop increment not in canonical form at %L",
10857 name
, &do_code
->loc
);
10860 else if (expr_uses_intervening_var (code
, i
,
10861 do_code
->ext
.iterator
->step
))
10863 gfc_error ("%s loop increment expression at %L uses variable "
10864 "bound in intervening code",
10865 name
, &do_code
->loc
);
10868 if (start_var
|| end_var
)
10869 code
->ext
.omp_clauses
->non_rectangular
= 1;
10871 /* Only parse loop body into nested loop and intervening code if
10872 there are supposed to be more loops in the nest to collapse. */
10876 next
= find_nested_loop_in_chain (do_code
->block
->next
);
10880 /* Parse error, can't recover from this. */
10881 gfc_error ("not enough DO loops for collapsed %s (level %d) at %L",
10882 name
, i
, &code
->loc
);
10885 else if (next
!= do_code
->block
->next
|| next
->next
)
10886 /* Imperfectly nested loop found. */
10888 /* Only diagnose violation of imperfect nesting constraints once. */
10889 if (!perfect_nesting_errorp
)
10891 if (code
->ext
.omp_clauses
->orderedc
)
10893 gfc_error ("%s inner loops must be perfectly nested with "
10894 "ORDERED clause at %L",
10896 perfect_nesting_errorp
= true;
10898 else if (code
->ext
.omp_clauses
->lists
[OMP_LIST_REDUCTION_INSCAN
])
10900 gfc_error ("%s inner loops must be perfectly nested with "
10901 "REDUCTION INSCAN clause at %L",
10903 perfect_nesting_errorp
= true;
10905 /* FIXME: Also diagnose for TILE directives. */
10906 if (perfect_nesting_errorp
)
10909 if (diagnose_intervening_code_errors (do_code
->block
->next
,
10916 /* Give up now if we found any constraint violations. */
10920 restructure_intervening_code (&(code
->block
->next
), code
, count
);
10924 static gfc_statement
10925 omp_code_to_statement (gfc_code
*code
)
10929 case EXEC_OMP_PARALLEL
:
10930 return ST_OMP_PARALLEL
;
10931 case EXEC_OMP_PARALLEL_MASKED
:
10932 return ST_OMP_PARALLEL_MASKED
;
10933 case EXEC_OMP_PARALLEL_MASKED_TASKLOOP
:
10934 return ST_OMP_PARALLEL_MASKED_TASKLOOP
;
10935 case EXEC_OMP_PARALLEL_MASKED_TASKLOOP_SIMD
:
10936 return ST_OMP_PARALLEL_MASKED_TASKLOOP_SIMD
;
10937 case EXEC_OMP_PARALLEL_MASTER
:
10938 return ST_OMP_PARALLEL_MASTER
;
10939 case EXEC_OMP_PARALLEL_MASTER_TASKLOOP
:
10940 return ST_OMP_PARALLEL_MASTER_TASKLOOP
;
10941 case EXEC_OMP_PARALLEL_MASTER_TASKLOOP_SIMD
:
10942 return ST_OMP_PARALLEL_MASTER_TASKLOOP_SIMD
;
10943 case EXEC_OMP_PARALLEL_SECTIONS
:
10944 return ST_OMP_PARALLEL_SECTIONS
;
10945 case EXEC_OMP_SECTIONS
:
10946 return ST_OMP_SECTIONS
;
10947 case EXEC_OMP_ORDERED
:
10948 return ST_OMP_ORDERED
;
10949 case EXEC_OMP_CRITICAL
:
10950 return ST_OMP_CRITICAL
;
10951 case EXEC_OMP_MASKED
:
10952 return ST_OMP_MASKED
;
10953 case EXEC_OMP_MASKED_TASKLOOP
:
10954 return ST_OMP_MASKED_TASKLOOP
;
10955 case EXEC_OMP_MASKED_TASKLOOP_SIMD
:
10956 return ST_OMP_MASKED_TASKLOOP_SIMD
;
10957 case EXEC_OMP_MASTER
:
10958 return ST_OMP_MASTER
;
10959 case EXEC_OMP_MASTER_TASKLOOP
:
10960 return ST_OMP_MASTER_TASKLOOP
;
10961 case EXEC_OMP_MASTER_TASKLOOP_SIMD
:
10962 return ST_OMP_MASTER_TASKLOOP_SIMD
;
10963 case EXEC_OMP_SINGLE
:
10964 return ST_OMP_SINGLE
;
10965 case EXEC_OMP_TASK
:
10966 return ST_OMP_TASK
;
10967 case EXEC_OMP_WORKSHARE
:
10968 return ST_OMP_WORKSHARE
;
10969 case EXEC_OMP_PARALLEL_WORKSHARE
:
10970 return ST_OMP_PARALLEL_WORKSHARE
;
10973 case EXEC_OMP_LOOP
:
10974 return ST_OMP_LOOP
;
10975 case EXEC_OMP_ALLOCATE
:
10976 return ST_OMP_ALLOCATE_EXEC
;
10977 case EXEC_OMP_ALLOCATORS
:
10978 return ST_OMP_ALLOCATORS
;
10979 case EXEC_OMP_ASSUME
:
10980 return ST_OMP_ASSUME
;
10981 case EXEC_OMP_ATOMIC
:
10982 return ST_OMP_ATOMIC
;
10983 case EXEC_OMP_BARRIER
:
10984 return ST_OMP_BARRIER
;
10985 case EXEC_OMP_CANCEL
:
10986 return ST_OMP_CANCEL
;
10987 case EXEC_OMP_CANCELLATION_POINT
:
10988 return ST_OMP_CANCELLATION_POINT
;
10989 case EXEC_OMP_ERROR
:
10990 return ST_OMP_ERROR
;
10991 case EXEC_OMP_FLUSH
:
10992 return ST_OMP_FLUSH
;
10993 case EXEC_OMP_DISTRIBUTE
:
10994 return ST_OMP_DISTRIBUTE
;
10995 case EXEC_OMP_DISTRIBUTE_PARALLEL_DO
:
10996 return ST_OMP_DISTRIBUTE_PARALLEL_DO
;
10997 case EXEC_OMP_DISTRIBUTE_PARALLEL_DO_SIMD
:
10998 return ST_OMP_DISTRIBUTE_PARALLEL_DO_SIMD
;
10999 case EXEC_OMP_DISTRIBUTE_SIMD
:
11000 return ST_OMP_DISTRIBUTE_SIMD
;
11001 case EXEC_OMP_DO_SIMD
:
11002 return ST_OMP_DO_SIMD
;
11003 case EXEC_OMP_SCAN
:
11004 return ST_OMP_SCAN
;
11005 case EXEC_OMP_SCOPE
:
11006 return ST_OMP_SCOPE
;
11007 case EXEC_OMP_SIMD
:
11008 return ST_OMP_SIMD
;
11009 case EXEC_OMP_TARGET
:
11010 return ST_OMP_TARGET
;
11011 case EXEC_OMP_TARGET_DATA
:
11012 return ST_OMP_TARGET_DATA
;
11013 case EXEC_OMP_TARGET_ENTER_DATA
:
11014 return ST_OMP_TARGET_ENTER_DATA
;
11015 case EXEC_OMP_TARGET_EXIT_DATA
:
11016 return ST_OMP_TARGET_EXIT_DATA
;
11017 case EXEC_OMP_TARGET_PARALLEL
:
11018 return ST_OMP_TARGET_PARALLEL
;
11019 case EXEC_OMP_TARGET_PARALLEL_DO
:
11020 return ST_OMP_TARGET_PARALLEL_DO
;
11021 case EXEC_OMP_TARGET_PARALLEL_DO_SIMD
:
11022 return ST_OMP_TARGET_PARALLEL_DO_SIMD
;
11023 case EXEC_OMP_TARGET_PARALLEL_LOOP
:
11024 return ST_OMP_TARGET_PARALLEL_LOOP
;
11025 case EXEC_OMP_TARGET_SIMD
:
11026 return ST_OMP_TARGET_SIMD
;
11027 case EXEC_OMP_TARGET_TEAMS
:
11028 return ST_OMP_TARGET_TEAMS
;
11029 case EXEC_OMP_TARGET_TEAMS_DISTRIBUTE
:
11030 return ST_OMP_TARGET_TEAMS_DISTRIBUTE
;
11031 case EXEC_OMP_TARGET_TEAMS_DISTRIBUTE_PARALLEL_DO
:
11032 return ST_OMP_TARGET_TEAMS_DISTRIBUTE_PARALLEL_DO
;
11033 case EXEC_OMP_TARGET_TEAMS_DISTRIBUTE_PARALLEL_DO_SIMD
:
11034 return ST_OMP_TARGET_TEAMS_DISTRIBUTE_PARALLEL_DO_SIMD
;
11035 case EXEC_OMP_TARGET_TEAMS_DISTRIBUTE_SIMD
:
11036 return ST_OMP_TARGET_TEAMS_DISTRIBUTE_SIMD
;
11037 case EXEC_OMP_TARGET_TEAMS_LOOP
:
11038 return ST_OMP_TARGET_TEAMS_LOOP
;
11039 case EXEC_OMP_TARGET_UPDATE
:
11040 return ST_OMP_TARGET_UPDATE
;
11041 case EXEC_OMP_TASKGROUP
:
11042 return ST_OMP_TASKGROUP
;
11043 case EXEC_OMP_TASKLOOP
:
11044 return ST_OMP_TASKLOOP
;
11045 case EXEC_OMP_TASKLOOP_SIMD
:
11046 return ST_OMP_TASKLOOP_SIMD
;
11047 case EXEC_OMP_TASKWAIT
:
11048 return ST_OMP_TASKWAIT
;
11049 case EXEC_OMP_TASKYIELD
:
11050 return ST_OMP_TASKYIELD
;
11051 case EXEC_OMP_TEAMS
:
11052 return ST_OMP_TEAMS
;
11053 case EXEC_OMP_TEAMS_DISTRIBUTE
:
11054 return ST_OMP_TEAMS_DISTRIBUTE
;
11055 case EXEC_OMP_TEAMS_DISTRIBUTE_PARALLEL_DO
:
11056 return ST_OMP_TEAMS_DISTRIBUTE_PARALLEL_DO
;
11057 case EXEC_OMP_TEAMS_DISTRIBUTE_PARALLEL_DO_SIMD
:
11058 return ST_OMP_TEAMS_DISTRIBUTE_PARALLEL_DO_SIMD
;
11059 case EXEC_OMP_TEAMS_DISTRIBUTE_SIMD
:
11060 return ST_OMP_TEAMS_DISTRIBUTE_SIMD
;
11061 case EXEC_OMP_TEAMS_LOOP
:
11062 return ST_OMP_TEAMS_LOOP
;
11063 case EXEC_OMP_PARALLEL_DO
:
11064 return ST_OMP_PARALLEL_DO
;
11065 case EXEC_OMP_PARALLEL_DO_SIMD
:
11066 return ST_OMP_PARALLEL_DO_SIMD
;
11067 case EXEC_OMP_PARALLEL_LOOP
:
11068 return ST_OMP_PARALLEL_LOOP
;
11069 case EXEC_OMP_DEPOBJ
:
11070 return ST_OMP_DEPOBJ
;
11072 gcc_unreachable ();
11076 static gfc_statement
11077 oacc_code_to_statement (gfc_code
*code
)
11081 case EXEC_OACC_PARALLEL
:
11082 return ST_OACC_PARALLEL
;
11083 case EXEC_OACC_KERNELS
:
11084 return ST_OACC_KERNELS
;
11085 case EXEC_OACC_SERIAL
:
11086 return ST_OACC_SERIAL
;
11087 case EXEC_OACC_DATA
:
11088 return ST_OACC_DATA
;
11089 case EXEC_OACC_HOST_DATA
:
11090 return ST_OACC_HOST_DATA
;
11091 case EXEC_OACC_PARALLEL_LOOP
:
11092 return ST_OACC_PARALLEL_LOOP
;
11093 case EXEC_OACC_KERNELS_LOOP
:
11094 return ST_OACC_KERNELS_LOOP
;
11095 case EXEC_OACC_SERIAL_LOOP
:
11096 return ST_OACC_SERIAL_LOOP
;
11097 case EXEC_OACC_LOOP
:
11098 return ST_OACC_LOOP
;
11099 case EXEC_OACC_ATOMIC
:
11100 return ST_OACC_ATOMIC
;
11101 case EXEC_OACC_ROUTINE
:
11102 return ST_OACC_ROUTINE
;
11103 case EXEC_OACC_UPDATE
:
11104 return ST_OACC_UPDATE
;
11105 case EXEC_OACC_WAIT
:
11106 return ST_OACC_WAIT
;
11107 case EXEC_OACC_CACHE
:
11108 return ST_OACC_CACHE
;
11109 case EXEC_OACC_ENTER_DATA
:
11110 return ST_OACC_ENTER_DATA
;
11111 case EXEC_OACC_EXIT_DATA
:
11112 return ST_OACC_EXIT_DATA
;
11113 case EXEC_OACC_DECLARE
:
11114 return ST_OACC_DECLARE
;
11116 gcc_unreachable ();
11121 resolve_oacc_directive_inside_omp_region (gfc_code
*code
)
11123 if (omp_current_ctx
!= NULL
&& omp_current_ctx
->is_openmp
)
11125 gfc_statement st
= omp_code_to_statement (omp_current_ctx
->code
);
11126 gfc_statement oacc_st
= oacc_code_to_statement (code
);
11127 gfc_error ("The %s directive cannot be specified within "
11128 "a %s region at %L", gfc_ascii_statement (oacc_st
),
11129 gfc_ascii_statement (st
), &code
->loc
);
11134 resolve_omp_directive_inside_oacc_region (gfc_code
*code
)
11136 if (omp_current_ctx
!= NULL
&& !omp_current_ctx
->is_openmp
)
11138 gfc_statement st
= oacc_code_to_statement (omp_current_ctx
->code
);
11139 gfc_statement omp_st
= omp_code_to_statement (code
);
11140 gfc_error ("The %s directive cannot be specified within "
11141 "a %s region at %L", gfc_ascii_statement (omp_st
),
11142 gfc_ascii_statement (st
), &code
->loc
);
11148 resolve_oacc_nested_loops (gfc_code
*code
, gfc_code
* do_code
, int collapse
,
11149 const char *clause
)
11155 for (i
= 1; i
<= collapse
; i
++)
11157 if (do_code
->op
== EXEC_DO_WHILE
)
11159 gfc_error ("!$ACC LOOP cannot be a DO WHILE or DO without loop control "
11160 "at %L", &do_code
->loc
);
11163 if (do_code
->op
== EXEC_DO_CONCURRENT
)
11165 gfc_error ("!$ACC LOOP cannot be a DO CONCURRENT loop at %L",
11169 gcc_assert (do_code
->op
== EXEC_DO
);
11170 if (do_code
->ext
.iterator
->var
->ts
.type
!= BT_INTEGER
)
11171 gfc_error ("!$ACC LOOP iteration variable must be of type integer at %L",
11173 dovar
= do_code
->ext
.iterator
->var
->symtree
->n
.sym
;
11176 gfc_code
*do_code2
= code
->block
->next
;
11179 for (j
= 1; j
< i
; j
++)
11181 gfc_symbol
*ivar
= do_code2
->ext
.iterator
->var
->symtree
->n
.sym
;
11183 || gfc_find_sym_in_expr (ivar
, do_code
->ext
.iterator
->start
)
11184 || gfc_find_sym_in_expr (ivar
, do_code
->ext
.iterator
->end
)
11185 || gfc_find_sym_in_expr (ivar
, do_code
->ext
.iterator
->step
))
11187 gfc_error ("!$ACC LOOP %s loops don't form rectangular "
11188 "iteration space at %L", clause
, &do_code
->loc
);
11191 do_code2
= do_code2
->block
->next
;
11196 for (c
= do_code
->next
; c
; c
= c
->next
)
11197 if (c
->op
!= EXEC_NOP
&& c
->op
!= EXEC_CONTINUE
)
11199 gfc_error ("%s !$ACC LOOP loops not perfectly nested at %L",
11205 do_code
= do_code
->block
;
11206 if (do_code
->op
!= EXEC_DO
&& do_code
->op
!= EXEC_DO_WHILE
11207 && do_code
->op
!= EXEC_DO_CONCURRENT
)
11209 gfc_error ("not enough DO loops for %s !$ACC LOOP at %L",
11210 clause
, &code
->loc
);
11213 do_code
= do_code
->next
;
11214 if (do_code
== NULL
11215 || (do_code
->op
!= EXEC_DO
&& do_code
->op
!= EXEC_DO_WHILE
11216 && do_code
->op
!= EXEC_DO_CONCURRENT
))
11218 gfc_error ("not enough DO loops for %s !$ACC LOOP at %L",
11219 clause
, &code
->loc
);
11227 resolve_oacc_loop_blocks (gfc_code
*code
)
11229 if (!oacc_is_loop (code
))
11232 if (code
->ext
.omp_clauses
->tile_list
&& code
->ext
.omp_clauses
->gang
11233 && code
->ext
.omp_clauses
->worker
&& code
->ext
.omp_clauses
->vector
)
11234 gfc_error ("Tiled loop cannot be parallelized across gangs, workers and "
11235 "vectors at the same time at %L", &code
->loc
);
11237 if (code
->ext
.omp_clauses
->tile_list
)
11240 for (el
= code
->ext
.omp_clauses
->tile_list
; el
; el
= el
->next
)
11242 if (el
->expr
== NULL
)
11244 /* NULL expressions are used to represent '*' arguments.
11245 Convert those to a 0 expressions. */
11246 el
->expr
= gfc_get_constant_expr (BT_INTEGER
,
11247 gfc_default_integer_kind
,
11249 mpz_set_si (el
->expr
->value
.integer
, 0);
11253 resolve_positive_int_expr (el
->expr
, "TILE");
11254 if (el
->expr
->expr_type
!= EXPR_CONSTANT
)
11255 gfc_error ("TILE requires constant expression at %L",
11264 gfc_resolve_oacc_blocks (gfc_code
*code
, gfc_namespace
*ns
)
11266 fortran_omp_context ctx
;
11267 gfc_omp_clauses
*omp_clauses
= code
->ext
.omp_clauses
;
11268 gfc_omp_namelist
*n
;
11271 resolve_oacc_loop_blocks (code
);
11274 ctx
.sharing_clauses
= new hash_set
<gfc_symbol
*>;
11275 ctx
.private_iterators
= new hash_set
<gfc_symbol
*>;
11276 ctx
.previous
= omp_current_ctx
;
11277 ctx
.is_openmp
= false;
11278 omp_current_ctx
= &ctx
;
11280 for (list
= 0; list
< OMP_LIST_NUM
; list
++)
11283 case OMP_LIST_PRIVATE
:
11284 for (n
= omp_clauses
->lists
[list
]; n
; n
= n
->next
)
11285 ctx
.sharing_clauses
->add (n
->sym
);
11291 gfc_resolve_blocks (code
->block
, ns
);
11293 omp_current_ctx
= ctx
.previous
;
11294 delete ctx
.sharing_clauses
;
11295 delete ctx
.private_iterators
;
11300 resolve_oacc_loop (gfc_code
*code
)
11305 if (code
->ext
.omp_clauses
)
11306 resolve_omp_clauses (code
, code
->ext
.omp_clauses
, NULL
, true);
11308 do_code
= code
->block
->next
;
11309 collapse
= code
->ext
.omp_clauses
->collapse
;
11311 /* Both collapsed and tiled loops are lowered the same way, but are not
11312 compatible. In gfc_trans_omp_do, the tile is prioritized. */
11313 if (code
->ext
.omp_clauses
->tile_list
)
11317 for (el
= code
->ext
.omp_clauses
->tile_list
; el
; el
= el
->next
)
11319 resolve_oacc_nested_loops (code
, code
->block
->next
, num
, "tiled");
11325 resolve_oacc_nested_loops (code
, do_code
, collapse
, "collapsed");
11329 gfc_resolve_oacc_declare (gfc_namespace
*ns
)
11332 gfc_omp_namelist
*n
;
11333 gfc_oacc_declare
*oc
;
11335 if (ns
->oacc_declare
== NULL
)
11338 for (oc
= ns
->oacc_declare
; oc
; oc
= oc
->next
)
11340 for (list
= 0; list
< OMP_LIST_NUM
; list
++)
11341 for (n
= oc
->clauses
->lists
[list
]; n
; n
= n
->next
)
11344 if (n
->sym
->attr
.flavor
!= FL_VARIABLE
11345 && (n
->sym
->attr
.flavor
!= FL_PROCEDURE
11346 || n
->sym
->result
!= n
->sym
))
11348 gfc_error ("Object %qs is not a variable at %L",
11349 n
->sym
->name
, &oc
->loc
);
11353 if (n
->expr
&& n
->expr
->ref
->type
== REF_ARRAY
)
11355 gfc_error ("Array sections: %qs not allowed in"
11356 " !$ACC DECLARE at %L", n
->sym
->name
, &oc
->loc
);
11361 for (n
= oc
->clauses
->lists
[OMP_LIST_DEVICE_RESIDENT
]; n
; n
= n
->next
)
11362 check_array_not_assumed (n
->sym
, oc
->loc
, "DEVICE_RESIDENT");
11365 for (oc
= ns
->oacc_declare
; oc
; oc
= oc
->next
)
11367 for (list
= 0; list
< OMP_LIST_NUM
; list
++)
11368 for (n
= oc
->clauses
->lists
[list
]; n
; n
= n
->next
)
11372 gfc_error ("Symbol %qs present on multiple clauses at %L",
11373 n
->sym
->name
, &oc
->loc
);
11381 for (oc
= ns
->oacc_declare
; oc
; oc
= oc
->next
)
11383 for (list
= 0; list
< OMP_LIST_NUM
; list
++)
11384 for (n
= oc
->clauses
->lists
[list
]; n
; n
= n
->next
)
11391 gfc_resolve_oacc_routines (gfc_namespace
*ns
)
11393 for (gfc_oacc_routine_name
*orn
= ns
->oacc_routine_names
;
11397 gfc_symbol
*sym
= orn
->sym
;
11398 if (!sym
->attr
.external
11399 && !sym
->attr
.function
11400 && !sym
->attr
.subroutine
)
11402 gfc_error ("NAME %qs does not refer to a subroutine or function"
11403 " in !$ACC ROUTINE ( NAME ) at %L", sym
->name
, &orn
->loc
);
11406 if (!gfc_add_omp_declare_target (&sym
->attr
, sym
->name
, &orn
->loc
))
11408 gfc_error ("NAME %qs invalid"
11409 " in !$ACC ROUTINE ( NAME ) at %L", sym
->name
, &orn
->loc
);
11417 gfc_resolve_oacc_directive (gfc_code
*code
, gfc_namespace
*ns ATTRIBUTE_UNUSED
)
11419 resolve_oacc_directive_inside_omp_region (code
);
11423 case EXEC_OACC_PARALLEL
:
11424 case EXEC_OACC_KERNELS
:
11425 case EXEC_OACC_SERIAL
:
11426 case EXEC_OACC_DATA
:
11427 case EXEC_OACC_HOST_DATA
:
11428 case EXEC_OACC_UPDATE
:
11429 case EXEC_OACC_ENTER_DATA
:
11430 case EXEC_OACC_EXIT_DATA
:
11431 case EXEC_OACC_WAIT
:
11432 case EXEC_OACC_CACHE
:
11433 resolve_omp_clauses (code
, code
->ext
.omp_clauses
, NULL
, true);
11435 case EXEC_OACC_PARALLEL_LOOP
:
11436 case EXEC_OACC_KERNELS_LOOP
:
11437 case EXEC_OACC_SERIAL_LOOP
:
11438 case EXEC_OACC_LOOP
:
11439 resolve_oacc_loop (code
);
11441 case EXEC_OACC_ATOMIC
:
11442 resolve_omp_atomic (code
);
11451 resolve_omp_target (gfc_code
*code
)
11453 #define GFC_IS_TEAMS_CONSTRUCT(op) \
11454 (op == EXEC_OMP_TEAMS \
11455 || op == EXEC_OMP_TEAMS_DISTRIBUTE \
11456 || op == EXEC_OMP_TEAMS_DISTRIBUTE_SIMD \
11457 || op == EXEC_OMP_TEAMS_DISTRIBUTE_PARALLEL_DO \
11458 || op == EXEC_OMP_TEAMS_DISTRIBUTE_PARALLEL_DO_SIMD \
11459 || op == EXEC_OMP_TEAMS_LOOP)
11461 if (!code
->ext
.omp_clauses
->contains_teams_construct
)
11463 gfc_code
*c
= code
->block
->next
;
11464 if (c
->op
== EXEC_BLOCK
)
11465 c
= c
->ext
.block
.ns
->code
;
11466 if (code
->ext
.omp_clauses
->target_first_st_is_teams
11467 && ((GFC_IS_TEAMS_CONSTRUCT (c
->op
) && c
->next
== NULL
)
11468 || (c
->op
== EXEC_BLOCK
11470 && GFC_IS_TEAMS_CONSTRUCT (c
->next
->op
)
11471 && c
->next
->next
== NULL
)))
11473 while (c
&& !GFC_IS_TEAMS_CONSTRUCT (c
->op
))
11476 gfc_error ("!$OMP TARGET region at %L with a nested TEAMS at %L may not "
11477 "contain any other statement, declaration or directive outside "
11478 "of the single TEAMS construct", &c
->loc
, &code
->loc
);
11480 gfc_error ("!$OMP TARGET region at %L with a nested TEAMS may not "
11481 "contain any other statement, declaration or directive outside "
11482 "of the single TEAMS construct", &code
->loc
);
11483 #undef GFC_IS_TEAMS_CONSTRUCT
11487 /* Resolve OpenMP directive clauses and check various requirements
11488 of each directive. */
11491 gfc_resolve_omp_directive (gfc_code
*code
, gfc_namespace
*ns
)
11493 resolve_omp_directive_inside_oacc_region (code
);
11495 if (code
->op
!= EXEC_OMP_ATOMIC
)
11496 gfc_maybe_initialize_eh ();
11500 case EXEC_OMP_DISTRIBUTE
:
11501 case EXEC_OMP_DISTRIBUTE_PARALLEL_DO
:
11502 case EXEC_OMP_DISTRIBUTE_PARALLEL_DO_SIMD
:
11503 case EXEC_OMP_DISTRIBUTE_SIMD
:
11505 case EXEC_OMP_DO_SIMD
:
11506 case EXEC_OMP_LOOP
:
11507 case EXEC_OMP_PARALLEL_DO
:
11508 case EXEC_OMP_PARALLEL_DO_SIMD
:
11509 case EXEC_OMP_PARALLEL_LOOP
:
11510 case EXEC_OMP_PARALLEL_MASKED_TASKLOOP
:
11511 case EXEC_OMP_PARALLEL_MASKED_TASKLOOP_SIMD
:
11512 case EXEC_OMP_PARALLEL_MASTER_TASKLOOP
:
11513 case EXEC_OMP_PARALLEL_MASTER_TASKLOOP_SIMD
:
11514 case EXEC_OMP_MASKED_TASKLOOP
:
11515 case EXEC_OMP_MASKED_TASKLOOP_SIMD
:
11516 case EXEC_OMP_MASTER_TASKLOOP
:
11517 case EXEC_OMP_MASTER_TASKLOOP_SIMD
:
11518 case EXEC_OMP_SIMD
:
11519 case EXEC_OMP_TARGET_PARALLEL_DO
:
11520 case EXEC_OMP_TARGET_PARALLEL_DO_SIMD
:
11521 case EXEC_OMP_TARGET_PARALLEL_LOOP
:
11522 case EXEC_OMP_TARGET_SIMD
:
11523 case EXEC_OMP_TARGET_TEAMS_DISTRIBUTE
:
11524 case EXEC_OMP_TARGET_TEAMS_DISTRIBUTE_PARALLEL_DO
:
11525 case EXEC_OMP_TARGET_TEAMS_DISTRIBUTE_PARALLEL_DO_SIMD
:
11526 case EXEC_OMP_TARGET_TEAMS_DISTRIBUTE_SIMD
:
11527 case EXEC_OMP_TARGET_TEAMS_LOOP
:
11528 case EXEC_OMP_TASKLOOP
:
11529 case EXEC_OMP_TASKLOOP_SIMD
:
11530 case EXEC_OMP_TEAMS_DISTRIBUTE
:
11531 case EXEC_OMP_TEAMS_DISTRIBUTE_PARALLEL_DO
:
11532 case EXEC_OMP_TEAMS_DISTRIBUTE_PARALLEL_DO_SIMD
:
11533 case EXEC_OMP_TEAMS_DISTRIBUTE_SIMD
:
11534 case EXEC_OMP_TEAMS_LOOP
:
11535 resolve_omp_do (code
);
11537 case EXEC_OMP_TARGET
:
11538 resolve_omp_target (code
);
11539 gcc_fallthrough ();
11540 case EXEC_OMP_ALLOCATE
:
11541 case EXEC_OMP_ALLOCATORS
:
11542 case EXEC_OMP_ASSUME
:
11543 case EXEC_OMP_CANCEL
:
11544 case EXEC_OMP_ERROR
:
11545 case EXEC_OMP_MASKED
:
11546 case EXEC_OMP_ORDERED
:
11547 case EXEC_OMP_PARALLEL_WORKSHARE
:
11548 case EXEC_OMP_PARALLEL
:
11549 case EXEC_OMP_PARALLEL_MASKED
:
11550 case EXEC_OMP_PARALLEL_MASTER
:
11551 case EXEC_OMP_PARALLEL_SECTIONS
:
11552 case EXEC_OMP_SCOPE
:
11553 case EXEC_OMP_SECTIONS
:
11554 case EXEC_OMP_SINGLE
:
11555 case EXEC_OMP_TARGET_DATA
:
11556 case EXEC_OMP_TARGET_ENTER_DATA
:
11557 case EXEC_OMP_TARGET_EXIT_DATA
:
11558 case EXEC_OMP_TARGET_PARALLEL
:
11559 case EXEC_OMP_TARGET_TEAMS
:
11560 case EXEC_OMP_TASK
:
11561 case EXEC_OMP_TASKWAIT
:
11562 case EXEC_OMP_TEAMS
:
11563 case EXEC_OMP_WORKSHARE
:
11564 case EXEC_OMP_DEPOBJ
:
11565 if (code
->ext
.omp_clauses
)
11566 resolve_omp_clauses (code
, code
->ext
.omp_clauses
, NULL
);
11568 case EXEC_OMP_TARGET_UPDATE
:
11569 if (code
->ext
.omp_clauses
)
11570 resolve_omp_clauses (code
, code
->ext
.omp_clauses
, NULL
);
11571 if (code
->ext
.omp_clauses
== NULL
11572 || (code
->ext
.omp_clauses
->lists
[OMP_LIST_TO
] == NULL
11573 && code
->ext
.omp_clauses
->lists
[OMP_LIST_FROM
] == NULL
))
11574 gfc_error ("OMP TARGET UPDATE at %L requires at least one TO or "
11575 "FROM clause", &code
->loc
);
11577 case EXEC_OMP_ATOMIC
:
11578 resolve_omp_clauses (code
, code
->block
->ext
.omp_clauses
, NULL
);
11579 resolve_omp_atomic (code
);
11581 case EXEC_OMP_CRITICAL
:
11582 resolve_omp_clauses (code
, code
->ext
.omp_clauses
, NULL
);
11583 if (!code
->ext
.omp_clauses
->critical_name
11584 && code
->ext
.omp_clauses
->hint
11585 && code
->ext
.omp_clauses
->hint
->ts
.type
== BT_INTEGER
11586 && code
->ext
.omp_clauses
->hint
->expr_type
== EXPR_CONSTANT
11587 && mpz_sgn (code
->ext
.omp_clauses
->hint
->value
.integer
) != 0)
11588 gfc_error ("OMP CRITICAL at %L with HINT clause requires a NAME, "
11589 "except when omp_sync_hint_none is used", &code
->loc
);
11591 case EXEC_OMP_SCAN
:
11592 /* Flag is only used to checking, hence, it is unset afterwards. */
11593 if (!code
->ext
.omp_clauses
->if_present
)
11594 gfc_error ("Unexpected !$OMP SCAN at %L outside loop construct with "
11595 "%<inscan%> REDUCTION clause", &code
->loc
);
11596 code
->ext
.omp_clauses
->if_present
= false;
11597 resolve_omp_clauses (code
, code
->ext
.omp_clauses
, ns
);
11604 /* Resolve !$omp declare simd constructs in NS. */
11607 gfc_resolve_omp_declare_simd (gfc_namespace
*ns
)
11609 gfc_omp_declare_simd
*ods
;
11611 for (ods
= ns
->omp_declare_simd
; ods
; ods
= ods
->next
)
11613 if (ods
->proc_name
!= NULL
11614 && ods
->proc_name
!= ns
->proc_name
)
11615 gfc_error ("!$OMP DECLARE SIMD should refer to containing procedure "
11616 "%qs at %L", ns
->proc_name
->name
, &ods
->where
);
11618 resolve_omp_clauses (NULL
, ods
->clauses
, ns
);
11622 struct omp_udr_callback_data
11624 gfc_omp_udr
*omp_udr
;
11625 bool is_initializer
;
11629 omp_udr_callback (gfc_expr
**e
, int *walk_subtrees ATTRIBUTE_UNUSED
,
11632 struct omp_udr_callback_data
*cd
= (struct omp_udr_callback_data
*) data
;
11633 if ((*e
)->expr_type
== EXPR_VARIABLE
)
11635 if (cd
->is_initializer
)
11637 if ((*e
)->symtree
->n
.sym
!= cd
->omp_udr
->omp_priv
11638 && (*e
)->symtree
->n
.sym
!= cd
->omp_udr
->omp_orig
)
11639 gfc_error ("Variable other than OMP_PRIV or OMP_ORIG used in "
11640 "INITIALIZER clause of !$OMP DECLARE REDUCTION at %L",
11645 if ((*e
)->symtree
->n
.sym
!= cd
->omp_udr
->omp_out
11646 && (*e
)->symtree
->n
.sym
!= cd
->omp_udr
->omp_in
)
11647 gfc_error ("Variable other than OMP_OUT or OMP_IN used in "
11648 "combiner of !$OMP DECLARE REDUCTION at %L",
11655 /* Resolve !$omp declare reduction constructs. */
11658 gfc_resolve_omp_udr (gfc_omp_udr
*omp_udr
)
11660 gfc_actual_arglist
*a
;
11661 const char *predef_name
= NULL
;
11663 switch (omp_udr
->rop
)
11665 case OMP_REDUCTION_PLUS
:
11666 case OMP_REDUCTION_TIMES
:
11667 case OMP_REDUCTION_MINUS
:
11668 case OMP_REDUCTION_AND
:
11669 case OMP_REDUCTION_OR
:
11670 case OMP_REDUCTION_EQV
:
11671 case OMP_REDUCTION_NEQV
:
11672 case OMP_REDUCTION_MAX
:
11673 case OMP_REDUCTION_USER
:
11676 gfc_error ("Invalid operator for !$OMP DECLARE REDUCTION %s at %L",
11677 omp_udr
->name
, &omp_udr
->where
);
11681 if (gfc_omp_udr_predef (omp_udr
->rop
, omp_udr
->name
,
11682 &omp_udr
->ts
, &predef_name
))
11685 gfc_error_now ("Redefinition of predefined %s "
11686 "!$OMP DECLARE REDUCTION at %L",
11687 predef_name
, &omp_udr
->where
);
11689 gfc_error_now ("Redefinition of predefined "
11690 "!$OMP DECLARE REDUCTION at %L", &omp_udr
->where
);
11694 if (omp_udr
->ts
.type
== BT_CHARACTER
11695 && omp_udr
->ts
.u
.cl
->length
11696 && omp_udr
->ts
.u
.cl
->length
->expr_type
!= EXPR_CONSTANT
)
11698 gfc_error ("CHARACTER length in !$OMP DECLARE REDUCTION %s not "
11699 "constant at %L", omp_udr
->name
, &omp_udr
->where
);
11703 struct omp_udr_callback_data cd
;
11704 cd
.omp_udr
= omp_udr
;
11705 cd
.is_initializer
= false;
11706 gfc_code_walker (&omp_udr
->combiner_ns
->code
, gfc_dummy_code_callback
,
11707 omp_udr_callback
, &cd
);
11708 if (omp_udr
->combiner_ns
->code
->op
== EXEC_CALL
)
11710 for (a
= omp_udr
->combiner_ns
->code
->ext
.actual
; a
; a
= a
->next
)
11711 if (a
->expr
== NULL
)
11714 gfc_error ("Subroutine call with alternate returns in combiner "
11715 "of !$OMP DECLARE REDUCTION at %L",
11716 &omp_udr
->combiner_ns
->code
->loc
);
11718 if (omp_udr
->initializer_ns
)
11720 cd
.is_initializer
= true;
11721 gfc_code_walker (&omp_udr
->initializer_ns
->code
, gfc_dummy_code_callback
,
11722 omp_udr_callback
, &cd
);
11723 if (omp_udr
->initializer_ns
->code
->op
== EXEC_CALL
)
11725 for (a
= omp_udr
->initializer_ns
->code
->ext
.actual
; a
; a
= a
->next
)
11726 if (a
->expr
== NULL
)
11729 gfc_error ("Subroutine call with alternate returns in "
11730 "INITIALIZER clause of !$OMP DECLARE REDUCTION "
11731 "at %L", &omp_udr
->initializer_ns
->code
->loc
);
11732 for (a
= omp_udr
->initializer_ns
->code
->ext
.actual
; a
; a
= a
->next
)
11734 && a
->expr
->expr_type
== EXPR_VARIABLE
11735 && a
->expr
->symtree
->n
.sym
== omp_udr
->omp_priv
11736 && a
->expr
->ref
== NULL
)
11739 gfc_error ("One of actual subroutine arguments in INITIALIZER "
11740 "clause of !$OMP DECLARE REDUCTION must be OMP_PRIV "
11741 "at %L", &omp_udr
->initializer_ns
->code
->loc
);
11744 else if (omp_udr
->ts
.type
== BT_DERIVED
11745 && !gfc_has_default_initializer (omp_udr
->ts
.u
.derived
))
11747 gfc_error ("Missing INITIALIZER clause for !$OMP DECLARE REDUCTION "
11748 "of derived type without default initializer at %L",
11755 gfc_resolve_omp_udrs (gfc_symtree
*st
)
11757 gfc_omp_udr
*omp_udr
;
11761 gfc_resolve_omp_udrs (st
->left
);
11762 gfc_resolve_omp_udrs (st
->right
);
11763 for (omp_udr
= st
->n
.omp_udr
; omp_udr
; omp_udr
= omp_udr
->next
)
11764 gfc_resolve_omp_udr (omp_udr
);