Branch data Line data Source code
1 : : /* OpenMP directive matching and resolving.
2 : : Copyright (C) 2005-2025 Free Software Foundation, Inc.
3 : : Contributed by Jakub Jelinek
4 : :
5 : : This file is part of GCC.
6 : :
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
10 : : version.
11 : :
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
15 : : for more details.
16 : :
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/>. */
20 : :
21 : : #define INCLUDE_VECTOR
22 : : #define INCLUDE_STRING
23 : : #include "config.h"
24 : : #include "system.h"
25 : : #include "coretypes.h"
26 : : #include "options.h"
27 : : #include "gfortran.h"
28 : : #include "arith.h"
29 : : #include "match.h"
30 : : #include "parse.h"
31 : : #include "constructor.h"
32 : : #include "diagnostic.h"
33 : : #include "gomp-constants.h"
34 : : #include "target-memory.h" /* For gfc_encode_character. */
35 : : #include "bitmap.h"
36 : : #include "omp-api.h" /* For omp_runtime_api_procname. */
37 : :
38 : : location_t gfc_get_location (locus *);
39 : :
40 : : static gfc_statement omp_code_to_statement (gfc_code *);
41 : :
42 : : enum gfc_omp_directive_kind {
43 : : GFC_OMP_DIR_DECLARATIVE,
44 : : GFC_OMP_DIR_EXECUTABLE,
45 : : GFC_OMP_DIR_INFORMATIONAL,
46 : : GFC_OMP_DIR_META,
47 : : GFC_OMP_DIR_SUBSIDIARY,
48 : : GFC_OMP_DIR_UTILITY
49 : : };
50 : :
51 : : struct gfc_omp_directive {
52 : : const char *name;
53 : : enum gfc_omp_directive_kind kind;
54 : : gfc_statement st;
55 : : };
56 : :
57 : : /* Alphabetically sorted OpenMP clauses, except that longer strings are before
58 : : substrings; excludes combined/composite directives. See note for "ordered"
59 : : and "nothing". */
60 : :
61 : : static const struct gfc_omp_directive gfc_omp_directives[] = {
62 : : /* allocate as alias for allocators is also executive. */
63 : : {"allocate", GFC_OMP_DIR_DECLARATIVE, ST_OMP_ALLOCATE},
64 : : {"allocators", GFC_OMP_DIR_EXECUTABLE, ST_OMP_ALLOCATORS},
65 : : {"assumes", GFC_OMP_DIR_INFORMATIONAL, ST_OMP_ASSUMES},
66 : : {"assume", GFC_OMP_DIR_INFORMATIONAL, ST_OMP_ASSUME},
67 : : {"atomic", GFC_OMP_DIR_EXECUTABLE, ST_OMP_ATOMIC},
68 : : {"barrier", GFC_OMP_DIR_EXECUTABLE, ST_OMP_BARRIER},
69 : : {"cancellation point", GFC_OMP_DIR_EXECUTABLE, ST_OMP_CANCELLATION_POINT},
70 : : {"cancel", GFC_OMP_DIR_EXECUTABLE, ST_OMP_CANCEL},
71 : : {"critical", GFC_OMP_DIR_EXECUTABLE, ST_OMP_CRITICAL},
72 : : /* {"declare induction", GFC_OMP_DIR_DECLARATIVE, ST_OMP_DECLARE_INDUCTION}, */
73 : : /* {"declare mapper", GFC_OMP_DIR_DECLARATIVE, ST_OMP_DECLARE_MAPPER}, */
74 : : {"declare reduction", GFC_OMP_DIR_DECLARATIVE, ST_OMP_DECLARE_REDUCTION},
75 : : {"declare simd", GFC_OMP_DIR_DECLARATIVE, ST_OMP_DECLARE_SIMD},
76 : : {"declare target", GFC_OMP_DIR_DECLARATIVE, ST_OMP_DECLARE_TARGET},
77 : : {"declare variant", GFC_OMP_DIR_DECLARATIVE, ST_OMP_DECLARE_VARIANT},
78 : : {"depobj", GFC_OMP_DIR_EXECUTABLE, ST_OMP_DEPOBJ},
79 : : {"dispatch", GFC_OMP_DIR_EXECUTABLE, ST_OMP_DISPATCH},
80 : : {"distribute", GFC_OMP_DIR_EXECUTABLE, ST_OMP_DISTRIBUTE},
81 : : {"do", GFC_OMP_DIR_EXECUTABLE, ST_OMP_DO},
82 : : /* "error" becomes GFC_OMP_DIR_EXECUTABLE with at(execution) */
83 : : {"error", GFC_OMP_DIR_UTILITY, ST_OMP_ERROR},
84 : : /* {"flatten", GFC_OMP_DIR_EXECUTABLE, ST_OMP_FLATTEN}, */
85 : : {"flush", GFC_OMP_DIR_EXECUTABLE, ST_OMP_FLUSH},
86 : : /* {"fuse", GFC_OMP_DIR_EXECUTABLE, ST_OMP_FLUSE}, */
87 : : /* {"interchange", GFC_OMP_DIR_EXECUTABLE, ST_OMP_INTERCHANGE}, */
88 : : {"interop", GFC_OMP_DIR_EXECUTABLE, ST_OMP_INTEROP},
89 : : {"loop", GFC_OMP_DIR_EXECUTABLE, ST_OMP_LOOP},
90 : : {"masked", GFC_OMP_DIR_EXECUTABLE, ST_OMP_MASKED},
91 : : {"metadirective", GFC_OMP_DIR_META, ST_OMP_METADIRECTIVE},
92 : : /* Note: gfc_match_omp_nothing returns ST_NONE. */
93 : : {"nothing", GFC_OMP_DIR_UTILITY, ST_OMP_NOTHING},
94 : : /* Special case; for now map to the first one.
95 : : ordered-blockassoc = ST_OMP_ORDERED
96 : : ordered-standalone = ST_OMP_ORDERED_DEPEND + depend/doacross. */
97 : : {"ordered", GFC_OMP_DIR_EXECUTABLE, ST_OMP_ORDERED},
98 : : {"parallel", GFC_OMP_DIR_EXECUTABLE, ST_OMP_PARALLEL},
99 : : {"requires", GFC_OMP_DIR_INFORMATIONAL, ST_OMP_REQUIRES},
100 : : {"scan", GFC_OMP_DIR_SUBSIDIARY, ST_OMP_SCAN},
101 : : {"scope", GFC_OMP_DIR_EXECUTABLE, ST_OMP_SCOPE},
102 : : {"sections", GFC_OMP_DIR_EXECUTABLE, ST_OMP_SECTIONS},
103 : : {"section", GFC_OMP_DIR_SUBSIDIARY, ST_OMP_SECTION},
104 : : {"simd", GFC_OMP_DIR_EXECUTABLE, ST_OMP_SIMD},
105 : : {"single", GFC_OMP_DIR_EXECUTABLE, ST_OMP_SINGLE},
106 : : /* {"split", GFC_OMP_DIR_EXECUTABLE, ST_OMP_SPLIT}, */
107 : : /* {"strip", GFC_OMP_DIR_EXECUTABLE, ST_OMP_STRIP}, */
108 : : {"target data", GFC_OMP_DIR_EXECUTABLE, ST_OMP_TARGET_DATA},
109 : : {"target enter data", GFC_OMP_DIR_EXECUTABLE, ST_OMP_TARGET_ENTER_DATA},
110 : : {"target exit data", GFC_OMP_DIR_EXECUTABLE, ST_OMP_TARGET_EXIT_DATA},
111 : : {"target update", GFC_OMP_DIR_EXECUTABLE, ST_OMP_TARGET_UPDATE},
112 : : {"target", GFC_OMP_DIR_EXECUTABLE, ST_OMP_TARGET},
113 : : /* {"taskgraph", GFC_OMP_DIR_EXECUTABLE, ST_OMP_TASKGRAPH}, */
114 : : /* {"task iteration", GFC_OMP_DIR_EXECUTABLE, ST_OMP_TASK_ITERATION}, */
115 : : {"taskloop", GFC_OMP_DIR_EXECUTABLE, ST_OMP_TASKLOOP},
116 : : {"taskwait", GFC_OMP_DIR_EXECUTABLE, ST_OMP_TASKWAIT},
117 : : {"taskyield", GFC_OMP_DIR_EXECUTABLE, ST_OMP_TASKYIELD},
118 : : {"task", GFC_OMP_DIR_EXECUTABLE, ST_OMP_TASK},
119 : : {"teams", GFC_OMP_DIR_EXECUTABLE, ST_OMP_TEAMS},
120 : : {"threadprivate", GFC_OMP_DIR_DECLARATIVE, ST_OMP_THREADPRIVATE},
121 : : {"tile", GFC_OMP_DIR_EXECUTABLE, ST_OMP_TILE},
122 : : {"unroll", GFC_OMP_DIR_EXECUTABLE, ST_OMP_UNROLL},
123 : : /* {"workdistribute", GFC_OMP_DIR_EXECUTABLE, ST_OMP_WORKDISTRIBUTE}, */
124 : : {"workshare", GFC_OMP_DIR_EXECUTABLE, ST_OMP_WORKSHARE},
125 : : };
126 : :
127 : :
128 : : /* Match an end of OpenMP directive. End of OpenMP directive is optional
129 : : whitespace, followed by '\n' or comment '!'. In the special case where a
130 : : context selector is being matched, match against ')' instead. */
131 : :
132 : : static match
133 : 54078 : gfc_match_omp_eos (void)
134 : : {
135 : 54078 : locus old_loc;
136 : 54078 : char c;
137 : :
138 : 54078 : old_loc = gfc_current_locus;
139 : 54078 : gfc_gobble_whitespace ();
140 : :
141 : 54078 : if (gfc_matching_omp_context_selector)
142 : : {
143 : 269 : if (gfc_peek_ascii_char () == ')')
144 : : return MATCH_YES;
145 : : }
146 : : else
147 : : {
148 : 53809 : c = gfc_next_ascii_char ();
149 : 53809 : switch (c)
150 : : {
151 : 0 : case '!':
152 : 0 : do
153 : 0 : c = gfc_next_ascii_char ();
154 : 0 : while (c != '\n');
155 : : /* Fall through */
156 : :
157 : 52223 : case '\n':
158 : 52223 : return MATCH_YES;
159 : : }
160 : : }
161 : :
162 : 1587 : gfc_current_locus = old_loc;
163 : 1587 : return MATCH_NO;
164 : : }
165 : :
166 : : match
167 : 13136 : gfc_match_omp_eos_error (void)
168 : : {
169 : 13136 : if (gfc_match_omp_eos() == MATCH_YES)
170 : : return MATCH_YES;
171 : :
172 : 35 : gfc_error ("Unexpected junk at %C");
173 : 35 : return MATCH_ERROR;
174 : : }
175 : :
176 : :
177 : : /* Free an omp_clauses structure. */
178 : :
179 : : void
180 : 60375 : gfc_free_omp_clauses (gfc_omp_clauses *c)
181 : : {
182 : 60375 : int i;
183 : 60375 : if (c == NULL)
184 : : return;
185 : :
186 : 33886 : gfc_free_expr (c->if_expr);
187 : 406632 : for (i = 0; i < OMP_IF_LAST; i++)
188 : 338860 : gfc_free_expr (c->if_exprs[i]);
189 : 33886 : gfc_free_expr (c->self_expr);
190 : 33886 : gfc_free_expr (c->final_expr);
191 : 33886 : gfc_free_expr (c->num_threads);
192 : 33886 : gfc_free_expr (c->chunk_size);
193 : 33886 : gfc_free_expr (c->safelen_expr);
194 : 33886 : gfc_free_expr (c->simdlen_expr);
195 : 33886 : gfc_free_expr (c->num_teams_lower);
196 : 33886 : gfc_free_expr (c->num_teams_upper);
197 : 33886 : gfc_free_expr (c->device);
198 : 33886 : gfc_free_expr (c->thread_limit);
199 : 33886 : gfc_free_expr (c->dist_chunk_size);
200 : 33886 : gfc_free_expr (c->grainsize);
201 : 33886 : gfc_free_expr (c->hint);
202 : 33886 : gfc_free_expr (c->num_tasks);
203 : 33886 : gfc_free_expr (c->priority);
204 : 33886 : gfc_free_expr (c->detach);
205 : 33886 : gfc_free_expr (c->novariants);
206 : 33886 : gfc_free_expr (c->nocontext);
207 : 33886 : gfc_free_expr (c->async_expr);
208 : 33886 : gfc_free_expr (c->gang_num_expr);
209 : 33886 : gfc_free_expr (c->gang_static_expr);
210 : 33886 : gfc_free_expr (c->worker_expr);
211 : 33886 : gfc_free_expr (c->vector_expr);
212 : 33886 : gfc_free_expr (c->num_gangs_expr);
213 : 33886 : gfc_free_expr (c->num_workers_expr);
214 : 33886 : gfc_free_expr (c->vector_length_expr);
215 : 1355440 : for (i = 0; i < OMP_LIST_NUM; i++)
216 : 1287668 : gfc_free_omp_namelist (c->lists[i],
217 : 1287668 : i == OMP_LIST_AFFINITY || i == OMP_LIST_DEPEND,
218 : : i == OMP_LIST_ALLOCATE,
219 : : i == OMP_LIST_USES_ALLOCATORS,
220 : : i == OMP_LIST_INIT);
221 : 33886 : gfc_free_expr_list (c->wait_list);
222 : 33886 : gfc_free_expr_list (c->tile_list);
223 : 33886 : gfc_free_expr_list (c->sizes_list);
224 : 33886 : free (CONST_CAST (char *, c->critical_name));
225 : 33886 : if (c->assume)
226 : : {
227 : 21 : free (c->assume->absent);
228 : 21 : free (c->assume->contains);
229 : 21 : gfc_free_expr_list (c->assume->holds);
230 : 21 : free (c->assume);
231 : : }
232 : 33886 : free (c);
233 : : }
234 : :
235 : : /* Free oacc_declare structures. */
236 : :
237 : : void
238 : 76 : gfc_free_oacc_declare_clauses (struct gfc_oacc_declare *oc)
239 : : {
240 : 76 : struct gfc_oacc_declare *decl = oc;
241 : :
242 : 76 : do
243 : : {
244 : 76 : struct gfc_oacc_declare *next;
245 : :
246 : 76 : next = decl->next;
247 : 76 : gfc_free_omp_clauses (decl->clauses);
248 : 76 : free (decl);
249 : 76 : decl = next;
250 : : }
251 : 76 : while (decl);
252 : 76 : }
253 : :
254 : : /* Free expression list. */
255 : : void
256 : 102562 : gfc_free_expr_list (gfc_expr_list *list)
257 : : {
258 : 102562 : gfc_expr_list *n;
259 : :
260 : 103965 : for (; list; list = n)
261 : : {
262 : 1403 : n = list->next;
263 : 1403 : free (list);
264 : : }
265 : 102562 : }
266 : :
267 : : /* Free an !$omp declare simd construct list. */
268 : :
269 : : void
270 : 236 : gfc_free_omp_declare_simd (gfc_omp_declare_simd *ods)
271 : : {
272 : 236 : if (ods)
273 : : {
274 : 236 : gfc_free_omp_clauses (ods->clauses);
275 : 236 : free (ods);
276 : : }
277 : 236 : }
278 : :
279 : : void
280 : 507131 : gfc_free_omp_declare_simd_list (gfc_omp_declare_simd *list)
281 : : {
282 : 507367 : while (list)
283 : : {
284 : 236 : gfc_omp_declare_simd *current = list;
285 : 236 : list = list->next;
286 : 236 : gfc_free_omp_declare_simd (current);
287 : : }
288 : 507131 : }
289 : :
290 : : static void
291 : 727 : gfc_free_omp_trait_property_list (gfc_omp_trait_property *list)
292 : : {
293 : 1134 : while (list)
294 : : {
295 : 407 : gfc_omp_trait_property *current = list;
296 : 407 : list = list->next;
297 : 407 : switch (current->property_kind)
298 : : {
299 : 24 : case OMP_TRAIT_PROPERTY_ID:
300 : 24 : free (current->name);
301 : 24 : break;
302 : 261 : case OMP_TRAIT_PROPERTY_NAME_LIST:
303 : 261 : if (current->is_name)
304 : 168 : free (current->name);
305 : : break;
306 : 15 : case OMP_TRAIT_PROPERTY_CLAUSE_LIST:
307 : 15 : gfc_free_omp_clauses (current->clauses);
308 : 15 : break;
309 : : default:
310 : : break;
311 : : }
312 : 407 : free (current);
313 : : }
314 : 727 : }
315 : :
316 : : static void
317 : 599 : gfc_free_omp_selector_list (gfc_omp_selector *list)
318 : : {
319 : 1326 : while (list)
320 : : {
321 : 727 : gfc_omp_selector *current = list;
322 : 727 : list = list->next;
323 : 727 : gfc_free_omp_trait_property_list (current->properties);
324 : 727 : free (current);
325 : : }
326 : 599 : }
327 : :
328 : : static void
329 : 667 : gfc_free_omp_set_selector_list (gfc_omp_set_selector *list)
330 : : {
331 : 1266 : while (list)
332 : : {
333 : 599 : gfc_omp_set_selector *current = list;
334 : 599 : list = list->next;
335 : 599 : gfc_free_omp_selector_list (current->trait_selectors);
336 : 599 : free (current);
337 : : }
338 : 667 : }
339 : :
340 : : /* Free an !$omp declare variant construct list. */
341 : :
342 : : void
343 : 507131 : gfc_free_omp_declare_variant_list (gfc_omp_declare_variant *list)
344 : : {
345 : 507584 : while (list)
346 : : {
347 : 453 : gfc_omp_declare_variant *current = list;
348 : 453 : list = list->next;
349 : 453 : gfc_free_omp_set_selector_list (current->set_selectors);
350 : 453 : gfc_free_omp_namelist (current->adjust_args_list, false, false, false,
351 : : false);
352 : 453 : free (current);
353 : : }
354 : 507131 : }
355 : :
356 : : /* Free an !$omp declare reduction. */
357 : :
358 : : void
359 : 1118 : gfc_free_omp_udr (gfc_omp_udr *omp_udr)
360 : : {
361 : 1118 : if (omp_udr)
362 : : {
363 : 607 : gfc_free_omp_udr (omp_udr->next);
364 : 607 : gfc_free_namespace (omp_udr->combiner_ns);
365 : 607 : if (omp_udr->initializer_ns)
366 : 377 : gfc_free_namespace (omp_udr->initializer_ns);
367 : 607 : free (omp_udr);
368 : : }
369 : 1118 : }
370 : :
371 : : /* Free variants of an !$omp metadirective construct. */
372 : :
373 : : void
374 : 93 : gfc_free_omp_variants (gfc_omp_variant *variant)
375 : : {
376 : 284 : while (variant)
377 : : {
378 : 191 : gfc_omp_variant *next_variant = variant->next;
379 : 191 : gfc_free_omp_set_selector_list (variant->selectors);
380 : 191 : free (variant);
381 : 191 : variant = next_variant;
382 : : }
383 : 93 : }
384 : :
385 : : static gfc_omp_udr *
386 : 4708 : gfc_find_omp_udr (gfc_namespace *ns, const char *name, gfc_typespec *ts)
387 : : {
388 : 4708 : gfc_symtree *st;
389 : :
390 : 4708 : if (ns == NULL)
391 : 467 : ns = gfc_current_ns;
392 : 5656 : do
393 : : {
394 : 5656 : gfc_omp_udr *omp_udr;
395 : :
396 : 5656 : st = gfc_find_symtree (ns->omp_udr_root, name);
397 : 5656 : if (st != NULL)
398 : : {
399 : 934 : for (omp_udr = st->n.omp_udr; omp_udr; omp_udr = omp_udr->next)
400 : 934 : if (ts == NULL)
401 : : return omp_udr;
402 : 567 : else if (gfc_compare_types (&omp_udr->ts, ts))
403 : : {
404 : 479 : if (ts->type == BT_CHARACTER)
405 : : {
406 : 60 : if (omp_udr->ts.u.cl->length == NULL)
407 : : return omp_udr;
408 : 36 : if (ts->u.cl->length == NULL)
409 : 0 : continue;
410 : 36 : if (gfc_compare_expr (omp_udr->ts.u.cl->length,
411 : : ts->u.cl->length,
412 : : INTRINSIC_EQ) != 0)
413 : 12 : continue;
414 : : }
415 : 443 : return omp_udr;
416 : : }
417 : : }
418 : :
419 : : /* Don't escape an interface block. */
420 : 4822 : if (ns && !ns->has_import_set
421 : 4822 : && ns->proc_name && ns->proc_name->attr.if_source == IFSRC_IFBODY)
422 : : break;
423 : :
424 : 4822 : ns = ns->parent;
425 : : }
426 : 4822 : while (ns != NULL);
427 : :
428 : : return NULL;
429 : : }
430 : :
431 : :
432 : : /* Match a variable/common block list and construct a namelist from it;
433 : : if has_all_memory != NULL, *has_all_memory is set and omp_all_memory
434 : : yields a list->sym NULL entry. */
435 : :
436 : : static match
437 : 30512 : gfc_match_omp_variable_list (const char *str, gfc_omp_namelist **list,
438 : : bool allow_common, bool *end_colon = NULL,
439 : : gfc_omp_namelist ***headp = NULL,
440 : : bool allow_sections = false,
441 : : bool allow_derived = false,
442 : : bool *has_all_memory = NULL,
443 : : bool reject_common_vars = false,
444 : : bool reverse_order = false)
445 : : {
446 : 30512 : gfc_omp_namelist *head, *tail, *p;
447 : 30512 : locus old_loc, cur_loc;
448 : 30512 : char n[GFC_MAX_SYMBOL_LEN+1];
449 : 30512 : gfc_symbol *sym;
450 : 30512 : match m;
451 : 30512 : gfc_symtree *st;
452 : :
453 : 30512 : head = tail = NULL;
454 : :
455 : 30512 : old_loc = gfc_current_locus;
456 : 30512 : if (has_all_memory)
457 : 705 : *has_all_memory = false;
458 : 30512 : m = gfc_match (str);
459 : 30512 : if (m != MATCH_YES)
460 : : return m;
461 : :
462 : 37000 : for (;;)
463 : : {
464 : 37000 : gfc_gobble_whitespace ();
465 : 37000 : cur_loc = gfc_current_locus;
466 : :
467 : 37000 : m = gfc_match_name (n);
468 : 37000 : if (m == MATCH_YES && strcmp (n, "omp_all_memory") == 0)
469 : : {
470 : 23 : locus loc = gfc_get_location_range (NULL, 0, &cur_loc, 1,
471 : : &gfc_current_locus);
472 : 23 : if (!has_all_memory)
473 : : {
474 : 2 : gfc_error ("%<omp_all_memory%> at %L not permitted in this "
475 : : "clause", &loc);
476 : 2 : goto cleanup;
477 : : }
478 : 21 : *has_all_memory = true;
479 : 21 : p = gfc_get_omp_namelist ();
480 : 21 : if (head == NULL)
481 : : head = tail = p;
482 : : else
483 : : {
484 : 3 : tail->next = p;
485 : 3 : tail = tail->next;
486 : : }
487 : 21 : tail->where = loc;
488 : 21 : goto next_item;
489 : : }
490 : 36771 : if (m == MATCH_YES)
491 : : {
492 : 36771 : gfc_symtree *st;
493 : 36771 : if ((m = gfc_get_ha_sym_tree (n, &st) ? MATCH_ERROR : MATCH_YES)
494 : : == MATCH_YES)
495 : 36771 : sym = st->n.sym;
496 : : }
497 : 36977 : switch (m)
498 : : {
499 : 36771 : case MATCH_YES:
500 : 36771 : gfc_expr *expr;
501 : 36771 : expr = NULL;
502 : 36771 : gfc_gobble_whitespace ();
503 : 22329 : if ((allow_sections && gfc_peek_ascii_char () == '(')
504 : 55011 : || (allow_derived && gfc_peek_ascii_char () == '%'))
505 : : {
506 : 5949 : gfc_current_locus = cur_loc;
507 : 5949 : m = gfc_match_variable (&expr, 0);
508 : 5949 : switch (m)
509 : : {
510 : 4 : case MATCH_ERROR:
511 : 12 : goto cleanup;
512 : 0 : case MATCH_NO:
513 : 0 : goto syntax;
514 : 5945 : default:
515 : 5945 : break;
516 : : }
517 : 5945 : if (gfc_is_coindexed (expr))
518 : : {
519 : 5 : gfc_error ("List item shall not be coindexed at %L",
520 : 5 : &expr->where);
521 : 5 : goto cleanup;
522 : : }
523 : : }
524 : 36762 : gfc_set_sym_referenced (sym);
525 : 36762 : p = gfc_get_omp_namelist ();
526 : 36762 : if (head == NULL)
527 : : head = tail = p;
528 : 9888 : else if (reverse_order)
529 : : {
530 : 57 : p->next = head;
531 : 57 : head = p;
532 : : }
533 : : else
534 : : {
535 : 9831 : tail->next = p;
536 : 9831 : tail = tail->next;
537 : : }
538 : 36762 : p->sym = sym;
539 : 36762 : p->expr = expr;
540 : 36762 : p->where = gfc_get_location_range (NULL, 0, &cur_loc, 1,
541 : : &gfc_current_locus);
542 : 36762 : if (reject_common_vars && sym->attr.in_common)
543 : : {
544 : 3 : gcc_assert (allow_common);
545 : 3 : gfc_error ("%qs at %L is part of the common block %</%s/%> and "
546 : : "may only be specificed implicitly via the named "
547 : : "common block", sym->name, &cur_loc,
548 : 3 : sym->common_head->name);
549 : 3 : goto cleanup;
550 : : }
551 : 36759 : goto next_item;
552 : 206 : case MATCH_NO:
553 : 206 : break;
554 : 0 : case MATCH_ERROR:
555 : 0 : goto cleanup;
556 : : }
557 : :
558 : 206 : if (!allow_common)
559 : 10 : goto syntax;
560 : :
561 : 196 : m = gfc_match ("/ %n /", n);
562 : 196 : if (m == MATCH_ERROR)
563 : 0 : goto cleanup;
564 : 196 : if (m == MATCH_NO)
565 : 19 : goto syntax;
566 : :
567 : 177 : cur_loc = gfc_get_location_range (NULL, 0, &cur_loc, 1,
568 : : &gfc_current_locus);
569 : 177 : st = gfc_find_symtree (gfc_current_ns->common_root, n);
570 : 177 : if (st == NULL)
571 : : {
572 : 2 : gfc_error ("COMMON block %</%s/%> not found at %L", n, &cur_loc);
573 : 2 : goto cleanup;
574 : : }
575 : 628 : for (sym = st->n.common->head; sym; sym = sym->common_next)
576 : : {
577 : 453 : gfc_set_sym_referenced (sym);
578 : 453 : p = gfc_get_omp_namelist ();
579 : 453 : if (head == NULL)
580 : : head = tail = p;
581 : 325 : else if (reverse_order)
582 : : {
583 : 0 : p->next = head;
584 : 0 : head = p;
585 : : }
586 : : else
587 : : {
588 : 325 : tail->next = p;
589 : 325 : tail = tail->next;
590 : : }
591 : 453 : p->sym = sym;
592 : 453 : p->where = cur_loc;
593 : : }
594 : :
595 : 175 : next_item:
596 : 36955 : if (end_colon && gfc_match_char (':') == MATCH_YES)
597 : : {
598 : 790 : *end_colon = true;
599 : 790 : break;
600 : : }
601 : 36165 : if (gfc_match_char (')') == MATCH_YES)
602 : : break;
603 : 9957 : if (gfc_match_char (',') != MATCH_YES)
604 : 19 : goto syntax;
605 : : }
606 : :
607 : 36411 : while (*list)
608 : 9413 : list = &(*list)->next;
609 : :
610 : 26998 : *list = head;
611 : 26998 : if (headp)
612 : 21316 : *headp = list;
613 : : return MATCH_YES;
614 : :
615 : 48 : syntax:
616 : 48 : gfc_error ("Syntax error in OpenMP variable list at %C");
617 : :
618 : 64 : cleanup:
619 : 64 : gfc_free_omp_namelist (head, false, false, false, false);
620 : 64 : gfc_current_locus = old_loc;
621 : 64 : return MATCH_ERROR;
622 : : }
623 : :
624 : : /* Match a variable/procedure/common block list and construct a namelist
625 : : from it. */
626 : :
627 : : static match
628 : 312 : gfc_match_omp_to_link (const char *str, gfc_omp_namelist **list)
629 : : {
630 : 312 : gfc_omp_namelist *head, *tail, *p;
631 : 312 : locus old_loc, cur_loc;
632 : 312 : char n[GFC_MAX_SYMBOL_LEN+1];
633 : 312 : gfc_symbol *sym;
634 : 312 : match m;
635 : 312 : gfc_symtree *st;
636 : :
637 : 312 : head = tail = NULL;
638 : :
639 : 312 : old_loc = gfc_current_locus;
640 : :
641 : 312 : m = gfc_match (str);
642 : 312 : if (m != MATCH_YES)
643 : : return m;
644 : :
645 : 506 : for (;;)
646 : : {
647 : 506 : cur_loc = gfc_current_locus;
648 : 506 : m = gfc_match_symbol (&sym, 1);
649 : 506 : switch (m)
650 : : {
651 : 481 : case MATCH_YES:
652 : 481 : p = gfc_get_omp_namelist ();
653 : 481 : if (head == NULL)
654 : : head = tail = p;
655 : : else
656 : : {
657 : 191 : tail->next = p;
658 : 191 : tail = tail->next;
659 : : }
660 : 481 : tail->sym = sym;
661 : 481 : tail->where = cur_loc;
662 : 481 : goto next_item;
663 : : case MATCH_NO:
664 : : break;
665 : 0 : case MATCH_ERROR:
666 : 0 : goto cleanup;
667 : : }
668 : :
669 : 25 : m = gfc_match (" / %n /", n);
670 : 25 : if (m == MATCH_ERROR)
671 : 0 : goto cleanup;
672 : 25 : if (m == MATCH_NO)
673 : 0 : goto syntax;
674 : :
675 : 25 : st = gfc_find_symtree (gfc_current_ns->common_root, n);
676 : 25 : if (st == NULL)
677 : : {
678 : 0 : gfc_error ("COMMON block /%s/ not found at %C", n);
679 : 0 : goto cleanup;
680 : : }
681 : 25 : p = gfc_get_omp_namelist ();
682 : 25 : if (head == NULL)
683 : : head = tail = p;
684 : : else
685 : : {
686 : 3 : tail->next = p;
687 : 3 : tail = tail->next;
688 : : }
689 : 25 : tail->u.common = st->n.common;
690 : 25 : tail->where = cur_loc;
691 : :
692 : 506 : next_item:
693 : 506 : if (gfc_match_char (')') == MATCH_YES)
694 : : break;
695 : 194 : if (gfc_match_char (',') != MATCH_YES)
696 : 0 : goto syntax;
697 : : }
698 : :
699 : 323 : while (*list)
700 : 11 : list = &(*list)->next;
701 : :
702 : 312 : *list = head;
703 : 312 : return MATCH_YES;
704 : :
705 : 0 : syntax:
706 : 0 : gfc_error ("Syntax error in OpenMP variable list at %C");
707 : :
708 : 0 : cleanup:
709 : 0 : gfc_free_omp_namelist (head, false, false, false, false);
710 : 0 : gfc_current_locus = old_loc;
711 : 0 : return MATCH_ERROR;
712 : : }
713 : :
714 : : /* Match detach(event-handle). */
715 : :
716 : : static match
717 : 126 : gfc_match_omp_detach (gfc_expr **expr)
718 : : {
719 : 126 : locus old_loc = gfc_current_locus;
720 : :
721 : 126 : if (gfc_match ("detach ( ") != MATCH_YES)
722 : 0 : goto syntax_error;
723 : :
724 : 126 : if (gfc_match_variable (expr, 0) != MATCH_YES)
725 : 0 : goto syntax_error;
726 : :
727 : 126 : if (gfc_match_char (')') != MATCH_YES)
728 : 0 : goto syntax_error;
729 : :
730 : : return MATCH_YES;
731 : :
732 : 0 : syntax_error:
733 : 0 : gfc_error ("Syntax error in OpenMP detach clause at %C");
734 : 0 : gfc_current_locus = old_loc;
735 : 0 : return MATCH_ERROR;
736 : :
737 : : }
738 : :
739 : : /* Match doacross(sink : ...) construct a namelist from it;
740 : : if depend is true, match legacy 'depend(sink : ...)'. */
741 : :
742 : : static match
743 : 240 : gfc_match_omp_doacross_sink (gfc_omp_namelist **list, bool depend)
744 : : {
745 : 240 : char n[GFC_MAX_SYMBOL_LEN+1];
746 : 240 : gfc_omp_namelist *head, *tail, *p;
747 : 240 : locus old_loc, cur_loc;
748 : 240 : gfc_symbol *sym;
749 : :
750 : 240 : head = tail = NULL;
751 : :
752 : 240 : old_loc = gfc_current_locus;
753 : :
754 : 2230 : for (;;)
755 : : {
756 : 1235 : gfc_gobble_whitespace ();
757 : 1235 : cur_loc = gfc_current_locus;
758 : :
759 : 1235 : if (gfc_match_name (n) != MATCH_YES)
760 : 1 : goto syntax;
761 : 1234 : locus loc = gfc_get_location_range (NULL, 0, &cur_loc, 1,
762 : : &gfc_current_locus);
763 : 1234 : if (UNLIKELY (strcmp (n, "omp_all_memory") == 0))
764 : : {
765 : 1 : gfc_error ("%<omp_all_memory%> used with dependence-type "
766 : : "other than OUT or INOUT at %L", &loc);
767 : 1 : goto cleanup;
768 : : }
769 : 1233 : sym = NULL;
770 : 1233 : if (!(strcmp (n, "omp_cur_iteration") == 0))
771 : : {
772 : 1228 : gfc_symtree *st;
773 : 1228 : if (gfc_get_ha_sym_tree (n, &st))
774 : 0 : goto syntax;
775 : 1228 : sym = st->n.sym;
776 : 1228 : gfc_set_sym_referenced (sym);
777 : : }
778 : 1233 : p = gfc_get_omp_namelist ();
779 : 1233 : if (head == NULL)
780 : : {
781 : 238 : head = tail = p;
782 : 252 : head->u.depend_doacross_op = (depend ? OMP_DEPEND_SINK_FIRST
783 : : : OMP_DOACROSS_SINK_FIRST);
784 : : }
785 : : else
786 : : {
787 : 995 : tail->next = p;
788 : 995 : tail = tail->next;
789 : 995 : tail->u.depend_doacross_op = OMP_DOACROSS_SINK;
790 : : }
791 : 1233 : tail->sym = sym;
792 : 1233 : tail->expr = NULL;
793 : 1233 : tail->where = loc;
794 : 1233 : if (gfc_match_char ('+') == MATCH_YES)
795 : : {
796 : 154 : if (gfc_match_literal_constant (&tail->expr, 0) != MATCH_YES)
797 : 0 : goto syntax;
798 : : }
799 : 1079 : else if (gfc_match_char ('-') == MATCH_YES)
800 : : {
801 : 418 : if (gfc_match_literal_constant (&tail->expr, 0) != MATCH_YES)
802 : 1 : goto syntax;
803 : 417 : tail->expr = gfc_uminus (tail->expr);
804 : : }
805 : 1232 : if (gfc_match_char (')') == MATCH_YES)
806 : : break;
807 : 995 : if (gfc_match_char (',') != MATCH_YES)
808 : 0 : goto syntax;
809 : 995 : }
810 : :
811 : 1029 : while (*list)
812 : 792 : list = &(*list)->next;
813 : :
814 : 237 : *list = head;
815 : 237 : return MATCH_YES;
816 : :
817 : 2 : syntax:
818 : 2 : gfc_error ("Syntax error in OpenMP SINK dependence-type list at %C");
819 : :
820 : 3 : cleanup:
821 : 3 : gfc_free_omp_namelist (head, false, false, false, false);
822 : 3 : gfc_current_locus = old_loc;
823 : 3 : return MATCH_ERROR;
824 : : }
825 : :
826 : : static match
827 : 819 : match_omp_oacc_expr_list (const char *str, gfc_expr_list **list,
828 : : bool allow_asterisk, bool is_omp)
829 : : {
830 : 819 : gfc_expr_list *head, *tail, *p;
831 : 819 : locus old_loc;
832 : 819 : gfc_expr *expr;
833 : 819 : match m;
834 : :
835 : 819 : head = tail = NULL;
836 : :
837 : 819 : old_loc = gfc_current_locus;
838 : :
839 : 819 : m = gfc_match (str);
840 : 819 : if (m != MATCH_YES)
841 : : return m;
842 : :
843 : 1030 : for (;;)
844 : : {
845 : 1030 : m = gfc_match_expr (&expr);
846 : 1030 : if (m == MATCH_YES || allow_asterisk)
847 : : {
848 : 1018 : p = gfc_get_expr_list ();
849 : 1018 : if (head == NULL)
850 : : head = tail = p;
851 : : else
852 : : {
853 : 335 : tail->next = p;
854 : 335 : tail = tail->next;
855 : : }
856 : 1018 : if (m == MATCH_YES)
857 : 885 : tail->expr = expr;
858 : 133 : else if (gfc_match (" *") != MATCH_YES)
859 : 18 : goto syntax;
860 : 1000 : goto next_item;
861 : : }
862 : 12 : if (m == MATCH_ERROR)
863 : 0 : goto cleanup;
864 : 12 : goto syntax;
865 : :
866 : 1000 : next_item:
867 : 1000 : if (gfc_match_char (')') == MATCH_YES)
868 : : break;
869 : 346 : if (gfc_match_char (',') != MATCH_YES)
870 : 6 : goto syntax;
871 : : }
872 : :
873 : 660 : while (*list)
874 : 6 : list = &(*list)->next;
875 : :
876 : 654 : *list = head;
877 : 654 : return MATCH_YES;
878 : :
879 : 36 : syntax:
880 : 36 : if (is_omp)
881 : 7 : gfc_error ("Syntax error in OpenMP expression list at %C");
882 : : else
883 : 29 : gfc_error ("Syntax error in OpenACC expression list at %C");
884 : :
885 : 36 : cleanup:
886 : 36 : gfc_free_expr_list (head);
887 : 36 : gfc_current_locus = old_loc;
888 : 36 : return MATCH_ERROR;
889 : : }
890 : :
891 : : static match
892 : 3055 : match_oacc_clause_gwv (gfc_omp_clauses *cp, unsigned gwv)
893 : : {
894 : 3055 : match ret = MATCH_YES;
895 : :
896 : 3055 : if (gfc_match (" ( ") != MATCH_YES)
897 : : return MATCH_NO;
898 : :
899 : 470 : if (gwv == GOMP_DIM_GANG)
900 : : {
901 : : /* The gang clause accepts two optional arguments, num and static.
902 : : The num argument may either be explicit (num: <val>) or
903 : : implicit without (<val> without num:). */
904 : :
905 : 457 : while (ret == MATCH_YES)
906 : : {
907 : 236 : if (gfc_match (" static :") == MATCH_YES)
908 : : {
909 : 114 : if (cp->gang_static)
910 : : return MATCH_ERROR;
911 : : else
912 : 113 : cp->gang_static = true;
913 : 113 : if (gfc_match_char ('*') == MATCH_YES)
914 : 18 : cp->gang_static_expr = NULL;
915 : 95 : else if (gfc_match (" %e ", &cp->gang_static_expr) != MATCH_YES)
916 : : return MATCH_ERROR;
917 : : }
918 : : else
919 : : {
920 : 122 : if (cp->gang_num_expr)
921 : : return MATCH_ERROR;
922 : :
923 : : /* The 'num' argument is optional. */
924 : 121 : gfc_match (" num :");
925 : :
926 : 121 : if (gfc_match (" %e ", &cp->gang_num_expr) != MATCH_YES)
927 : : return MATCH_ERROR;
928 : : }
929 : :
930 : 231 : ret = gfc_match (" , ");
931 : : }
932 : : }
933 : 244 : else if (gwv == GOMP_DIM_WORKER)
934 : : {
935 : : /* The 'num' argument is optional. */
936 : 107 : gfc_match (" num :");
937 : :
938 : 107 : if (gfc_match (" %e ", &cp->worker_expr) != MATCH_YES)
939 : : return MATCH_ERROR;
940 : : }
941 : 137 : else if (gwv == GOMP_DIM_VECTOR)
942 : : {
943 : : /* The 'length' argument is optional. */
944 : 137 : gfc_match (" length :");
945 : :
946 : 137 : if (gfc_match (" %e ", &cp->vector_expr) != MATCH_YES)
947 : : return MATCH_ERROR;
948 : : }
949 : : else
950 : 0 : gfc_fatal_error ("Unexpected OpenACC parallelism.");
951 : :
952 : 459 : return gfc_match (" )");
953 : : }
954 : :
955 : : static match
956 : 8 : gfc_match_oacc_clause_link (const char *str, gfc_omp_namelist **list)
957 : : {
958 : 8 : gfc_omp_namelist *head = NULL;
959 : 8 : gfc_omp_namelist *tail, *p;
960 : 8 : locus old_loc;
961 : 8 : char n[GFC_MAX_SYMBOL_LEN+1];
962 : 8 : gfc_symbol *sym;
963 : 8 : match m;
964 : 8 : gfc_symtree *st;
965 : :
966 : 8 : old_loc = gfc_current_locus;
967 : :
968 : 8 : m = gfc_match (str);
969 : 8 : if (m != MATCH_YES)
970 : : return m;
971 : :
972 : 8 : m = gfc_match (" (");
973 : :
974 : 14 : for (;;)
975 : : {
976 : 14 : m = gfc_match_symbol (&sym, 0);
977 : 14 : switch (m)
978 : : {
979 : 8 : case MATCH_YES:
980 : 8 : if (sym->attr.in_common)
981 : : {
982 : 2 : gfc_error_now ("Variable at %C is an element of a COMMON block");
983 : 2 : goto cleanup;
984 : : }
985 : 6 : gfc_set_sym_referenced (sym);
986 : 6 : p = gfc_get_omp_namelist ();
987 : 6 : if (head == NULL)
988 : : head = tail = p;
989 : : else
990 : : {
991 : 4 : tail->next = p;
992 : 4 : tail = tail->next;
993 : : }
994 : 6 : tail->sym = sym;
995 : 6 : tail->expr = NULL;
996 : 6 : tail->where = gfc_current_locus;
997 : 6 : goto next_item;
998 : : case MATCH_NO:
999 : : break;
1000 : :
1001 : 0 : case MATCH_ERROR:
1002 : 0 : goto cleanup;
1003 : : }
1004 : :
1005 : 6 : m = gfc_match (" / %n /", n);
1006 : 6 : if (m == MATCH_ERROR)
1007 : 0 : goto cleanup;
1008 : 6 : if (m == MATCH_NO || n[0] == '\0')
1009 : 0 : goto syntax;
1010 : :
1011 : 6 : st = gfc_find_symtree (gfc_current_ns->common_root, n);
1012 : 6 : if (st == NULL)
1013 : : {
1014 : 1 : gfc_error ("COMMON block /%s/ not found at %C", n);
1015 : 1 : goto cleanup;
1016 : : }
1017 : :
1018 : 20 : for (sym = st->n.common->head; sym; sym = sym->common_next)
1019 : : {
1020 : 15 : gfc_set_sym_referenced (sym);
1021 : 15 : p = gfc_get_omp_namelist ();
1022 : 15 : if (head == NULL)
1023 : : head = tail = p;
1024 : : else
1025 : : {
1026 : 12 : tail->next = p;
1027 : 12 : tail = tail->next;
1028 : : }
1029 : 15 : tail->sym = sym;
1030 : 15 : tail->where = gfc_current_locus;
1031 : : }
1032 : :
1033 : 5 : next_item:
1034 : 11 : if (gfc_match_char (')') == MATCH_YES)
1035 : : break;
1036 : 6 : if (gfc_match_char (',') != MATCH_YES)
1037 : 0 : goto syntax;
1038 : : }
1039 : :
1040 : 5 : if (gfc_match_omp_eos () != MATCH_YES)
1041 : : {
1042 : 1 : gfc_error ("Unexpected junk after !$ACC DECLARE at %C");
1043 : 1 : goto cleanup;
1044 : : }
1045 : :
1046 : 4 : while (*list)
1047 : 0 : list = &(*list)->next;
1048 : 4 : *list = head;
1049 : 4 : return MATCH_YES;
1050 : :
1051 : 0 : syntax:
1052 : 0 : gfc_error ("Syntax error in !$ACC DECLARE list at %C");
1053 : :
1054 : 4 : cleanup:
1055 : 4 : gfc_current_locus = old_loc;
1056 : 4 : return MATCH_ERROR;
1057 : : }
1058 : :
1059 : : /* OpenMP clauses. */
1060 : : enum omp_mask1
1061 : : {
1062 : : OMP_CLAUSE_PRIVATE,
1063 : : OMP_CLAUSE_FIRSTPRIVATE,
1064 : : OMP_CLAUSE_LASTPRIVATE,
1065 : : OMP_CLAUSE_COPYPRIVATE,
1066 : : OMP_CLAUSE_SHARED,
1067 : : OMP_CLAUSE_COPYIN,
1068 : : OMP_CLAUSE_REDUCTION,
1069 : : OMP_CLAUSE_IN_REDUCTION,
1070 : : OMP_CLAUSE_TASK_REDUCTION,
1071 : : OMP_CLAUSE_IF,
1072 : : OMP_CLAUSE_NUM_THREADS,
1073 : : OMP_CLAUSE_SCHEDULE,
1074 : : OMP_CLAUSE_DEFAULT,
1075 : : OMP_CLAUSE_ORDER,
1076 : : OMP_CLAUSE_ORDERED,
1077 : : OMP_CLAUSE_COLLAPSE,
1078 : : OMP_CLAUSE_UNTIED,
1079 : : OMP_CLAUSE_FINAL,
1080 : : OMP_CLAUSE_MERGEABLE,
1081 : : OMP_CLAUSE_ALIGNED,
1082 : : OMP_CLAUSE_DEPEND,
1083 : : OMP_CLAUSE_INBRANCH,
1084 : : OMP_CLAUSE_LINEAR,
1085 : : OMP_CLAUSE_NOTINBRANCH,
1086 : : OMP_CLAUSE_PROC_BIND,
1087 : : OMP_CLAUSE_SAFELEN,
1088 : : OMP_CLAUSE_SIMDLEN,
1089 : : OMP_CLAUSE_UNIFORM,
1090 : : OMP_CLAUSE_DEVICE,
1091 : : OMP_CLAUSE_MAP,
1092 : : OMP_CLAUSE_TO,
1093 : : OMP_CLAUSE_FROM,
1094 : : OMP_CLAUSE_NUM_TEAMS,
1095 : : OMP_CLAUSE_THREAD_LIMIT,
1096 : : OMP_CLAUSE_DIST_SCHEDULE,
1097 : : OMP_CLAUSE_DEFAULTMAP,
1098 : : OMP_CLAUSE_GRAINSIZE,
1099 : : OMP_CLAUSE_HINT,
1100 : : OMP_CLAUSE_IS_DEVICE_PTR,
1101 : : OMP_CLAUSE_LINK,
1102 : : OMP_CLAUSE_NOGROUP,
1103 : : OMP_CLAUSE_NOTEMPORAL,
1104 : : OMP_CLAUSE_NUM_TASKS,
1105 : : OMP_CLAUSE_PRIORITY,
1106 : : OMP_CLAUSE_SIMD,
1107 : : OMP_CLAUSE_THREADS,
1108 : : OMP_CLAUSE_USE_DEVICE_PTR,
1109 : : OMP_CLAUSE_USE_DEVICE_ADDR, /* OpenMP 5.0. */
1110 : : OMP_CLAUSE_DEVICE_TYPE, /* OpenMP 5.0. */
1111 : : OMP_CLAUSE_ATOMIC, /* OpenMP 5.0. */
1112 : : OMP_CLAUSE_CAPTURE, /* OpenMP 5.0. */
1113 : : OMP_CLAUSE_MEMORDER, /* OpenMP 5.0. */
1114 : : OMP_CLAUSE_DETACH, /* OpenMP 5.0. */
1115 : : OMP_CLAUSE_AFFINITY, /* OpenMP 5.0. */
1116 : : OMP_CLAUSE_ALLOCATE, /* OpenMP 5.0. */
1117 : : OMP_CLAUSE_BIND, /* OpenMP 5.0. */
1118 : : OMP_CLAUSE_FILTER, /* OpenMP 5.1. */
1119 : : OMP_CLAUSE_AT, /* OpenMP 5.1. */
1120 : : OMP_CLAUSE_MESSAGE, /* OpenMP 5.1. */
1121 : : OMP_CLAUSE_SEVERITY, /* OpenMP 5.1. */
1122 : : OMP_CLAUSE_COMPARE, /* OpenMP 5.1. */
1123 : : OMP_CLAUSE_FAIL, /* OpenMP 5.1. */
1124 : : OMP_CLAUSE_WEAK, /* OpenMP 5.1. */
1125 : : OMP_CLAUSE_NOWAIT,
1126 : : /* This must come last. */
1127 : : OMP_MASK1_LAST
1128 : : };
1129 : :
1130 : : /* More OpenMP clauses and OpenACC 2.0+ specific clauses. */
1131 : : enum omp_mask2
1132 : : {
1133 : : OMP_CLAUSE_ASYNC,
1134 : : OMP_CLAUSE_NUM_GANGS,
1135 : : OMP_CLAUSE_NUM_WORKERS,
1136 : : OMP_CLAUSE_VECTOR_LENGTH,
1137 : : OMP_CLAUSE_COPY,
1138 : : OMP_CLAUSE_COPYOUT,
1139 : : OMP_CLAUSE_CREATE,
1140 : : OMP_CLAUSE_NO_CREATE,
1141 : : OMP_CLAUSE_PRESENT,
1142 : : OMP_CLAUSE_DEVICEPTR,
1143 : : OMP_CLAUSE_GANG,
1144 : : OMP_CLAUSE_WORKER,
1145 : : OMP_CLAUSE_VECTOR,
1146 : : OMP_CLAUSE_SEQ,
1147 : : OMP_CLAUSE_INDEPENDENT,
1148 : : OMP_CLAUSE_USE_DEVICE,
1149 : : OMP_CLAUSE_DEVICE_RESIDENT,
1150 : : OMP_CLAUSE_SELF,
1151 : : OMP_CLAUSE_HOST,
1152 : : OMP_CLAUSE_WAIT,
1153 : : OMP_CLAUSE_DELETE,
1154 : : OMP_CLAUSE_AUTO,
1155 : : OMP_CLAUSE_TILE,
1156 : : OMP_CLAUSE_IF_PRESENT,
1157 : : OMP_CLAUSE_FINALIZE,
1158 : : OMP_CLAUSE_ATTACH,
1159 : : OMP_CLAUSE_NOHOST,
1160 : : OMP_CLAUSE_HAS_DEVICE_ADDR, /* OpenMP 5.1 */
1161 : : OMP_CLAUSE_ENTER, /* OpenMP 5.2 */
1162 : : OMP_CLAUSE_DOACROSS, /* OpenMP 5.2 */
1163 : : OMP_CLAUSE_ASSUMPTIONS, /* OpenMP 5.1. */
1164 : : OMP_CLAUSE_USES_ALLOCATORS, /* OpenMP 5.0 */
1165 : : OMP_CLAUSE_INDIRECT, /* OpenMP 5.1 */
1166 : : OMP_CLAUSE_FULL, /* OpenMP 5.1. */
1167 : : OMP_CLAUSE_PARTIAL, /* OpenMP 5.1. */
1168 : : OMP_CLAUSE_SIZES, /* OpenMP 5.1. */
1169 : : OMP_CLAUSE_INIT, /* OpenMP 5.1. */
1170 : : OMP_CLAUSE_DESTROY, /* OpenMP 5.1. */
1171 : : OMP_CLAUSE_USE, /* OpenMP 5.1. */
1172 : : OMP_CLAUSE_NOVARIANTS, /* OpenMP 5.1 */
1173 : : OMP_CLAUSE_NOCONTEXT, /* OpenMP 5.1 */
1174 : : OMP_CLAUSE_INTEROP, /* OpenMP 5.1 */
1175 : : /* This must come last. */
1176 : : OMP_MASK2_LAST
1177 : : };
1178 : :
1179 : : struct omp_inv_mask;
1180 : :
1181 : : /* Customized bitset for up to 128-bits.
1182 : : The two enums above provide bit numbers to use, and which of the
1183 : : two enums it is determines which of the two mask fields is used.
1184 : : Supported operations are defining a mask, like:
1185 : : #define XXX_CLAUSES \
1186 : : (omp_mask (OMP_CLAUSE_XXX) | OMP_CLAUSE_YYY | OMP_CLAUSE_ZZZ)
1187 : : oring such bitsets together or removing selected bits:
1188 : : (XXX_CLAUSES | YYY_CLAUSES) & ~(omp_mask (OMP_CLAUSE_VVV))
1189 : : and testing individual bits:
1190 : : if (mask & OMP_CLAUSE_UUU) */
1191 : :
1192 : : struct omp_mask {
1193 : : const uint64_t mask1;
1194 : : const uint64_t mask2;
1195 : : inline omp_mask ();
1196 : : inline omp_mask (omp_mask1);
1197 : : inline omp_mask (omp_mask2);
1198 : : inline omp_mask (uint64_t, uint64_t);
1199 : : inline omp_mask operator| (omp_mask1) const;
1200 : : inline omp_mask operator| (omp_mask2) const;
1201 : : inline omp_mask operator| (omp_mask) const;
1202 : : inline omp_mask operator& (const omp_inv_mask &) const;
1203 : : inline bool operator& (omp_mask1) const;
1204 : : inline bool operator& (omp_mask2) const;
1205 : : inline omp_inv_mask operator~ () const;
1206 : : };
1207 : :
1208 : : struct omp_inv_mask : public omp_mask {
1209 : : inline omp_inv_mask (const omp_mask &);
1210 : : };
1211 : :
1212 : : omp_mask::omp_mask () : mask1 (0), mask2 (0)
1213 : : {
1214 : : }
1215 : :
1216 : 31602 : omp_mask::omp_mask (omp_mask1 m) : mask1 (((uint64_t) 1) << m), mask2 (0)
1217 : : {
1218 : : }
1219 : :
1220 : 2173 : omp_mask::omp_mask (omp_mask2 m) : mask1 (0), mask2 (((uint64_t) 1) << m)
1221 : : {
1222 : : }
1223 : :
1224 : 32521 : omp_mask::omp_mask (uint64_t m1, uint64_t m2) : mask1 (m1), mask2 (m2)
1225 : : {
1226 : : }
1227 : :
1228 : : omp_mask
1229 : 31570 : omp_mask::operator| (omp_mask1 m) const
1230 : : {
1231 : 31570 : return omp_mask (mask1 | (((uint64_t) 1) << m), mask2);
1232 : : }
1233 : :
1234 : : omp_mask
1235 : 16429 : omp_mask::operator| (omp_mask2 m) const
1236 : : {
1237 : 16429 : return omp_mask (mask1, mask2 | (((uint64_t) 1) << m));
1238 : : }
1239 : :
1240 : : omp_mask
1241 : 4347 : omp_mask::operator| (omp_mask m) const
1242 : : {
1243 : 4347 : return omp_mask (mask1 | m.mask1, mask2 | m.mask2);
1244 : : }
1245 : :
1246 : : omp_mask
1247 : 2008 : omp_mask::operator& (const omp_inv_mask &m) const
1248 : : {
1249 : 2008 : return omp_mask (mask1 & ~m.mask1, mask2 & ~m.mask2);
1250 : : }
1251 : :
1252 : : bool
1253 : 122965 : omp_mask::operator& (omp_mask1 m) const
1254 : : {
1255 : 122965 : return (mask1 & (((uint64_t) 1) << m)) != 0;
1256 : : }
1257 : :
1258 : : bool
1259 : 86175 : omp_mask::operator& (omp_mask2 m) const
1260 : : {
1261 : 86175 : return (mask2 & (((uint64_t) 1) << m)) != 0;
1262 : : }
1263 : :
1264 : : omp_inv_mask
1265 : 2008 : omp_mask::operator~ () const
1266 : : {
1267 : 2008 : return omp_inv_mask (*this);
1268 : : }
1269 : :
1270 : 2008 : omp_inv_mask::omp_inv_mask (const omp_mask &m) : omp_mask (m)
1271 : : {
1272 : : }
1273 : :
1274 : : /* Helper function for OpenACC and OpenMP clauses involving memory
1275 : : mapping. */
1276 : :
1277 : : static bool
1278 : 5539 : gfc_match_omp_map_clause (gfc_omp_namelist **list, gfc_omp_map_op map_op,
1279 : : bool allow_common, bool allow_derived)
1280 : : {
1281 : 5539 : gfc_omp_namelist **head = NULL;
1282 : 5539 : if (gfc_match_omp_variable_list ("", list, allow_common, NULL, &head, true,
1283 : : allow_derived)
1284 : : == MATCH_YES)
1285 : : {
1286 : 5530 : gfc_omp_namelist *n;
1287 : 13395 : for (n = *head; n; n = n->next)
1288 : 7865 : n->u.map.op = map_op;
1289 : : return true;
1290 : : }
1291 : :
1292 : : return false;
1293 : : }
1294 : :
1295 : : static match
1296 : 1109 : gfc_match_iterator (gfc_namespace **ns, bool permit_var)
1297 : : {
1298 : 1109 : locus old_loc = gfc_current_locus;
1299 : :
1300 : 1109 : if (gfc_match ("iterator ( ") != MATCH_YES)
1301 : : return MATCH_NO;
1302 : :
1303 : 77 : gfc_typespec ts;
1304 : 77 : gfc_symbol *last = NULL;
1305 : 77 : gfc_expr *begin, *end, *step;
1306 : 77 : *ns = gfc_build_block_ns (gfc_current_ns);
1307 : 83 : char name[GFC_MAX_SYMBOL_LEN + 1];
1308 : 89 : while (true)
1309 : : {
1310 : 83 : locus prev_loc = gfc_current_locus;
1311 : 83 : if (gfc_match_type_spec (&ts) == MATCH_YES
1312 : 83 : && gfc_match (" :: ") == MATCH_YES)
1313 : : {
1314 : 5 : if (ts.type != BT_INTEGER)
1315 : : {
1316 : 2 : gfc_error ("Expected INTEGER type at %L", &prev_loc);
1317 : 5 : return MATCH_ERROR;
1318 : : }
1319 : : permit_var = false;
1320 : : }
1321 : : else
1322 : : {
1323 : 78 : ts.type = BT_INTEGER;
1324 : 78 : ts.kind = gfc_default_integer_kind;
1325 : 78 : gfc_current_locus = prev_loc;
1326 : : }
1327 : 81 : prev_loc = gfc_current_locus;
1328 : 81 : if (gfc_match_name (name) != MATCH_YES)
1329 : : {
1330 : 4 : gfc_error ("Expected identifier at %C");
1331 : 4 : goto failed;
1332 : : }
1333 : 77 : if (gfc_find_symtree ((*ns)->sym_root, name))
1334 : : {
1335 : 2 : gfc_error ("Same identifier %qs specified again at %C", name);
1336 : 2 : goto failed;
1337 : : }
1338 : :
1339 : 75 : gfc_symbol *sym = gfc_new_symbol (name, *ns);
1340 : 75 : if (last)
1341 : 4 : last->tlink = sym;
1342 : : else
1343 : 71 : (*ns)->omp_affinity_iterators = sym;
1344 : 75 : last = sym;
1345 : 75 : sym->declared_at = prev_loc;
1346 : 75 : sym->ts = ts;
1347 : 75 : sym->attr.flavor = FL_VARIABLE;
1348 : 75 : sym->attr.artificial = 1;
1349 : 75 : sym->attr.referenced = 1;
1350 : 75 : sym->refs++;
1351 : 75 : gfc_symtree *st = gfc_new_symtree (&(*ns)->sym_root, name);
1352 : 75 : st->n.sym = sym;
1353 : :
1354 : 75 : prev_loc = gfc_current_locus;
1355 : 75 : if (gfc_match (" = ") != MATCH_YES)
1356 : 3 : goto failed;
1357 : 72 : permit_var = false;
1358 : 72 : begin = end = step = NULL;
1359 : 72 : if (gfc_match ("%e : ", &begin) != MATCH_YES
1360 : 72 : || gfc_match ("%e ", &end) != MATCH_YES)
1361 : : {
1362 : 3 : gfc_error ("Expected range-specification at %C");
1363 : 3 : gfc_free_expr (begin);
1364 : 3 : gfc_free_expr (end);
1365 : 3 : return MATCH_ERROR;
1366 : : }
1367 : 69 : if (':' == gfc_peek_ascii_char ())
1368 : : {
1369 : 23 : if (gfc_match (": %e ", &step) != MATCH_YES)
1370 : : {
1371 : 5 : gfc_free_expr (begin);
1372 : 5 : gfc_free_expr (end);
1373 : 5 : gfc_free_expr (step);
1374 : 5 : goto failed;
1375 : : }
1376 : : }
1377 : :
1378 : 64 : gfc_expr *e = gfc_get_expr ();
1379 : 64 : e->where = prev_loc;
1380 : 64 : e->expr_type = EXPR_ARRAY;
1381 : 64 : e->ts = ts;
1382 : 64 : e->rank = 1;
1383 : 64 : e->shape = gfc_get_shape (1);
1384 : 110 : mpz_init_set_ui (e->shape[0], step ? 3 : 2);
1385 : 64 : gfc_constructor_append_expr (&e->value.constructor, begin, &begin->where);
1386 : 64 : gfc_constructor_append_expr (&e->value.constructor, end, &end->where);
1387 : 64 : if (step)
1388 : 18 : gfc_constructor_append_expr (&e->value.constructor, step, &step->where);
1389 : 64 : sym->value = e;
1390 : :
1391 : 64 : if (gfc_match (") ") == MATCH_YES)
1392 : : break;
1393 : 6 : if (gfc_match (", ") != MATCH_YES)
1394 : 0 : goto failed;
1395 : 6 : }
1396 : 58 : return MATCH_YES;
1397 : :
1398 : 14 : failed:
1399 : 14 : gfc_namespace *prev_ns = NULL;
1400 : 14 : for (gfc_namespace *it = gfc_current_ns->contained; it; it = it->sibling)
1401 : : {
1402 : 0 : if (it == *ns)
1403 : : {
1404 : 0 : if (prev_ns)
1405 : 0 : prev_ns->sibling = it->sibling;
1406 : : else
1407 : 0 : gfc_current_ns->contained = it->sibling;
1408 : 0 : gfc_free_namespace (it);
1409 : 0 : break;
1410 : : }
1411 : 0 : prev_ns = it;
1412 : : }
1413 : 14 : *ns = NULL;
1414 : 14 : if (!permit_var)
1415 : : return MATCH_ERROR;
1416 : 4 : gfc_current_locus = old_loc;
1417 : 4 : return MATCH_NO;
1418 : : }
1419 : :
1420 : : /* Match target update's to/from( [present:] var-list). */
1421 : :
1422 : : static match
1423 : 1715 : gfc_match_motion_var_list (const char *str, gfc_omp_namelist **list,
1424 : : gfc_omp_namelist ***headp)
1425 : : {
1426 : 1715 : match m = gfc_match (str);
1427 : 1715 : if (m != MATCH_YES)
1428 : : return m;
1429 : :
1430 : 1715 : match m_present = gfc_match (" present : ");
1431 : :
1432 : 1715 : m = gfc_match_omp_variable_list ("", list, false, NULL, headp, true, true);
1433 : 1715 : if (m != MATCH_YES)
1434 : : return m;
1435 : 1715 : if (m_present == MATCH_YES)
1436 : : {
1437 : 5 : gfc_omp_namelist *n;
1438 : 10 : for (n = **headp; n; n = n->next)
1439 : 5 : n->u.present_modifier = true;
1440 : : }
1441 : : return MATCH_YES;
1442 : : }
1443 : :
1444 : : /* reduction ( reduction-modifier, reduction-operator : variable-list )
1445 : : in_reduction ( reduction-operator : variable-list )
1446 : : task_reduction ( reduction-operator : variable-list ) */
1447 : :
1448 : : static match
1449 : 4355 : gfc_match_omp_clause_reduction (char pc, gfc_omp_clauses *c, bool openacc,
1450 : : bool allow_derived, bool openmp_target = false)
1451 : : {
1452 : 4355 : if (pc == 'r' && gfc_match ("reduction ( ") != MATCH_YES)
1453 : : return MATCH_NO;
1454 : 4355 : else if (pc == 'i' && gfc_match ("in_reduction ( ") != MATCH_YES)
1455 : : return MATCH_NO;
1456 : 4243 : else if (pc == 't' && gfc_match ("task_reduction ( ") != MATCH_YES)
1457 : : return MATCH_NO;
1458 : :
1459 : 4243 : locus old_loc = gfc_current_locus;
1460 : 4243 : int list_idx = 0;
1461 : :
1462 : 4243 : if (pc == 'r' && !openacc)
1463 : : {
1464 : 2116 : if (gfc_match ("inscan") == MATCH_YES)
1465 : : list_idx = OMP_LIST_REDUCTION_INSCAN;
1466 : 2046 : else if (gfc_match ("task") == MATCH_YES)
1467 : : list_idx = OMP_LIST_REDUCTION_TASK;
1468 : 1942 : else if (gfc_match ("default") == MATCH_YES)
1469 : : list_idx = OMP_LIST_REDUCTION;
1470 : 230 : if (list_idx != 0 && gfc_match (", ") != MATCH_YES)
1471 : : {
1472 : 1 : gfc_error ("Comma expected at %C");
1473 : 1 : gfc_current_locus = old_loc;
1474 : 1 : return MATCH_NO;
1475 : : }
1476 : 2115 : if (list_idx == 0)
1477 : 3830 : list_idx = OMP_LIST_REDUCTION;
1478 : : }
1479 : 2127 : else if (pc == 'i')
1480 : : list_idx = OMP_LIST_IN_REDUCTION;
1481 : 2009 : else if (pc == 't')
1482 : : list_idx = OMP_LIST_TASK_REDUCTION;
1483 : : else
1484 : 3830 : list_idx = OMP_LIST_REDUCTION;
1485 : :
1486 : 4242 : gfc_omp_reduction_op rop = OMP_REDUCTION_NONE;
1487 : 4242 : char buffer[GFC_MAX_SYMBOL_LEN + 3];
1488 : 4242 : if (gfc_match_char ('+') == MATCH_YES)
1489 : : rop = OMP_REDUCTION_PLUS;
1490 : 2222 : else if (gfc_match_char ('*') == MATCH_YES)
1491 : : rop = OMP_REDUCTION_TIMES;
1492 : 1990 : else if (gfc_match_char ('-') == MATCH_YES)
1493 : : rop = OMP_REDUCTION_MINUS;
1494 : 1820 : else if (gfc_match (".and.") == MATCH_YES)
1495 : : rop = OMP_REDUCTION_AND;
1496 : 1714 : else if (gfc_match (".or.") == MATCH_YES)
1497 : : rop = OMP_REDUCTION_OR;
1498 : 929 : else if (gfc_match (".eqv.") == MATCH_YES)
1499 : : rop = OMP_REDUCTION_EQV;
1500 : 831 : else if (gfc_match (".neqv.") == MATCH_YES)
1501 : : rop = OMP_REDUCTION_NEQV;
1502 : 736 : if (rop != OMP_REDUCTION_NONE)
1503 : 3506 : snprintf (buffer, sizeof buffer, "operator %s",
1504 : : gfc_op2string ((gfc_intrinsic_op) rop));
1505 : 736 : else if (gfc_match_defined_op_name (buffer + 1, 1) == MATCH_YES)
1506 : : {
1507 : 38 : buffer[0] = '.';
1508 : 38 : strcat (buffer, ".");
1509 : : }
1510 : 698 : else if (gfc_match_name (buffer) == MATCH_YES)
1511 : : {
1512 : 697 : gfc_symbol *sym;
1513 : 697 : const char *n = buffer;
1514 : :
1515 : 697 : gfc_find_symbol (buffer, NULL, 1, &sym);
1516 : 697 : if (sym != NULL)
1517 : : {
1518 : 216 : if (sym->attr.intrinsic)
1519 : 139 : n = sym->name;
1520 : 77 : else if ((sym->attr.flavor != FL_UNKNOWN
1521 : 75 : && sym->attr.flavor != FL_PROCEDURE)
1522 : 75 : || sym->attr.external
1523 : 64 : || sym->attr.generic
1524 : 64 : || sym->attr.entry
1525 : 64 : || sym->attr.result
1526 : 64 : || sym->attr.dummy
1527 : 64 : || sym->attr.subroutine
1528 : 63 : || sym->attr.pointer
1529 : 63 : || sym->attr.target
1530 : 63 : || sym->attr.cray_pointer
1531 : 63 : || sym->attr.cray_pointee
1532 : 63 : || (sym->attr.proc != PROC_UNKNOWN
1533 : 1 : && sym->attr.proc != PROC_INTRINSIC)
1534 : 62 : || sym->attr.if_source != IFSRC_UNKNOWN
1535 : 62 : || sym == sym->ns->proc_name)
1536 : : {
1537 : : sym = NULL;
1538 : : n = NULL;
1539 : : }
1540 : : else
1541 : 62 : n = sym->name;
1542 : : }
1543 : 201 : if (n == NULL)
1544 : : rop = OMP_REDUCTION_NONE;
1545 : 682 : else if (strcmp (n, "max") == 0)
1546 : : rop = OMP_REDUCTION_MAX;
1547 : 517 : else if (strcmp (n, "min") == 0)
1548 : : rop = OMP_REDUCTION_MIN;
1549 : 376 : else if (strcmp (n, "iand") == 0)
1550 : : rop = OMP_REDUCTION_IAND;
1551 : 321 : else if (strcmp (n, "ior") == 0)
1552 : : rop = OMP_REDUCTION_IOR;
1553 : 255 : else if (strcmp (n, "ieor") == 0)
1554 : : rop = OMP_REDUCTION_IEOR;
1555 : : if (rop != OMP_REDUCTION_NONE
1556 : 477 : && sym != NULL
1557 : 200 : && ! sym->attr.intrinsic
1558 : 61 : && ! sym->attr.use_assoc
1559 : 61 : && ((sym->attr.flavor == FL_UNKNOWN
1560 : 2 : && !gfc_add_flavor (&sym->attr, FL_PROCEDURE,
1561 : : sym->name, NULL))
1562 : 61 : || !gfc_add_intrinsic (&sym->attr, NULL)))
1563 : : rop = OMP_REDUCTION_NONE;
1564 : : }
1565 : : else
1566 : 1 : buffer[0] = '\0';
1567 : 4242 : gfc_omp_udr *udr = (buffer[0] ? gfc_find_omp_udr (gfc_current_ns, buffer, NULL)
1568 : : : NULL);
1569 : 4242 : gfc_omp_namelist **head = NULL;
1570 : 4242 : if (rop == OMP_REDUCTION_NONE && udr)
1571 : 250 : rop = OMP_REDUCTION_USER;
1572 : :
1573 : 4242 : if (gfc_match_omp_variable_list (" :", &c->lists[list_idx], false, NULL,
1574 : : &head, openacc, allow_derived) != MATCH_YES)
1575 : : {
1576 : 9 : gfc_current_locus = old_loc;
1577 : 9 : return MATCH_NO;
1578 : : }
1579 : 4233 : gfc_omp_namelist *n;
1580 : 4233 : if (rop == OMP_REDUCTION_NONE)
1581 : : {
1582 : 6 : n = *head;
1583 : 6 : *head = NULL;
1584 : 6 : gfc_error_now ("!$OMP DECLARE REDUCTION %s not found at %L",
1585 : : buffer, &old_loc);
1586 : 6 : gfc_free_omp_namelist (n, false, false, false, false);
1587 : : }
1588 : : else
1589 : 9106 : for (n = *head; n; n = n->next)
1590 : : {
1591 : 4879 : n->u.reduction_op = rop;
1592 : 4879 : if (udr)
1593 : : {
1594 : 473 : n->u2.udr = gfc_get_omp_namelist_udr ();
1595 : 473 : n->u2.udr->udr = udr;
1596 : : }
1597 : 4879 : if (openmp_target && list_idx == OMP_LIST_IN_REDUCTION)
1598 : : {
1599 : 40 : gfc_omp_namelist *p = gfc_get_omp_namelist (), **tl;
1600 : 40 : p->sym = n->sym;
1601 : 40 : p->where = n->where;
1602 : 40 : p->u.map.op = OMP_MAP_ALWAYS_TOFROM;
1603 : :
1604 : 40 : tl = &c->lists[OMP_LIST_MAP];
1605 : 52 : while (*tl)
1606 : 12 : tl = &((*tl)->next);
1607 : 40 : *tl = p;
1608 : 40 : p->next = NULL;
1609 : : }
1610 : : }
1611 : : return MATCH_YES;
1612 : : }
1613 : :
1614 : : static match
1615 : 39 : gfc_omp_absent_contains_clause (gfc_omp_assumptions **assume, bool is_absent)
1616 : : {
1617 : 39 : if (*assume == NULL)
1618 : 14 : *assume = gfc_get_omp_assumptions ();
1619 : 61 : do
1620 : : {
1621 : 50 : gfc_statement st = ST_NONE;
1622 : 50 : gfc_gobble_whitespace ();
1623 : 50 : locus old_loc = gfc_current_locus;
1624 : 50 : char c = gfc_peek_ascii_char ();
1625 : 50 : enum gfc_omp_directive_kind kind
1626 : : = GFC_OMP_DIR_DECLARATIVE; /* Silence warning. */
1627 : 1490 : for (size_t i = 0; i < ARRAY_SIZE (gfc_omp_directives); i++)
1628 : : {
1629 : 1490 : if (gfc_omp_directives[i].name[0] > c)
1630 : : break;
1631 : 1440 : if (gfc_omp_directives[i].name[0] != c)
1632 : 1101 : continue;
1633 : 339 : if (gfc_match (gfc_omp_directives[i].name) == MATCH_YES)
1634 : : {
1635 : 50 : st = gfc_omp_directives[i].st;
1636 : 50 : kind = gfc_omp_directives[i].kind;
1637 : : }
1638 : : }
1639 : 50 : gfc_gobble_whitespace ();
1640 : 50 : c = gfc_peek_ascii_char ();
1641 : 50 : if (st == ST_NONE || (c != ',' && c != ')'))
1642 : : {
1643 : 0 : if (st == ST_NONE)
1644 : 0 : gfc_error ("Unknown directive at %L", &old_loc);
1645 : : else
1646 : 0 : gfc_error ("Invalid combined or composite directive at %L",
1647 : : &old_loc);
1648 : 3 : return MATCH_ERROR;
1649 : : }
1650 : 50 : if (kind == GFC_OMP_DIR_DECLARATIVE
1651 : 50 : || kind == GFC_OMP_DIR_INFORMATIONAL
1652 : : || kind == GFC_OMP_DIR_META)
1653 : : {
1654 : 3 : gfc_error ("Invalid %qs directive at %L in %s clause: declarative, "
1655 : : "informational, and meta directives not permitted",
1656 : : gfc_ascii_statement (st, true), &old_loc,
1657 : : is_absent ? "ABSENT" : "CONTAINS");
1658 : 3 : return MATCH_ERROR;
1659 : : }
1660 : 47 : if (is_absent)
1661 : : {
1662 : : /* Use exponential allocation; equivalent to pow2p(x). */
1663 : 33 : int i = (*assume)->n_absent;
1664 : 33 : int size = ((i == 0) ? 4
1665 : 10 : : pow2p_hwi (i) == 1 ? i*2 : 0);
1666 : 8 : if (size != 0)
1667 : 31 : (*assume)->absent = XRESIZEVEC (gfc_statement,
1668 : : (*assume)->absent, size);
1669 : 33 : (*assume)->absent[(*assume)->n_absent++] = st;
1670 : : }
1671 : : else
1672 : : {
1673 : 14 : int i = (*assume)->n_contains;
1674 : 14 : int size = ((i == 0) ? 4
1675 : 4 : : pow2p_hwi (i) == 1 ? i*2 : 0);
1676 : 4 : if (size != 0)
1677 : 14 : (*assume)->contains = XRESIZEVEC (gfc_statement,
1678 : : (*assume)->contains, size);
1679 : 14 : (*assume)->contains[(*assume)->n_contains++] = st;
1680 : : }
1681 : 47 : gfc_gobble_whitespace ();
1682 : 47 : if (gfc_match(",") == MATCH_YES)
1683 : 11 : continue;
1684 : 36 : if (gfc_match(")") == MATCH_YES)
1685 : : break;
1686 : 0 : gfc_error ("Expected %<,%> or %<)%> at %C");
1687 : 0 : return MATCH_ERROR;
1688 : : }
1689 : : while (true);
1690 : :
1691 : 36 : return MATCH_YES;
1692 : : }
1693 : :
1694 : : /* Check 'check' argument for duplicated statements in absent and/or contains
1695 : : clauses. If 'merge', merge them from check to 'merge'. */
1696 : :
1697 : : static match
1698 : 43 : omp_verify_merge_absent_contains (gfc_statement st, gfc_omp_assumptions *check,
1699 : : gfc_omp_assumptions *merge, locus *loc)
1700 : : {
1701 : 43 : if (check == NULL)
1702 : : return MATCH_YES;
1703 : 43 : bitmap_head absent_head, contains_head;
1704 : 43 : bitmap_obstack_initialize (NULL);
1705 : 43 : bitmap_initialize (&absent_head, &bitmap_default_obstack);
1706 : 43 : bitmap_initialize (&contains_head, &bitmap_default_obstack);
1707 : :
1708 : 43 : match m = MATCH_YES;
1709 : 76 : for (int i = 0; i < check->n_absent; i++)
1710 : 33 : if (!bitmap_set_bit (&absent_head, check->absent[i]))
1711 : : {
1712 : 2 : gfc_error ("%qs directive mentioned multiple times in %s clause in %s "
1713 : : "directive at %L",
1714 : 2 : gfc_ascii_statement (check->absent[i], true),
1715 : : "ABSENT", gfc_ascii_statement (st), loc);
1716 : 2 : m = MATCH_ERROR;
1717 : : }
1718 : 57 : for (int i = 0; i < check->n_contains; i++)
1719 : : {
1720 : 14 : if (!bitmap_set_bit (&contains_head, check->contains[i]))
1721 : : {
1722 : 2 : gfc_error ("%qs directive mentioned multiple times in %s clause in %s "
1723 : : "directive at %L",
1724 : 2 : gfc_ascii_statement (check->contains[i], true),
1725 : : "CONTAINS", gfc_ascii_statement (st), loc);
1726 : 2 : m = MATCH_ERROR;
1727 : : }
1728 : 14 : if (bitmap_bit_p (&absent_head, check->contains[i]))
1729 : : {
1730 : 2 : gfc_error ("%qs directive mentioned both times in ABSENT and CONTAINS "
1731 : : "clauses in %s directive at %L",
1732 : 2 : gfc_ascii_statement (check->absent[i], true),
1733 : : gfc_ascii_statement (st), loc);
1734 : 2 : m = MATCH_ERROR;
1735 : : }
1736 : : }
1737 : :
1738 : 43 : if (m == MATCH_ERROR)
1739 : : return MATCH_ERROR;
1740 : 37 : if (merge == NULL)
1741 : : return MATCH_YES;
1742 : 2 : if (merge->absent == NULL && check->absent)
1743 : : {
1744 : 1 : merge->n_absent = check->n_absent;
1745 : 1 : merge->absent = check->absent;
1746 : 1 : check->absent = NULL;
1747 : : }
1748 : 1 : else if (merge->absent && check->absent)
1749 : : {
1750 : 0 : check->absent = XRESIZEVEC (gfc_statement, check->absent,
1751 : : merge->n_absent + check->n_absent);
1752 : 0 : for (int i = 0; i < merge->n_absent; i++)
1753 : 0 : if (!bitmap_bit_p (&absent_head, merge->absent[i]))
1754 : 0 : check->absent[check->n_absent++] = merge->absent[i];
1755 : 0 : free (merge->absent);
1756 : 0 : merge->absent = check->absent;
1757 : 0 : merge->n_absent = check->n_absent;
1758 : 0 : check->absent = NULL;
1759 : : }
1760 : 2 : if (merge->contains == NULL && check->contains)
1761 : : {
1762 : 0 : merge->n_contains = check->n_contains;
1763 : 0 : merge->contains = check->contains;
1764 : 0 : check->contains = NULL;
1765 : : }
1766 : 2 : else if (merge->contains && check->contains)
1767 : : {
1768 : 0 : check->contains = XRESIZEVEC (gfc_statement, check->contains,
1769 : : merge->n_contains + check->n_contains);
1770 : 0 : for (int i = 0; i < merge->n_contains; i++)
1771 : 0 : if (!bitmap_bit_p (&contains_head, merge->contains[i]))
1772 : 0 : check->contains[check->n_contains++] = merge->contains[i];
1773 : 0 : free (merge->contains);
1774 : 0 : merge->contains = check->contains;
1775 : 0 : merge->n_contains = check->n_contains;
1776 : 0 : check->contains = NULL;
1777 : : }
1778 : : return MATCH_YES;
1779 : : }
1780 : :
1781 : : /* OpenMP 5.0
1782 : : uses_allocators ( allocator-list )
1783 : :
1784 : : allocator:
1785 : : predefined-allocator
1786 : : variable ( traits-array )
1787 : :
1788 : : OpenMP 5.2:
1789 : : uses_allocators ( [modifier-list :] allocator-list )
1790 : :
1791 : : allocator:
1792 : : variable or predefined-allocator
1793 : : modifier:
1794 : : traits ( traits-array )
1795 : : memspace ( mem-space-handle ) */
1796 : :
1797 : : static match
1798 : 47 : gfc_match_omp_clause_uses_allocators (gfc_omp_clauses *c)
1799 : : {
1800 : 47 : gfc_symbol *memspace_sym = NULL;
1801 : 47 : gfc_symbol *traits_sym = NULL;
1802 : 47 : gfc_omp_namelist *head = NULL;
1803 : 47 : gfc_omp_namelist *p, *tail, **list;
1804 : 47 : int ntraits, nmemspace;
1805 : 47 : bool has_modifiers;
1806 : 47 : locus old_loc, cur_loc;
1807 : :
1808 : 47 : gfc_gobble_whitespace ();
1809 : 47 : old_loc = gfc_current_locus;
1810 : 47 : ntraits = nmemspace = 0;
1811 : 77 : do
1812 : : {
1813 : 62 : cur_loc = gfc_current_locus;
1814 : 62 : if (gfc_match ("traits ( %S ) ", &traits_sym) == MATCH_YES)
1815 : 21 : ntraits++;
1816 : 41 : else if (gfc_match ("memspace ( %S ) ", &memspace_sym) == MATCH_YES)
1817 : 21 : nmemspace++;
1818 : 62 : if (ntraits > 1 || nmemspace > 1)
1819 : : {
1820 : 2 : gfc_error ("Duplicate %s modifier at %L in USES_ALLOCATORS clause",
1821 : : ntraits > 1 ? "TRAITS" : "MEMSPACE", &cur_loc);
1822 : 2 : return MATCH_ERROR;
1823 : : }
1824 : 60 : if (gfc_match (", ") == MATCH_YES)
1825 : 15 : continue;
1826 : 45 : if (gfc_match (": ") != MATCH_YES)
1827 : : {
1828 : : /* Assume no modifier. */
1829 : 22 : memspace_sym = traits_sym = NULL;
1830 : 22 : gfc_current_locus = old_loc;
1831 : 22 : break;
1832 : : }
1833 : : break;
1834 : : } while (true);
1835 : :
1836 : 68 : has_modifiers = traits_sym != NULL || memspace_sym != NULL;
1837 : 127 : do
1838 : : {
1839 : 86 : p = gfc_get_omp_namelist ();
1840 : 86 : p->where = gfc_current_locus;
1841 : 86 : if (head == NULL)
1842 : : head = tail = p;
1843 : : else
1844 : : {
1845 : 41 : tail->next = p;
1846 : 41 : tail = tail->next;
1847 : : }
1848 : 86 : if (gfc_match ("%S ", &p->sym) != MATCH_YES)
1849 : 0 : goto error;
1850 : 86 : if (!has_modifiers)
1851 : 58 : gfc_match ("( %S ) ", &p->u2.traits_sym);
1852 : 28 : else if (gfc_peek_ascii_char () == '(')
1853 : : {
1854 : 0 : gfc_error ("Unexpected %<(%> at %C");
1855 : 0 : goto error;
1856 : : }
1857 : : else
1858 : : {
1859 : 28 : p->u.memspace_sym = memspace_sym;
1860 : 28 : p->u2.traits_sym = traits_sym;
1861 : : }
1862 : 86 : if (gfc_match (", ") == MATCH_YES)
1863 : 41 : continue;
1864 : 45 : if (gfc_match (") ") == MATCH_YES)
1865 : : break;
1866 : 2 : goto error;
1867 : : } while (true);
1868 : :
1869 : 43 : list = &c->lists[OMP_LIST_USES_ALLOCATORS];
1870 : 48 : while (*list)
1871 : 5 : list = &(*list)->next;
1872 : 43 : *list = head;
1873 : :
1874 : 43 : return MATCH_YES;
1875 : :
1876 : 2 : error:
1877 : 2 : gfc_free_omp_namelist (head, false, false, true, false);
1878 : 2 : return MATCH_ERROR;
1879 : : }
1880 : :
1881 : :
1882 : : /* Match the 'prefer_type' modifier of the interop 'init' clause:
1883 : : with either OpenMP 5.1's
1884 : : prefer_type ( <const-int-expr|string literal> [, ...]
1885 : : or
1886 : : prefer_type ( '{' <fr(...) | attr (...)>, ...] '}' [, '{' ... '}' ] )
1887 : : where 'fr' takes a constant expression or a string literal
1888 : : and 'attr takes a list of string literals, starting with 'ompx_')
1889 : :
1890 : : For the foreign runtime identifiers, string values are converted to
1891 : : their integer value; unknown string or integer values are set to
1892 : : GOMP_INTEROP_IFR_KNOWN.
1893 : :
1894 : : Data format:
1895 : : For the foreign runtime identifiers, string values are converted to
1896 : : their integer value; unknown string or integer values are set to 0.
1897 : :
1898 : : Each item (a) GOMP_INTEROP_IFR_SEPARATOR
1899 : : (b) for any 'fr', its integer value.
1900 : : Note: Spec only permits 1 'fr' entry (6.0; changed after TR13)
1901 : : (c) GOMP_INTEROP_IFR_SEPARATOR
1902 : : (d) list of \0-terminated non-empty strings for 'attr'
1903 : : (e) '\0'
1904 : : Tailing '\0'. */
1905 : :
1906 : : static match
1907 : 82 : gfc_match_omp_prefer_type (char **type_str, int *type_str_len)
1908 : : {
1909 : 82 : gfc_expr *e;
1910 : 82 : std::string type_string, attr_string;
1911 : : /* New syntax. */
1912 : 82 : if (gfc_peek_ascii_char () == '{')
1913 : 115 : do
1914 : : {
1915 : 85 : attr_string.clear ();
1916 : 85 : type_string += (char) GOMP_INTEROP_IFR_SEPARATOR;
1917 : 85 : if (gfc_match ("{ ") != MATCH_YES)
1918 : : {
1919 : 1 : gfc_error ("Expected %<{%> at %C");
1920 : 1 : return MATCH_ERROR;
1921 : : }
1922 : : bool fr_found = false;
1923 : 148 : do
1924 : : {
1925 : 116 : if (gfc_match ("fr ( ") == MATCH_YES)
1926 : : {
1927 : 62 : if (fr_found)
1928 : : {
1929 : 1 : gfc_error ("Duplicated %<fr%> preference-selector-name "
1930 : : "at %C");
1931 : 1 : return MATCH_ERROR;
1932 : : }
1933 : 61 : fr_found = true;
1934 : 61 : do
1935 : : {
1936 : 61 : bool found_literal = false;
1937 : 61 : match m = MATCH_YES;
1938 : 61 : if (gfc_match_literal_constant (&e, false) == MATCH_YES)
1939 : : found_literal = true;
1940 : : else
1941 : 12 : m = gfc_match_expr (&e);
1942 : 12 : if (m != MATCH_YES
1943 : 61 : || !gfc_resolve_expr (e)
1944 : 61 : || e->rank != 0
1945 : 60 : || e->expr_type != EXPR_CONSTANT
1946 : 59 : || (e->ts.type != BT_INTEGER
1947 : 43 : && (!found_literal || e->ts.type != BT_CHARACTER))
1948 : 58 : || (e->ts.type == BT_INTEGER
1949 : 16 : && !mpz_fits_sint_p (e->value.integer))
1950 : 70 : || (e->ts.type == BT_CHARACTER
1951 : 42 : && (e->ts.kind != gfc_default_character_kind
1952 : 41 : || e->value.character.length == 0)))
1953 : : {
1954 : 5 : gfc_error ("Expected constant scalar integer expression"
1955 : : " or non-empty default-kind character "
1956 : 5 : "literal at %L", &e->where);
1957 : 5 : gfc_free_expr (e);
1958 : 5 : return MATCH_ERROR;
1959 : : }
1960 : 56 : gfc_gobble_whitespace ();
1961 : 56 : int val;
1962 : 56 : if (e->ts.type == BT_INTEGER)
1963 : : {
1964 : 16 : val = mpz_get_si (e->value.integer);
1965 : 16 : if (val < 1 || val > GOMP_INTEROP_IFR_LAST)
1966 : : {
1967 : 0 : gfc_warning_now (OPT_Wopenmp,
1968 : : "Unknown foreign runtime "
1969 : : "identifier %qd at %L",
1970 : : val, &e->where);
1971 : 0 : val = GOMP_INTEROP_IFR_UNKNOWN;
1972 : : }
1973 : : }
1974 : : else
1975 : : {
1976 : 40 : char *str = XALLOCAVEC (char,
1977 : : e->value.character.length+1);
1978 : 229 : for (int i = 0; i < e->value.character.length + 1; i++)
1979 : 189 : str[i] = e->value.character.string[i];
1980 : 40 : if (memchr (str, '\0', e->value.character.length) != 0)
1981 : : {
1982 : 0 : gfc_error ("Unexpected null character in character "
1983 : : "literal at %L", &e->where);
1984 : 0 : return MATCH_ERROR;
1985 : : }
1986 : 40 : val = omp_get_fr_id_from_name (str);
1987 : 40 : if (val == GOMP_INTEROP_IFR_UNKNOWN)
1988 : 2 : gfc_warning_now (OPT_Wopenmp,
1989 : : "Unknown foreign runtime identifier "
1990 : 2 : "%qs at %L", str, &e->where);
1991 : : }
1992 : :
1993 : 56 : type_string += (char) val;
1994 : 56 : if (gfc_match (") ") == MATCH_YES)
1995 : : break;
1996 : 4 : gfc_error ("Expected %<)%> at %C");
1997 : 4 : return MATCH_ERROR;
1998 : : }
1999 : : while (true);
2000 : : }
2001 : 54 : else if (gfc_match ("attr ( ") == MATCH_YES)
2002 : : {
2003 : 60 : do
2004 : : {
2005 : 57 : if (gfc_match_literal_constant (&e, false) != MATCH_YES
2006 : 56 : || !gfc_resolve_expr (e)
2007 : 56 : || e->expr_type != EXPR_CONSTANT
2008 : 56 : || e->rank != 0
2009 : 56 : || e->ts.type != BT_CHARACTER
2010 : 113 : || e->ts.kind != gfc_default_character_kind)
2011 : : {
2012 : 1 : gfc_error ("Expected default-kind character literal "
2013 : 1 : "at %L", &e->where);
2014 : 1 : gfc_free_expr (e);
2015 : 1 : return MATCH_ERROR;
2016 : : }
2017 : 56 : gfc_gobble_whitespace ();
2018 : 56 : char *str = XALLOCAVEC (char, e->value.character.length+1);
2019 : 564 : for (int i = 0; i < e->value.character.length + 1; i++)
2020 : 508 : str[i] = e->value.character.string[i];
2021 : 56 : if (!startswith (str, "ompx_"))
2022 : : {
2023 : 1 : gfc_error ("Character literal at %L must start with "
2024 : : "%<ompx_%>", &e->where);
2025 : 1 : gfc_free_expr (e);
2026 : 1 : return MATCH_ERROR;
2027 : : }
2028 : 55 : if (memchr (str, '\0', e->value.character.length) != 0
2029 : 55 : || memchr (str, ',', e->value.character.length) != 0)
2030 : : {
2031 : 1 : gfc_error ("Unexpected null or %<,%> character in "
2032 : : "character literal at %L", &e->where);
2033 : 1 : return MATCH_ERROR;
2034 : : }
2035 : 54 : attr_string += str;
2036 : 54 : attr_string += '\0';
2037 : 54 : if (gfc_match (", ") == MATCH_YES)
2038 : 3 : continue;
2039 : 51 : if (gfc_match (") ") == MATCH_YES)
2040 : : break;
2041 : 0 : gfc_error ("Expected %<,%> or %<)%> at %C");
2042 : 0 : return MATCH_ERROR;
2043 : 3 : }
2044 : : while (true);
2045 : : }
2046 : : else
2047 : : {
2048 : 0 : gfc_error ("Expected %<fr(%> or %<attr(%> at %C");
2049 : 0 : return MATCH_ERROR;
2050 : : }
2051 : 103 : if (gfc_match (", ") == MATCH_YES)
2052 : 32 : continue;
2053 : 71 : if (gfc_match ("} ") == MATCH_YES)
2054 : : break;
2055 : 2 : gfc_error ("Expected %<,%> or %<}%> at %C");
2056 : 2 : return MATCH_ERROR;
2057 : 32 : }
2058 : : while (true);
2059 : 69 : type_string += (char) GOMP_INTEROP_IFR_SEPARATOR;
2060 : 69 : type_string += attr_string;
2061 : 69 : type_string += '\0';
2062 : 69 : if (gfc_match (", ") == MATCH_YES)
2063 : 30 : continue;
2064 : 39 : if (gfc_match (") ") == MATCH_YES)
2065 : : break;
2066 : 1 : gfc_error ("Expected %<,%> or %<)%> at %C");
2067 : 1 : return MATCH_ERROR;
2068 : 30 : }
2069 : : while (true);
2070 : : else
2071 : 75 : do
2072 : : {
2073 : 51 : type_string += (char) GOMP_INTEROP_IFR_SEPARATOR;
2074 : 51 : bool found_literal = false;
2075 : 51 : match m = MATCH_YES;
2076 : 51 : if (gfc_match_literal_constant (&e, false) == MATCH_YES)
2077 : : found_literal = true;
2078 : : else
2079 : 19 : m = gfc_match_expr (&e);
2080 : 19 : if (m != MATCH_YES
2081 : 51 : || !gfc_resolve_expr (e)
2082 : 51 : || e->rank != 0
2083 : 50 : || e->expr_type != EXPR_CONSTANT
2084 : 49 : || (e->ts.type != BT_INTEGER
2085 : 28 : && (!found_literal || e->ts.type != BT_CHARACTER))
2086 : 48 : || (e->ts.type == BT_INTEGER
2087 : 21 : && !mpz_fits_sint_p (e->value.integer))
2088 : 67 : || (e->ts.type == BT_CHARACTER
2089 : 27 : && (e->ts.kind != gfc_default_character_kind
2090 : 27 : || e->value.character.length == 0)))
2091 : : {
2092 : 3 : gfc_error ("Expected constant scalar integer expression or "
2093 : 3 : "non-empty default-kind character literal at %L", &e->where);
2094 : 3 : gfc_free_expr (e);
2095 : 3 : return MATCH_ERROR;
2096 : : }
2097 : 48 : gfc_gobble_whitespace ();
2098 : 48 : int val;
2099 : 48 : if (e->ts.type == BT_INTEGER)
2100 : : {
2101 : 21 : val = mpz_get_si (e->value.integer);
2102 : 21 : if (val < 1 || val > GOMP_INTEROP_IFR_LAST)
2103 : : {
2104 : 3 : gfc_warning_now (OPT_Wopenmp,
2105 : : "Unknown foreign runtime identifier %qd at %L",
2106 : : val, &e->where);
2107 : 3 : val = 0;
2108 : : }
2109 : : }
2110 : : else
2111 : : {
2112 : 27 : char *str = XALLOCAVEC (char, e->value.character.length+1);
2113 : 169 : for (int i = 0; i < e->value.character.length + 1; i++)
2114 : 142 : str[i] = e->value.character.string[i];
2115 : 27 : if (memchr (str, '\0', e->value.character.length) != 0)
2116 : : {
2117 : 0 : gfc_error ("Unexpected null character in character "
2118 : : "literal at %L", &e->where);
2119 : 0 : return MATCH_ERROR;
2120 : : }
2121 : 27 : val = omp_get_fr_id_from_name (str);
2122 : 27 : if (val == GOMP_INTEROP_IFR_UNKNOWN)
2123 : 5 : gfc_warning_now (OPT_Wopenmp,
2124 : : "Unknown foreign runtime identifier %qs at %L",
2125 : 5 : str, &e->where);
2126 : : }
2127 : 48 : type_string += (char) val;
2128 : 48 : type_string += (char) GOMP_INTEROP_IFR_SEPARATOR;
2129 : 48 : type_string += '\0';
2130 : 48 : gfc_free_expr (e);
2131 : 48 : if (gfc_match (", ") == MATCH_YES)
2132 : 24 : continue;
2133 : 24 : if (gfc_match (") ") == MATCH_YES)
2134 : : break;
2135 : 2 : gfc_error ("Expected %<,%> or %<)%> at %C");
2136 : 2 : return MATCH_ERROR;
2137 : 24 : }
2138 : : while (true);
2139 : 60 : type_string += '\0';
2140 : 60 : *type_str_len = type_string.length();
2141 : 60 : *type_str = XNEWVEC (char, type_string.length ());
2142 : 60 : memcpy (*type_str, type_string.data (), type_string.length ());
2143 : 60 : return MATCH_YES;
2144 : 82 : }
2145 : :
2146 : :
2147 : : /* Match OpenMP 5.1's 'init'-clause modifiers, used by the 'init' clause of
2148 : : the 'interop' directive and the 'append_args' directive of 'declare variant'.
2149 : : [prefer_type(...)][,][<target|targetsync>, ...])
2150 : :
2151 : : If is_init_clause, the modifier parsing ends with a ':'.
2152 : : If not is_init_clause (i.e. append_args), the parsing ends with ')'. */
2153 : :
2154 : : static match
2155 : 164 : gfc_parser_omp_clause_init_modifiers (bool &target, bool &targetsync,
2156 : : char **type_str, int &type_str_len,
2157 : : bool is_init_clause)
2158 : : {
2159 : 164 : target = false;
2160 : 164 : targetsync = false;
2161 : 164 : *type_str = NULL;
2162 : 164 : type_str_len = 0;
2163 : 286 : match m;
2164 : :
2165 : 286 : do
2166 : : {
2167 : 286 : if (gfc_match ("prefer_type ( ") == MATCH_YES)
2168 : : {
2169 : 83 : if (*type_str)
2170 : : {
2171 : 1 : gfc_error ("Duplicate %<prefer_type%> modifier at %C");
2172 : 1 : return MATCH_ERROR;
2173 : : }
2174 : 82 : m = gfc_match_omp_prefer_type (type_str, &type_str_len);
2175 : 82 : if (m != MATCH_YES)
2176 : : return m;
2177 : 60 : if (gfc_match (", ") == MATCH_YES)
2178 : 14 : continue;
2179 : 46 : if (is_init_clause)
2180 : : {
2181 : 24 : if (gfc_match (": ") == MATCH_YES)
2182 : : break;
2183 : 0 : gfc_error ("Expected %<,%> or %<:%> at %C");
2184 : : }
2185 : : else
2186 : : {
2187 : 22 : if (gfc_match (") ") == MATCH_YES)
2188 : : break;
2189 : 0 : gfc_error ("Expected %<,%> or %<)%> at %C");
2190 : : }
2191 : 0 : return MATCH_ERROR;
2192 : : }
2193 : :
2194 : 203 : if (gfc_match ("prefer_type ") == MATCH_YES)
2195 : : {
2196 : 2 : gfc_error ("Expected %<(%> after %<prefer_type%> at %C");
2197 : 2 : return MATCH_ERROR;
2198 : : }
2199 : :
2200 : 201 : if (gfc_match ("targetsync ") == MATCH_YES)
2201 : : {
2202 : 57 : if (targetsync)
2203 : : {
2204 : 3 : gfc_error ("Duplicate %<targetsync%> at %C");
2205 : 3 : return MATCH_ERROR;
2206 : : }
2207 : 54 : targetsync = true;
2208 : 54 : if (gfc_match (", ") == MATCH_YES)
2209 : 13 : continue;
2210 : 41 : if (!is_init_clause)
2211 : : {
2212 : 23 : if (gfc_match (") ") == MATCH_YES)
2213 : : break;
2214 : 0 : gfc_error ("Expected %<,%> or %<)%> at %C");
2215 : 0 : return MATCH_ERROR;
2216 : : }
2217 : 18 : if (gfc_match (": ") == MATCH_YES)
2218 : : break;
2219 : 1 : gfc_error ("Expected %<,%> or %<:%> at %C");
2220 : 1 : return MATCH_ERROR;
2221 : : }
2222 : 144 : if (gfc_match ("target ") == MATCH_YES)
2223 : : {
2224 : 135 : if (target)
2225 : : {
2226 : 3 : gfc_error ("Duplicate %<target%> at %C");
2227 : 3 : return MATCH_ERROR;
2228 : : }
2229 : 132 : target = true;
2230 : 132 : if (gfc_match (", ") == MATCH_YES)
2231 : 95 : continue;
2232 : 37 : if (!is_init_clause)
2233 : : {
2234 : 11 : if (gfc_match (") ") == MATCH_YES)
2235 : : break;
2236 : 0 : gfc_error ("Expected %<,%> or %<)%> at %C");
2237 : 0 : return MATCH_ERROR;
2238 : : }
2239 : 26 : if (gfc_match (": ") == MATCH_YES)
2240 : : break;
2241 : 1 : gfc_error ("Expected %<,%> or %<:%> at %C");
2242 : 1 : return MATCH_ERROR;
2243 : : }
2244 : 9 : gfc_error ("Expected %<prefer_type%>, %<target%>, or %<targetsync%> "
2245 : : "at %C");
2246 : 9 : return MATCH_ERROR;
2247 : : }
2248 : : while (true);
2249 : :
2250 : 122 : if (!target && !targetsync)
2251 : : {
2252 : 4 : gfc_error ("Missing required %<target%> and/or %<targetsync%> "
2253 : : "modifier at %C");
2254 : 4 : return MATCH_ERROR;
2255 : : }
2256 : : return MATCH_YES;
2257 : : }
2258 : :
2259 : : /* Match OpenMP 5.1's 'init' clause for 'interop' objects:
2260 : : init([prefer_type(...)][,][<target|targetsync>, ...] :] interop-obj-list) */
2261 : :
2262 : : static match
2263 : 108 : gfc_match_omp_init (gfc_omp_namelist **list)
2264 : : {
2265 : 108 : bool target, targetsync;
2266 : 108 : char *type_str = NULL;
2267 : 108 : int type_str_len;
2268 : 108 : if (gfc_parser_omp_clause_init_modifiers (target, targetsync, &type_str,
2269 : : type_str_len, true) == MATCH_ERROR)
2270 : : return MATCH_ERROR;
2271 : :
2272 : 64 : gfc_omp_namelist **head = NULL;
2273 : 64 : if (gfc_match_omp_variable_list ("", list, false, NULL, &head) != MATCH_YES)
2274 : : return MATCH_ERROR;
2275 : 147 : for (gfc_omp_namelist *n = *head; n; n = n->next)
2276 : : {
2277 : 84 : n->u.init.target = target;
2278 : 84 : n->u.init.targetsync = targetsync;
2279 : 84 : n->u.init.len = type_str_len;
2280 : 84 : n->u2.init_interop = type_str;
2281 : : }
2282 : : return MATCH_YES;
2283 : : }
2284 : :
2285 : :
2286 : : /* Match with duplicate check. Matches 'name'. If expr != NULL, it
2287 : : then matches '(expr)', otherwise, if open_parens is true,
2288 : : it matches a ' ( ' after 'name'.
2289 : : dupl_message requires '%qs %L' - and is used by
2290 : : gfc_match_dupl_memorder and gfc_match_dupl_atomic. */
2291 : :
2292 : : static match
2293 : 21947 : gfc_match_dupl_check (bool not_dupl, const char *name, bool open_parens = false,
2294 : : gfc_expr **expr = NULL, const char *dupl_msg = NULL)
2295 : : {
2296 : 21947 : match m;
2297 : 21947 : locus old_loc = gfc_current_locus;
2298 : 21947 : if ((m = gfc_match (name)) != MATCH_YES)
2299 : : return m;
2300 : 17170 : if (!not_dupl)
2301 : : {
2302 : 42 : if (dupl_msg)
2303 : 2 : gfc_error (dupl_msg, name, &old_loc);
2304 : : else
2305 : 40 : gfc_error ("Duplicated %qs clause at %L", name, &old_loc);
2306 : 42 : return MATCH_ERROR;
2307 : : }
2308 : 17128 : if (open_parens || expr)
2309 : : {
2310 : 9006 : if (gfc_match (" ( ") != MATCH_YES)
2311 : : {
2312 : 26 : gfc_error ("Expected %<(%> after %qs at %C", name);
2313 : 26 : return MATCH_ERROR;
2314 : : }
2315 : 8980 : if (expr)
2316 : : {
2317 : 4318 : if (gfc_match ("%e )", expr) != MATCH_YES)
2318 : : {
2319 : 9 : gfc_error ("Invalid expression after %<%s(%> at %C", name);
2320 : 9 : return MATCH_ERROR;
2321 : : }
2322 : : }
2323 : : }
2324 : : return MATCH_YES;
2325 : : }
2326 : :
2327 : : static match
2328 : 211 : gfc_match_dupl_memorder (bool not_dupl, const char *name)
2329 : : {
2330 : 0 : return gfc_match_dupl_check (not_dupl, name, false, NULL,
2331 : : "Duplicated memory-order clause: unexpected %s "
2332 : 0 : "clause at %L");
2333 : : }
2334 : :
2335 : : static match
2336 : 1175 : gfc_match_dupl_atomic (bool not_dupl, const char *name)
2337 : : {
2338 : 0 : return gfc_match_dupl_check (not_dupl, name, false, NULL,
2339 : : "Duplicated atomic clause: unexpected %s "
2340 : 0 : "clause at %L");
2341 : : }
2342 : :
2343 : : /* Match OpenMP and OpenACC directive clauses. MASK is a bitmask of
2344 : : clauses that are allowed for a particular directive. */
2345 : :
2346 : : static match
2347 : 33775 : gfc_match_omp_clauses (gfc_omp_clauses **cp, const omp_mask mask,
2348 : : bool first = true, bool needs_space = true,
2349 : : bool openacc = false, bool openmp_target = false)
2350 : : {
2351 : 33775 : bool error = false;
2352 : 33775 : gfc_omp_clauses *c = gfc_get_omp_clauses ();
2353 : 33775 : locus old_loc;
2354 : : /* Determine whether we're dealing with an OpenACC directive that permits
2355 : : derived type member accesses. This in particular disallows
2356 : : "!$acc declare" from using such accesses, because it's not clear if/how
2357 : : that should work. */
2358 : 33775 : bool allow_derived = (openacc
2359 : 33775 : && ((mask & OMP_CLAUSE_ATTACH)
2360 : 5927 : || (mask & OMP_CLAUSE_DETACH)));
2361 : :
2362 : 33775 : gcc_checking_assert (OMP_MASK1_LAST <= 64 && OMP_MASK2_LAST <= 64);
2363 : 33775 : *cp = NULL;
2364 : 123665 : while (1)
2365 : : {
2366 : 78720 : match m = MATCH_NO;
2367 : 58705 : if ((first || (m = gfc_match_char (',')) != MATCH_YES)
2368 : 137079 : && (needs_space && gfc_match_space () != MATCH_YES))
2369 : : break;
2370 : 70758 : needs_space = false;
2371 : 70758 : first = false;
2372 : 70758 : gfc_gobble_whitespace ();
2373 : 70758 : bool end_colon;
2374 : 70758 : gfc_omp_namelist **head;
2375 : 70758 : old_loc = gfc_current_locus;
2376 : 70758 : char pc = gfc_peek_ascii_char ();
2377 : 70758 : if (pc == '\n' && m == MATCH_YES)
2378 : : {
2379 : 1 : gfc_error ("Clause expected at %C after trailing comma");
2380 : 1 : goto error;
2381 : : }
2382 : 70757 : switch (pc)
2383 : : {
2384 : 1267 : case 'a':
2385 : 1267 : end_colon = false;
2386 : 1267 : head = NULL;
2387 : 1291 : if ((mask & OMP_CLAUSE_ASSUMPTIONS)
2388 : 1267 : && gfc_match ("absent ( ") == MATCH_YES)
2389 : : {
2390 : 27 : if (gfc_omp_absent_contains_clause (&c->assume, true)
2391 : : != MATCH_YES)
2392 : 3 : goto error;
2393 : 24 : continue;
2394 : : }
2395 : 1240 : if ((mask & OMP_CLAUSE_ALIGNED)
2396 : 1240 : && gfc_match_omp_variable_list ("aligned (",
2397 : : &c->lists[OMP_LIST_ALIGNED],
2398 : : false, &end_colon,
2399 : : &head) == MATCH_YES)
2400 : : {
2401 : 112 : gfc_expr *alignment = NULL;
2402 : 112 : gfc_omp_namelist *n;
2403 : :
2404 : 112 : if (end_colon && gfc_match (" %e )", &alignment) != MATCH_YES)
2405 : : {
2406 : 0 : gfc_free_omp_namelist (*head, false, false, false, false);
2407 : 0 : gfc_current_locus = old_loc;
2408 : 0 : *head = NULL;
2409 : 0 : break;
2410 : : }
2411 : 268 : for (n = *head; n; n = n->next)
2412 : 156 : if (n->next && alignment)
2413 : 42 : n->expr = gfc_copy_expr (alignment);
2414 : : else
2415 : 114 : n->expr = alignment;
2416 : 112 : continue;
2417 : 112 : }
2418 : 1138 : if ((mask & OMP_CLAUSE_MEMORDER)
2419 : 1145 : && (m = gfc_match_dupl_memorder ((c->memorder
2420 : 17 : == OMP_MEMORDER_UNSET),
2421 : : "acq_rel")) != MATCH_NO)
2422 : : {
2423 : 10 : if (m == MATCH_ERROR)
2424 : 0 : goto error;
2425 : 10 : c->memorder = OMP_MEMORDER_ACQ_REL;
2426 : 10 : needs_space = true;
2427 : 10 : continue;
2428 : : }
2429 : 1125 : if ((mask & OMP_CLAUSE_MEMORDER)
2430 : 1125 : && (m = gfc_match_dupl_memorder ((c->memorder
2431 : 7 : == OMP_MEMORDER_UNSET),
2432 : : "acquire")) != MATCH_NO)
2433 : : {
2434 : 7 : if (m == MATCH_ERROR)
2435 : 0 : goto error;
2436 : 7 : c->memorder = OMP_MEMORDER_ACQUIRE;
2437 : 7 : needs_space = true;
2438 : 7 : continue;
2439 : : }
2440 : 1111 : if ((mask & OMP_CLAUSE_AFFINITY)
2441 : 1111 : && gfc_match ("affinity ( ") == MATCH_YES)
2442 : : {
2443 : 41 : gfc_namespace *ns_iter = NULL, *ns_curr = gfc_current_ns;
2444 : 41 : m = gfc_match_iterator (&ns_iter, true);
2445 : 41 : if (m == MATCH_ERROR)
2446 : : break;
2447 : 31 : if (m == MATCH_YES && gfc_match (" : ") != MATCH_YES)
2448 : : {
2449 : 1 : gfc_error ("Expected %<:%> at %C");
2450 : 1 : break;
2451 : : }
2452 : 30 : if (ns_iter)
2453 : 18 : gfc_current_ns = ns_iter;
2454 : 30 : head = NULL;
2455 : 30 : m = gfc_match_omp_variable_list ("", &c->lists[OMP_LIST_AFFINITY],
2456 : : false, NULL, &head, true);
2457 : 30 : gfc_current_ns = ns_curr;
2458 : 30 : if (m == MATCH_ERROR)
2459 : : break;
2460 : 27 : if (ns_iter)
2461 : : {
2462 : 45 : for (gfc_omp_namelist *n = *head; n; n = n->next)
2463 : : {
2464 : 27 : n->u2.ns = ns_iter;
2465 : 27 : ns_iter->refs++;
2466 : : }
2467 : : }
2468 : 27 : continue;
2469 : 27 : }
2470 : 1070 : if ((mask & OMP_CLAUSE_ALLOCATE)
2471 : 1070 : && gfc_match ("allocate ( ") == MATCH_YES)
2472 : : {
2473 : 236 : gfc_expr *allocator = NULL;
2474 : 236 : gfc_expr *align = NULL;
2475 : 236 : old_loc = gfc_current_locus;
2476 : 236 : if ((m = gfc_match ("allocator ( %e )", &allocator)) == MATCH_YES)
2477 : 7 : gfc_match (" , align ( %e )", &align);
2478 : 229 : else if ((m = gfc_match ("align ( %e )", &align)) == MATCH_YES)
2479 : 29 : gfc_match (" , allocator ( %e )", &allocator);
2480 : :
2481 : 236 : if (m == MATCH_YES)
2482 : : {
2483 : 36 : if (gfc_match (" : ") != MATCH_YES)
2484 : : {
2485 : 5 : gfc_error ("Expected %<:%> at %C");
2486 : 8 : goto error;
2487 : : }
2488 : : }
2489 : : else
2490 : : {
2491 : 200 : m = gfc_match_expr (&allocator);
2492 : 200 : if (m == MATCH_YES && gfc_match (" : ") != MATCH_YES)
2493 : : {
2494 : : /* If no ":" then there is no allocator, we backtrack
2495 : : and read the variable list. */
2496 : 101 : gfc_free_expr (allocator);
2497 : 101 : allocator = NULL;
2498 : 101 : gfc_current_locus = old_loc;
2499 : : }
2500 : : }
2501 : 231 : gfc_omp_namelist **head = NULL;
2502 : 231 : m = gfc_match_omp_variable_list ("", &c->lists[OMP_LIST_ALLOCATE],
2503 : : true, NULL, &head);
2504 : :
2505 : 231 : if (m != MATCH_YES)
2506 : : {
2507 : 3 : gfc_free_expr (allocator);
2508 : 3 : gfc_free_expr (align);
2509 : 3 : gfc_error ("Expected variable list at %C");
2510 : 3 : goto error;
2511 : : }
2512 : :
2513 : 632 : for (gfc_omp_namelist *n = *head; n; n = n->next)
2514 : : {
2515 : 404 : n->u2.allocator = allocator;
2516 : 404 : n->u.align = (align) ? gfc_copy_expr (align) : NULL;
2517 : : }
2518 : 228 : gfc_free_expr (align);
2519 : 228 : continue;
2520 : 228 : }
2521 : 894 : if ((mask & OMP_CLAUSE_AT)
2522 : 834 : && (m = gfc_match_dupl_check (c->at == OMP_AT_UNSET, "at", true))
2523 : : != MATCH_NO)
2524 : : {
2525 : 66 : if (m == MATCH_ERROR)
2526 : 2 : goto error;
2527 : 64 : if (gfc_match ("compilation )") == MATCH_YES)
2528 : 15 : c->at = OMP_AT_COMPILATION;
2529 : 49 : else if (gfc_match ("execution )") == MATCH_YES)
2530 : 45 : c->at = OMP_AT_EXECUTION;
2531 : : else
2532 : : {
2533 : 4 : gfc_error ("Expected COMPILATION or EXECUTION in AT clause "
2534 : : "at %C");
2535 : 4 : goto error;
2536 : : }
2537 : 60 : continue;
2538 : : }
2539 : 1412 : if ((mask & OMP_CLAUSE_ASYNC)
2540 : 768 : && (m = gfc_match_dupl_check (!c->async, "async")) != MATCH_NO)
2541 : : {
2542 : 644 : if (m == MATCH_ERROR)
2543 : 0 : goto error;
2544 : 644 : c->async = true;
2545 : 644 : m = gfc_match (" ( %e )", &c->async_expr);
2546 : 644 : if (m == MATCH_ERROR)
2547 : : {
2548 : 0 : gfc_current_locus = old_loc;
2549 : 0 : break;
2550 : : }
2551 : 644 : else if (m == MATCH_NO)
2552 : : {
2553 : 134 : c->async_expr
2554 : 134 : = gfc_get_constant_expr (BT_INTEGER,
2555 : : gfc_default_integer_kind,
2556 : : &gfc_current_locus);
2557 : 134 : mpz_set_si (c->async_expr->value.integer, GOMP_ASYNC_NOVAL);
2558 : 134 : needs_space = true;
2559 : : }
2560 : 644 : continue;
2561 : : }
2562 : 187 : if ((mask & OMP_CLAUSE_AUTO)
2563 : 124 : && (m = gfc_match_dupl_check (!c->par_auto, "auto"))
2564 : : != MATCH_NO)
2565 : : {
2566 : 63 : if (m == MATCH_ERROR)
2567 : 0 : goto error;
2568 : 63 : c->par_auto = true;
2569 : 63 : needs_space = true;
2570 : 63 : continue;
2571 : : }
2572 : 120 : if ((mask & OMP_CLAUSE_ATTACH)
2573 : 59 : && gfc_match ("attach ( ") == MATCH_YES
2574 : 120 : && gfc_match_omp_map_clause (&c->lists[OMP_LIST_MAP],
2575 : : OMP_MAP_ATTACH, false,
2576 : : allow_derived))
2577 : 59 : continue;
2578 : : break;
2579 : 36 : case 'b':
2580 : 70 : if ((mask & OMP_CLAUSE_BIND)
2581 : 36 : && (m = gfc_match_dupl_check (c->bind == OMP_BIND_UNSET, "bind",
2582 : : true)) != MATCH_NO)
2583 : : {
2584 : 36 : if (m == MATCH_ERROR)
2585 : 1 : goto error;
2586 : 35 : if (gfc_match ("teams )") == MATCH_YES)
2587 : 11 : c->bind = OMP_BIND_TEAMS;
2588 : 24 : else if (gfc_match ("parallel )") == MATCH_YES)
2589 : 15 : c->bind = OMP_BIND_PARALLEL;
2590 : 9 : else if (gfc_match ("thread )") == MATCH_YES)
2591 : 8 : c->bind = OMP_BIND_THREAD;
2592 : : else
2593 : : {
2594 : 1 : gfc_error ("Expected TEAMS, PARALLEL or THREAD as binding in "
2595 : : "BIND at %C");
2596 : 1 : break;
2597 : : }
2598 : 34 : continue;
2599 : : }
2600 : : break;
2601 : 7105 : case 'c':
2602 : 7378 : if ((mask & OMP_CLAUSE_CAPTURE)
2603 : 7105 : && (m = gfc_match_dupl_check (!c->capture, "capture"))
2604 : : != MATCH_NO)
2605 : : {
2606 : 274 : if (m == MATCH_ERROR)
2607 : 1 : goto error;
2608 : 273 : c->capture = true;
2609 : 273 : needs_space = true;
2610 : 273 : continue;
2611 : : }
2612 : 6831 : if (mask & OMP_CLAUSE_COLLAPSE)
2613 : : {
2614 : 1995 : gfc_expr *cexpr = NULL;
2615 : 1995 : if ((m = gfc_match_dupl_check (!c->collapse, "collapse", true,
2616 : : &cexpr)) != MATCH_NO)
2617 : : {
2618 : 1505 : int collapse;
2619 : 1505 : if (m == MATCH_ERROR)
2620 : 0 : goto error;
2621 : 1505 : if (gfc_extract_int (cexpr, &collapse, -1))
2622 : 4 : collapse = 1;
2623 : 1501 : else if (collapse <= 0)
2624 : : {
2625 : 8 : gfc_error_now ("COLLAPSE clause argument not constant "
2626 : : "positive integer at %C");
2627 : 8 : collapse = 1;
2628 : : }
2629 : 1505 : gfc_free_expr (cexpr);
2630 : 1505 : c->collapse = collapse;
2631 : 1505 : continue;
2632 : 1505 : }
2633 : : }
2634 : 5492 : if ((mask & OMP_CLAUSE_COMPARE)
2635 : 5326 : && (m = gfc_match_dupl_check (!c->compare, "compare"))
2636 : : != MATCH_NO)
2637 : : {
2638 : 167 : if (m == MATCH_ERROR)
2639 : 1 : goto error;
2640 : 166 : c->compare = true;
2641 : 166 : needs_space = true;
2642 : 166 : continue;
2643 : : }
2644 : 5171 : if ((mask & OMP_CLAUSE_ASSUMPTIONS)
2645 : 5159 : && gfc_match ("contains ( ") == MATCH_YES)
2646 : : {
2647 : 12 : if (gfc_omp_absent_contains_clause (&c->assume, false)
2648 : : != MATCH_YES)
2649 : 0 : goto error;
2650 : 12 : continue;
2651 : : }
2652 : 7263 : if ((mask & OMP_CLAUSE_COPY)
2653 : 3720 : && gfc_match ("copy ( ") == MATCH_YES
2654 : 7264 : && gfc_match_omp_map_clause (&c->lists[OMP_LIST_MAP],
2655 : : OMP_MAP_TOFROM, true,
2656 : : allow_derived))
2657 : 2116 : continue;
2658 : 3031 : if (mask & OMP_CLAUSE_COPYIN)
2659 : : {
2660 : 2625 : if (openacc)
2661 : : {
2662 : 2526 : if (gfc_match ("copyin ( ") == MATCH_YES)
2663 : : {
2664 : 1456 : bool readonly = gfc_match ("readonly : ") == MATCH_YES;
2665 : 1456 : head = NULL;
2666 : 1456 : if (gfc_match_omp_variable_list ("",
2667 : : &c->lists[OMP_LIST_MAP],
2668 : : true, NULL, &head, true,
2669 : : allow_derived)
2670 : : == MATCH_YES)
2671 : : {
2672 : 1450 : gfc_omp_namelist *n;
2673 : 3343 : for (n = *head; n; n = n->next)
2674 : : {
2675 : 1893 : n->u.map.op = OMP_MAP_TO;
2676 : 1893 : n->u.map.readonly = readonly;
2677 : : }
2678 : 1450 : continue;
2679 : 1450 : }
2680 : : }
2681 : : }
2682 : 99 : else if (gfc_match_omp_variable_list ("copyin (",
2683 : : &c->lists[OMP_LIST_COPYIN],
2684 : : true) == MATCH_YES)
2685 : 97 : continue;
2686 : : }
2687 : 2554 : if ((mask & OMP_CLAUSE_COPYOUT)
2688 : 1215 : && gfc_match ("copyout ( ") == MATCH_YES
2689 : 2554 : && gfc_match_omp_map_clause (&c->lists[OMP_LIST_MAP],
2690 : : OMP_MAP_FROM, true, allow_derived))
2691 : 1070 : continue;
2692 : 498 : if ((mask & OMP_CLAUSE_COPYPRIVATE)
2693 : 414 : && gfc_match_omp_variable_list ("copyprivate (",
2694 : : &c->lists[OMP_LIST_COPYPRIVATE],
2695 : : true) == MATCH_YES)
2696 : 84 : continue;
2697 : 651 : if ((mask & OMP_CLAUSE_CREATE)
2698 : 328 : && gfc_match ("create ( ") == MATCH_YES
2699 : 651 : && gfc_match_omp_map_clause (&c->lists[OMP_LIST_MAP],
2700 : : OMP_MAP_ALLOC, true, allow_derived))
2701 : 321 : continue;
2702 : : break;
2703 : 3652 : case 'd':
2704 : 3652 : if ((mask & OMP_CLAUSE_DEFAULTMAP)
2705 : 3652 : && gfc_match ("defaultmap ( ") == MATCH_YES)
2706 : : {
2707 : 182 : enum gfc_omp_defaultmap behavior;
2708 : 182 : gfc_omp_defaultmap_category category
2709 : : = OMP_DEFAULTMAP_CAT_UNCATEGORIZED;
2710 : 182 : if (gfc_match ("alloc ") == MATCH_YES)
2711 : : behavior = OMP_DEFAULTMAP_ALLOC;
2712 : 176 : else if (gfc_match ("tofrom ") == MATCH_YES)
2713 : : behavior = OMP_DEFAULTMAP_TOFROM;
2714 : 144 : else if (gfc_match ("to ") == MATCH_YES)
2715 : : behavior = OMP_DEFAULTMAP_TO;
2716 : 129 : else if (gfc_match ("from ") == MATCH_YES)
2717 : : behavior = OMP_DEFAULTMAP_FROM;
2718 : 126 : else if (gfc_match ("firstprivate ") == MATCH_YES)
2719 : : behavior = OMP_DEFAULTMAP_FIRSTPRIVATE;
2720 : 91 : else if (gfc_match ("present ") == MATCH_YES)
2721 : : behavior = OMP_DEFAULTMAP_PRESENT;
2722 : 87 : else if (gfc_match ("none ") == MATCH_YES)
2723 : : behavior = OMP_DEFAULTMAP_NONE;
2724 : 10 : else if (gfc_match ("default ") == MATCH_YES)
2725 : : behavior = OMP_DEFAULTMAP_DEFAULT;
2726 : : else
2727 : : {
2728 : 1 : gfc_error ("Expected ALLOC, TO, FROM, TOFROM, FIRSTPRIVATE, "
2729 : : "PRESENT, NONE or DEFAULT at %C");
2730 : 1 : break;
2731 : : }
2732 : 181 : if (')' == gfc_peek_ascii_char ())
2733 : : ;
2734 : 107 : else if (gfc_match (": ") != MATCH_YES)
2735 : : break;
2736 : : else
2737 : : {
2738 : 107 : if (gfc_match ("scalar ") == MATCH_YES)
2739 : : category = OMP_DEFAULTMAP_CAT_SCALAR;
2740 : 72 : else if (gfc_match ("aggregate ") == MATCH_YES)
2741 : : category = OMP_DEFAULTMAP_CAT_AGGREGATE;
2742 : 48 : else if (gfc_match ("allocatable ") == MATCH_YES)
2743 : : category = OMP_DEFAULTMAP_CAT_ALLOCATABLE;
2744 : 36 : else if (gfc_match ("pointer ") == MATCH_YES)
2745 : : category = OMP_DEFAULTMAP_CAT_POINTER;
2746 : 19 : else if (gfc_match ("all ") == MATCH_YES)
2747 : : category = OMP_DEFAULTMAP_CAT_ALL;
2748 : : else
2749 : : {
2750 : 1 : gfc_error ("Expected SCALAR, AGGREGATE, ALLOCATABLE, "
2751 : : "POINTER or ALL at %C");
2752 : 1 : break;
2753 : : }
2754 : : }
2755 : 1207 : for (int i = 0; i < OMP_DEFAULTMAP_CAT_NUM; ++i)
2756 : : {
2757 : 1040 : if (i != category
2758 : 1040 : && category != OMP_DEFAULTMAP_CAT_UNCATEGORIZED
2759 : 511 : && category != OMP_DEFAULTMAP_CAT_ALL
2760 : 511 : && i != OMP_DEFAULTMAP_CAT_UNCATEGORIZED
2761 : 341 : && i != OMP_DEFAULTMAP_CAT_ALL)
2762 : 254 : continue;
2763 : 786 : if (c->defaultmap[i] != OMP_DEFAULTMAP_UNSET)
2764 : : {
2765 : 13 : const char *pcategory = NULL;
2766 : 13 : switch (i)
2767 : : {
2768 : : case OMP_DEFAULTMAP_CAT_UNCATEGORIZED: break;
2769 : : case OMP_DEFAULTMAP_CAT_ALL: pcategory = "ALL"; break;
2770 : 1 : case OMP_DEFAULTMAP_CAT_SCALAR: pcategory = "SCALAR"; break;
2771 : 2 : case OMP_DEFAULTMAP_CAT_AGGREGATE:
2772 : 2 : pcategory = "AGGREGATE";
2773 : 2 : break;
2774 : 1 : case OMP_DEFAULTMAP_CAT_ALLOCATABLE:
2775 : 1 : pcategory = "ALLOCATABLE";
2776 : 1 : break;
2777 : 2 : case OMP_DEFAULTMAP_CAT_POINTER:
2778 : 2 : pcategory = "POINTER";
2779 : 2 : break;
2780 : : default: gcc_unreachable ();
2781 : : }
2782 : 6 : if (i == OMP_DEFAULTMAP_CAT_UNCATEGORIZED)
2783 : 4 : gfc_error ("DEFAULTMAP at %C but prior DEFAULTMAP with "
2784 : : "unspecified category");
2785 : : else
2786 : 9 : gfc_error ("DEFAULTMAP at %C but prior DEFAULTMAP for "
2787 : : "category %s", pcategory);
2788 : 13 : goto error;
2789 : : }
2790 : : }
2791 : 167 : c->defaultmap[category] = behavior;
2792 : 167 : if (gfc_match (")") != MATCH_YES)
2793 : : break;
2794 : 167 : continue;
2795 : 167 : }
2796 : 4425 : if ((mask & OMP_CLAUSE_DEFAULT)
2797 : 3470 : && (m = gfc_match_dupl_check (c->default_sharing
2798 : : == OMP_DEFAULT_UNKNOWN, "default",
2799 : : true)) != MATCH_NO)
2800 : : {
2801 : 1000 : if (m == MATCH_ERROR)
2802 : 6 : goto error;
2803 : 994 : if (gfc_match ("none") == MATCH_YES)
2804 : 584 : c->default_sharing = OMP_DEFAULT_NONE;
2805 : 410 : else if (openacc)
2806 : : {
2807 : 225 : if (gfc_match ("present") == MATCH_YES)
2808 : 195 : c->default_sharing = OMP_DEFAULT_PRESENT;
2809 : : }
2810 : : else
2811 : : {
2812 : 185 : if (gfc_match ("firstprivate") == MATCH_YES)
2813 : 8 : c->default_sharing = OMP_DEFAULT_FIRSTPRIVATE;
2814 : 177 : else if (gfc_match ("private") == MATCH_YES)
2815 : 24 : c->default_sharing = OMP_DEFAULT_PRIVATE;
2816 : 153 : else if (gfc_match ("shared") == MATCH_YES)
2817 : 153 : c->default_sharing = OMP_DEFAULT_SHARED;
2818 : : }
2819 : 994 : if (c->default_sharing == OMP_DEFAULT_UNKNOWN)
2820 : : {
2821 : 30 : if (openacc)
2822 : 30 : gfc_error ("Expected NONE or PRESENT in DEFAULT clause "
2823 : : "at %C");
2824 : : else
2825 : 0 : gfc_error ("Expected NONE, FIRSTPRIVATE, PRIVATE or SHARED "
2826 : : "in DEFAULT clause at %C");
2827 : 30 : goto error;
2828 : : }
2829 : 964 : if (gfc_match (" )") != MATCH_YES)
2830 : 9 : goto error;
2831 : 955 : continue;
2832 : : }
2833 : 2778 : if ((mask & OMP_CLAUSE_DELETE)
2834 : 343 : && gfc_match ("delete ( ") == MATCH_YES
2835 : 2778 : && gfc_match_omp_map_clause (&c->lists[OMP_LIST_MAP],
2836 : : OMP_MAP_RELEASE, true,
2837 : : allow_derived))
2838 : 308 : continue;
2839 : : /* DOACROSS: match 'doacross' and 'depend' with sink/source.
2840 : : DEPEND: match 'depend' but not sink/source. */
2841 : 2162 : m = MATCH_NO;
2842 : 2162 : if (((mask & OMP_CLAUSE_DOACROSS)
2843 : 381 : && gfc_match ("doacross ( ") == MATCH_YES)
2844 : 2516 : || (((mask & OMP_CLAUSE_DEPEND) || (mask & OMP_CLAUSE_DOACROSS))
2845 : 1561 : && (m = gfc_match ("depend ( ")) == MATCH_YES))
2846 : : {
2847 : 1095 : bool has_omp_all_memory;
2848 : 1095 : bool is_depend = m == MATCH_YES;
2849 : 1095 : gfc_namespace *ns_iter = NULL, *ns_curr = gfc_current_ns;
2850 : 1095 : match m_it = MATCH_NO;
2851 : 1095 : if (is_depend)
2852 : 1068 : m_it = gfc_match_iterator (&ns_iter, false);
2853 : 1068 : if (m_it == MATCH_ERROR)
2854 : : break;
2855 : 1090 : if (m_it == MATCH_YES && gfc_match (" , ") != MATCH_YES)
2856 : : break;
2857 : 1090 : m = MATCH_YES;
2858 : 1090 : gfc_omp_depend_doacross_op depend_op = OMP_DEPEND_OUT;
2859 : 1090 : if (gfc_match ("inoutset") == MATCH_YES)
2860 : : depend_op = OMP_DEPEND_INOUTSET;
2861 : 1078 : else if (gfc_match ("inout") == MATCH_YES)
2862 : : depend_op = OMP_DEPEND_INOUT;
2863 : 986 : else if (gfc_match ("in") == MATCH_YES)
2864 : : depend_op = OMP_DEPEND_IN;
2865 : 700 : else if (gfc_match ("out") == MATCH_YES)
2866 : : depend_op = OMP_DEPEND_OUT;
2867 : 440 : else if (gfc_match ("mutexinoutset") == MATCH_YES)
2868 : : depend_op = OMP_DEPEND_MUTEXINOUTSET;
2869 : 422 : else if (gfc_match ("depobj") == MATCH_YES)
2870 : : depend_op = OMP_DEPEND_DEPOBJ;
2871 : 385 : else if (gfc_match ("source") == MATCH_YES)
2872 : : {
2873 : 142 : if (m_it == MATCH_YES)
2874 : : {
2875 : 1 : gfc_error ("ITERATOR may not be combined with SOURCE "
2876 : : "at %C");
2877 : 17 : goto error;
2878 : : }
2879 : 141 : if (!(mask & OMP_CLAUSE_DOACROSS))
2880 : : {
2881 : 1 : gfc_error ("SOURCE at %C not permitted as dependence-type"
2882 : : " for this directive");
2883 : 1 : goto error;
2884 : : }
2885 : 140 : if (c->doacross_source)
2886 : : {
2887 : 0 : gfc_error ("Duplicated clause with SOURCE dependence-type"
2888 : : " at %C");
2889 : 0 : goto error;
2890 : : }
2891 : 140 : gfc_gobble_whitespace ();
2892 : 140 : m = gfc_match (": ");
2893 : 140 : if (m != MATCH_YES && !is_depend)
2894 : : {
2895 : 1 : gfc_error ("Expected %<:%> at %C");
2896 : 1 : goto error;
2897 : : }
2898 : 139 : if (gfc_match (")") != MATCH_YES
2899 : 145 : && !(m == MATCH_YES
2900 : 6 : && gfc_match ("omp_cur_iteration )") == MATCH_YES))
2901 : : {
2902 : 2 : gfc_error ("Expected %<)%> or %<omp_cur_iteration)%> "
2903 : : "at %C");
2904 : 2 : goto error;
2905 : : }
2906 : 137 : c->doacross_source = true;
2907 : 137 : c->depend_source = is_depend;
2908 : 1073 : continue;
2909 : : }
2910 : 243 : else if (gfc_match ("sink ") == MATCH_YES)
2911 : : {
2912 : 243 : if (!(mask & OMP_CLAUSE_DOACROSS))
2913 : : {
2914 : 2 : gfc_error ("SINK at %C not permitted as dependence-type "
2915 : : "for this directive");
2916 : 2 : goto error;
2917 : : }
2918 : 241 : if (gfc_match (": ") != MATCH_YES)
2919 : : {
2920 : 1 : gfc_error ("Expected %<:%> at %C");
2921 : 1 : goto error;
2922 : : }
2923 : 240 : if (m_it == MATCH_YES)
2924 : : {
2925 : 0 : gfc_error ("ITERATOR may not be combined with SINK "
2926 : : "at %C");
2927 : 0 : goto error;
2928 : : }
2929 : 240 : m = gfc_match_omp_doacross_sink (&c->lists[OMP_LIST_DEPEND],
2930 : : is_depend);
2931 : 240 : if (m == MATCH_YES)
2932 : 237 : continue;
2933 : 3 : goto error;
2934 : : }
2935 : : else
2936 : : m = MATCH_NO;
2937 : 705 : if (!(mask & OMP_CLAUSE_DEPEND))
2938 : : {
2939 : 0 : gfc_error ("Expected dependence-type SINK or SOURCE at %C");
2940 : 0 : goto error;
2941 : : }
2942 : 705 : head = NULL;
2943 : 705 : if (ns_iter)
2944 : 37 : gfc_current_ns = ns_iter;
2945 : 705 : if (m == MATCH_YES)
2946 : 705 : m = gfc_match_omp_variable_list (" : ",
2947 : : &c->lists[OMP_LIST_DEPEND],
2948 : : false, NULL, &head, true,
2949 : : false, &has_omp_all_memory);
2950 : 705 : if (m != MATCH_YES)
2951 : 2 : goto error;
2952 : 703 : gfc_current_ns = ns_curr;
2953 : 703 : if (has_omp_all_memory && depend_op != OMP_DEPEND_INOUT
2954 : 21 : && depend_op != OMP_DEPEND_OUT)
2955 : : {
2956 : 4 : gfc_error ("%<omp_all_memory%> used with DEPEND kind "
2957 : : "other than OUT or INOUT at %C");
2958 : 4 : goto error;
2959 : : }
2960 : 699 : gfc_omp_namelist *n;
2961 : 1429 : for (n = *head; n; n = n->next)
2962 : : {
2963 : 730 : n->u.depend_doacross_op = depend_op;
2964 : 730 : n->u2.ns = ns_iter;
2965 : 730 : if (ns_iter)
2966 : 36 : ns_iter->refs++;
2967 : : }
2968 : 699 : continue;
2969 : 699 : }
2970 : 1088 : if ((mask & OMP_CLAUSE_DESTROY)
2971 : 1067 : && gfc_match_omp_variable_list ("destroy (",
2972 : : &c->lists[OMP_LIST_DESTROY],
2973 : : true) == MATCH_YES)
2974 : 21 : continue;
2975 : 1172 : if ((mask & OMP_CLAUSE_DETACH)
2976 : 162 : && !openacc
2977 : 127 : && !c->detach
2978 : 1172 : && gfc_match_omp_detach (&c->detach) == MATCH_YES)
2979 : 126 : continue;
2980 : 955 : if ((mask & OMP_CLAUSE_DETACH)
2981 : 36 : && openacc
2982 : 35 : && gfc_match ("detach ( ") == MATCH_YES
2983 : 955 : && gfc_match_omp_map_clause (&c->lists[OMP_LIST_MAP],
2984 : : OMP_MAP_DETACH, false,
2985 : : allow_derived))
2986 : 35 : continue;
2987 : 885 : if ((mask & OMP_CLAUSE_DEVICE)
2988 : 674 : && !openacc
2989 : 1245 : && ((m = gfc_match_dupl_check (!c->device, "device", true))
2990 : : != MATCH_NO))
2991 : : {
2992 : 333 : if (m == MATCH_ERROR)
2993 : 0 : goto error;
2994 : 333 : c->ancestor = false;
2995 : 333 : if (gfc_match ("device_num : ") == MATCH_YES)
2996 : : {
2997 : 18 : if (gfc_match ("%e )", &c->device) != MATCH_YES)
2998 : : {
2999 : 1 : gfc_error ("Expected integer expression at %C");
3000 : 1 : break;
3001 : : }
3002 : : }
3003 : 315 : else if (gfc_match ("ancestor : ") == MATCH_YES)
3004 : : {
3005 : 45 : bool has_requires = false;
3006 : 45 : c->ancestor = true;
3007 : 82 : for (gfc_namespace *ns = gfc_current_ns; ns; ns = ns->parent)
3008 : 80 : if (ns->omp_requires & OMP_REQ_REVERSE_OFFLOAD)
3009 : : {
3010 : : has_requires = true;
3011 : : break;
3012 : : }
3013 : 45 : if (!has_requires)
3014 : : {
3015 : 2 : gfc_error ("%<ancestor%> device modifier not "
3016 : : "preceded by %<requires%> directive "
3017 : : "with %<reverse_offload%> clause at %C");
3018 : 5 : break;
3019 : : }
3020 : 43 : locus old_loc2 = gfc_current_locus;
3021 : 43 : if (gfc_match ("%e )", &c->device) == MATCH_YES)
3022 : : {
3023 : 43 : int device = 0;
3024 : 43 : if (!gfc_extract_int (c->device, &device) && device != 1)
3025 : : {
3026 : 1 : gfc_current_locus = old_loc2;
3027 : 1 : gfc_error ("the %<device%> clause expression must "
3028 : : "evaluate to %<1%> at %C");
3029 : 1 : break;
3030 : : }
3031 : : }
3032 : : else
3033 : : {
3034 : 0 : gfc_error ("Expected integer expression at %C");
3035 : 0 : break;
3036 : : }
3037 : : }
3038 : 270 : else if (gfc_match ("%e )", &c->device) != MATCH_YES)
3039 : : {
3040 : 13 : gfc_error ("Expected integer expression or a single device-"
3041 : : "modifier %<device_num%> or %<ancestor%> at %C");
3042 : 13 : break;
3043 : : }
3044 : 316 : continue;
3045 : 316 : }
3046 : 864 : if ((mask & OMP_CLAUSE_DEVICE)
3047 : 341 : && openacc
3048 : 314 : && gfc_match ("device ( ") == MATCH_YES
3049 : 865 : && gfc_match_omp_map_clause (&c->lists[OMP_LIST_MAP],
3050 : : OMP_MAP_FORCE_TO, true,
3051 : : /* allow_derived = */ true))
3052 : 312 : continue;
3053 : 276 : if ((mask & OMP_CLAUSE_DEVICEPTR)
3054 : 87 : && gfc_match ("deviceptr ( ") == MATCH_YES
3055 : 278 : && gfc_match_omp_map_clause (&c->lists[OMP_LIST_MAP],
3056 : : OMP_MAP_FORCE_DEVICEPTR, false,
3057 : : allow_derived))
3058 : 36 : continue;
3059 : 254 : if ((mask & OMP_CLAUSE_DEVICE_TYPE)
3060 : 204 : && gfc_match ("device_type ( ") == MATCH_YES)
3061 : : {
3062 : 51 : if (gfc_match ("host") == MATCH_YES)
3063 : 17 : c->device_type = OMP_DEVICE_TYPE_HOST;
3064 : 34 : else if (gfc_match ("nohost") == MATCH_YES)
3065 : 17 : c->device_type = OMP_DEVICE_TYPE_NOHOST;
3066 : 17 : else if (gfc_match ("any") == MATCH_YES)
3067 : 16 : c->device_type = OMP_DEVICE_TYPE_ANY;
3068 : : else
3069 : : {
3070 : 1 : gfc_error ("Expected HOST, NOHOST or ANY at %C");
3071 : 1 : break;
3072 : : }
3073 : 50 : if (gfc_match (" )") != MATCH_YES)
3074 : : break;
3075 : 50 : continue;
3076 : : }
3077 : 201 : if ((mask & OMP_CLAUSE_DEVICE_RESIDENT)
3078 : 202 : && gfc_match_omp_variable_list
3079 : 49 : ("device_resident (",
3080 : : &c->lists[OMP_LIST_DEVICE_RESIDENT], true) == MATCH_YES)
3081 : 48 : continue;
3082 : 105 : if ((mask & OMP_CLAUSE_DIST_SCHEDULE)
3083 : 97 : && c->dist_sched_kind == OMP_SCHED_NONE
3084 : 202 : && gfc_match ("dist_schedule ( static") == MATCH_YES)
3085 : : {
3086 : 97 : m = MATCH_NO;
3087 : 97 : c->dist_sched_kind = OMP_SCHED_STATIC;
3088 : 97 : m = gfc_match (" , %e )", &c->dist_chunk_size);
3089 : 97 : if (m != MATCH_YES)
3090 : 14 : m = gfc_match_char (')');
3091 : 14 : if (m != MATCH_YES)
3092 : : {
3093 : 0 : c->dist_sched_kind = OMP_SCHED_NONE;
3094 : 0 : gfc_current_locus = old_loc;
3095 : : }
3096 : : else
3097 : 97 : continue;
3098 : : }
3099 : : break;
3100 : 82 : case 'e':
3101 : 82 : if ((mask & OMP_CLAUSE_ENTER))
3102 : : {
3103 : 82 : m = gfc_match_omp_to_link ("enter (", &c->lists[OMP_LIST_ENTER]);
3104 : 82 : if (m == MATCH_ERROR)
3105 : 0 : goto error;
3106 : 82 : if (m == MATCH_YES)
3107 : 82 : continue;
3108 : : }
3109 : : break;
3110 : 2232 : case 'f':
3111 : 2281 : if ((mask & OMP_CLAUSE_FAIL)
3112 : 2232 : && (m = gfc_match_dupl_check (c->fail == OMP_MEMORDER_UNSET,
3113 : : "fail", true)) != MATCH_NO)
3114 : : {
3115 : 58 : if (m == MATCH_ERROR)
3116 : 3 : goto error;
3117 : 55 : if (gfc_match ("seq_cst") == MATCH_YES)
3118 : 6 : c->fail = OMP_MEMORDER_SEQ_CST;
3119 : 49 : else if (gfc_match ("acquire") == MATCH_YES)
3120 : 14 : c->fail = OMP_MEMORDER_ACQUIRE;
3121 : 35 : else if (gfc_match ("relaxed") == MATCH_YES)
3122 : 30 : c->fail = OMP_MEMORDER_RELAXED;
3123 : : else
3124 : : {
3125 : 5 : gfc_error ("Expected SEQ_CST, ACQUIRE or RELAXED at %C");
3126 : 5 : break;
3127 : : }
3128 : 50 : if (gfc_match (" )") != MATCH_YES)
3129 : 1 : goto error;
3130 : 49 : continue;
3131 : : }
3132 : 2217 : if ((mask & OMP_CLAUSE_FILTER)
3133 : 2174 : && (m = gfc_match_dupl_check (!c->filter, "filter", true,
3134 : : &c->filter)) != MATCH_NO)
3135 : : {
3136 : 44 : if (m == MATCH_ERROR)
3137 : 1 : goto error;
3138 : 43 : continue;
3139 : : }
3140 : 2194 : if ((mask & OMP_CLAUSE_FINAL)
3141 : 2130 : && (m = gfc_match_dupl_check (!c->final_expr, "final", true,
3142 : : &c->final_expr)) != MATCH_NO)
3143 : : {
3144 : 64 : if (m == MATCH_ERROR)
3145 : 0 : goto error;
3146 : 64 : continue;
3147 : : }
3148 : 2092 : if ((mask & OMP_CLAUSE_FINALIZE)
3149 : 2066 : && (m = gfc_match_dupl_check (!c->finalize, "finalize"))
3150 : : != MATCH_NO)
3151 : : {
3152 : 26 : if (m == MATCH_ERROR)
3153 : 0 : goto error;
3154 : 26 : c->finalize = true;
3155 : 26 : needs_space = true;
3156 : 26 : continue;
3157 : : }
3158 : 3004 : if ((mask & OMP_CLAUSE_FIRSTPRIVATE)
3159 : 2040 : && gfc_match_omp_variable_list ("firstprivate (",
3160 : : &c->lists[OMP_LIST_FIRSTPRIVATE],
3161 : : true) == MATCH_YES)
3162 : 964 : continue;
3163 : 2075 : if ((mask & OMP_CLAUSE_FROM)
3164 : 1076 : && gfc_match_motion_var_list ("from (", &c->lists[OMP_LIST_FROM],
3165 : : &head) == MATCH_YES)
3166 : 999 : continue;
3167 : 142 : if ((mask & OMP_CLAUSE_FULL)
3168 : 77 : && (m = gfc_match_dupl_check (!c->full, "full")) != MATCH_NO)
3169 : : {
3170 : 65 : if (m == MATCH_ERROR)
3171 : 0 : goto error;
3172 : 65 : c->full = needs_space = true;
3173 : 65 : continue;
3174 : : }
3175 : : break;
3176 : 1230 : case 'g':
3177 : 2421 : if ((mask & OMP_CLAUSE_GANG)
3178 : 1230 : && (m = gfc_match_dupl_check (!c->gang, "gang")) != MATCH_NO)
3179 : : {
3180 : 1196 : if (m == MATCH_ERROR)
3181 : 0 : goto error;
3182 : 1196 : c->gang = true;
3183 : 1196 : m = match_oacc_clause_gwv (c, GOMP_DIM_GANG);
3184 : 1196 : if (m == MATCH_ERROR)
3185 : : {
3186 : 5 : gfc_current_locus = old_loc;
3187 : 5 : break;
3188 : : }
3189 : 1191 : else if (m == MATCH_NO)
3190 : 972 : needs_space = true;
3191 : 1191 : continue;
3192 : : }
3193 : 68 : if ((mask & OMP_CLAUSE_GRAINSIZE)
3194 : 34 : && (m = gfc_match_dupl_check (!c->grainsize, "grainsize", true))
3195 : : != MATCH_NO)
3196 : : {
3197 : 34 : if (m == MATCH_ERROR)
3198 : 0 : goto error;
3199 : 34 : if (gfc_match ("strict : ") == MATCH_YES)
3200 : 1 : c->grainsize_strict = true;
3201 : 34 : if (gfc_match (" %e )", &c->grainsize) != MATCH_YES)
3202 : 0 : goto error;
3203 : 34 : continue;
3204 : : }
3205 : : break;
3206 : 453 : case 'h':
3207 : 489 : if ((mask & OMP_CLAUSE_HAS_DEVICE_ADDR)
3208 : 489 : && gfc_match_omp_variable_list
3209 : 36 : ("has_device_addr (", &c->lists[OMP_LIST_HAS_DEVICE_ADDR],
3210 : : false, NULL, NULL, true) == MATCH_YES)
3211 : 36 : continue;
3212 : 460 : if ((mask & OMP_CLAUSE_HINT)
3213 : 417 : && (m = gfc_match_dupl_check (!c->hint, "hint", true, &c->hint))
3214 : : != MATCH_NO)
3215 : : {
3216 : 43 : if (m == MATCH_ERROR)
3217 : 0 : goto error;
3218 : 43 : continue;
3219 : : }
3220 : 374 : if ((mask & OMP_CLAUSE_ASSUMPTIONS)
3221 : 374 : && gfc_match ("holds ( ") == MATCH_YES)
3222 : : {
3223 : 19 : gfc_expr *e;
3224 : 19 : if (gfc_match ("%e )", &e) != MATCH_YES)
3225 : 0 : goto error;
3226 : 19 : if (c->assume == NULL)
3227 : 12 : c->assume = gfc_get_omp_assumptions ();
3228 : 19 : gfc_expr_list *el = XCNEW (gfc_expr_list);
3229 : 19 : el->expr = e;
3230 : 19 : el->next = c->assume->holds;
3231 : 19 : c->assume->holds = el;
3232 : 19 : continue;
3233 : 19 : }
3234 : 709 : if ((mask & OMP_CLAUSE_HOST)
3235 : 355 : && gfc_match ("host ( ") == MATCH_YES
3236 : 710 : && gfc_match_omp_map_clause (&c->lists[OMP_LIST_MAP],
3237 : : OMP_MAP_FORCE_FROM, true,
3238 : : /* allow_derived = */ true))
3239 : 354 : continue;
3240 : : break;
3241 : 2116 : case 'i':
3242 : 2139 : if ((mask & OMP_CLAUSE_IF_PRESENT)
3243 : 2116 : && (m = gfc_match_dupl_check (!c->if_present, "if_present"))
3244 : : != MATCH_NO)
3245 : : {
3246 : 23 : if (m == MATCH_ERROR)
3247 : 0 : goto error;
3248 : 23 : c->if_present = true;
3249 : 23 : needs_space = true;
3250 : 23 : continue;
3251 : : }
3252 : 2093 : if ((mask & OMP_CLAUSE_IF)
3253 : 2093 : && (m = gfc_match_dupl_check (!c->if_expr, "if", true))
3254 : : != MATCH_NO)
3255 : : {
3256 : 1350 : if (m == MATCH_ERROR)
3257 : 18 : goto error;
3258 : 1332 : if (!openacc)
3259 : : {
3260 : : /* This should match the enum gfc_omp_if_kind order. */
3261 : : static const char *ifs[OMP_IF_LAST] = {
3262 : : "cancel : %e )",
3263 : : "parallel : %e )",
3264 : : "simd : %e )",
3265 : : "task : %e )",
3266 : : "taskloop : %e )",
3267 : : "target : %e )",
3268 : : "target data : %e )",
3269 : : "target update : %e )",
3270 : : "target enter data : %e )",
3271 : : "target exit data : %e )" };
3272 : : int i;
3273 : 4808 : for (i = 0; i < OMP_IF_LAST; i++)
3274 : 4413 : if (c->if_exprs[i] == NULL
3275 : 4413 : && gfc_match (ifs[i], &c->if_exprs[i]) == MATCH_YES)
3276 : : break;
3277 : 533 : if (i < OMP_IF_LAST)
3278 : 138 : continue;
3279 : : }
3280 : 1194 : if (gfc_match (" %e )", &c->if_expr) == MATCH_YES)
3281 : 1189 : continue;
3282 : 5 : goto error;
3283 : : }
3284 : 860 : if ((mask & OMP_CLAUSE_IN_REDUCTION)
3285 : 743 : && gfc_match_omp_clause_reduction (pc, c, openacc, allow_derived,
3286 : : openmp_target) == MATCH_YES)
3287 : 117 : continue;
3288 : 651 : if ((mask & OMP_CLAUSE_INBRANCH)
3289 : 626 : && (m = gfc_match_dupl_check (!c->inbranch && !c->notinbranch,
3290 : : "inbranch")) != MATCH_NO)
3291 : : {
3292 : 25 : if (m == MATCH_ERROR)
3293 : 0 : goto error;
3294 : 25 : c->inbranch = needs_space = true;
3295 : 25 : continue;
3296 : : }
3297 : 843 : if ((mask & OMP_CLAUSE_INDEPENDENT)
3298 : 601 : && (m = gfc_match_dupl_check (!c->independent, "independent"))
3299 : : != MATCH_NO)
3300 : : {
3301 : 242 : if (m == MATCH_ERROR)
3302 : 0 : goto error;
3303 : 242 : c->independent = true;
3304 : 242 : needs_space = true;
3305 : 242 : continue;
3306 : : }
3307 : 359 : if ((mask & OMP_CLAUSE_INDIRECT)
3308 : 359 : && (m = gfc_match_dupl_check (!c->indirect, "indirect"))
3309 : : != MATCH_NO)
3310 : : {
3311 : 61 : if (m == MATCH_ERROR)
3312 : 5 : goto error;
3313 : 60 : gfc_expr *indirect_expr = NULL;
3314 : 60 : m = gfc_match (" ( %e )", &indirect_expr);
3315 : 60 : if (m == MATCH_YES)
3316 : : {
3317 : 13 : if (!gfc_resolve_expr (indirect_expr)
3318 : 13 : || indirect_expr->ts.type != BT_LOGICAL
3319 : 23 : || indirect_expr->expr_type != EXPR_CONSTANT)
3320 : : {
3321 : 4 : gfc_error ("INDIRECT clause at %C requires a constant "
3322 : : "logical expression");
3323 : 4 : gfc_free_expr (indirect_expr);
3324 : 4 : goto error;
3325 : : }
3326 : 9 : c->indirect = indirect_expr->value.logical;
3327 : 9 : gfc_free_expr (indirect_expr);
3328 : : }
3329 : : else
3330 : 47 : c->indirect = 1;
3331 : 56 : continue;
3332 : 56 : }
3333 : 298 : if ((mask & OMP_CLAUSE_INIT)
3334 : 298 : && gfc_match ("init ( ") == MATCH_YES)
3335 : : {
3336 : 108 : m = gfc_match_omp_init (&c->lists[OMP_LIST_INIT]);
3337 : 108 : if (m == MATCH_YES)
3338 : 63 : continue;
3339 : 45 : goto error;
3340 : : }
3341 : 190 : if ((mask & OMP_CLAUSE_INTEROP)
3342 : 190 : && (m = gfc_match_dupl_check (!c->lists[OMP_LIST_INTEROP],
3343 : : "interop", true)) != MATCH_NO)
3344 : : {
3345 : : /* Note: the interop objects are saved in reverse order to match
3346 : : the order in C/C++. */
3347 : 125 : if (m == MATCH_YES
3348 : 63 : && (gfc_match_omp_variable_list ("",
3349 : : &c->lists[OMP_LIST_INTEROP],
3350 : : false, NULL, NULL, false,
3351 : : false, NULL, false, true)
3352 : : == MATCH_YES))
3353 : 62 : continue;
3354 : 1 : goto error;
3355 : : }
3356 : 247 : if ((mask & OMP_CLAUSE_IS_DEVICE_PTR)
3357 : 247 : && gfc_match_omp_variable_list
3358 : 120 : ("is_device_ptr (",
3359 : : &c->lists[OMP_LIST_IS_DEVICE_PTR], false) == MATCH_YES)
3360 : 120 : continue;
3361 : : break;
3362 : 2314 : case 'l':
3363 : 2314 : if ((mask & OMP_CLAUSE_LASTPRIVATE)
3364 : 2314 : && gfc_match ("lastprivate ( ") == MATCH_YES)
3365 : : {
3366 : 1431 : bool conditional = gfc_match ("conditional : ") == MATCH_YES;
3367 : 1431 : head = NULL;
3368 : 1431 : if (gfc_match_omp_variable_list ("",
3369 : : &c->lists[OMP_LIST_LASTPRIVATE],
3370 : : false, NULL, &head) == MATCH_YES)
3371 : : {
3372 : 1431 : gfc_omp_namelist *n;
3373 : 3737 : for (n = *head; n; n = n->next)
3374 : 2306 : n->u.lastprivate_conditional = conditional;
3375 : 1431 : continue;
3376 : 1431 : }
3377 : 0 : gfc_current_locus = old_loc;
3378 : 0 : break;
3379 : : }
3380 : 883 : end_colon = false;
3381 : 883 : head = NULL;
3382 : 883 : if ((mask & OMP_CLAUSE_LINEAR)
3383 : 883 : && gfc_match ("linear (") == MATCH_YES)
3384 : : {
3385 : 835 : bool old_linear_modifier = false;
3386 : 835 : gfc_omp_linear_op linear_op = OMP_LINEAR_DEFAULT;
3387 : 835 : gfc_expr *step = NULL;
3388 : :
3389 : 835 : if (gfc_match_omp_variable_list (" ref (",
3390 : : &c->lists[OMP_LIST_LINEAR],
3391 : : false, NULL, &head)
3392 : : == MATCH_YES)
3393 : : {
3394 : : linear_op = OMP_LINEAR_REF;
3395 : : old_linear_modifier = true;
3396 : : }
3397 : 806 : else if (gfc_match_omp_variable_list (" val (",
3398 : : &c->lists[OMP_LIST_LINEAR],
3399 : : false, NULL, &head)
3400 : : == MATCH_YES)
3401 : : {
3402 : : linear_op = OMP_LINEAR_VAL;
3403 : : old_linear_modifier = true;
3404 : : }
3405 : 794 : else if (gfc_match_omp_variable_list (" uval (",
3406 : : &c->lists[OMP_LIST_LINEAR],
3407 : : false, NULL, &head)
3408 : : == MATCH_YES)
3409 : : {
3410 : : linear_op = OMP_LINEAR_UVAL;
3411 : : old_linear_modifier = true;
3412 : : }
3413 : 784 : else if (gfc_match_omp_variable_list ("",
3414 : : &c->lists[OMP_LIST_LINEAR],
3415 : : false, &end_colon, &head)
3416 : : == MATCH_YES)
3417 : : linear_op = OMP_LINEAR_DEFAULT;
3418 : : else
3419 : : {
3420 : 2 : gfc_current_locus = old_loc;
3421 : 2 : break;
3422 : : }
3423 : : if (linear_op != OMP_LINEAR_DEFAULT)
3424 : : {
3425 : 51 : if (gfc_match (" :") == MATCH_YES)
3426 : 31 : end_colon = true;
3427 : 20 : else if (gfc_match (" )") != MATCH_YES)
3428 : : {
3429 : 0 : gfc_free_omp_namelist (*head, false, false, false, false);
3430 : 0 : gfc_current_locus = old_loc;
3431 : 0 : *head = NULL;
3432 : 0 : break;
3433 : : }
3434 : : }
3435 : 833 : gfc_gobble_whitespace ();
3436 : 833 : if (old_linear_modifier && end_colon)
3437 : : {
3438 : 31 : if (gfc_match (" %e )", &step) != MATCH_YES)
3439 : : {
3440 : 1 : gfc_free_omp_namelist (*head, false, false, false, false);
3441 : 1 : gfc_current_locus = old_loc;
3442 : 1 : *head = NULL;
3443 : 5 : goto error;
3444 : : }
3445 : : }
3446 : 802 : else if (end_colon)
3447 : : {
3448 : 710 : bool has_error = false;
3449 : : bool has_modifiers = false;
3450 : : bool has_step = false;
3451 : 710 : bool duplicate_step = false;
3452 : 710 : bool duplicate_mod = false;
3453 : 710 : while (true)
3454 : : {
3455 : 710 : old_loc = gfc_current_locus;
3456 : 710 : bool close_paren = gfc_match ("val )") == MATCH_YES;
3457 : 710 : if (close_paren || gfc_match ("val , ") == MATCH_YES)
3458 : : {
3459 : 16 : if (linear_op != OMP_LINEAR_DEFAULT)
3460 : : {
3461 : : duplicate_mod = true;
3462 : : break;
3463 : : }
3464 : 15 : linear_op = OMP_LINEAR_VAL;
3465 : 15 : has_modifiers = true;
3466 : 15 : if (close_paren)
3467 : : break;
3468 : 10 : continue;
3469 : : }
3470 : 694 : close_paren = gfc_match ("uval )") == MATCH_YES;
3471 : 694 : if (close_paren || gfc_match ("uval , ") == MATCH_YES)
3472 : : {
3473 : 6 : if (linear_op != OMP_LINEAR_DEFAULT)
3474 : : {
3475 : : duplicate_mod = true;
3476 : : break;
3477 : : }
3478 : 6 : linear_op = OMP_LINEAR_UVAL;
3479 : 6 : has_modifiers = true;
3480 : 6 : if (close_paren)
3481 : : break;
3482 : 2 : continue;
3483 : : }
3484 : 688 : close_paren = gfc_match ("ref )") == MATCH_YES;
3485 : 688 : if (close_paren || gfc_match ("ref , ") == MATCH_YES)
3486 : : {
3487 : 15 : if (linear_op != OMP_LINEAR_DEFAULT)
3488 : : {
3489 : : duplicate_mod = true;
3490 : : break;
3491 : : }
3492 : 14 : linear_op = OMP_LINEAR_REF;
3493 : 14 : has_modifiers = true;
3494 : 14 : if (close_paren)
3495 : : break;
3496 : 7 : continue;
3497 : : }
3498 : 673 : close_paren = (gfc_match ("step ( %e ) )", &step)
3499 : : == MATCH_YES);
3500 : 684 : if (close_paren
3501 : 673 : || gfc_match ("step ( %e ) , ", &step) == MATCH_YES)
3502 : : {
3503 : 38 : if (has_step)
3504 : : {
3505 : : duplicate_step = true;
3506 : : break;
3507 : : }
3508 : 37 : has_modifiers = has_step = true;
3509 : 37 : if (close_paren)
3510 : : break;
3511 : 11 : continue;
3512 : : }
3513 : 635 : if (!has_modifiers
3514 : 635 : && gfc_match ("%e )", &step) == MATCH_YES)
3515 : : {
3516 : 635 : if ((step->expr_type == EXPR_FUNCTION
3517 : 634 : || step->expr_type == EXPR_VARIABLE)
3518 : 31 : && strcmp (step->symtree->name, "step") == 0)
3519 : : {
3520 : 1 : gfc_current_locus = old_loc;
3521 : 1 : gfc_match ("step (");
3522 : 1 : has_error = true;
3523 : : }
3524 : : break;
3525 : : }
3526 : : has_error = true;
3527 : : break;
3528 : : }
3529 : 46 : if (duplicate_mod || duplicate_step)
3530 : : {
3531 : 3 : gfc_error ("Multiple %qs modifiers specified at %C",
3532 : : duplicate_mod ? "linear" : "step");
3533 : 3 : has_error = true;
3534 : : }
3535 : 680 : if (has_error)
3536 : : {
3537 : 4 : gfc_free_omp_namelist (*head, false, false, false, false);
3538 : 4 : *head = NULL;
3539 : 4 : goto error;
3540 : : }
3541 : : }
3542 : 828 : if (step == NULL)
3543 : : {
3544 : 129 : step = gfc_get_constant_expr (BT_INTEGER,
3545 : : gfc_default_integer_kind,
3546 : : &old_loc);
3547 : 129 : mpz_set_si (step->value.integer, 1);
3548 : : }
3549 : 828 : (*head)->expr = step;
3550 : 828 : if (linear_op != OMP_LINEAR_DEFAULT || old_linear_modifier)
3551 : 176 : for (gfc_omp_namelist *n = *head; n; n = n->next)
3552 : : {
3553 : 94 : n->u.linear.op = linear_op;
3554 : 94 : n->u.linear.old_modifier = old_linear_modifier;
3555 : : }
3556 : 828 : continue;
3557 : 828 : }
3558 : 52 : if ((mask & OMP_CLAUSE_LINK)
3559 : 48 : && openacc
3560 : 56 : && (gfc_match_oacc_clause_link ("link (",
3561 : : &c->lists[OMP_LIST_LINK])
3562 : : == MATCH_YES))
3563 : 4 : continue;
3564 : 84 : else if ((mask & OMP_CLAUSE_LINK)
3565 : 44 : && !openacc
3566 : 84 : && (gfc_match_omp_to_link ("link (",
3567 : : &c->lists[OMP_LIST_LINK])
3568 : : == MATCH_YES))
3569 : 40 : continue;
3570 : : break;
3571 : 5004 : case 'm':
3572 : 5004 : if ((mask & OMP_CLAUSE_MAP)
3573 : 5004 : && gfc_match ("map ( ") == MATCH_YES)
3574 : : {
3575 : 4912 : locus old_loc2 = gfc_current_locus;
3576 : 4912 : int always_modifier = 0;
3577 : 4912 : int close_modifier = 0;
3578 : 4912 : int present_modifier = 0;
3579 : 4912 : locus second_always_locus = old_loc2;
3580 : 4912 : locus second_close_locus = old_loc2;
3581 : 4912 : locus second_present_locus = old_loc2;
3582 : :
3583 : 5422 : for (;;)
3584 : : {
3585 : 5167 : locus current_locus = gfc_current_locus;
3586 : 5167 : if (gfc_match ("always ") == MATCH_YES)
3587 : : {
3588 : 139 : if (always_modifier++ == 1)
3589 : 5 : second_always_locus = current_locus;
3590 : : }
3591 : 5028 : else if (gfc_match ("close ") == MATCH_YES)
3592 : : {
3593 : 65 : if (close_modifier++ == 1)
3594 : 5 : second_close_locus = current_locus;
3595 : : }
3596 : 4963 : else if (gfc_match ("present ") == MATCH_YES)
3597 : : {
3598 : 51 : if (present_modifier++ == 1)
3599 : 4 : second_present_locus = current_locus;
3600 : : }
3601 : : else
3602 : : break;
3603 : 255 : gfc_match (", ");
3604 : 255 : }
3605 : :
3606 : 4912 : gfc_omp_map_op map_op = OMP_MAP_TOFROM;
3607 : 4912 : int always_present_modifier
3608 : 4912 : = always_modifier && present_modifier;
3609 : :
3610 : 4912 : if (gfc_match ("alloc : ") == MATCH_YES)
3611 : 593 : map_op = (present_modifier ? OMP_MAP_PRESENT_ALLOC
3612 : : : OMP_MAP_ALLOC);
3613 : 4319 : else if (gfc_match ("tofrom : ") == MATCH_YES)
3614 : 836 : map_op = (always_present_modifier ? OMP_MAP_ALWAYS_PRESENT_TOFROM
3615 : 832 : : present_modifier ? OMP_MAP_PRESENT_TOFROM
3616 : 828 : : always_modifier ? OMP_MAP_ALWAYS_TOFROM
3617 : : : OMP_MAP_TOFROM);
3618 : 3483 : else if (gfc_match ("to : ") == MATCH_YES)
3619 : 1571 : map_op = (always_present_modifier ? OMP_MAP_ALWAYS_PRESENT_TO
3620 : 1567 : : present_modifier ? OMP_MAP_PRESENT_TO
3621 : 1556 : : always_modifier ? OMP_MAP_ALWAYS_TO
3622 : : : OMP_MAP_TO);
3623 : 1912 : else if (gfc_match ("from : ") == MATCH_YES)
3624 : 1464 : map_op = (always_present_modifier ? OMP_MAP_ALWAYS_PRESENT_FROM
3625 : 1460 : : present_modifier ? OMP_MAP_PRESENT_FROM
3626 : 1456 : : always_modifier ? OMP_MAP_ALWAYS_FROM
3627 : : : OMP_MAP_FROM);
3628 : 448 : else if (gfc_match ("release : ") == MATCH_YES)
3629 : : map_op = OMP_MAP_RELEASE;
3630 : 431 : else if (gfc_match ("delete : ") == MATCH_YES)
3631 : : map_op = OMP_MAP_DELETE;
3632 : : else
3633 : : {
3634 : 384 : gfc_current_locus = old_loc2;
3635 : 384 : always_modifier = 0;
3636 : 384 : close_modifier = 0;
3637 : : }
3638 : :
3639 : 1178 : if (always_modifier > 1)
3640 : : {
3641 : 5 : gfc_error ("too many %<always%> modifiers at %L",
3642 : : &second_always_locus);
3643 : 21 : break;
3644 : : }
3645 : 4907 : if (close_modifier > 1)
3646 : : {
3647 : 4 : gfc_error ("too many %<close%> modifiers at %L",
3648 : : &second_close_locus);
3649 : 4 : break;
3650 : : }
3651 : 4903 : if (present_modifier > 1)
3652 : : {
3653 : 4 : gfc_error ("too many %<present%> modifiers at %L",
3654 : : &second_present_locus);
3655 : 4 : break;
3656 : : }
3657 : :
3658 : 4899 : head = NULL;
3659 : 4899 : if (gfc_match_omp_variable_list ("", &c->lists[OMP_LIST_MAP],
3660 : : false, NULL, &head,
3661 : : true, true) == MATCH_YES)
3662 : : {
3663 : 4896 : gfc_omp_namelist *n;
3664 : 11190 : for (n = *head; n; n = n->next)
3665 : 6294 : n->u.map.op = map_op;
3666 : 4896 : continue;
3667 : 4896 : }
3668 : 3 : gfc_current_locus = old_loc;
3669 : 3 : break;
3670 : : }
3671 : 126 : if ((mask & OMP_CLAUSE_MERGEABLE)
3672 : 92 : && (m = gfc_match_dupl_check (!c->mergeable, "mergeable"))
3673 : : != MATCH_NO)
3674 : : {
3675 : 34 : if (m == MATCH_ERROR)
3676 : 0 : goto error;
3677 : 34 : c->mergeable = needs_space = true;
3678 : 34 : continue;
3679 : : }
3680 : 111 : if ((mask & OMP_CLAUSE_MESSAGE)
3681 : 58 : && (m = gfc_match_dupl_check (!c->message, "message", true,
3682 : : &c->message)) != MATCH_NO)
3683 : : {
3684 : 58 : if (m == MATCH_ERROR)
3685 : 5 : goto error;
3686 : 53 : continue;
3687 : : }
3688 : : break;
3689 : 2892 : case 'n':
3690 : 2944 : if ((mask & OMP_CLAUSE_NO_CREATE)
3691 : 1343 : && gfc_match ("no_create ( ") == MATCH_YES
3692 : 2944 : && gfc_match_omp_map_clause (&c->lists[OMP_LIST_MAP],
3693 : : OMP_MAP_IF_PRESENT, true,
3694 : : allow_derived))
3695 : 52 : continue;
3696 : 2852 : if ((mask & OMP_CLAUSE_ASSUMPTIONS)
3697 : 2860 : && (m = gfc_match_dupl_check (!c->assume
3698 : 20 : || !c->assume->no_openmp_routines,
3699 : : "no_openmp_routines")) == MATCH_YES)
3700 : : {
3701 : 12 : if (m == MATCH_ERROR)
3702 : : goto error;
3703 : 12 : if (c->assume == NULL)
3704 : 12 : c->assume = gfc_get_omp_assumptions ();
3705 : 12 : c->assume->no_openmp_routines = needs_space = true;
3706 : 12 : continue;
3707 : : }
3708 : 2830 : if ((mask & OMP_CLAUSE_ASSUMPTIONS)
3709 : 2836 : && (m = gfc_match_dupl_check (!c->assume || !c->assume->no_openmp,
3710 : : "no_openmp")) == MATCH_YES)
3711 : : {
3712 : 2 : if (m == MATCH_ERROR)
3713 : : goto error;
3714 : 2 : if (c->assume == NULL)
3715 : 2 : c->assume = gfc_get_omp_assumptions ();
3716 : 2 : c->assume->no_openmp = needs_space = true;
3717 : 2 : continue;
3718 : : }
3719 : 2832 : if ((mask & OMP_CLAUSE_ASSUMPTIONS)
3720 : 2832 : && (m = gfc_match_dupl_check (!c->assume
3721 : 6 : || !c->assume->no_parallelism,
3722 : : "no_parallelism")) == MATCH_YES)
3723 : : {
3724 : 6 : if (m == MATCH_ERROR)
3725 : : goto error;
3726 : 6 : if (c->assume == NULL)
3727 : 6 : c->assume = gfc_get_omp_assumptions ();
3728 : 6 : c->assume->no_parallelism = needs_space = true;
3729 : 6 : continue;
3730 : : }
3731 : :
3732 : 2830 : if ((mask & OMP_CLAUSE_NOVARIANTS)
3733 : 2820 : && (m = gfc_match_dupl_check (!c->novariants, "novariants", true,
3734 : : &c->novariants))
3735 : : != MATCH_NO)
3736 : : {
3737 : 12 : if (m == MATCH_ERROR)
3738 : 2 : goto error;
3739 : 10 : continue;
3740 : : }
3741 : 2821 : if ((mask & OMP_CLAUSE_NOCONTEXT)
3742 : 2808 : && (m = gfc_match_dupl_check (!c->nocontext, "nocontext", true,
3743 : : &c->nocontext))
3744 : : != MATCH_NO)
3745 : : {
3746 : 15 : if (m == MATCH_ERROR)
3747 : 2 : goto error;
3748 : 13 : continue;
3749 : : }
3750 : 2807 : if ((mask & OMP_CLAUSE_NOGROUP)
3751 : 2793 : && (m = gfc_match_dupl_check (!c->nogroup, "nogroup"))
3752 : : != MATCH_NO)
3753 : : {
3754 : 14 : if (m == MATCH_ERROR)
3755 : 0 : goto error;
3756 : 14 : c->nogroup = needs_space = true;
3757 : 14 : continue;
3758 : : }
3759 : 2929 : if ((mask & OMP_CLAUSE_NOHOST)
3760 : 2779 : && (m = gfc_match_dupl_check (!c->nohost, "nohost")) != MATCH_NO)
3761 : : {
3762 : 151 : if (m == MATCH_ERROR)
3763 : 1 : goto error;
3764 : 150 : c->nohost = needs_space = true;
3765 : 150 : continue;
3766 : : }
3767 : 2670 : if ((mask & OMP_CLAUSE_NOTEMPORAL)
3768 : 2628 : && gfc_match_omp_variable_list ("nontemporal (",
3769 : : &c->lists[OMP_LIST_NONTEMPORAL],
3770 : : true) == MATCH_YES)
3771 : 42 : continue;
3772 : 2610 : if ((mask & OMP_CLAUSE_NOTINBRANCH)
3773 : 2587 : && (m = gfc_match_dupl_check (!c->notinbranch && !c->inbranch,
3774 : : "notinbranch")) != MATCH_NO)
3775 : : {
3776 : 25 : if (m == MATCH_ERROR)
3777 : 1 : goto error;
3778 : 24 : c->notinbranch = needs_space = true;
3779 : 24 : continue;
3780 : : }
3781 : 2690 : if ((mask & OMP_CLAUSE_NOWAIT)
3782 : 2561 : && (m = gfc_match_dupl_check (!c->nowait, "nowait")) != MATCH_NO)
3783 : : {
3784 : 132 : if (m == MATCH_ERROR)
3785 : 3 : goto error;
3786 : 129 : c->nowait = needs_space = true;
3787 : 129 : continue;
3788 : : }
3789 : 3111 : if ((mask & OMP_CLAUSE_NUM_GANGS)
3790 : 2429 : && (m = gfc_match_dupl_check (!c->num_gangs_expr, "num_gangs",
3791 : : true)) != MATCH_NO)
3792 : : {
3793 : 686 : if (m == MATCH_ERROR)
3794 : 2 : goto error;
3795 : 684 : if (gfc_match (" %e )", &c->num_gangs_expr) != MATCH_YES)
3796 : 2 : goto error;
3797 : 682 : continue;
3798 : : }
3799 : 1769 : if ((mask & OMP_CLAUSE_NUM_TASKS)
3800 : 1743 : && (m = gfc_match_dupl_check (!c->num_tasks, "num_tasks", true))
3801 : : != MATCH_NO)
3802 : : {
3803 : 26 : if (m == MATCH_ERROR)
3804 : 0 : goto error;
3805 : 26 : if (gfc_match ("strict : ") == MATCH_YES)
3806 : 1 : c->num_tasks_strict = true;
3807 : 26 : if (gfc_match (" %e )", &c->num_tasks) != MATCH_YES)
3808 : 0 : goto error;
3809 : 26 : continue;
3810 : : }
3811 : 1844 : if ((mask & OMP_CLAUSE_NUM_TEAMS)
3812 : 1717 : && (m = gfc_match_dupl_check (!c->num_teams_upper, "num_teams",
3813 : : true)) != MATCH_NO)
3814 : : {
3815 : 127 : if (m == MATCH_ERROR)
3816 : 0 : goto error;
3817 : 127 : if (gfc_match ("%e ", &c->num_teams_upper) != MATCH_YES)
3818 : 0 : goto error;
3819 : 127 : if (gfc_peek_ascii_char () == ':')
3820 : : {
3821 : 21 : c->num_teams_lower = c->num_teams_upper;
3822 : 21 : c->num_teams_upper = NULL;
3823 : 21 : if (gfc_match (": %e ", &c->num_teams_upper) != MATCH_YES)
3824 : 0 : goto error;
3825 : : }
3826 : 127 : if (gfc_match (") ") != MATCH_YES)
3827 : 0 : goto error;
3828 : 127 : continue;
3829 : : }
3830 : 2540 : if ((mask & OMP_CLAUSE_NUM_THREADS)
3831 : 1590 : && (m = gfc_match_dupl_check (!c->num_threads, "num_threads", true,
3832 : : &c->num_threads)) != MATCH_NO)
3833 : : {
3834 : 950 : if (m == MATCH_ERROR)
3835 : 0 : goto error;
3836 : 950 : continue;
3837 : : }
3838 : 1239 : if ((mask & OMP_CLAUSE_NUM_WORKERS)
3839 : 640 : && (m = gfc_match_dupl_check (!c->num_workers_expr, "num_workers",
3840 : : true, &c->num_workers_expr))
3841 : : != MATCH_NO)
3842 : : {
3843 : 603 : if (m == MATCH_ERROR)
3844 : 4 : goto error;
3845 : 599 : continue;
3846 : : }
3847 : : break;
3848 : 590 : case 'o':
3849 : 824 : if ((mask & OMP_CLAUSE_ORDER)
3850 : 590 : && (m = gfc_match_dupl_check (!c->order_concurrent, "order ("))
3851 : : != MATCH_NO)
3852 : : {
3853 : 245 : if (m == MATCH_ERROR)
3854 : 8 : goto error;
3855 : 237 : if (gfc_match (" reproducible : concurrent )") == MATCH_YES)
3856 : 55 : c->order_reproducible = true;
3857 : 182 : else if (gfc_match (" concurrent )") == MATCH_YES)
3858 : : ;
3859 : 50 : else if (gfc_match (" unconstrained : concurrent )") == MATCH_YES)
3860 : 47 : c->order_unconstrained = true;
3861 : : else
3862 : : {
3863 : 3 : gfc_error ("Expected ORDER(CONCURRENT) at %C "
3864 : : "with optional %<reproducible%> or "
3865 : : "%<unconstrained%> modifier");
3866 : 3 : goto error;
3867 : : }
3868 : 234 : c->order_concurrent = true;
3869 : 234 : continue;
3870 : : }
3871 : 345 : if ((mask & OMP_CLAUSE_ORDERED)
3872 : 345 : && (m = gfc_match_dupl_check (!c->ordered, "ordered"))
3873 : : != MATCH_NO)
3874 : : {
3875 : 342 : if (m == MATCH_ERROR)
3876 : 0 : goto error;
3877 : 342 : gfc_expr *cexpr = NULL;
3878 : 342 : m = gfc_match (" ( %e )", &cexpr);
3879 : :
3880 : 342 : c->ordered = true;
3881 : 342 : if (m == MATCH_YES)
3882 : : {
3883 : 143 : int ordered = 0;
3884 : 143 : if (gfc_extract_int (cexpr, &ordered, -1))
3885 : 0 : ordered = 0;
3886 : 143 : else if (ordered <= 0)
3887 : : {
3888 : 0 : gfc_error_now ("ORDERED clause argument not"
3889 : : " constant positive integer at %C");
3890 : 0 : ordered = 0;
3891 : : }
3892 : 143 : c->orderedc = ordered;
3893 : 143 : gfc_free_expr (cexpr);
3894 : 143 : continue;
3895 : 143 : }
3896 : :
3897 : 199 : needs_space = true;
3898 : 199 : continue;
3899 : 199 : }
3900 : : break;
3901 : 3077 : case 'p':
3902 : 3077 : if (mask & OMP_CLAUSE_PARTIAL)
3903 : : {
3904 : 276 : if ((m = gfc_match_dupl_check (!c->partial, "partial"))
3905 : : != MATCH_NO)
3906 : : {
3907 : 276 : int expr;
3908 : 276 : if (m == MATCH_ERROR)
3909 : 0 : goto error;
3910 : :
3911 : 276 : c->partial = -1;
3912 : :
3913 : 276 : gfc_expr *cexpr = NULL;
3914 : 276 : m = gfc_match (" ( %e )", &cexpr);
3915 : 276 : if (m == MATCH_NO)
3916 : : ;
3917 : 251 : else if (m == MATCH_YES
3918 : 251 : && !gfc_extract_int (cexpr, &expr, -1)
3919 : 502 : && expr > 0)
3920 : 247 : c->partial = expr;
3921 : : else
3922 : 4 : gfc_error_now ("PARTIAL clause argument not constant "
3923 : : "positive integer at %C");
3924 : 276 : gfc_free_expr (cexpr);
3925 : 276 : continue;
3926 : 276 : }
3927 : : }
3928 : 2870 : if ((mask & OMP_CLAUSE_COPY)
3929 : 877 : && gfc_match ("pcopy ( ") == MATCH_YES
3930 : 2871 : && gfc_match_omp_map_clause (&c->lists[OMP_LIST_MAP],
3931 : : OMP_MAP_TOFROM, true, allow_derived))
3932 : 69 : continue;
3933 : 2806 : if ((mask & OMP_CLAUSE_COPYIN)
3934 : 1904 : && gfc_match ("pcopyin ( ") == MATCH_YES
3935 : 2806 : && gfc_match_omp_map_clause (&c->lists[OMP_LIST_MAP],
3936 : : OMP_MAP_TO, true, allow_derived))
3937 : 74 : continue;
3938 : 2731 : if ((mask & OMP_CLAUSE_COPYOUT)
3939 : 735 : && gfc_match ("pcopyout ( ") == MATCH_YES
3940 : 2731 : && gfc_match_omp_map_clause (&c->lists[OMP_LIST_MAP],
3941 : : OMP_MAP_FROM, true, allow_derived))
3942 : 73 : continue;
3943 : 2600 : if ((mask & OMP_CLAUSE_CREATE)
3944 : 672 : && gfc_match ("pcreate ( ") == MATCH_YES
3945 : 2600 : && gfc_match_omp_map_clause (&c->lists[OMP_LIST_MAP],
3946 : : OMP_MAP_ALLOC, true, allow_derived))
3947 : 15 : continue;
3948 : 2986 : if ((mask & OMP_CLAUSE_PRESENT)
3949 : 647 : && gfc_match ("present ( ") == MATCH_YES
3950 : 2988 : && gfc_match_omp_map_clause (&c->lists[OMP_LIST_MAP],
3951 : : OMP_MAP_FORCE_PRESENT, false,
3952 : : allow_derived))
3953 : 416 : continue;
3954 : 2177 : if ((mask & OMP_CLAUSE_COPY)
3955 : 231 : && gfc_match ("present_or_copy ( ") == MATCH_YES
3956 : 2177 : && gfc_match_omp_map_clause (&c->lists[OMP_LIST_MAP],
3957 : : OMP_MAP_TOFROM, true,
3958 : : allow_derived))
3959 : 23 : continue;
3960 : 2171 : if ((mask & OMP_CLAUSE_COPYIN)
3961 : 1303 : && gfc_match ("present_or_copyin ( ") == MATCH_YES
3962 : 2171 : && gfc_match_omp_map_clause (&c->lists[OMP_LIST_MAP],
3963 : : OMP_MAP_TO, true, allow_derived))
3964 : 40 : continue;
3965 : 2126 : if ((mask & OMP_CLAUSE_COPYOUT)
3966 : 173 : && gfc_match ("present_or_copyout ( ") == MATCH_YES
3967 : 2126 : && gfc_match_omp_map_clause (&c->lists[OMP_LIST_MAP],
3968 : : OMP_MAP_FROM, true, allow_derived))
3969 : 35 : continue;
3970 : 2084 : if ((mask & OMP_CLAUSE_CREATE)
3971 : 143 : && gfc_match ("present_or_create ( ") == MATCH_YES
3972 : 2084 : && gfc_match_omp_map_clause (&c->lists[OMP_LIST_MAP],
3973 : : OMP_MAP_ALLOC, true, allow_derived))
3974 : 28 : continue;
3975 : 2062 : if ((mask & OMP_CLAUSE_PRIORITY)
3976 : 2028 : && (m = gfc_match_dupl_check (!c->priority, "priority", true,
3977 : : &c->priority)) != MATCH_NO)
3978 : : {
3979 : 34 : if (m == MATCH_ERROR)
3980 : 0 : goto error;
3981 : 34 : continue;
3982 : : }
3983 : 3911 : if ((mask & OMP_CLAUSE_PRIVATE)
3984 : 1994 : && gfc_match_omp_variable_list ("private (",
3985 : : &c->lists[OMP_LIST_PRIVATE],
3986 : : true) == MATCH_YES)
3987 : 1917 : continue;
3988 : 141 : if ((mask & OMP_CLAUSE_PROC_BIND)
3989 : 141 : && (m = gfc_match_dupl_check ((c->proc_bind
3990 : 64 : == OMP_PROC_BIND_UNKNOWN),
3991 : : "proc_bind", true)) != MATCH_NO)
3992 : : {
3993 : 64 : if (m == MATCH_ERROR)
3994 : 0 : goto error;
3995 : 64 : if (gfc_match ("primary )") == MATCH_YES)
3996 : 1 : c->proc_bind = OMP_PROC_BIND_PRIMARY;
3997 : 63 : else if (gfc_match ("master )") == MATCH_YES)
3998 : 9 : c->proc_bind = OMP_PROC_BIND_MASTER;
3999 : 54 : else if (gfc_match ("spread )") == MATCH_YES)
4000 : 53 : c->proc_bind = OMP_PROC_BIND_SPREAD;
4001 : 1 : else if (gfc_match ("close )") == MATCH_YES)
4002 : 1 : c->proc_bind = OMP_PROC_BIND_CLOSE;
4003 : : else
4004 : 0 : goto error;
4005 : 64 : continue;
4006 : : }
4007 : : break;
4008 : 4578 : case 'r':
4009 : 5068 : if ((mask & OMP_CLAUSE_ATOMIC)
4010 : 4578 : && (m = gfc_match_dupl_atomic ((c->atomic_op
4011 : : == GFC_OMP_ATOMIC_UNSET),
4012 : : "read")) != MATCH_NO)
4013 : : {
4014 : 490 : if (m == MATCH_ERROR)
4015 : 0 : goto error;
4016 : 490 : c->atomic_op = GFC_OMP_ATOMIC_READ;
4017 : 490 : needs_space = true;
4018 : 490 : continue;
4019 : : }
4020 : 8139 : if ((mask & OMP_CLAUSE_REDUCTION)
4021 : 4088 : && gfc_match_omp_clause_reduction (pc, c, openacc,
4022 : : allow_derived) == MATCH_YES)
4023 : 4051 : continue;
4024 : 47 : if ((mask & OMP_CLAUSE_MEMORDER)
4025 : 65 : && (m = gfc_match_dupl_memorder ((c->memorder
4026 : 28 : == OMP_MEMORDER_UNSET),
4027 : : "relaxed")) != MATCH_NO)
4028 : : {
4029 : 10 : if (m == MATCH_ERROR)
4030 : 0 : goto error;
4031 : 10 : c->memorder = OMP_MEMORDER_RELAXED;
4032 : 10 : needs_space = true;
4033 : 10 : continue;
4034 : : }
4035 : 44 : if ((mask & OMP_CLAUSE_MEMORDER)
4036 : 45 : && (m = gfc_match_dupl_memorder ((c->memorder
4037 : 18 : == OMP_MEMORDER_UNSET),
4038 : : "release")) != MATCH_NO)
4039 : : {
4040 : 18 : if (m == MATCH_ERROR)
4041 : 1 : goto error;
4042 : 17 : c->memorder = OMP_MEMORDER_RELEASE;
4043 : 17 : needs_space = true;
4044 : 17 : continue;
4045 : : }
4046 : : break;
4047 : 3023 : case 's':
4048 : 3116 : if ((mask & OMP_CLAUSE_SAFELEN)
4049 : 3023 : && (m = gfc_match_dupl_check (!c->safelen_expr, "safelen",
4050 : : true, &c->safelen_expr))
4051 : : != MATCH_NO)
4052 : : {
4053 : 93 : if (m == MATCH_ERROR)
4054 : 0 : goto error;
4055 : 93 : continue;
4056 : : }
4057 : 2930 : if ((mask & OMP_CLAUSE_SCHEDULE)
4058 : 2930 : && (m = gfc_match_dupl_check (c->sched_kind == OMP_SCHED_NONE,
4059 : : "schedule", true)) != MATCH_NO)
4060 : : {
4061 : 809 : if (m == MATCH_ERROR)
4062 : 0 : goto error;
4063 : 809 : int nmodifiers = 0;
4064 : 809 : locus old_loc2 = gfc_current_locus;
4065 : 827 : do
4066 : : {
4067 : 818 : if (gfc_match ("simd") == MATCH_YES)
4068 : : {
4069 : 18 : c->sched_simd = true;
4070 : 18 : nmodifiers++;
4071 : : }
4072 : 800 : else if (gfc_match ("monotonic") == MATCH_YES)
4073 : : {
4074 : 30 : c->sched_monotonic = true;
4075 : 30 : nmodifiers++;
4076 : : }
4077 : 770 : else if (gfc_match ("nonmonotonic") == MATCH_YES)
4078 : : {
4079 : 35 : c->sched_nonmonotonic = true;
4080 : 35 : nmodifiers++;
4081 : : }
4082 : : else
4083 : : {
4084 : 735 : if (nmodifiers)
4085 : 0 : gfc_current_locus = old_loc2;
4086 : : break;
4087 : : }
4088 : 92 : if (nmodifiers == 1
4089 : 83 : && gfc_match (" , ") == MATCH_YES)
4090 : 9 : continue;
4091 : 74 : else if (gfc_match (" : ") == MATCH_YES)
4092 : : break;
4093 : 0 : gfc_current_locus = old_loc2;
4094 : 0 : break;
4095 : : }
4096 : : while (1);
4097 : 809 : if (gfc_match ("static") == MATCH_YES)
4098 : 425 : c->sched_kind = OMP_SCHED_STATIC;
4099 : 384 : else if (gfc_match ("dynamic") == MATCH_YES)
4100 : 164 : c->sched_kind = OMP_SCHED_DYNAMIC;
4101 : 220 : else if (gfc_match ("guided") == MATCH_YES)
4102 : 127 : c->sched_kind = OMP_SCHED_GUIDED;
4103 : 93 : else if (gfc_match ("runtime") == MATCH_YES)
4104 : 85 : c->sched_kind = OMP_SCHED_RUNTIME;
4105 : 8 : else if (gfc_match ("auto") == MATCH_YES)
4106 : 8 : c->sched_kind = OMP_SCHED_AUTO;
4107 : 809 : if (c->sched_kind != OMP_SCHED_NONE)
4108 : : {
4109 : 809 : m = MATCH_NO;
4110 : 809 : if (c->sched_kind != OMP_SCHED_RUNTIME
4111 : 809 : && c->sched_kind != OMP_SCHED_AUTO)
4112 : 716 : m = gfc_match (" , %e )", &c->chunk_size);
4113 : 716 : if (m != MATCH_YES)
4114 : 299 : m = gfc_match_char (')');
4115 : 299 : if (m != MATCH_YES)
4116 : 0 : c->sched_kind = OMP_SCHED_NONE;
4117 : : }
4118 : 809 : if (c->sched_kind != OMP_SCHED_NONE)
4119 : 809 : continue;
4120 : : else
4121 : 0 : gfc_current_locus = old_loc;
4122 : : }
4123 : 2304 : if ((mask & OMP_CLAUSE_SELF)
4124 : 335 : && !(mask & OMP_CLAUSE_HOST) /* OpenACC compute construct */
4125 : 2361 : && (m = gfc_match_dupl_check (!c->self_expr, "self"))
4126 : : != MATCH_NO)
4127 : : {
4128 : 186 : if (m == MATCH_ERROR)
4129 : 3 : goto error;
4130 : 183 : m = gfc_match (" ( %e )", &c->self_expr);
4131 : 183 : if (m == MATCH_ERROR)
4132 : : {
4133 : 0 : gfc_current_locus = old_loc;
4134 : 0 : break;
4135 : : }
4136 : 183 : else if (m == MATCH_NO)
4137 : : {
4138 : 9 : c->self_expr = gfc_get_logical_expr (gfc_default_logical_kind,
4139 : : NULL, true);
4140 : 9 : needs_space = true;
4141 : : }
4142 : 183 : continue;
4143 : : }
4144 : 2029 : if ((mask & OMP_CLAUSE_SELF)
4145 : 149 : && (mask & OMP_CLAUSE_HOST) /* OpenACC 'update' directive */
4146 : 95 : && gfc_match ("self ( ") == MATCH_YES
4147 : 2030 : && gfc_match_omp_map_clause (&c->lists[OMP_LIST_MAP],
4148 : : OMP_MAP_FORCE_FROM, true,
4149 : : /* allow_derived = */ true))
4150 : 94 : continue;
4151 : 2189 : if ((mask & OMP_CLAUSE_SEQ)
4152 : 1841 : && (m = gfc_match_dupl_check (!c->seq, "seq")) != MATCH_NO)
4153 : : {
4154 : 348 : if (m == MATCH_ERROR)
4155 : 0 : goto error;
4156 : 348 : c->seq = true;
4157 : 348 : needs_space = true;
4158 : 348 : continue;
4159 : : }
4160 : 1634 : if ((mask & OMP_CLAUSE_MEMORDER)
4161 : 1634 : && (m = gfc_match_dupl_memorder ((c->memorder
4162 : 141 : == OMP_MEMORDER_UNSET),
4163 : : "seq_cst")) != MATCH_NO)
4164 : : {
4165 : 141 : if (m == MATCH_ERROR)
4166 : 0 : goto error;
4167 : 141 : c->memorder = OMP_MEMORDER_SEQ_CST;
4168 : 141 : needs_space = true;
4169 : 141 : continue;
4170 : : }
4171 : 2315 : if ((mask & OMP_CLAUSE_SHARED)
4172 : 1352 : && gfc_match_omp_variable_list ("shared (",
4173 : : &c->lists[OMP_LIST_SHARED],
4174 : : true) == MATCH_YES)
4175 : 963 : continue;
4176 : 507 : if ((mask & OMP_CLAUSE_SIMDLEN)
4177 : 389 : && (m = gfc_match_dupl_check (!c->simdlen_expr, "simdlen", true,
4178 : : &c->simdlen_expr)) != MATCH_NO)
4179 : : {
4180 : 118 : if (m == MATCH_ERROR)
4181 : 0 : goto error;
4182 : 118 : continue;
4183 : : }
4184 : 293 : if ((mask & OMP_CLAUSE_SIMD)
4185 : 271 : && (m = gfc_match_dupl_check (!c->simd, "simd")) != MATCH_NO)
4186 : : {
4187 : 22 : if (m == MATCH_ERROR)
4188 : 0 : goto error;
4189 : 22 : c->simd = needs_space = true;
4190 : 22 : continue;
4191 : : }
4192 : 288 : if ((mask & OMP_CLAUSE_SEVERITY)
4193 : 249 : && (m = gfc_match_dupl_check (!c->severity, "severity", true))
4194 : : != MATCH_NO)
4195 : : {
4196 : 45 : if (m == MATCH_ERROR)
4197 : 2 : goto error;
4198 : 43 : if (gfc_match ("fatal )") == MATCH_YES)
4199 : 10 : c->severity = OMP_SEVERITY_FATAL;
4200 : 33 : else if (gfc_match ("warning )") == MATCH_YES)
4201 : 29 : c->severity = OMP_SEVERITY_WARNING;
4202 : : else
4203 : : {
4204 : 4 : gfc_error ("Expected FATAL or WARNING in SEVERITY clause "
4205 : : "at %C");
4206 : 4 : goto error;
4207 : : }
4208 : 39 : continue;
4209 : : }
4210 : 204 : if ((mask & OMP_CLAUSE_SIZES)
4211 : 204 : && ((m = gfc_match_dupl_check (!c->sizes_list, "sizes"))
4212 : : != MATCH_NO))
4213 : : {
4214 : 203 : if (m == MATCH_ERROR)
4215 : 0 : goto error;
4216 : 203 : m = match_omp_oacc_expr_list (" (", &c->sizes_list, false, true);
4217 : 203 : if (m == MATCH_ERROR)
4218 : 7 : goto error;
4219 : 196 : if (m == MATCH_YES)
4220 : 195 : continue;
4221 : 1 : gfc_error ("Expected %<(%> after %qs at %C", "sizes");
4222 : 1 : goto error;
4223 : : }
4224 : : break;
4225 : 1196 : case 't':
4226 : 1261 : if ((mask & OMP_CLAUSE_TASK_REDUCTION)
4227 : 1196 : && gfc_match_omp_clause_reduction (pc, c, openacc,
4228 : : allow_derived) == MATCH_YES)
4229 : 65 : continue;
4230 : 1203 : if ((mask & OMP_CLAUSE_THREAD_LIMIT)
4231 : 1131 : && (m = gfc_match_dupl_check (!c->thread_limit, "thread_limit",
4232 : : true, &c->thread_limit))
4233 : : != MATCH_NO)
4234 : : {
4235 : 72 : if (m == MATCH_ERROR)
4236 : 0 : goto error;
4237 : 72 : continue;
4238 : : }
4239 : 1072 : if ((mask & OMP_CLAUSE_THREADS)
4240 : 1059 : && (m = gfc_match_dupl_check (!c->threads, "threads"))
4241 : : != MATCH_NO)
4242 : : {
4243 : 13 : if (m == MATCH_ERROR)
4244 : 0 : goto error;
4245 : 13 : c->threads = needs_space = true;
4246 : 13 : continue;
4247 : : }
4248 : 1243 : if ((mask & OMP_CLAUSE_TILE)
4249 : 221 : && !c->tile_list
4250 : 1267 : && match_omp_oacc_expr_list ("tile (", &c->tile_list,
4251 : : true, false) == MATCH_YES)
4252 : 197 : continue;
4253 : 849 : if ((mask & OMP_CLAUSE_TO) && (mask & OMP_CLAUSE_LINK))
4254 : : {
4255 : : /* Declare target: 'to' is an alias for 'enter';
4256 : : 'to' is deprecated since 5.2. */
4257 : 109 : m = gfc_match_omp_to_link ("to (", &c->lists[OMP_LIST_TO]);
4258 : 109 : if (m == MATCH_ERROR)
4259 : 0 : goto error;
4260 : 109 : if (m == MATCH_YES)
4261 : 109 : continue;
4262 : : }
4263 : 1456 : else if ((mask & OMP_CLAUSE_TO)
4264 : 740 : && gfc_match_motion_var_list ("to (", &c->lists[OMP_LIST_TO],
4265 : : &head) == MATCH_YES)
4266 : 716 : continue;
4267 : : break;
4268 : 1507 : case 'u':
4269 : 1565 : if ((mask & OMP_CLAUSE_UNIFORM)
4270 : 1507 : && gfc_match_omp_variable_list ("uniform (",
4271 : : &c->lists[OMP_LIST_UNIFORM],
4272 : : false) == MATCH_YES)
4273 : 58 : continue;
4274 : 1590 : if ((mask & OMP_CLAUSE_UNTIED)
4275 : 1449 : && (m = gfc_match_dupl_check (!c->untied, "untied")) != MATCH_NO)
4276 : : {
4277 : 141 : if (m == MATCH_ERROR)
4278 : 0 : goto error;
4279 : 141 : c->untied = needs_space = true;
4280 : 141 : continue;
4281 : : }
4282 : 1552 : if ((mask & OMP_CLAUSE_ATOMIC)
4283 : 1308 : && (m = gfc_match_dupl_atomic ((c->atomic_op
4284 : : == GFC_OMP_ATOMIC_UNSET),
4285 : : "update")) != MATCH_NO)
4286 : : {
4287 : 245 : if (m == MATCH_ERROR)
4288 : 1 : goto error;
4289 : 244 : c->atomic_op = GFC_OMP_ATOMIC_UPDATE;
4290 : 244 : needs_space = true;
4291 : 244 : continue;
4292 : : }
4293 : 1085 : if ((mask & OMP_CLAUSE_USE)
4294 : 1063 : && gfc_match_omp_variable_list ("use (",
4295 : : &c->lists[OMP_LIST_USE],
4296 : : true) == MATCH_YES)
4297 : 22 : continue;
4298 : 1101 : if ((mask & OMP_CLAUSE_USE_DEVICE)
4299 : 1041 : && gfc_match_omp_variable_list ("use_device (",
4300 : : &c->lists[OMP_LIST_USE_DEVICE],
4301 : : true) == MATCH_YES)
4302 : 60 : continue;
4303 : 1144 : if ((mask & OMP_CLAUSE_USE_DEVICE_PTR)
4304 : 1909 : && gfc_match_omp_variable_list
4305 : 928 : ("use_device_ptr (",
4306 : : &c->lists[OMP_LIST_USE_DEVICE_PTR], false) == MATCH_YES)
4307 : 163 : continue;
4308 : 1583 : if ((mask & OMP_CLAUSE_USE_DEVICE_ADDR)
4309 : 1583 : && gfc_match_omp_variable_list
4310 : 765 : ("use_device_addr (", &c->lists[OMP_LIST_USE_DEVICE_ADDR],
4311 : : false, NULL, NULL, true) == MATCH_YES)
4312 : 765 : continue;
4313 : 96 : if ((mask & OMP_CLAUSE_USES_ALLOCATORS)
4314 : 53 : && (gfc_match ("uses_allocators ( ") == MATCH_YES))
4315 : : {
4316 : 47 : if (gfc_match_omp_clause_uses_allocators (c) != MATCH_YES)
4317 : 4 : goto error;
4318 : 43 : continue;
4319 : : }
4320 : : break;
4321 : 1570 : case 'v':
4322 : : /* VECTOR_LENGTH must be matched before VECTOR, because the latter
4323 : : doesn't unconditionally match '('. */
4324 : 2139 : if ((mask & OMP_CLAUSE_VECTOR_LENGTH)
4325 : 1570 : && (m = gfc_match_dupl_check (!c->vector_length_expr,
4326 : : "vector_length", true,
4327 : : &c->vector_length_expr))
4328 : : != MATCH_NO)
4329 : : {
4330 : 573 : if (m == MATCH_ERROR)
4331 : 4 : goto error;
4332 : 569 : continue;
4333 : : }
4334 : 1989 : if ((mask & OMP_CLAUSE_VECTOR)
4335 : 997 : && (m = gfc_match_dupl_check (!c->vector, "vector")) != MATCH_NO)
4336 : : {
4337 : 995 : if (m == MATCH_ERROR)
4338 : 0 : goto error;
4339 : 995 : c->vector = true;
4340 : 995 : m = match_oacc_clause_gwv (c, GOMP_DIM_VECTOR);
4341 : 995 : if (m == MATCH_ERROR)
4342 : 3 : goto error;
4343 : 992 : if (m == MATCH_NO)
4344 : 860 : needs_space = true;
4345 : 992 : continue;
4346 : : }
4347 : : break;
4348 : 1482 : case 'w':
4349 : 1482 : if ((mask & OMP_CLAUSE_WAIT)
4350 : 1482 : && gfc_match ("wait") == MATCH_YES)
4351 : : {
4352 : 192 : m = match_omp_oacc_expr_list (" (", &c->wait_list, false, false);
4353 : 192 : if (m == MATCH_ERROR)
4354 : 9 : goto error;
4355 : 183 : else if (m == MATCH_NO)
4356 : : {
4357 : 47 : gfc_expr *expr
4358 : 47 : = gfc_get_constant_expr (BT_INTEGER,
4359 : : gfc_default_integer_kind,
4360 : : &gfc_current_locus);
4361 : 47 : mpz_set_si (expr->value.integer, GOMP_ASYNC_NOVAL);
4362 : 47 : gfc_expr_list **expr_list = &c->wait_list;
4363 : 56 : while (*expr_list)
4364 : 9 : expr_list = &(*expr_list)->next;
4365 : 47 : *expr_list = gfc_get_expr_list ();
4366 : 47 : (*expr_list)->expr = expr;
4367 : 47 : needs_space = true;
4368 : : }
4369 : 183 : continue;
4370 : 183 : }
4371 : 1303 : if ((mask & OMP_CLAUSE_WEAK)
4372 : 1290 : && (m = gfc_match_dupl_check (!c->weak, "weak"))
4373 : : != MATCH_NO)
4374 : : {
4375 : 14 : if (m == MATCH_ERROR)
4376 : 1 : goto error;
4377 : 13 : c->weak = true;
4378 : 13 : needs_space = true;
4379 : 13 : continue;
4380 : : }
4381 : 2137 : if ((mask & OMP_CLAUSE_WORKER)
4382 : 1276 : && (m = gfc_match_dupl_check (!c->worker, "worker")) != MATCH_NO)
4383 : : {
4384 : 864 : if (m == MATCH_ERROR)
4385 : 0 : goto error;
4386 : 864 : c->worker = true;
4387 : 864 : m = match_oacc_clause_gwv (c, GOMP_DIM_WORKER);
4388 : 864 : if (m == MATCH_ERROR)
4389 : 3 : goto error;
4390 : 861 : else if (m == MATCH_NO)
4391 : 760 : needs_space = true;
4392 : 861 : continue;
4393 : : }
4394 : 824 : if ((mask & OMP_CLAUSE_ATOMIC)
4395 : 412 : && (m = gfc_match_dupl_atomic ((c->atomic_op
4396 : : == GFC_OMP_ATOMIC_UNSET),
4397 : : "write")) != MATCH_NO)
4398 : : {
4399 : 412 : if (m == MATCH_ERROR)
4400 : 0 : goto error;
4401 : 412 : c->atomic_op = GFC_OMP_ATOMIC_WRITE;
4402 : 412 : needs_space = true;
4403 : 412 : continue;
4404 : : }
4405 : : break;
4406 : : }
4407 : : break;
4408 : 44945 : }
4409 : :
4410 : 33775 : end:
4411 : 33519 : if (error || gfc_match_omp_eos () != MATCH_YES)
4412 : : {
4413 : 517 : if (!gfc_error_flag_test ())
4414 : 131 : gfc_error ("Failed to match clause at %C");
4415 : 517 : gfc_free_omp_clauses (c);
4416 : 517 : return MATCH_ERROR;
4417 : : }
4418 : :
4419 : 33258 : *cp = c;
4420 : 33258 : return MATCH_YES;
4421 : :
4422 : 256 : error:
4423 : 256 : error = true;
4424 : 256 : goto end;
4425 : : }
4426 : :
4427 : :
4428 : : #define OACC_PARALLEL_CLAUSES \
4429 : : (omp_mask (OMP_CLAUSE_IF) | OMP_CLAUSE_ASYNC | OMP_CLAUSE_NUM_GANGS \
4430 : : | OMP_CLAUSE_NUM_WORKERS | OMP_CLAUSE_VECTOR_LENGTH | OMP_CLAUSE_REDUCTION \
4431 : : | OMP_CLAUSE_COPY | OMP_CLAUSE_COPYIN | OMP_CLAUSE_COPYOUT \
4432 : : | OMP_CLAUSE_CREATE | OMP_CLAUSE_NO_CREATE | OMP_CLAUSE_PRESENT \
4433 : : | OMP_CLAUSE_DEVICEPTR | OMP_CLAUSE_PRIVATE | OMP_CLAUSE_FIRSTPRIVATE \
4434 : : | OMP_CLAUSE_DEFAULT | OMP_CLAUSE_WAIT | OMP_CLAUSE_ATTACH \
4435 : : | OMP_CLAUSE_SELF)
4436 : : #define OACC_KERNELS_CLAUSES \
4437 : : (omp_mask (OMP_CLAUSE_IF) | OMP_CLAUSE_ASYNC | OMP_CLAUSE_NUM_GANGS \
4438 : : | OMP_CLAUSE_NUM_WORKERS | OMP_CLAUSE_VECTOR_LENGTH | OMP_CLAUSE_DEVICEPTR \
4439 : : | OMP_CLAUSE_COPY | OMP_CLAUSE_COPYIN | OMP_CLAUSE_COPYOUT \
4440 : : | OMP_CLAUSE_CREATE | OMP_CLAUSE_NO_CREATE | OMP_CLAUSE_PRESENT \
4441 : : | OMP_CLAUSE_DEFAULT | OMP_CLAUSE_WAIT | OMP_CLAUSE_ATTACH \
4442 : : | OMP_CLAUSE_SELF)
4443 : : #define OACC_SERIAL_CLAUSES \
4444 : : (omp_mask (OMP_CLAUSE_IF) | OMP_CLAUSE_ASYNC | OMP_CLAUSE_REDUCTION \
4445 : : | OMP_CLAUSE_COPY | OMP_CLAUSE_COPYIN | OMP_CLAUSE_COPYOUT \
4446 : : | OMP_CLAUSE_CREATE | OMP_CLAUSE_NO_CREATE | OMP_CLAUSE_PRESENT \
4447 : : | OMP_CLAUSE_DEVICEPTR | OMP_CLAUSE_PRIVATE | OMP_CLAUSE_FIRSTPRIVATE \
4448 : : | OMP_CLAUSE_DEFAULT | OMP_CLAUSE_WAIT | OMP_CLAUSE_ATTACH \
4449 : : | OMP_CLAUSE_SELF)
4450 : : #define OACC_DATA_CLAUSES \
4451 : : (omp_mask (OMP_CLAUSE_IF) | OMP_CLAUSE_DEVICEPTR | OMP_CLAUSE_COPY \
4452 : : | OMP_CLAUSE_COPYIN | OMP_CLAUSE_COPYOUT | OMP_CLAUSE_CREATE \
4453 : : | OMP_CLAUSE_NO_CREATE | OMP_CLAUSE_PRESENT | OMP_CLAUSE_ATTACH \
4454 : : | OMP_CLAUSE_DEFAULT)
4455 : : #define OACC_LOOP_CLAUSES \
4456 : : (omp_mask (OMP_CLAUSE_COLLAPSE) | OMP_CLAUSE_GANG | OMP_CLAUSE_WORKER \
4457 : : | OMP_CLAUSE_VECTOR | OMP_CLAUSE_SEQ | OMP_CLAUSE_INDEPENDENT \
4458 : : | OMP_CLAUSE_PRIVATE | OMP_CLAUSE_REDUCTION | OMP_CLAUSE_AUTO \
4459 : : | OMP_CLAUSE_TILE)
4460 : : #define OACC_PARALLEL_LOOP_CLAUSES \
4461 : : (OACC_LOOP_CLAUSES | OACC_PARALLEL_CLAUSES)
4462 : : #define OACC_KERNELS_LOOP_CLAUSES \
4463 : : (OACC_LOOP_CLAUSES | OACC_KERNELS_CLAUSES)
4464 : : #define OACC_SERIAL_LOOP_CLAUSES \
4465 : : (OACC_LOOP_CLAUSES | OACC_SERIAL_CLAUSES)
4466 : : #define OACC_HOST_DATA_CLAUSES \
4467 : : (omp_mask (OMP_CLAUSE_USE_DEVICE) \
4468 : : | OMP_CLAUSE_IF \
4469 : : | OMP_CLAUSE_IF_PRESENT)
4470 : : #define OACC_DECLARE_CLAUSES \
4471 : : (omp_mask (OMP_CLAUSE_COPY) | OMP_CLAUSE_COPYIN | OMP_CLAUSE_COPYOUT \
4472 : : | OMP_CLAUSE_CREATE | OMP_CLAUSE_DEVICEPTR | OMP_CLAUSE_DEVICE_RESIDENT \
4473 : : | OMP_CLAUSE_PRESENT \
4474 : : | OMP_CLAUSE_LINK)
4475 : : #define OACC_UPDATE_CLAUSES \
4476 : : (omp_mask (OMP_CLAUSE_IF) | OMP_CLAUSE_ASYNC | OMP_CLAUSE_HOST \
4477 : : | OMP_CLAUSE_DEVICE | OMP_CLAUSE_WAIT | OMP_CLAUSE_IF_PRESENT \
4478 : : | OMP_CLAUSE_SELF)
4479 : : #define OACC_ENTER_DATA_CLAUSES \
4480 : : (omp_mask (OMP_CLAUSE_IF) | OMP_CLAUSE_ASYNC | OMP_CLAUSE_WAIT \
4481 : : | OMP_CLAUSE_COPYIN | OMP_CLAUSE_CREATE | OMP_CLAUSE_ATTACH)
4482 : : #define OACC_EXIT_DATA_CLAUSES \
4483 : : (omp_mask (OMP_CLAUSE_IF) | OMP_CLAUSE_ASYNC | OMP_CLAUSE_WAIT \
4484 : : | OMP_CLAUSE_COPYOUT | OMP_CLAUSE_DELETE | OMP_CLAUSE_FINALIZE \
4485 : : | OMP_CLAUSE_DETACH)
4486 : : #define OACC_WAIT_CLAUSES \
4487 : : omp_mask (OMP_CLAUSE_ASYNC) | OMP_CLAUSE_IF
4488 : : #define OACC_ROUTINE_CLAUSES \
4489 : : (omp_mask (OMP_CLAUSE_GANG) | OMP_CLAUSE_WORKER | OMP_CLAUSE_VECTOR \
4490 : : | OMP_CLAUSE_SEQ \
4491 : : | OMP_CLAUSE_NOHOST)
4492 : :
4493 : :
4494 : : static match
4495 : 11796 : match_acc (gfc_exec_op op, const omp_mask mask)
4496 : : {
4497 : 11796 : gfc_omp_clauses *c;
4498 : 11796 : if (gfc_match_omp_clauses (&c, mask, false, false, true) != MATCH_YES)
4499 : : return MATCH_ERROR;
4500 : 11591 : new_st.op = op;
4501 : 11591 : new_st.ext.omp_clauses = c;
4502 : 11591 : return MATCH_YES;
4503 : : }
4504 : :
4505 : : match
4506 : 1378 : gfc_match_oacc_parallel_loop (void)
4507 : : {
4508 : 1378 : return match_acc (EXEC_OACC_PARALLEL_LOOP, OACC_PARALLEL_LOOP_CLAUSES);
4509 : : }
4510 : :
4511 : :
4512 : : match
4513 : 2974 : gfc_match_oacc_parallel (void)
4514 : : {
4515 : 2974 : return match_acc (EXEC_OACC_PARALLEL, OACC_PARALLEL_CLAUSES);
4516 : : }
4517 : :
4518 : :
4519 : : match
4520 : 129 : gfc_match_oacc_kernels_loop (void)
4521 : : {
4522 : 129 : return match_acc (EXEC_OACC_KERNELS_LOOP, OACC_KERNELS_LOOP_CLAUSES);
4523 : : }
4524 : :
4525 : :
4526 : : match
4527 : 904 : gfc_match_oacc_kernels (void)
4528 : : {
4529 : 904 : return match_acc (EXEC_OACC_KERNELS, OACC_KERNELS_CLAUSES);
4530 : : }
4531 : :
4532 : :
4533 : : match
4534 : 230 : gfc_match_oacc_serial_loop (void)
4535 : : {
4536 : 230 : return match_acc (EXEC_OACC_SERIAL_LOOP, OACC_SERIAL_LOOP_CLAUSES);
4537 : : }
4538 : :
4539 : :
4540 : : match
4541 : 359 : gfc_match_oacc_serial (void)
4542 : : {
4543 : 359 : return match_acc (EXEC_OACC_SERIAL, OACC_SERIAL_CLAUSES);
4544 : : }
4545 : :
4546 : :
4547 : : match
4548 : 689 : gfc_match_oacc_data (void)
4549 : : {
4550 : 689 : return match_acc (EXEC_OACC_DATA, OACC_DATA_CLAUSES);
4551 : : }
4552 : :
4553 : :
4554 : : match
4555 : 65 : gfc_match_oacc_host_data (void)
4556 : : {
4557 : 65 : return match_acc (EXEC_OACC_HOST_DATA, OACC_HOST_DATA_CLAUSES);
4558 : : }
4559 : :
4560 : :
4561 : : match
4562 : 3583 : gfc_match_oacc_loop (void)
4563 : : {
4564 : 3583 : return match_acc (EXEC_OACC_LOOP, OACC_LOOP_CLAUSES);
4565 : : }
4566 : :
4567 : :
4568 : : match
4569 : 176 : gfc_match_oacc_declare (void)
4570 : : {
4571 : 176 : gfc_omp_clauses *c;
4572 : 176 : gfc_omp_namelist *n;
4573 : 176 : gfc_namespace *ns = gfc_current_ns;
4574 : 176 : gfc_oacc_declare *new_oc;
4575 : 176 : bool module_var = false;
4576 : 176 : locus where = gfc_current_locus;
4577 : :
4578 : 176 : if (gfc_match_omp_clauses (&c, OACC_DECLARE_CLAUSES, false, false, true)
4579 : : != MATCH_YES)
4580 : : return MATCH_ERROR;
4581 : :
4582 : 260 : for (n = c->lists[OMP_LIST_DEVICE_RESIDENT]; n != NULL; n = n->next)
4583 : 90 : n->sym->attr.oacc_declare_device_resident = 1;
4584 : :
4585 : 190 : for (n = c->lists[OMP_LIST_LINK]; n != NULL; n = n->next)
4586 : 20 : n->sym->attr.oacc_declare_link = 1;
4587 : :
4588 : 312 : for (n = c->lists[OMP_LIST_MAP]; n != NULL; n = n->next)
4589 : : {
4590 : 152 : gfc_symbol *s = n->sym;
4591 : :
4592 : 152 : if (gfc_current_ns->proc_name
4593 : 152 : && gfc_current_ns->proc_name->attr.flavor == FL_MODULE)
4594 : : {
4595 : 48 : if (n->u.map.op != OMP_MAP_ALLOC && n->u.map.op != OMP_MAP_TO)
4596 : : {
4597 : 6 : gfc_error ("Invalid clause in module with !$ACC DECLARE at %L",
4598 : : &where);
4599 : 6 : return MATCH_ERROR;
4600 : : }
4601 : :
4602 : : module_var = true;
4603 : : }
4604 : :
4605 : 146 : if (s->attr.use_assoc)
4606 : : {
4607 : 0 : gfc_error ("Variable is USE-associated with !$ACC DECLARE at %L",
4608 : : &where);
4609 : 0 : return MATCH_ERROR;
4610 : : }
4611 : :
4612 : 146 : if ((s->result == s && s->ns->contained != gfc_current_ns)
4613 : 146 : || ((s->attr.flavor == FL_UNKNOWN || s->attr.flavor == FL_VARIABLE)
4614 : 131 : && s->ns != gfc_current_ns))
4615 : : {
4616 : 2 : gfc_error ("Variable %qs shall be declared in the same scoping unit "
4617 : : "as !$ACC DECLARE at %L", s->name, &where);
4618 : 2 : return MATCH_ERROR;
4619 : : }
4620 : :
4621 : 144 : if ((s->attr.dimension || s->attr.codimension)
4622 : 76 : && s->attr.dummy && s->as->type != AS_EXPLICIT)
4623 : : {
4624 : 2 : gfc_error ("Assumed-size dummy array with !$ACC DECLARE at %L",
4625 : : &where);
4626 : 2 : return MATCH_ERROR;
4627 : : }
4628 : :
4629 : 142 : switch (n->u.map.op)
4630 : : {
4631 : 49 : case OMP_MAP_FORCE_ALLOC:
4632 : 49 : case OMP_MAP_ALLOC:
4633 : 49 : s->attr.oacc_declare_create = 1;
4634 : 49 : break;
4635 : :
4636 : 59 : case OMP_MAP_FORCE_TO:
4637 : 59 : case OMP_MAP_TO:
4638 : 59 : s->attr.oacc_declare_copyin = 1;
4639 : 59 : break;
4640 : :
4641 : 1 : case OMP_MAP_FORCE_DEVICEPTR:
4642 : 1 : s->attr.oacc_declare_deviceptr = 1;
4643 : 1 : break;
4644 : :
4645 : : default:
4646 : : break;
4647 : : }
4648 : : }
4649 : :
4650 : 160 : new_oc = gfc_get_oacc_declare ();
4651 : 160 : new_oc->next = ns->oacc_declare;
4652 : 160 : new_oc->module_var = module_var;
4653 : 160 : new_oc->clauses = c;
4654 : 160 : new_oc->loc = gfc_current_locus;
4655 : 160 : ns->oacc_declare = new_oc;
4656 : :
4657 : 160 : return MATCH_YES;
4658 : : }
4659 : :
4660 : :
4661 : : match
4662 : 760 : gfc_match_oacc_update (void)
4663 : : {
4664 : 760 : gfc_omp_clauses *c;
4665 : 760 : locus here = gfc_current_locus;
4666 : :
4667 : 760 : if (gfc_match_omp_clauses (&c, OACC_UPDATE_CLAUSES, false, false, true)
4668 : : != MATCH_YES)
4669 : : return MATCH_ERROR;
4670 : :
4671 : 756 : if (!c->lists[OMP_LIST_MAP])
4672 : : {
4673 : 1 : gfc_error ("%<acc update%> must contain at least one "
4674 : : "%<device%> or %<host%> or %<self%> clause at %L", &here);
4675 : 1 : return MATCH_ERROR;
4676 : : }
4677 : :
4678 : 755 : new_st.op = EXEC_OACC_UPDATE;
4679 : 755 : new_st.ext.omp_clauses = c;
4680 : 755 : return MATCH_YES;
4681 : : }
4682 : :
4683 : :
4684 : : match
4685 : 875 : gfc_match_oacc_enter_data (void)
4686 : : {
4687 : 875 : return match_acc (EXEC_OACC_ENTER_DATA, OACC_ENTER_DATA_CLAUSES);
4688 : : }
4689 : :
4690 : :
4691 : : match
4692 : 610 : gfc_match_oacc_exit_data (void)
4693 : : {
4694 : 610 : return match_acc (EXEC_OACC_EXIT_DATA, OACC_EXIT_DATA_CLAUSES);
4695 : : }
4696 : :
4697 : :
4698 : : match
4699 : 203 : gfc_match_oacc_wait (void)
4700 : : {
4701 : 203 : gfc_omp_clauses *c = gfc_get_omp_clauses ();
4702 : 203 : gfc_expr_list *wait_list = NULL, *el;
4703 : 203 : bool space = true;
4704 : 203 : match m;
4705 : :
4706 : 203 : m = match_omp_oacc_expr_list (" (", &wait_list, true, false);
4707 : 203 : if (m == MATCH_ERROR)
4708 : : return m;
4709 : 197 : else if (m == MATCH_YES)
4710 : 126 : space = false;
4711 : :
4712 : 197 : if (gfc_match_omp_clauses (&c, OACC_WAIT_CLAUSES, space, space, true)
4713 : : == MATCH_ERROR)
4714 : : return MATCH_ERROR;
4715 : :
4716 : 184 : if (wait_list)
4717 : 261 : for (el = wait_list; el; el = el->next)
4718 : : {
4719 : 140 : if (el->expr == NULL)
4720 : : {
4721 : 2 : gfc_error ("Invalid argument to !$ACC WAIT at %C");
4722 : 2 : return MATCH_ERROR;
4723 : : }
4724 : :
4725 : 138 : if (!gfc_resolve_expr (el->expr)
4726 : 138 : || el->expr->ts.type != BT_INTEGER || el->expr->rank != 0)
4727 : : {
4728 : 3 : gfc_error ("WAIT clause at %L requires a scalar INTEGER expression",
4729 : 3 : &el->expr->where);
4730 : :
4731 : 3 : return MATCH_ERROR;
4732 : : }
4733 : : }
4734 : 179 : c->wait_list = wait_list;
4735 : 179 : new_st.op = EXEC_OACC_WAIT;
4736 : 179 : new_st.ext.omp_clauses = c;
4737 : 179 : return MATCH_YES;
4738 : : }
4739 : :
4740 : :
4741 : : match
4742 : 97 : gfc_match_oacc_cache (void)
4743 : : {
4744 : 97 : bool readonly = false;
4745 : 97 : gfc_omp_clauses *c = gfc_get_omp_clauses ();
4746 : : /* The OpenACC cache directive explicitly only allows "array elements or
4747 : : subarrays", which we're currently not checking here. Either check this
4748 : : after the call of gfc_match_omp_variable_list, or add something like a
4749 : : only_sections variant next to its allow_sections parameter. */
4750 : 97 : match m = gfc_match (" ( ");
4751 : 97 : if (m != MATCH_YES)
4752 : : {
4753 : 0 : gfc_free_omp_clauses(c);
4754 : 0 : return m;
4755 : : }
4756 : :
4757 : 97 : if (gfc_match ("readonly : ") == MATCH_YES)
4758 : 8 : readonly = true;
4759 : :
4760 : 97 : gfc_omp_namelist **head = NULL;
4761 : 97 : m = gfc_match_omp_variable_list ("", &c->lists[OMP_LIST_CACHE], true,
4762 : : NULL, &head, true);
4763 : 97 : if (m != MATCH_YES)
4764 : : {
4765 : 2 : gfc_free_omp_clauses(c);
4766 : 2 : return m;
4767 : : }
4768 : :
4769 : 95 : if (readonly)
4770 : 24 : for (gfc_omp_namelist *n = *head; n; n = n->next)
4771 : 16 : n->u.map.readonly = true;
4772 : :
4773 : 95 : if (gfc_current_state() != COMP_DO
4774 : 56 : && gfc_current_state() != COMP_DO_CONCURRENT)
4775 : : {
4776 : 2 : gfc_error ("ACC CACHE directive must be inside of loop %C");
4777 : 2 : gfc_free_omp_clauses(c);
4778 : 2 : return MATCH_ERROR;
4779 : : }
4780 : :
4781 : 93 : new_st.op = EXEC_OACC_CACHE;
4782 : 93 : new_st.ext.omp_clauses = c;
4783 : 93 : return MATCH_YES;
4784 : : }
4785 : :
4786 : : /* Determine the OpenACC 'routine' directive's level of parallelism. */
4787 : :
4788 : : static oacc_routine_lop
4789 : 734 : gfc_oacc_routine_lop (gfc_omp_clauses *clauses)
4790 : : {
4791 : 734 : oacc_routine_lop ret = OACC_ROUTINE_LOP_SEQ;
4792 : :
4793 : 734 : if (clauses)
4794 : : {
4795 : 584 : unsigned n_lop_clauses = 0;
4796 : :
4797 : 584 : if (clauses->gang)
4798 : : {
4799 : 164 : ++n_lop_clauses;
4800 : 164 : ret = OACC_ROUTINE_LOP_GANG;
4801 : : }
4802 : 584 : if (clauses->worker)
4803 : : {
4804 : 114 : ++n_lop_clauses;
4805 : 114 : ret = OACC_ROUTINE_LOP_WORKER;
4806 : : }
4807 : 584 : if (clauses->vector)
4808 : : {
4809 : 116 : ++n_lop_clauses;
4810 : 116 : ret = OACC_ROUTINE_LOP_VECTOR;
4811 : : }
4812 : 584 : if (clauses->seq)
4813 : : {
4814 : 206 : ++n_lop_clauses;
4815 : 206 : ret = OACC_ROUTINE_LOP_SEQ;
4816 : : }
4817 : :
4818 : 584 : if (n_lop_clauses > 1)
4819 : 47 : ret = OACC_ROUTINE_LOP_ERROR;
4820 : : }
4821 : :
4822 : 734 : return ret;
4823 : : }
4824 : :
4825 : : match
4826 : 698 : gfc_match_oacc_routine (void)
4827 : : {
4828 : 698 : locus old_loc;
4829 : 698 : match m;
4830 : 698 : gfc_intrinsic_sym *isym = NULL;
4831 : 698 : gfc_symbol *sym = NULL;
4832 : 698 : gfc_omp_clauses *c = NULL;
4833 : 698 : gfc_oacc_routine_name *n = NULL;
4834 : 698 : oacc_routine_lop lop = OACC_ROUTINE_LOP_NONE;
4835 : 698 : bool nohost;
4836 : :
4837 : 698 : old_loc = gfc_current_locus;
4838 : :
4839 : 698 : m = gfc_match (" (");
4840 : :
4841 : 698 : if (gfc_current_ns->proc_name
4842 : 696 : && gfc_current_ns->proc_name->attr.if_source == IFSRC_IFBODY
4843 : 90 : && m == MATCH_YES)
4844 : : {
4845 : 3 : gfc_error ("Only the !$ACC ROUTINE form without "
4846 : : "list is allowed in interface block at %C");
4847 : 3 : goto cleanup;
4848 : : }
4849 : :
4850 : 608 : if (m == MATCH_YES)
4851 : : {
4852 : 295 : char buffer[GFC_MAX_SYMBOL_LEN + 1];
4853 : :
4854 : 295 : m = gfc_match_name (buffer);
4855 : 295 : if (m == MATCH_YES)
4856 : : {
4857 : 294 : gfc_symtree *st = NULL;
4858 : :
4859 : : /* First look for an intrinsic symbol. */
4860 : 294 : isym = gfc_find_function (buffer);
4861 : 294 : if (!isym)
4862 : 294 : isym = gfc_find_subroutine (buffer);
4863 : : /* If no intrinsic symbol found, search the current namespace. */
4864 : 294 : if (!isym)
4865 : 276 : st = gfc_find_symtree (gfc_current_ns->sym_root, buffer);
4866 : 276 : if (st)
4867 : : {
4868 : 270 : sym = st->n.sym;
4869 : : /* If the name in a 'routine' directive refers to the containing
4870 : : subroutine or function, then make sure that we'll later handle
4871 : : this accordingly. */
4872 : 270 : if (gfc_current_ns->proc_name != NULL
4873 : 270 : && strcmp (sym->name, gfc_current_ns->proc_name->name) == 0)
4874 : 294 : sym = NULL;
4875 : : }
4876 : :
4877 : 294 : if (isym == NULL && st == NULL)
4878 : : {
4879 : 6 : gfc_error ("Invalid NAME %qs in !$ACC ROUTINE ( NAME ) at %C",
4880 : : buffer);
4881 : 6 : gfc_current_locus = old_loc;
4882 : 9 : return MATCH_ERROR;
4883 : : }
4884 : : }
4885 : : else
4886 : : {
4887 : 1 : gfc_error ("Syntax error in !$ACC ROUTINE ( NAME ) at %C");
4888 : 1 : gfc_current_locus = old_loc;
4889 : 1 : return MATCH_ERROR;
4890 : : }
4891 : :
4892 : 288 : if (gfc_match_char (')') != MATCH_YES)
4893 : : {
4894 : 2 : gfc_error ("Syntax error in !$ACC ROUTINE ( NAME ) at %C, expecting"
4895 : : " %<)%> after NAME");
4896 : 2 : gfc_current_locus = old_loc;
4897 : 2 : return MATCH_ERROR;
4898 : : }
4899 : : }
4900 : :
4901 : 686 : if (gfc_match_omp_eos () != MATCH_YES
4902 : 686 : && (gfc_match_omp_clauses (&c, OACC_ROUTINE_CLAUSES, false, false, true)
4903 : : != MATCH_YES))
4904 : : return MATCH_ERROR;
4905 : :
4906 : 683 : lop = gfc_oacc_routine_lop (c);
4907 : 683 : if (lop == OACC_ROUTINE_LOP_ERROR)
4908 : : {
4909 : 47 : gfc_error ("Multiple loop axes specified for routine at %C");
4910 : 47 : goto cleanup;
4911 : : }
4912 : 636 : nohost = c ? c->nohost : false;
4913 : :
4914 : 636 : if (isym != NULL)
4915 : : {
4916 : : /* Diagnose any OpenACC 'routine' directive that doesn't match the
4917 : : (implicit) one with a 'seq' clause. */
4918 : 16 : if (c && (c->gang || c->worker || c->vector))
4919 : : {
4920 : 10 : gfc_error ("Intrinsic symbol specified in !$ACC ROUTINE ( NAME )"
4921 : : " at %C marked with incompatible GANG, WORKER, or VECTOR"
4922 : : " clause");
4923 : 10 : goto cleanup;
4924 : : }
4925 : : /* ..., and no 'nohost' clause. */
4926 : 6 : if (nohost)
4927 : : {
4928 : 2 : gfc_error ("Intrinsic symbol specified in !$ACC ROUTINE ( NAME )"
4929 : : " at %C marked with incompatible NOHOST clause");
4930 : 2 : goto cleanup;
4931 : : }
4932 : : }
4933 : 620 : else if (sym != NULL)
4934 : : {
4935 : 151 : bool add = true;
4936 : :
4937 : : /* For a repeated OpenACC 'routine' directive, diagnose if it doesn't
4938 : : match the first one. */
4939 : 151 : for (gfc_oacc_routine_name *n_p = gfc_current_ns->oacc_routine_names;
4940 : 346 : n_p;
4941 : 195 : n_p = n_p->next)
4942 : 235 : if (n_p->sym == sym)
4943 : : {
4944 : 51 : add = false;
4945 : 51 : bool nohost_p = n_p->clauses ? n_p->clauses->nohost : false;
4946 : 51 : if (lop != gfc_oacc_routine_lop (n_p->clauses)
4947 : 51 : || nohost != nohost_p)
4948 : : {
4949 : 40 : gfc_error ("!$ACC ROUTINE already applied at %C");
4950 : 40 : goto cleanup;
4951 : : }
4952 : : }
4953 : :
4954 : 111 : if (add)
4955 : : {
4956 : 100 : sym->attr.oacc_routine_lop = lop;
4957 : 100 : sym->attr.oacc_routine_nohost = nohost;
4958 : :
4959 : 100 : n = gfc_get_oacc_routine_name ();
4960 : 100 : n->sym = sym;
4961 : 100 : n->clauses = c;
4962 : 100 : n->next = gfc_current_ns->oacc_routine_names;
4963 : 100 : n->loc = old_loc;
4964 : 100 : gfc_current_ns->oacc_routine_names = n;
4965 : : }
4966 : : }
4967 : 469 : else if (gfc_current_ns->proc_name)
4968 : : {
4969 : : /* For a repeated OpenACC 'routine' directive, diagnose if it doesn't
4970 : : match the first one. */
4971 : 468 : oacc_routine_lop lop_p = gfc_current_ns->proc_name->attr.oacc_routine_lop;
4972 : 468 : bool nohost_p = gfc_current_ns->proc_name->attr.oacc_routine_nohost;
4973 : 468 : if (lop_p != OACC_ROUTINE_LOP_NONE
4974 : 86 : && (lop != lop_p
4975 : 86 : || nohost != nohost_p))
4976 : : {
4977 : 56 : gfc_error ("!$ACC ROUTINE already applied at %C");
4978 : 56 : goto cleanup;
4979 : : }
4980 : :
4981 : 412 : if (!gfc_add_omp_declare_target (&gfc_current_ns->proc_name->attr,
4982 : : gfc_current_ns->proc_name->name,
4983 : : &old_loc))
4984 : 1 : goto cleanup;
4985 : 411 : gfc_current_ns->proc_name->attr.oacc_routine_lop = lop;
4986 : 411 : gfc_current_ns->proc_name->attr.oacc_routine_nohost = nohost;
4987 : : }
4988 : : else
4989 : : /* Something has gone wrong, possibly a syntax error. */
4990 : 1 : goto cleanup;
4991 : :
4992 : 526 : if (gfc_pure (NULL) && c && (c->gang || c->worker || c->vector))
4993 : : {
4994 : 6 : gfc_error ("!$ACC ROUTINE with GANG, WORKER, or VECTOR clause is not "
4995 : : "permitted in PURE procedure at %C");
4996 : 6 : goto cleanup;
4997 : : }
4998 : :
4999 : :
5000 : 520 : if (n)
5001 : 100 : n->clauses = c;
5002 : 420 : else if (gfc_current_ns->oacc_routine)
5003 : 0 : gfc_current_ns->oacc_routine_clauses = c;
5004 : :
5005 : 520 : new_st.op = EXEC_OACC_ROUTINE;
5006 : 520 : new_st.ext.omp_clauses = c;
5007 : 520 : return MATCH_YES;
5008 : :
5009 : 166 : cleanup:
5010 : 166 : gfc_current_locus = old_loc;
5011 : 166 : return MATCH_ERROR;
5012 : : }
5013 : :
5014 : :
5015 : : #define OMP_PARALLEL_CLAUSES \
5016 : : (omp_mask (OMP_CLAUSE_PRIVATE) | OMP_CLAUSE_FIRSTPRIVATE \
5017 : : | OMP_CLAUSE_SHARED | OMP_CLAUSE_COPYIN | OMP_CLAUSE_REDUCTION \
5018 : : | OMP_CLAUSE_IF | OMP_CLAUSE_NUM_THREADS | OMP_CLAUSE_DEFAULT \
5019 : : | OMP_CLAUSE_PROC_BIND | OMP_CLAUSE_ALLOCATE)
5020 : : #define OMP_DECLARE_SIMD_CLAUSES \
5021 : : (omp_mask (OMP_CLAUSE_SIMDLEN) | OMP_CLAUSE_LINEAR \
5022 : : | OMP_CLAUSE_UNIFORM | OMP_CLAUSE_ALIGNED | OMP_CLAUSE_INBRANCH \
5023 : : | OMP_CLAUSE_NOTINBRANCH)
5024 : : #define OMP_DO_CLAUSES \
5025 : : (omp_mask (OMP_CLAUSE_PRIVATE) | OMP_CLAUSE_FIRSTPRIVATE \
5026 : : | OMP_CLAUSE_LASTPRIVATE | OMP_CLAUSE_REDUCTION \
5027 : : | OMP_CLAUSE_SCHEDULE | OMP_CLAUSE_ORDERED | OMP_CLAUSE_COLLAPSE \
5028 : : | OMP_CLAUSE_LINEAR | OMP_CLAUSE_ORDER | OMP_CLAUSE_ALLOCATE \
5029 : : | OMP_CLAUSE_NOWAIT)
5030 : : #define OMP_LOOP_CLAUSES \
5031 : : (omp_mask (OMP_CLAUSE_BIND) | OMP_CLAUSE_COLLAPSE | OMP_CLAUSE_ORDER \
5032 : : | OMP_CLAUSE_PRIVATE | OMP_CLAUSE_LASTPRIVATE | OMP_CLAUSE_REDUCTION)
5033 : :
5034 : : #define OMP_SCOPE_CLAUSES \
5035 : : (omp_mask (OMP_CLAUSE_PRIVATE) |OMP_CLAUSE_FIRSTPRIVATE \
5036 : : | OMP_CLAUSE_REDUCTION | OMP_CLAUSE_ALLOCATE | OMP_CLAUSE_NOWAIT)
5037 : : #define OMP_SECTIONS_CLAUSES \
5038 : : (omp_mask (OMP_CLAUSE_PRIVATE) | OMP_CLAUSE_FIRSTPRIVATE \
5039 : : | OMP_CLAUSE_LASTPRIVATE | OMP_CLAUSE_REDUCTION \
5040 : : | OMP_CLAUSE_ALLOCATE | OMP_CLAUSE_NOWAIT)
5041 : : #define OMP_SIMD_CLAUSES \
5042 : : (omp_mask (OMP_CLAUSE_PRIVATE) | OMP_CLAUSE_LASTPRIVATE \
5043 : : | OMP_CLAUSE_REDUCTION | OMP_CLAUSE_COLLAPSE | OMP_CLAUSE_SAFELEN \
5044 : : | OMP_CLAUSE_LINEAR | OMP_CLAUSE_ALIGNED | OMP_CLAUSE_SIMDLEN \
5045 : : | OMP_CLAUSE_IF | OMP_CLAUSE_ORDER | OMP_CLAUSE_NOTEMPORAL)
5046 : : #define OMP_TASK_CLAUSES \
5047 : : (omp_mask (OMP_CLAUSE_PRIVATE) | OMP_CLAUSE_FIRSTPRIVATE \
5048 : : | OMP_CLAUSE_SHARED | OMP_CLAUSE_IF | OMP_CLAUSE_DEFAULT \
5049 : : | OMP_CLAUSE_UNTIED | OMP_CLAUSE_FINAL | OMP_CLAUSE_MERGEABLE \
5050 : : | OMP_CLAUSE_DEPEND | OMP_CLAUSE_PRIORITY | OMP_CLAUSE_IN_REDUCTION \
5051 : : | OMP_CLAUSE_DETACH | OMP_CLAUSE_AFFINITY | OMP_CLAUSE_ALLOCATE)
5052 : : #define OMP_TASKLOOP_CLAUSES \
5053 : : (omp_mask (OMP_CLAUSE_PRIVATE) | OMP_CLAUSE_FIRSTPRIVATE \
5054 : : | OMP_CLAUSE_LASTPRIVATE | OMP_CLAUSE_SHARED | OMP_CLAUSE_IF \
5055 : : | OMP_CLAUSE_DEFAULT | OMP_CLAUSE_UNTIED | OMP_CLAUSE_FINAL \
5056 : : | OMP_CLAUSE_MERGEABLE | OMP_CLAUSE_PRIORITY | OMP_CLAUSE_GRAINSIZE \
5057 : : | OMP_CLAUSE_NUM_TASKS | OMP_CLAUSE_COLLAPSE | OMP_CLAUSE_NOGROUP \
5058 : : | OMP_CLAUSE_REDUCTION | OMP_CLAUSE_IN_REDUCTION | OMP_CLAUSE_ALLOCATE)
5059 : : #define OMP_TASKGROUP_CLAUSES \
5060 : : (omp_mask (OMP_CLAUSE_TASK_REDUCTION) | OMP_CLAUSE_ALLOCATE)
5061 : : #define OMP_TARGET_CLAUSES \
5062 : : (omp_mask (OMP_CLAUSE_DEVICE) | OMP_CLAUSE_MAP | OMP_CLAUSE_IF \
5063 : : | OMP_CLAUSE_DEPEND | OMP_CLAUSE_NOWAIT | OMP_CLAUSE_PRIVATE \
5064 : : | OMP_CLAUSE_FIRSTPRIVATE | OMP_CLAUSE_DEFAULTMAP \
5065 : : | OMP_CLAUSE_IS_DEVICE_PTR | OMP_CLAUSE_IN_REDUCTION \
5066 : : | OMP_CLAUSE_THREAD_LIMIT | OMP_CLAUSE_ALLOCATE \
5067 : : | OMP_CLAUSE_HAS_DEVICE_ADDR | OMP_CLAUSE_USES_ALLOCATORS)
5068 : : #define OMP_TARGET_DATA_CLAUSES \
5069 : : (omp_mask (OMP_CLAUSE_DEVICE) | OMP_CLAUSE_MAP | OMP_CLAUSE_IF \
5070 : : | OMP_CLAUSE_USE_DEVICE_PTR | OMP_CLAUSE_USE_DEVICE_ADDR)
5071 : : #define OMP_TARGET_ENTER_DATA_CLAUSES \
5072 : : (omp_mask (OMP_CLAUSE_DEVICE) | OMP_CLAUSE_MAP | OMP_CLAUSE_IF \
5073 : : | OMP_CLAUSE_DEPEND | OMP_CLAUSE_NOWAIT)
5074 : : #define OMP_TARGET_EXIT_DATA_CLAUSES \
5075 : : (omp_mask (OMP_CLAUSE_DEVICE) | OMP_CLAUSE_MAP | OMP_CLAUSE_IF \
5076 : : | OMP_CLAUSE_DEPEND | OMP_CLAUSE_NOWAIT)
5077 : : #define OMP_TARGET_UPDATE_CLAUSES \
5078 : : (omp_mask (OMP_CLAUSE_DEVICE) | OMP_CLAUSE_IF | OMP_CLAUSE_TO \
5079 : : | OMP_CLAUSE_FROM | OMP_CLAUSE_DEPEND | OMP_CLAUSE_NOWAIT)
5080 : : #define OMP_TEAMS_CLAUSES \
5081 : : (omp_mask (OMP_CLAUSE_NUM_TEAMS) | OMP_CLAUSE_THREAD_LIMIT \
5082 : : | OMP_CLAUSE_DEFAULT | OMP_CLAUSE_PRIVATE | OMP_CLAUSE_FIRSTPRIVATE \
5083 : : | OMP_CLAUSE_SHARED | OMP_CLAUSE_REDUCTION | OMP_CLAUSE_ALLOCATE)
5084 : : #define OMP_DISTRIBUTE_CLAUSES \
5085 : : (omp_mask (OMP_CLAUSE_PRIVATE) | OMP_CLAUSE_FIRSTPRIVATE \
5086 : : | OMP_CLAUSE_LASTPRIVATE | OMP_CLAUSE_COLLAPSE | OMP_CLAUSE_DIST_SCHEDULE \
5087 : : | OMP_CLAUSE_ORDER | OMP_CLAUSE_ALLOCATE)
5088 : : #define OMP_SINGLE_CLAUSES \
5089 : : (omp_mask (OMP_CLAUSE_PRIVATE) | OMP_CLAUSE_FIRSTPRIVATE \
5090 : : | OMP_CLAUSE_ALLOCATE | OMP_CLAUSE_NOWAIT | OMP_CLAUSE_COPYPRIVATE)
5091 : : #define OMP_ORDERED_CLAUSES \
5092 : : (omp_mask (OMP_CLAUSE_THREADS) | OMP_CLAUSE_SIMD)
5093 : : #define OMP_DECLARE_TARGET_CLAUSES \
5094 : : (omp_mask (OMP_CLAUSE_ENTER) | OMP_CLAUSE_LINK | OMP_CLAUSE_DEVICE_TYPE \
5095 : : | OMP_CLAUSE_TO | OMP_CLAUSE_INDIRECT)
5096 : : #define OMP_ATOMIC_CLAUSES \
5097 : : (omp_mask (OMP_CLAUSE_ATOMIC) | OMP_CLAUSE_CAPTURE | OMP_CLAUSE_HINT \
5098 : : | OMP_CLAUSE_MEMORDER | OMP_CLAUSE_COMPARE | OMP_CLAUSE_FAIL \
5099 : : | OMP_CLAUSE_WEAK)
5100 : : #define OMP_MASKED_CLAUSES \
5101 : : (omp_mask (OMP_CLAUSE_FILTER))
5102 : : #define OMP_ERROR_CLAUSES \
5103 : : (omp_mask (OMP_CLAUSE_AT) | OMP_CLAUSE_MESSAGE | OMP_CLAUSE_SEVERITY)
5104 : : #define OMP_WORKSHARE_CLAUSES \
5105 : : omp_mask (OMP_CLAUSE_NOWAIT)
5106 : : #define OMP_UNROLL_CLAUSES \
5107 : : (omp_mask (OMP_CLAUSE_FULL) | OMP_CLAUSE_PARTIAL)
5108 : : #define OMP_TILE_CLAUSES \
5109 : : (omp_mask (OMP_CLAUSE_SIZES))
5110 : : #define OMP_ALLOCATORS_CLAUSES \
5111 : : omp_mask (OMP_CLAUSE_ALLOCATE)
5112 : : #define OMP_INTEROP_CLAUSES \
5113 : : (omp_mask (OMP_CLAUSE_DEPEND) | OMP_CLAUSE_NOWAIT | OMP_CLAUSE_DEVICE \
5114 : : | OMP_CLAUSE_INIT | OMP_CLAUSE_DESTROY | OMP_CLAUSE_USE)
5115 : : #define OMP_DISPATCH_CLAUSES \
5116 : : (omp_mask (OMP_CLAUSE_DEVICE) | OMP_CLAUSE_DEPEND | OMP_CLAUSE_NOVARIANTS \
5117 : : | OMP_CLAUSE_NOCONTEXT | OMP_CLAUSE_IS_DEVICE_PTR | OMP_CLAUSE_NOWAIT \
5118 : : | OMP_CLAUSE_HAS_DEVICE_ADDR | OMP_CLAUSE_INTEROP)
5119 : :
5120 : :
5121 : : static match
5122 : 16529 : match_omp (gfc_exec_op op, const omp_mask mask)
5123 : : {
5124 : 16529 : gfc_omp_clauses *c;
5125 : 16529 : if (gfc_match_omp_clauses (&c, mask, true, true, false,
5126 : : op == EXEC_OMP_TARGET) != MATCH_YES)
5127 : : return MATCH_ERROR;
5128 : 16283 : new_st.op = op;
5129 : 16283 : new_st.ext.omp_clauses = c;
5130 : 16283 : return MATCH_YES;
5131 : : }
5132 : :
5133 : : /* Handles both declarative and (deprecated) executable ALLOCATE directive;
5134 : : accepts optional list (for executable) and common blocks.
5135 : : If no variables have been provided, the single omp namelist has sym == NULL.
5136 : :
5137 : : Note that the executable ALLOCATE directive permits structure elements only
5138 : : in OpenMP 5.0 and 5.1 but not longer in 5.2. See also the comment on the
5139 : : 'omp allocators' directive below. The accidental change was reverted for
5140 : : OpenMP TR12, permitting them again. See also gfc_match_omp_allocators.
5141 : :
5142 : : Hence, structure elements are rejected for now, also to make resolving
5143 : : OMP_LIST_ALLOCATE simpler (check for duplicates, same symbol in
5144 : : Fortran allocate stmt). TODO: Permit structure elements. */
5145 : :
5146 : : match
5147 : 185 : gfc_match_omp_allocate (void)
5148 : : {
5149 : 185 : match m;
5150 : 185 : bool first = true;
5151 : 185 : gfc_omp_namelist *vars = NULL;
5152 : 185 : gfc_expr *align = NULL;
5153 : 185 : gfc_expr *allocator = NULL;
5154 : 185 : locus loc = gfc_current_locus;
5155 : :
5156 : 185 : m = gfc_match_omp_variable_list (" (", &vars, true, NULL, NULL, true, true,
5157 : : NULL, true);
5158 : :
5159 : 185 : if (m == MATCH_ERROR)
5160 : : return m;
5161 : :
5162 : 325 : while (true)
5163 : : {
5164 : 325 : gfc_gobble_whitespace ();
5165 : 325 : if (gfc_match_omp_eos () == MATCH_YES)
5166 : : break;
5167 : 146 : if (!first)
5168 : 28 : gfc_match (", ");
5169 : 146 : first = false;
5170 : 146 : if ((m = gfc_match_dupl_check (!align, "align", true, &align))
5171 : : != MATCH_NO)
5172 : : {
5173 : 62 : if (m == MATCH_ERROR)
5174 : 1 : goto error;
5175 : 61 : continue;
5176 : : }
5177 : 84 : if ((m = gfc_match_dupl_check (!allocator, "allocator",
5178 : : true, &allocator)) != MATCH_NO)
5179 : : {
5180 : 83 : if (m == MATCH_ERROR)
5181 : 1 : goto error;
5182 : 82 : continue;
5183 : : }
5184 : 1 : gfc_error ("Expected ALIGN or ALLOCATOR clause at %C");
5185 : 1 : return MATCH_ERROR;
5186 : : }
5187 : 363 : for (gfc_omp_namelist *n = vars; n; n = n->next)
5188 : 187 : if (n->expr)
5189 : : {
5190 : 3 : if ((n->expr->ref && n->expr->ref->type == REF_COMPONENT)
5191 : 3 : || (n->expr->ref->next && n->expr->ref->type == REF_COMPONENT))
5192 : 1 : gfc_error ("Sorry, structure-element list item at %L in ALLOCATE "
5193 : : "directive is not yet supported", &n->expr->where);
5194 : : else
5195 : 2 : gfc_error ("Unexpected expression as list item at %L in ALLOCATE "
5196 : : "directive", &n->expr->where);
5197 : :
5198 : 3 : gfc_free_omp_namelist (vars, false, true, false, false);
5199 : 3 : goto error;
5200 : : }
5201 : :
5202 : 176 : new_st.op = EXEC_OMP_ALLOCATE;
5203 : 176 : new_st.ext.omp_clauses = gfc_get_omp_clauses ();
5204 : 176 : if (vars == NULL)
5205 : : {
5206 : 27 : vars = gfc_get_omp_namelist ();
5207 : 27 : vars->where = loc;
5208 : 27 : vars->u.align = align;
5209 : 27 : vars->u2.allocator = allocator;
5210 : 27 : new_st.ext.omp_clauses->lists[OMP_LIST_ALLOCATE] = vars;
5211 : : }
5212 : : else
5213 : : {
5214 : 149 : new_st.ext.omp_clauses->lists[OMP_LIST_ALLOCATE] = vars;
5215 : 333 : for (; vars; vars = vars->next)
5216 : : {
5217 : 184 : vars->u.align = (align) ? gfc_copy_expr (align) : NULL;
5218 : 184 : vars->u2.allocator = allocator;
5219 : : }
5220 : 149 : gfc_free_expr (align);
5221 : : }
5222 : : return MATCH_YES;
5223 : :
5224 : 5 : error:
5225 : 5 : gfc_free_expr (align);
5226 : 5 : gfc_free_expr (allocator);
5227 : 5 : return MATCH_ERROR;
5228 : : }
5229 : :
5230 : : /* In line with OpenMP 5.2 derived-type components are rejected.
5231 : : See also comment before gfc_match_omp_allocate. */
5232 : :
5233 : : match
5234 : 26 : gfc_match_omp_allocators (void)
5235 : : {
5236 : 26 : return match_omp (EXEC_OMP_ALLOCATORS, OMP_ALLOCATORS_CLAUSES);
5237 : : }
5238 : :
5239 : :
5240 : : match
5241 : 20 : gfc_match_omp_assume (void)
5242 : : {
5243 : 20 : gfc_omp_clauses *c;
5244 : 20 : locus loc = gfc_current_locus;
5245 : 20 : if ((gfc_match_omp_clauses (&c, omp_mask (OMP_CLAUSE_ASSUMPTIONS))
5246 : : != MATCH_YES)
5247 : 20 : || (omp_verify_merge_absent_contains (ST_OMP_ASSUME, c->assume, NULL,
5248 : : &loc) != MATCH_YES))
5249 : 4 : return MATCH_ERROR;
5250 : 16 : new_st.op = EXEC_OMP_ASSUME;
5251 : 16 : new_st.ext.omp_clauses = c;
5252 : 16 : return MATCH_YES;
5253 : : }
5254 : :
5255 : :
5256 : : match
5257 : 28 : gfc_match_omp_assumes (void)
5258 : : {
5259 : 28 : gfc_omp_clauses *c;
5260 : 28 : locus loc = gfc_current_locus;
5261 : 28 : if (!gfc_current_ns->proc_name
5262 : 27 : || (gfc_current_ns->proc_name->attr.flavor != FL_MODULE
5263 : 23 : && !gfc_current_ns->proc_name->attr.subroutine
5264 : 10 : && !gfc_current_ns->proc_name->attr.function))
5265 : : {
5266 : 2 : gfc_error ("!$OMP ASSUMES at %C must be in the specification part of a "
5267 : : "subprogram or module");
5268 : 2 : return MATCH_ERROR;
5269 : : }
5270 : 26 : if ((gfc_match_omp_clauses (&c, omp_mask (OMP_CLAUSE_ASSUMPTIONS))
5271 : : != MATCH_YES)
5272 : 50 : || (omp_verify_merge_absent_contains (ST_OMP_ASSUMES, c->assume,
5273 : 24 : gfc_current_ns->omp_assumes, &loc)
5274 : : != MATCH_YES))
5275 : 5 : return MATCH_ERROR;
5276 : 21 : if (gfc_current_ns->omp_assumes == NULL)
5277 : : {
5278 : 19 : gfc_current_ns->omp_assumes = c->assume;
5279 : 19 : c->assume = NULL;
5280 : : }
5281 : 2 : else if (gfc_current_ns->omp_assumes && c->assume)
5282 : : {
5283 : 2 : gfc_current_ns->omp_assumes->no_openmp |= c->assume->no_openmp;
5284 : 2 : gfc_current_ns->omp_assumes->no_openmp_routines
5285 : 2 : |= c->assume->no_openmp_routines;
5286 : 2 : gfc_current_ns->omp_assumes->no_parallelism |= c->assume->no_parallelism;
5287 : 2 : if (gfc_current_ns->omp_assumes->holds && c->assume->holds)
5288 : : {
5289 : : gfc_expr_list *el = gfc_current_ns->omp_assumes->holds;
5290 : 1 : for ( ; el->next ; el = el->next)
5291 : : ;
5292 : 1 : el->next = c->assume->holds;
5293 : 1 : }
5294 : 1 : else if (c->assume->holds)
5295 : 0 : gfc_current_ns->omp_assumes->holds = c->assume->holds;
5296 : 2 : c->assume->holds = NULL;
5297 : : }
5298 : 21 : gfc_free_omp_clauses (c);
5299 : 21 : return MATCH_YES;
5300 : : }
5301 : :
5302 : :
5303 : : match
5304 : 162 : gfc_match_omp_critical (void)
5305 : : {
5306 : 162 : char n[GFC_MAX_SYMBOL_LEN+1];
5307 : 162 : gfc_omp_clauses *c = NULL;
5308 : :
5309 : 162 : if (gfc_match (" ( %n )", n) != MATCH_YES)
5310 : 115 : n[0] = '\0';
5311 : :
5312 : 162 : if (gfc_match_omp_clauses (&c, omp_mask (OMP_CLAUSE_HINT),
5313 : 162 : /* first = */ n[0] == '\0') != MATCH_YES)
5314 : : return MATCH_ERROR;
5315 : :
5316 : 160 : new_st.op = EXEC_OMP_CRITICAL;
5317 : 160 : new_st.ext.omp_clauses = c;
5318 : 160 : if (n[0])
5319 : 47 : c->critical_name = xstrdup (n);
5320 : : return MATCH_YES;
5321 : : }
5322 : :
5323 : :
5324 : : match
5325 : 160 : gfc_match_omp_end_critical (void)
5326 : : {
5327 : 160 : char n[GFC_MAX_SYMBOL_LEN+1];
5328 : :
5329 : 160 : if (gfc_match (" ( %n )", n) != MATCH_YES)
5330 : 113 : n[0] = '\0';
5331 : 160 : if (gfc_match_omp_eos () != MATCH_YES)
5332 : : {
5333 : 1 : gfc_error ("Unexpected junk after $OMP CRITICAL statement at %C");
5334 : 1 : return MATCH_ERROR;
5335 : : }
5336 : :
5337 : 159 : new_st.op = EXEC_OMP_END_CRITICAL;
5338 : 159 : new_st.ext.omp_name = n[0] ? xstrdup (n) : NULL;
5339 : 159 : return MATCH_YES;
5340 : : }
5341 : :
5342 : : /* depobj(depobj) depend(dep-type:loc)|destroy|update(dep-type)
5343 : : dep-type = in/out/inout/mutexinoutset/depobj/source/sink
5344 : : depend: !source, !sink
5345 : : update: !source, !sink, !depobj
5346 : : locator = exactly one list item .*/
5347 : : match
5348 : 125 : gfc_match_omp_depobj (void)
5349 : : {
5350 : 125 : gfc_omp_clauses *c = NULL;
5351 : 125 : gfc_expr *depobj;
5352 : :
5353 : 125 : if (gfc_match (" ( %v ) ", &depobj) != MATCH_YES)
5354 : : {
5355 : 2 : gfc_error ("Expected %<( depobj )%> at %C");
5356 : 2 : return MATCH_ERROR;
5357 : : }
5358 : 123 : if (gfc_match ("update ( ") == MATCH_YES)
5359 : : {
5360 : 12 : c = gfc_get_omp_clauses ();
5361 : 12 : if (gfc_match ("inoutset )") == MATCH_YES)
5362 : 2 : c->depobj_update = OMP_DEPEND_INOUTSET;
5363 : 10 : else if (gfc_match ("inout )") == MATCH_YES)
5364 : 1 : c->depobj_update = OMP_DEPEND_INOUT;
5365 : 9 : else if (gfc_match ("in )") == MATCH_YES)
5366 : 2 : c->depobj_update = OMP_DEPEND_IN;
5367 : 7 : else if (gfc_match ("out )") == MATCH_YES)
5368 : 2 : c->depobj_update = OMP_DEPEND_OUT;
5369 : 5 : else if (gfc_match ("mutexinoutset )") == MATCH_YES)
5370 : 2 : c->depobj_update = OMP_DEPEND_MUTEXINOUTSET;
5371 : : else
5372 : : {
5373 : 3 : gfc_error ("Expected IN, OUT, INOUT, INOUTSET or MUTEXINOUTSET "
5374 : : "followed by %<)%> at %C");
5375 : 3 : goto error;
5376 : : }
5377 : : }
5378 : 111 : else if (gfc_match ("destroy ") == MATCH_YES)
5379 : : {
5380 : 16 : gfc_expr *destroyobj = NULL;
5381 : 16 : c = gfc_get_omp_clauses ();
5382 : 16 : c->destroy = true;
5383 : :
5384 : 16 : if (gfc_match (" ( %v ) ", &destroyobj) == MATCH_YES)
5385 : : {
5386 : 3 : if (destroyobj->symtree != depobj->symtree)
5387 : 2 : gfc_warning (OPT_Wopenmp, "The same depend object should be used as"
5388 : : " DEPOBJ argument at %L and as DESTROY argument at %L",
5389 : : &depobj->where, &destroyobj->where);
5390 : 3 : gfc_free_expr (destroyobj);
5391 : : }
5392 : : }
5393 : 95 : else if (gfc_match_omp_clauses (&c, omp_mask (OMP_CLAUSE_DEPEND), true, false)
5394 : : != MATCH_YES)
5395 : 2 : goto error;
5396 : :
5397 : 118 : if (c->depobj_update == OMP_DEPEND_UNSET && !c->destroy)
5398 : : {
5399 : 93 : if (!c->doacross_source && !c->lists[OMP_LIST_DEPEND])
5400 : : {
5401 : 1 : gfc_error ("Expected DEPEND, UPDATE, or DESTROY clause at %C");
5402 : 1 : goto error;
5403 : : }
5404 : 92 : if (c->lists[OMP_LIST_DEPEND]->u.depend_doacross_op == OMP_DEPEND_DEPOBJ)
5405 : : {
5406 : 1 : gfc_error ("DEPEND clause at %L of OMP DEPOBJ construct shall not "
5407 : : "have dependence-type DEPOBJ",
5408 : : c->lists[OMP_LIST_DEPEND]
5409 : : ? &c->lists[OMP_LIST_DEPEND]->where : &gfc_current_locus);
5410 : 1 : goto error;
5411 : : }
5412 : 91 : if (c->lists[OMP_LIST_DEPEND]->next)
5413 : : {
5414 : 1 : gfc_error ("DEPEND clause at %L of OMP DEPOBJ construct shall have "
5415 : : "only a single locator",
5416 : : &c->lists[OMP_LIST_DEPEND]->next->where);
5417 : 1 : goto error;
5418 : : }
5419 : : }
5420 : :
5421 : 115 : c->depobj = depobj;
5422 : 115 : new_st.op = EXEC_OMP_DEPOBJ;
5423 : 115 : new_st.ext.omp_clauses = c;
5424 : 115 : return MATCH_YES;
5425 : :
5426 : 8 : error:
5427 : 8 : gfc_free_expr (depobj);
5428 : 8 : gfc_free_omp_clauses (c);
5429 : 8 : return MATCH_ERROR;
5430 : : }
5431 : :
5432 : : match
5433 : 160 : gfc_match_omp_dispatch (void)
5434 : : {
5435 : 160 : return match_omp (EXEC_OMP_DISPATCH, OMP_DISPATCH_CLAUSES);
5436 : : }
5437 : :
5438 : : match
5439 : 57 : gfc_match_omp_distribute (void)
5440 : : {
5441 : 57 : return match_omp (EXEC_OMP_DISTRIBUTE, OMP_DISTRIBUTE_CLAUSES);
5442 : : }
5443 : :
5444 : :
5445 : : match
5446 : 44 : gfc_match_omp_distribute_parallel_do (void)
5447 : : {
5448 : 44 : return match_omp (EXEC_OMP_DISTRIBUTE_PARALLEL_DO,
5449 : 44 : (OMP_DISTRIBUTE_CLAUSES | OMP_PARALLEL_CLAUSES
5450 : 44 : | OMP_DO_CLAUSES)
5451 : 44 : & ~(omp_mask (OMP_CLAUSE_ORDERED)
5452 : 44 : | OMP_CLAUSE_LINEAR | OMP_CLAUSE_NOWAIT));
5453 : : }
5454 : :
5455 : :
5456 : : match
5457 : 34 : gfc_match_omp_distribute_parallel_do_simd (void)
5458 : : {
5459 : 34 : return match_omp (EXEC_OMP_DISTRIBUTE_PARALLEL_DO_SIMD,
5460 : 34 : (OMP_DISTRIBUTE_CLAUSES | OMP_PARALLEL_CLAUSES
5461 : 34 : | OMP_DO_CLAUSES | OMP_SIMD_CLAUSES)
5462 : 34 : & ~(omp_mask (OMP_CLAUSE_ORDERED) | OMP_CLAUSE_NOWAIT));
5463 : : }
5464 : :
5465 : :
5466 : : match
5467 : 52 : gfc_match_omp_distribute_simd (void)
5468 : : {
5469 : 52 : return match_omp (EXEC_OMP_DISTRIBUTE_SIMD,
5470 : 52 : OMP_DISTRIBUTE_CLAUSES | OMP_SIMD_CLAUSES);
5471 : : }
5472 : :
5473 : :
5474 : : match
5475 : 1251 : gfc_match_omp_do (void)
5476 : : {
5477 : 1251 : return match_omp (EXEC_OMP_DO, OMP_DO_CLAUSES);
5478 : : }
5479 : :
5480 : :
5481 : : match
5482 : 137 : gfc_match_omp_do_simd (void)
5483 : : {
5484 : 137 : return match_omp (EXEC_OMP_DO_SIMD, OMP_DO_CLAUSES | OMP_SIMD_CLAUSES);
5485 : : }
5486 : :
5487 : :
5488 : : match
5489 : 70 : gfc_match_omp_loop (void)
5490 : : {
5491 : 70 : return match_omp (EXEC_OMP_LOOP, OMP_LOOP_CLAUSES);
5492 : : }
5493 : :
5494 : :
5495 : : match
5496 : 35 : gfc_match_omp_teams_loop (void)
5497 : : {
5498 : 35 : return match_omp (EXEC_OMP_TEAMS_LOOP, OMP_TEAMS_CLAUSES | OMP_LOOP_CLAUSES);
5499 : : }
5500 : :
5501 : :
5502 : : match
5503 : 18 : gfc_match_omp_target_teams_loop (void)
5504 : : {
5505 : 18 : return match_omp (EXEC_OMP_TARGET_TEAMS_LOOP,
5506 : 18 : OMP_TARGET_CLAUSES | OMP_TEAMS_CLAUSES | OMP_LOOP_CLAUSES);
5507 : : }
5508 : :
5509 : :
5510 : : match
5511 : 31 : gfc_match_omp_parallel_loop (void)
5512 : : {
5513 : 31 : return match_omp (EXEC_OMP_PARALLEL_LOOP,
5514 : 31 : OMP_PARALLEL_CLAUSES | OMP_LOOP_CLAUSES);
5515 : : }
5516 : :
5517 : :
5518 : : match
5519 : 16 : gfc_match_omp_target_parallel_loop (void)
5520 : : {
5521 : 16 : return match_omp (EXEC_OMP_TARGET_PARALLEL_LOOP,
5522 : 16 : (OMP_TARGET_CLAUSES | OMP_PARALLEL_CLAUSES
5523 : 16 : | OMP_LOOP_CLAUSES));
5524 : : }
5525 : :
5526 : :
5527 : : match
5528 : 101 : gfc_match_omp_error (void)
5529 : : {
5530 : 101 : locus loc = gfc_current_locus;
5531 : 101 : match m = match_omp (EXEC_OMP_ERROR, OMP_ERROR_CLAUSES);
5532 : 101 : if (m != MATCH_YES)
5533 : : return m;
5534 : :
5535 : 82 : gfc_omp_clauses *c = new_st.ext.omp_clauses;
5536 : 82 : if (c->severity == OMP_SEVERITY_UNSET)
5537 : 45 : c->severity = OMP_SEVERITY_FATAL;
5538 : 82 : if (new_st.ext.omp_clauses->at == OMP_AT_EXECUTION)
5539 : : return MATCH_YES;
5540 : 37 : if (c->message
5541 : 37 : && (!gfc_resolve_expr (c->message)
5542 : 16 : || c->message->ts.type != BT_CHARACTER
5543 : 14 : || c->message->ts.kind != gfc_default_character_kind
5544 : 13 : || c->message->rank != 0))
5545 : : {
5546 : 4 : gfc_error ("MESSAGE clause at %L requires a scalar default-kind "
5547 : : "CHARACTER expression",
5548 : 4 : &new_st.ext.omp_clauses->message->where);
5549 : 4 : return MATCH_ERROR;
5550 : : }
5551 : 33 : if (c->message && !gfc_is_constant_expr (c->message))
5552 : : {
5553 : 2 : gfc_error ("Constant character expression required in MESSAGE clause "
5554 : 2 : "at %L", &new_st.ext.omp_clauses->message->where);
5555 : 2 : return MATCH_ERROR;
5556 : : }
5557 : 31 : if (c->message)
5558 : : {
5559 : 10 : const char *msg = G_("$OMP ERROR encountered at %L: %s");
5560 : 10 : gcc_assert (c->message->expr_type == EXPR_CONSTANT);
5561 : 10 : gfc_charlen_t slen = c->message->value.character.length;
5562 : 10 : int i = gfc_validate_kind (BT_CHARACTER, gfc_default_character_kind,
5563 : : false);
5564 : 10 : size_t size = slen * gfc_character_kinds[i].bit_size / 8;
5565 : 10 : unsigned char *s = XCNEWVAR (unsigned char, size + 1);
5566 : 10 : gfc_encode_character (gfc_default_character_kind, slen,
5567 : 10 : c->message->value.character.string,
5568 : : (unsigned char *) s, size);
5569 : 10 : s[size] = '\0';
5570 : 10 : if (c->severity == OMP_SEVERITY_WARNING)
5571 : 6 : gfc_warning_now (0, msg, &loc, s);
5572 : : else
5573 : 4 : gfc_error_now (msg, &loc, s);
5574 : 10 : free (s);
5575 : : }
5576 : : else
5577 : : {
5578 : 21 : const char *msg = G_("$OMP ERROR encountered at %L");
5579 : 21 : if (c->severity == OMP_SEVERITY_WARNING)
5580 : 7 : gfc_warning_now (0, msg, &loc);
5581 : : else
5582 : 14 : gfc_error_now (msg, &loc);
5583 : : }
5584 : : return MATCH_YES;
5585 : : }
5586 : :
5587 : : match
5588 : 86 : gfc_match_omp_flush (void)
5589 : : {
5590 : 86 : gfc_omp_namelist *list = NULL;
5591 : 86 : gfc_omp_clauses *c = NULL;
5592 : 86 : gfc_gobble_whitespace ();
5593 : 86 : enum gfc_omp_memorder mo = OMP_MEMORDER_UNSET;
5594 : 86 : if (gfc_match_omp_eos () == MATCH_NO && gfc_peek_ascii_char () != '(')
5595 : : {
5596 : 14 : if (gfc_match ("seq_cst") == MATCH_YES)
5597 : : mo = OMP_MEMORDER_SEQ_CST;
5598 : 11 : else if (gfc_match ("acq_rel") == MATCH_YES)
5599 : : mo = OMP_MEMORDER_ACQ_REL;
5600 : 8 : else if (gfc_match ("release") == MATCH_YES)
5601 : : mo = OMP_MEMORDER_RELEASE;
5602 : 5 : else if (gfc_match ("acquire") == MATCH_YES)
5603 : : mo = OMP_MEMORDER_ACQUIRE;
5604 : : else
5605 : : {
5606 : 2 : gfc_error ("Expected SEQ_CST, AQC_REL, RELEASE, or ACQUIRE at %C");
5607 : 2 : return MATCH_ERROR;
5608 : : }
5609 : 12 : c = gfc_get_omp_clauses ();
5610 : 12 : c->memorder = mo;
5611 : : }
5612 : 84 : gfc_match_omp_variable_list (" (", &list, true);
5613 : 84 : if (list && mo != OMP_MEMORDER_UNSET)
5614 : : {
5615 : 4 : gfc_error ("List specified together with memory order clause in FLUSH "
5616 : : "directive at %C");
5617 : 4 : gfc_free_omp_namelist (list, false, false, false, false);
5618 : 4 : gfc_free_omp_clauses (c);
5619 : 4 : return MATCH_ERROR;
5620 : : }
5621 : 80 : if (gfc_match_omp_eos () != MATCH_YES)
5622 : : {
5623 : 0 : gfc_error ("Unexpected junk after $OMP FLUSH statement at %C");
5624 : 0 : gfc_free_omp_namelist (list, false, false, false, false);
5625 : 0 : gfc_free_omp_clauses (c);
5626 : 0 : return MATCH_ERROR;
5627 : : }
5628 : 80 : new_st.op = EXEC_OMP_FLUSH;
5629 : 80 : new_st.ext.omp_namelist = list;
5630 : 80 : new_st.ext.omp_clauses = c;
5631 : 80 : return MATCH_YES;
5632 : : }
5633 : :
5634 : :
5635 : : match
5636 : 188 : gfc_match_omp_declare_simd (void)
5637 : : {
5638 : 188 : locus where = gfc_current_locus;
5639 : 188 : gfc_symbol *proc_name;
5640 : 188 : gfc_omp_clauses *c;
5641 : 188 : gfc_omp_declare_simd *ods;
5642 : 188 : bool needs_space = false;
5643 : :
5644 : 188 : switch (gfc_match (" ( "))
5645 : : {
5646 : 144 : case MATCH_YES:
5647 : 144 : if (gfc_match_symbol (&proc_name, /* host assoc = */ true) != MATCH_YES
5648 : 144 : || gfc_match (" ) ") != MATCH_YES)
5649 : 0 : return MATCH_ERROR;
5650 : : break;
5651 : 44 : case MATCH_NO: proc_name = NULL; needs_space = true; break;
5652 : : case MATCH_ERROR: return MATCH_ERROR;
5653 : : }
5654 : :
5655 : 188 : if (gfc_match_omp_clauses (&c, OMP_DECLARE_SIMD_CLAUSES, true,
5656 : : needs_space) != MATCH_YES)
5657 : : return MATCH_ERROR;
5658 : :
5659 : 183 : if (gfc_current_ns->is_block_data)
5660 : : {
5661 : 1 : gfc_free_omp_clauses (c);
5662 : 1 : return MATCH_YES;
5663 : : }
5664 : :
5665 : 182 : ods = gfc_get_omp_declare_simd ();
5666 : 182 : ods->where = where;
5667 : 182 : ods->proc_name = proc_name;
5668 : 182 : ods->clauses = c;
5669 : 182 : ods->next = gfc_current_ns->omp_declare_simd;
5670 : 182 : gfc_current_ns->omp_declare_simd = ods;
5671 : 182 : return MATCH_YES;
5672 : : }
5673 : :
5674 : :
5675 : : static bool
5676 : 877 : match_udr_expr (gfc_symtree *omp_sym1, gfc_symtree *omp_sym2)
5677 : : {
5678 : 877 : match m;
5679 : 877 : locus old_loc = gfc_current_locus;
5680 : 877 : char sname[GFC_MAX_SYMBOL_LEN + 1];
5681 : 877 : gfc_symbol *sym;
5682 : 877 : gfc_namespace *ns = gfc_current_ns;
5683 : 877 : gfc_expr *lvalue = NULL, *rvalue = NULL;
5684 : 877 : gfc_symtree *st;
5685 : 877 : gfc_actual_arglist *arglist;
5686 : :
5687 : 877 : m = gfc_match (" %v =", &lvalue);
5688 : 877 : if (m != MATCH_YES)
5689 : 200 : gfc_current_locus = old_loc;
5690 : : else
5691 : : {
5692 : 677 : m = gfc_match (" %e )", &rvalue);
5693 : 677 : if (m == MATCH_YES)
5694 : : {
5695 : 675 : ns->code = gfc_get_code (EXEC_ASSIGN);
5696 : 675 : ns->code->expr1 = lvalue;
5697 : 675 : ns->code->expr2 = rvalue;
5698 : 675 : ns->code->loc = old_loc;
5699 : 675 : return true;
5700 : : }
5701 : :
5702 : 2 : gfc_current_locus = old_loc;
5703 : 2 : gfc_free_expr (lvalue);
5704 : : }
5705 : :
5706 : 202 : m = gfc_match (" %n", sname);
5707 : 202 : if (m != MATCH_YES)
5708 : : return false;
5709 : :
5710 : 202 : if (strcmp (sname, omp_sym1->name) == 0
5711 : 200 : || strcmp (sname, omp_sym2->name) == 0)
5712 : : return false;
5713 : :
5714 : 200 : gfc_current_ns = ns->parent;
5715 : 200 : if (gfc_get_ha_sym_tree (sname, &st))
5716 : : return false;
5717 : :
5718 : 200 : sym = st->n.sym;
5719 : 200 : if (sym->attr.flavor != FL_PROCEDURE
5720 : 72 : && sym->attr.flavor != FL_UNKNOWN)
5721 : : return false;
5722 : :
5723 : 199 : if (!sym->attr.generic
5724 : 189 : && !sym->attr.subroutine
5725 : 71 : && !sym->attr.function)
5726 : : {
5727 : 71 : if (!(sym->attr.external && !sym->attr.referenced))
5728 : : {
5729 : : /* ...create a symbol in this scope... */
5730 : 71 : if (sym->ns != gfc_current_ns
5731 : 71 : && gfc_get_sym_tree (sname, NULL, &st, false) == 1)
5732 : : return false;
5733 : :
5734 : 71 : if (sym != st->n.sym)
5735 : 71 : sym = st->n.sym;
5736 : : }
5737 : :
5738 : : /* ...and then to try to make the symbol into a subroutine. */
5739 : 71 : if (!gfc_add_subroutine (&sym->attr, sym->name, NULL))
5740 : : return false;
5741 : : }
5742 : :
5743 : 199 : gfc_set_sym_referenced (sym);
5744 : 199 : gfc_gobble_whitespace ();
5745 : 199 : if (gfc_peek_ascii_char () != '(')
5746 : : return false;
5747 : :
5748 : 195 : gfc_current_ns = ns;
5749 : 195 : m = gfc_match_actual_arglist (1, &arglist);
5750 : 195 : if (m != MATCH_YES)
5751 : : return false;
5752 : :
5753 : 195 : if (gfc_match_char (')') != MATCH_YES)
5754 : : return false;
5755 : :
5756 : 195 : ns->code = gfc_get_code (EXEC_CALL);
5757 : 195 : ns->code->symtree = st;
5758 : 195 : ns->code->ext.actual = arglist;
5759 : 195 : ns->code->loc = old_loc;
5760 : 195 : return true;
5761 : : }
5762 : :
5763 : : static bool
5764 : 1156 : gfc_omp_udr_predef (gfc_omp_reduction_op rop, const char *name,
5765 : : gfc_typespec *ts, const char **n)
5766 : : {
5767 : 1156 : if (!gfc_numeric_ts (ts) && ts->type != BT_LOGICAL)
5768 : : return false;
5769 : :
5770 : 648 : switch (rop)
5771 : : {
5772 : 21 : case OMP_REDUCTION_PLUS:
5773 : 21 : case OMP_REDUCTION_MINUS:
5774 : 21 : case OMP_REDUCTION_TIMES:
5775 : 21 : return ts->type != BT_LOGICAL;
5776 : 8 : case OMP_REDUCTION_AND:
5777 : 8 : case OMP_REDUCTION_OR:
5778 : 8 : case OMP_REDUCTION_EQV:
5779 : 8 : case OMP_REDUCTION_NEQV:
5780 : 8 : return ts->type == BT_LOGICAL;
5781 : 618 : case OMP_REDUCTION_USER:
5782 : 618 : if (name[0] != '.' && (ts->type == BT_INTEGER || ts->type == BT_REAL))
5783 : : {
5784 : 546 : gfc_symbol *sym;
5785 : :
5786 : 546 : gfc_find_symbol (name, NULL, 1, &sym);
5787 : 546 : if (sym != NULL)
5788 : : {
5789 : 93 : if (sym->attr.intrinsic)
5790 : 0 : *n = sym->name;
5791 : 93 : else if ((sym->attr.flavor != FL_UNKNOWN
5792 : 81 : && sym->attr.flavor != FL_PROCEDURE)
5793 : 69 : || sym->attr.external
5794 : 54 : || sym->attr.generic
5795 : 54 : || sym->attr.entry
5796 : 54 : || sym->attr.result
5797 : 54 : || sym->attr.dummy
5798 : 54 : || sym->attr.subroutine
5799 : 50 : || sym->attr.pointer
5800 : 50 : || sym->attr.target
5801 : 50 : || sym->attr.cray_pointer
5802 : 50 : || sym->attr.cray_pointee
5803 : 50 : || (sym->attr.proc != PROC_UNKNOWN
5804 : 0 : && sym->attr.proc != PROC_INTRINSIC)
5805 : 50 : || sym->attr.if_source != IFSRC_UNKNOWN
5806 : 50 : || sym == sym->ns->proc_name)
5807 : 43 : *n = NULL;
5808 : : else
5809 : 50 : *n = sym->name;
5810 : : }
5811 : : else
5812 : 453 : *n = name;
5813 : 546 : if (*n
5814 : 503 : && (strcmp (*n, "max") == 0 || strcmp (*n, "min") == 0))
5815 : 54 : return true;
5816 : 510 : else if (*n
5817 : 467 : && ts->type == BT_INTEGER
5818 : 383 : && (strcmp (*n, "iand") == 0
5819 : 377 : || strcmp (*n, "ior") == 0
5820 : 371 : || strcmp (*n, "ieor") == 0))
5821 : : return true;
5822 : : }
5823 : : break;
5824 : : default:
5825 : : break;
5826 : : }
5827 : : return false;
5828 : : }
5829 : :
5830 : : gfc_omp_udr *
5831 : 639 : gfc_omp_udr_find (gfc_symtree *st, gfc_typespec *ts)
5832 : : {
5833 : 639 : gfc_omp_udr *omp_udr;
5834 : :
5835 : 639 : if (st == NULL)
5836 : : return NULL;
5837 : :
5838 : 250 : for (omp_udr = st->n.omp_udr; omp_udr; omp_udr = omp_udr->next)
5839 : 154 : if (omp_udr->ts.type == ts->type
5840 : 89 : || ((omp_udr->ts.type == BT_DERIVED || omp_udr->ts.type == BT_CLASS)
5841 : 0 : && (ts->type == BT_DERIVED || ts->type == BT_CLASS)))
5842 : : {
5843 : 65 : if (omp_udr->ts.type == BT_DERIVED || omp_udr->ts.type == BT_CLASS)
5844 : : {
5845 : 12 : if (strcmp (omp_udr->ts.u.derived->name, ts->u.derived->name) == 0)
5846 : : return omp_udr;
5847 : : }
5848 : 53 : else if (omp_udr->ts.kind == ts->kind)
5849 : : {
5850 : 19 : if (omp_udr->ts.type == BT_CHARACTER)
5851 : : {
5852 : 17 : if (omp_udr->ts.u.cl->length == NULL
5853 : 15 : || ts->u.cl->length == NULL)
5854 : : return omp_udr;
5855 : 15 : if (omp_udr->ts.u.cl->length->expr_type != EXPR_CONSTANT)
5856 : : return omp_udr;
5857 : 15 : if (ts->u.cl->length->expr_type != EXPR_CONSTANT)
5858 : : return omp_udr;
5859 : 15 : if (omp_udr->ts.u.cl->length->ts.type != BT_INTEGER)
5860 : : return omp_udr;
5861 : 15 : if (ts->u.cl->length->ts.type != BT_INTEGER)
5862 : : return omp_udr;
5863 : 15 : if (gfc_compare_expr (omp_udr->ts.u.cl->length,
5864 : : ts->u.cl->length, INTRINSIC_EQ) != 0)
5865 : 15 : continue;
5866 : : }
5867 : 2 : return omp_udr;
5868 : : }
5869 : : }
5870 : : return NULL;
5871 : : }
5872 : :
5873 : : match
5874 : 532 : gfc_match_omp_declare_reduction (void)
5875 : : {
5876 : 532 : match m;
5877 : 532 : gfc_intrinsic_op op;
5878 : 532 : char name[GFC_MAX_SYMBOL_LEN + 3];
5879 : 532 : auto_vec<gfc_typespec, 5> tss;
5880 : 532 : gfc_typespec ts;
5881 : 532 : unsigned int i;
5882 : 532 : gfc_symtree *st;
5883 : 532 : locus where = gfc_current_locus;
5884 : 532 : locus end_loc = gfc_current_locus;
5885 : 532 : bool end_loc_set = false;
5886 : 532 : gfc_omp_reduction_op rop = OMP_REDUCTION_NONE;
5887 : :
5888 : 532 : if (gfc_match_char ('(') != MATCH_YES)
5889 : : return MATCH_ERROR;
5890 : :
5891 : 530 : m = gfc_match (" %o : ", &op);
5892 : 530 : if (m == MATCH_ERROR)
5893 : : return MATCH_ERROR;
5894 : 530 : if (m == MATCH_YES)
5895 : : {
5896 : 117 : snprintf (name, sizeof name, "operator %s", gfc_op2string (op));
5897 : 117 : rop = (gfc_omp_reduction_op) op;
5898 : : }
5899 : : else
5900 : : {
5901 : 413 : m = gfc_match_defined_op_name (name + 1, 1);
5902 : 413 : if (m == MATCH_ERROR)
5903 : : return MATCH_ERROR;
5904 : 413 : if (m == MATCH_YES)
5905 : : {
5906 : 41 : name[0] = '.';
5907 : 41 : strcat (name, ".");
5908 : 41 : if (gfc_match (" : ") != MATCH_YES)
5909 : : return MATCH_ERROR;
5910 : : }
5911 : : else
5912 : : {
5913 : 372 : if (gfc_match (" %n : ", name) != MATCH_YES)
5914 : : return MATCH_ERROR;
5915 : : }
5916 : : rop = OMP_REDUCTION_USER;
5917 : : }
5918 : :
5919 : 529 : m = gfc_match_type_spec (&ts);
5920 : 529 : if (m != MATCH_YES)
5921 : : return MATCH_ERROR;
5922 : : /* Treat len=: the same as len=*. */
5923 : 528 : if (ts.type == BT_CHARACTER)
5924 : 61 : ts.deferred = false;
5925 : 528 : tss.safe_push (ts);
5926 : :
5927 : 1093 : while (gfc_match_char (',') == MATCH_YES)
5928 : : {
5929 : 37 : m = gfc_match_type_spec (&ts);
5930 : 37 : if (m != MATCH_YES)
5931 : : return MATCH_ERROR;
5932 : 37 : tss.safe_push (ts);
5933 : : }
5934 : 528 : if (gfc_match_char (':') != MATCH_YES)
5935 : : return MATCH_ERROR;
5936 : :
5937 : 527 : st = gfc_find_symtree (gfc_current_ns->omp_udr_root, name);
5938 : 1084 : for (i = 0; i < tss.length (); i++)
5939 : : {
5940 : 564 : gfc_symtree *omp_out, *omp_in;
5941 : 564 : gfc_symtree *omp_priv = NULL, *omp_orig = NULL;
5942 : 564 : gfc_namespace *combiner_ns, *initializer_ns = NULL;
5943 : 564 : gfc_omp_udr *prev_udr, *omp_udr;
5944 : 564 : const char *predef_name = NULL;
5945 : :
5946 : 564 : omp_udr = gfc_get_omp_udr ();
5947 : 564 : omp_udr->name = gfc_get_string ("%s", name);
5948 : 564 : omp_udr->rop = rop;
5949 : 564 : omp_udr->ts = tss[i];
5950 : 564 : omp_udr->where = where;
5951 : :
5952 : 564 : gfc_current_ns = combiner_ns = gfc_get_namespace (gfc_current_ns, 1);
5953 : 564 : combiner_ns->proc_name = combiner_ns->parent->proc_name;
5954 : :
5955 : 564 : gfc_get_sym_tree ("omp_out", combiner_ns, &omp_out, false);
5956 : 564 : gfc_get_sym_tree ("omp_in", combiner_ns, &omp_in, false);
5957 : 564 : combiner_ns->omp_udr_ns = 1;
5958 : 564 : omp_out->n.sym->ts = tss[i];
5959 : 564 : omp_in->n.sym->ts = tss[i];
5960 : 564 : omp_out->n.sym->attr.omp_udr_artificial_var = 1;
5961 : 564 : omp_in->n.sym->attr.omp_udr_artificial_var = 1;
5962 : 564 : omp_out->n.sym->attr.flavor = FL_VARIABLE;
5963 : 564 : omp_in->n.sym->attr.flavor = FL_VARIABLE;
5964 : 564 : gfc_commit_symbols ();
5965 : 564 : omp_udr->combiner_ns = combiner_ns;
5966 : 564 : omp_udr->omp_out = omp_out->n.sym;
5967 : 564 : omp_udr->omp_in = omp_in->n.sym;
5968 : :
5969 : 564 : locus old_loc = gfc_current_locus;
5970 : :
5971 : 564 : if (!match_udr_expr (omp_out, omp_in))
5972 : : {
5973 : 4 : syntax:
5974 : 7 : gfc_current_locus = old_loc;
5975 : 7 : gfc_current_ns = combiner_ns->parent;
5976 : 7 : gfc_undo_symbols ();
5977 : 7 : gfc_free_omp_udr (omp_udr);
5978 : 7 : return MATCH_ERROR;
5979 : : }
5980 : :
5981 : 560 : if (gfc_match (" initializer ( ") == MATCH_YES)
5982 : : {
5983 : 313 : gfc_current_ns = combiner_ns->parent;
5984 : 313 : initializer_ns = gfc_get_namespace (gfc_current_ns, 1);
5985 : 313 : gfc_current_ns = initializer_ns;
5986 : 313 : initializer_ns->proc_name = initializer_ns->parent->proc_name;
5987 : :
5988 : 313 : gfc_get_sym_tree ("omp_priv", initializer_ns, &omp_priv, false);
5989 : 313 : gfc_get_sym_tree ("omp_orig", initializer_ns, &omp_orig, false);
5990 : 313 : initializer_ns->omp_udr_ns = 1;
5991 : 313 : omp_priv->n.sym->ts = tss[i];
5992 : 313 : omp_orig->n.sym->ts = tss[i];
5993 : 313 : omp_priv->n.sym->attr.omp_udr_artificial_var = 1;
5994 : 313 : omp_orig->n.sym->attr.omp_udr_artificial_var = 1;
5995 : 313 : omp_priv->n.sym->attr.flavor = FL_VARIABLE;
5996 : 313 : omp_orig->n.sym->attr.flavor = FL_VARIABLE;
5997 : 313 : gfc_commit_symbols ();
5998 : 313 : omp_udr->initializer_ns = initializer_ns;
5999 : 313 : omp_udr->omp_priv = omp_priv->n.sym;
6000 : 313 : omp_udr->omp_orig = omp_orig->n.sym;
6001 : :
6002 : 313 : if (!match_udr_expr (omp_priv, omp_orig))
6003 : 3 : goto syntax;
6004 : : }
6005 : :
6006 : 557 : gfc_current_ns = combiner_ns->parent;
6007 : 557 : if (!end_loc_set)
6008 : : {
6009 : 520 : end_loc_set = true;
6010 : 520 : end_loc = gfc_current_locus;
6011 : : }
6012 : 557 : gfc_current_locus = old_loc;
6013 : :
6014 : 557 : prev_udr = gfc_omp_udr_find (st, &tss[i]);
6015 : 557 : if (gfc_omp_udr_predef (rop, name, &tss[i], &predef_name)
6016 : : /* Don't error on !$omp declare reduction (min : integer : ...)
6017 : : just yet, there could be integer :: min afterwards,
6018 : : making it valid. When the UDR is resolved, we'll get
6019 : : to it again. */
6020 : 557 : && (rop != OMP_REDUCTION_USER || name[0] == '.'))
6021 : : {
6022 : 29 : if (predef_name)
6023 : 0 : gfc_error_now ("Redefinition of predefined %s "
6024 : : "!$OMP DECLARE REDUCTION at %L",
6025 : : predef_name, &where);
6026 : : else
6027 : 29 : gfc_error_now ("Redefinition of predefined "
6028 : : "!$OMP DECLARE REDUCTION at %L", &where);
6029 : : }
6030 : 528 : else if (prev_udr)
6031 : : {
6032 : 6 : gfc_error_now ("Redefinition of !$OMP DECLARE REDUCTION at %L",
6033 : : &where);
6034 : 6 : gfc_error_now ("Previous !$OMP DECLARE REDUCTION at %L",
6035 : : &prev_udr->where);
6036 : : }
6037 : 522 : else if (st)
6038 : : {
6039 : 96 : omp_udr->next = st->n.omp_udr;
6040 : 96 : st->n.omp_udr = omp_udr;
6041 : : }
6042 : : else
6043 : : {
6044 : 426 : st = gfc_new_symtree (&gfc_current_ns->omp_udr_root, name);
6045 : 426 : st->n.omp_udr = omp_udr;
6046 : : }
6047 : : }
6048 : :
6049 : 520 : if (end_loc_set)
6050 : : {
6051 : 520 : gfc_current_locus = end_loc;
6052 : 520 : if (gfc_match_omp_eos () != MATCH_YES)
6053 : : {
6054 : 1 : gfc_error ("Unexpected junk after !$OMP DECLARE REDUCTION at %C");
6055 : 1 : gfc_current_locus = where;
6056 : 1 : return MATCH_ERROR;
6057 : : }
6058 : :
6059 : : return MATCH_YES;
6060 : : }
6061 : 0 : gfc_clear_error ();
6062 : 0 : return MATCH_ERROR;
6063 : 532 : }
6064 : :
6065 : :
6066 : : match
6067 : 441 : gfc_match_omp_declare_target (void)
6068 : : {
6069 : 441 : locus old_loc;
6070 : 441 : match m;
6071 : 441 : gfc_omp_clauses *c = NULL;
6072 : 441 : int list;
6073 : 441 : gfc_omp_namelist *n;
6074 : 441 : gfc_symbol *s;
6075 : :
6076 : 441 : old_loc = gfc_current_locus;
6077 : :
6078 : 441 : if (gfc_current_ns->proc_name
6079 : 441 : && gfc_match_omp_eos () == MATCH_YES)
6080 : : {
6081 : 138 : if (!gfc_add_omp_declare_target (&gfc_current_ns->proc_name->attr,
6082 : 138 : gfc_current_ns->proc_name->name,
6083 : : &old_loc))
6084 : 0 : goto cleanup;
6085 : : return MATCH_YES;
6086 : : }
6087 : :
6088 : 303 : if (gfc_current_ns->proc_name
6089 : 303 : && gfc_current_ns->proc_name->attr.if_source == IFSRC_IFBODY)
6090 : : {
6091 : 2 : gfc_error ("Only the !$OMP DECLARE TARGET form without "
6092 : : "clauses is allowed in interface block at %C");
6093 : 2 : goto cleanup;
6094 : : }
6095 : :
6096 : 301 : m = gfc_match (" (");
6097 : 301 : if (m == MATCH_YES)
6098 : : {
6099 : 81 : c = gfc_get_omp_clauses ();
6100 : 81 : gfc_current_locus = old_loc;
6101 : 81 : m = gfc_match_omp_to_link (" (", &c->lists[OMP_LIST_ENTER]);
6102 : 81 : if (m != MATCH_YES)
6103 : 0 : goto syntax;
6104 : 81 : if (gfc_match_omp_eos () != MATCH_YES)
6105 : : {
6106 : 0 : gfc_error ("Unexpected junk after !$OMP DECLARE TARGET at %C");
6107 : 0 : goto cleanup;
6108 : : }
6109 : : }
6110 : 220 : else if (gfc_match_omp_clauses (&c, OMP_DECLARE_TARGET_CLAUSES) != MATCH_YES)
6111 : : return MATCH_ERROR;
6112 : :
6113 : 295 : gfc_buffer_error (false);
6114 : :
6115 : 295 : static const int to_enter_link_lists[]
6116 : : = { OMP_LIST_TO, OMP_LIST_ENTER, OMP_LIST_LINK };
6117 : 1180 : for (size_t listn = 0; listn < ARRAY_SIZE (to_enter_link_lists)
6118 : 1180 : && (list = to_enter_link_lists[listn], true); ++listn)
6119 : 1387 : for (n = c->lists[list]; n; n = n->next)
6120 : 502 : if (n->sym)
6121 : 477 : n->sym->mark = 0;
6122 : 25 : else if (n->u.common->head)
6123 : 25 : n->u.common->head->mark = 0;
6124 : :
6125 : 885 : for (size_t listn = 0; listn < ARRAY_SIZE (to_enter_link_lists)
6126 : 1180 : && (list = to_enter_link_lists[listn], true); ++listn)
6127 : 1387 : for (n = c->lists[list]; n; n = n->next)
6128 : 502 : if (n->sym)
6129 : : {
6130 : 477 : if (n->sym->attr.in_common)
6131 : 1 : gfc_error_now ("OMP DECLARE TARGET variable at %L is an "
6132 : : "element of a COMMON block", &n->where);
6133 : 476 : else if (n->sym->mark)
6134 : 9 : gfc_error_now ("Variable at %L mentioned multiple times in "
6135 : : "clauses of the same OMP DECLARE TARGET directive",
6136 : : &n->where);
6137 : 467 : else if (n->sym->attr.omp_declare_target
6138 : 23 : && n->sym->attr.omp_declare_target_link
6139 : 9 : && list != OMP_LIST_LINK)
6140 : 1 : gfc_error_now ("OMP DECLARE TARGET variable at %L previously "
6141 : : "mentioned in LINK clause and later in %s clause",
6142 : : &n->where, list == OMP_LIST_TO ? "TO" : "ENTER");
6143 : 466 : else if (n->sym->attr.omp_declare_target
6144 : 22 : && !n->sym->attr.omp_declare_target_link
6145 : 14 : && list == OMP_LIST_LINK)
6146 : 1 : gfc_error_now ("OMP DECLARE TARGET variable at %L previously "
6147 : : "mentioned in TO or ENTER clause and later in "
6148 : : "LINK clause", &n->where);
6149 : 465 : else if (gfc_add_omp_declare_target (&n->sym->attr, n->sym->name,
6150 : : &n->sym->declared_at))
6151 : : {
6152 : 459 : if (list == OMP_LIST_LINK)
6153 : 25 : gfc_add_omp_declare_target_link (&n->sym->attr, n->sym->name,
6154 : 25 : &n->sym->declared_at);
6155 : : }
6156 : 477 : if (c->device_type != OMP_DEVICE_TYPE_UNSET)
6157 : : {
6158 : 43 : if (n->sym->attr.omp_device_type != OMP_DEVICE_TYPE_UNSET
6159 : 17 : && n->sym->attr.omp_device_type != c->device_type)
6160 : 13 : gfc_error_now ("List item %qs at %L set in previous OMP DECLARE "
6161 : : "TARGET directive to a different DEVICE_TYPE",
6162 : : n->sym->name, &n->where);
6163 : 43 : n->sym->attr.omp_device_type = c->device_type;
6164 : : }
6165 : 477 : if (c->indirect)
6166 : : {
6167 : 50 : if (n->sym->attr.omp_device_type != OMP_DEVICE_TYPE_UNSET
6168 : 1 : && n->sym->attr.omp_device_type != OMP_DEVICE_TYPE_ANY)
6169 : 1 : gfc_error_now ("DEVICE_TYPE must be ANY when used with "
6170 : : "INDIRECT at %L", &n->where);
6171 : 50 : n->sym->attr.omp_declare_target_indirect = c->indirect;
6172 : : }
6173 : :
6174 : 477 : n->sym->mark = 1;
6175 : : }
6176 : 25 : else if (n->u.common->omp_declare_target
6177 : 12 : && n->u.common->omp_declare_target_link
6178 : 6 : && list != OMP_LIST_LINK)
6179 : 2 : gfc_error_now ("OMP DECLARE TARGET COMMON at %L previously "
6180 : : "mentioned in LINK clause and later in %s clause",
6181 : : &n->where, list == OMP_LIST_TO ? "TO" : "ENTER");
6182 : 24 : else if (n->u.common->omp_declare_target
6183 : 11 : && !n->u.common->omp_declare_target_link
6184 : 6 : && list == OMP_LIST_LINK)
6185 : 1 : gfc_error_now ("OMP DECLARE TARGET COMMON at %L previously "
6186 : : "mentioned in TO or ENTER clause and later in "
6187 : : "LINK clause", &n->where);
6188 : 23 : else if (n->u.common->head && n->u.common->head->mark)
6189 : 4 : gfc_error_now ("COMMON at %L mentioned multiple times in "
6190 : : "clauses of the same OMP DECLARE TARGET directive",
6191 : : &n->where);
6192 : : else
6193 : : {
6194 : 19 : n->u.common->omp_declare_target = 1;
6195 : 19 : n->u.common->omp_declare_target_link = (list == OMP_LIST_LINK);
6196 : 19 : if (n->u.common->omp_device_type != OMP_DEVICE_TYPE_UNSET
6197 : 0 : && n->u.common->omp_device_type != c->device_type)
6198 : 0 : gfc_error_now ("COMMON at %L set in previous OMP DECLARE "
6199 : : "TARGET directive to a different DEVICE_TYPE",
6200 : : &n->where);
6201 : 19 : n->u.common->omp_device_type = c->device_type;
6202 : :
6203 : 59 : for (s = n->u.common->head; s; s = s->common_next)
6204 : : {
6205 : 40 : s->mark = 1;
6206 : 40 : if (gfc_add_omp_declare_target (&s->attr, s->name,
6207 : : &s->declared_at))
6208 : : {
6209 : 40 : if (list == OMP_LIST_LINK)
6210 : 21 : gfc_add_omp_declare_target_link (&s->attr, s->name,
6211 : : &s->declared_at);
6212 : : }
6213 : 40 : if (s->attr.omp_device_type != OMP_DEVICE_TYPE_UNSET
6214 : 0 : && s->attr.omp_device_type != c->device_type)
6215 : 0 : gfc_error_now ("List item %qs at %L set in previous OMP DECLARE"
6216 : : " TARGET directive to a different DEVICE_TYPE",
6217 : : s->name, &n->where);
6218 : 40 : s->attr.omp_device_type = c->device_type;
6219 : :
6220 : 40 : if (c->indirect
6221 : 0 : && s->attr.omp_device_type != OMP_DEVICE_TYPE_UNSET
6222 : 0 : && s->attr.omp_device_type != OMP_DEVICE_TYPE_ANY)
6223 : 0 : gfc_error_now ("DEVICE_TYPE must be ANY when used with "
6224 : : "INDIRECT at %L", &n->where);
6225 : 40 : s->attr.omp_declare_target_indirect = c->indirect;
6226 : : }
6227 : : }
6228 : 295 : if ((c->device_type || c->indirect)
6229 : 99 : && !c->lists[OMP_LIST_ENTER]
6230 : 87 : && !c->lists[OMP_LIST_TO]
6231 : 19 : && !c->lists[OMP_LIST_LINK])
6232 : 2 : gfc_warning_now (OPT_Wopenmp,
6233 : : "OMP DECLARE TARGET directive at %L with only "
6234 : : "DEVICE_TYPE or INDIRECT clauses is ignored",
6235 : : &old_loc);
6236 : :
6237 : 295 : gfc_buffer_error (true);
6238 : :
6239 : 295 : if (c)
6240 : 295 : gfc_free_omp_clauses (c);
6241 : 295 : return MATCH_YES;
6242 : :
6243 : 0 : syntax:
6244 : 0 : gfc_error ("Syntax error in !$OMP DECLARE TARGET list at %C");
6245 : :
6246 : 2 : cleanup:
6247 : 2 : gfc_current_locus = old_loc;
6248 : 2 : if (c)
6249 : 0 : gfc_free_omp_clauses (c);
6250 : : return MATCH_ERROR;
6251 : : }
6252 : :
6253 : : /* Skip over and ignore trait-property-extensions.
6254 : :
6255 : : trait-property-extension :
6256 : : trait-property-name
6257 : : identifier (trait-property-extension[, trait-property-extension[, ...]])
6258 : : constant integer expression
6259 : : */
6260 : :
6261 : : static match gfc_ignore_trait_property_extension_list (void);
6262 : :
6263 : : static match
6264 : 7 : gfc_ignore_trait_property_extension (void)
6265 : : {
6266 : 7 : char buf[GFC_MAX_SYMBOL_LEN + 1];
6267 : 7 : gfc_expr *expr;
6268 : :
6269 : : /* Identifier form of trait-property name, possibly followed by
6270 : : a list of (recursive) trait-property-extensions. */
6271 : 7 : if (gfc_match_name (buf) == MATCH_YES)
6272 : : {
6273 : 0 : if (gfc_match (" (") == MATCH_YES)
6274 : 0 : return gfc_ignore_trait_property_extension_list ();
6275 : : return MATCH_YES;
6276 : : }
6277 : :
6278 : : /* Literal constant. */
6279 : 7 : if (gfc_match_literal_constant (&expr, 0) == MATCH_YES)
6280 : : return MATCH_YES;
6281 : :
6282 : : /* FIXME: constant integer expressions. */
6283 : 0 : gfc_error ("Expected trait-property-extension at %C");
6284 : 0 : return MATCH_ERROR;
6285 : : }
6286 : :
6287 : : static match
6288 : 5 : gfc_ignore_trait_property_extension_list (void)
6289 : : {
6290 : 9 : while (1)
6291 : : {
6292 : 7 : if (gfc_ignore_trait_property_extension () != MATCH_YES)
6293 : : return MATCH_ERROR;
6294 : 7 : if (gfc_match (" ,") == MATCH_YES)
6295 : 2 : continue;
6296 : 5 : if (gfc_match (" )") == MATCH_YES)
6297 : : return MATCH_YES;
6298 : 0 : gfc_error ("expected %<)%> at %C");
6299 : 0 : return MATCH_ERROR;
6300 : : }
6301 : : }
6302 : :
6303 : :
6304 : : match
6305 : 110 : gfc_match_omp_interop (void)
6306 : : {
6307 : 110 : return match_omp (EXEC_OMP_INTEROP, OMP_INTEROP_CLAUSES);
6308 : : }
6309 : :
6310 : :
6311 : : /* OpenMP 5.0:
6312 : :
6313 : : trait-selector:
6314 : : trait-selector-name[([trait-score:]trait-property[,trait-property[,...]])]
6315 : :
6316 : : trait-score:
6317 : : score(score-expression) */
6318 : :
6319 : : static match
6320 : 637 : gfc_match_omp_context_selector (gfc_omp_set_selector *oss)
6321 : : {
6322 : 775 : do
6323 : : {
6324 : 775 : char selector[GFC_MAX_SYMBOL_LEN + 1];
6325 : :
6326 : 775 : if (gfc_match_name (selector) != MATCH_YES)
6327 : : {
6328 : 2 : gfc_error ("expected trait selector name at %C");
6329 : 39 : return MATCH_ERROR;
6330 : : }
6331 : :
6332 : 773 : gfc_omp_selector *os = gfc_get_omp_selector ();
6333 : 773 : if (oss->code == OMP_TRAIT_SET_CONSTRUCT
6334 : 335 : && !strcmp (selector, "do"))
6335 : 48 : os->code = OMP_TRAIT_CONSTRUCT_FOR;
6336 : 725 : else if (oss->code == OMP_TRAIT_SET_CONSTRUCT
6337 : 287 : && !strcmp (selector, "for"))
6338 : 1 : os->code = OMP_TRAIT_INVALID;
6339 : : else
6340 : 724 : os->code = omp_lookup_ts_code (oss->code, selector);
6341 : 773 : os->next = oss->trait_selectors;
6342 : 773 : oss->trait_selectors = os;
6343 : :
6344 : 773 : if (os->code == OMP_TRAIT_INVALID)
6345 : : {
6346 : 18 : gfc_warning (OPT_Wopenmp,
6347 : : "unknown selector %qs for context selector set %qs "
6348 : : "at %C",
6349 : 18 : selector, omp_tss_map[oss->code]);
6350 : 18 : if (gfc_match (" (") == MATCH_YES
6351 : 18 : && gfc_ignore_trait_property_extension_list () != MATCH_YES)
6352 : : return MATCH_ERROR;
6353 : 18 : if (gfc_match (" ,") == MATCH_YES)
6354 : 1 : continue;
6355 : 598 : break;
6356 : : }
6357 : :
6358 : 755 : enum omp_tp_type property_kind = omp_ts_map[os->code].tp_type;
6359 : 755 : bool allow_score = omp_ts_map[os->code].allow_score;
6360 : :
6361 : 755 : if (gfc_match (" (") == MATCH_YES)
6362 : : {
6363 : 431 : if (property_kind == OMP_TRAIT_PROPERTY_NONE)
6364 : : {
6365 : 6 : gfc_error ("selector %qs does not accept any properties at %C",
6366 : : selector);
6367 : 6 : return MATCH_ERROR;
6368 : : }
6369 : :
6370 : 425 : if (gfc_match (" score") == MATCH_YES)
6371 : : {
6372 : 63 : if (!allow_score)
6373 : : {
6374 : 10 : gfc_error ("%<score%> cannot be specified in traits "
6375 : : "in the %qs trait-selector-set at %C",
6376 : 10 : omp_tss_map[oss->code]);
6377 : 10 : return MATCH_ERROR;
6378 : : }
6379 : 53 : if (gfc_match (" (") != MATCH_YES)
6380 : : {
6381 : 0 : gfc_error ("expected %<(%> at %C");
6382 : 0 : return MATCH_ERROR;
6383 : : }
6384 : 53 : if (gfc_match_expr (&os->score) != MATCH_YES)
6385 : : return MATCH_ERROR;
6386 : :
6387 : 52 : if (gfc_match (" )") != MATCH_YES)
6388 : : {
6389 : 0 : gfc_error ("expected %<)%> at %C");
6390 : 0 : return MATCH_ERROR;
6391 : : }
6392 : :
6393 : 52 : if (gfc_match (" :") != MATCH_YES)
6394 : : {
6395 : 0 : gfc_error ("expected : at %C");
6396 : 0 : return MATCH_ERROR;
6397 : : }
6398 : : }
6399 : :
6400 : 414 : gfc_omp_trait_property *otp = gfc_get_omp_trait_property ();
6401 : 414 : otp->property_kind = property_kind;
6402 : 414 : otp->next = os->properties;
6403 : 414 : os->properties = otp;
6404 : :
6405 : 414 : switch (property_kind)
6406 : : {
6407 : 25 : case OMP_TRAIT_PROPERTY_ID:
6408 : 25 : {
6409 : 25 : char buf[GFC_MAX_SYMBOL_LEN + 1];
6410 : 25 : if (gfc_match_name (buf) == MATCH_YES)
6411 : : {
6412 : 24 : otp->name = XNEWVEC (char, strlen (buf) + 1);
6413 : 24 : strcpy (otp->name, buf);
6414 : : }
6415 : : else
6416 : : {
6417 : 1 : gfc_error ("expected identifier at %C");
6418 : 1 : free (otp);
6419 : 1 : os->properties = nullptr;
6420 : 1 : return MATCH_ERROR;
6421 : : }
6422 : : }
6423 : 24 : break;
6424 : 290 : case OMP_TRAIT_PROPERTY_NAME_LIST:
6425 : 343 : do
6426 : : {
6427 : 290 : char buf[GFC_MAX_SYMBOL_LEN + 1];
6428 : 290 : if (gfc_match_name (buf) == MATCH_YES)
6429 : : {
6430 : 170 : otp->name = XNEWVEC (char, strlen (buf) + 1);
6431 : 170 : strcpy (otp->name, buf);
6432 : 170 : otp->is_name = true;
6433 : : }
6434 : 120 : else if (gfc_match_literal_constant (&otp->expr, 0)
6435 : : != MATCH_YES
6436 : 120 : || otp->expr->ts.type != BT_CHARACTER)
6437 : : {
6438 : 5 : gfc_error ("expected identifier or string literal "
6439 : : "at %C");
6440 : 5 : free (otp);
6441 : 5 : os->properties = nullptr;
6442 : 5 : return MATCH_ERROR;
6443 : : }
6444 : :
6445 : 285 : if (gfc_match (" ,") == MATCH_YES)
6446 : : {
6447 : 53 : otp = gfc_get_omp_trait_property ();
6448 : 53 : otp->property_kind = property_kind;
6449 : 53 : otp->next = os->properties;
6450 : 53 : os->properties = otp;
6451 : : }
6452 : : else
6453 : : break;
6454 : 53 : }
6455 : : while (1);
6456 : 232 : break;
6457 : 137 : case OMP_TRAIT_PROPERTY_DEV_NUM_EXPR:
6458 : 137 : case OMP_TRAIT_PROPERTY_BOOL_EXPR:
6459 : 137 : if (gfc_match_expr (&otp->expr) != MATCH_YES)
6460 : : {
6461 : 3 : gfc_error ("expected expression at %C");
6462 : 3 : free (otp);
6463 : 3 : os->properties = nullptr;
6464 : 3 : return MATCH_ERROR;
6465 : : }
6466 : : break;
6467 : 15 : case OMP_TRAIT_PROPERTY_CLAUSE_LIST:
6468 : 15 : {
6469 : 15 : if (os->code == OMP_TRAIT_CONSTRUCT_SIMD)
6470 : : {
6471 : 15 : gfc_matching_omp_context_selector = true;
6472 : 15 : if (gfc_match_omp_clauses (&otp->clauses,
6473 : 15 : OMP_DECLARE_SIMD_CLAUSES,
6474 : : true, false, false)
6475 : : != MATCH_YES)
6476 : : {
6477 : 1 : gfc_matching_omp_context_selector = false;
6478 : 1 : gfc_error ("expected simd clause at %C");
6479 : 1 : return MATCH_ERROR;
6480 : : }
6481 : 14 : gfc_matching_omp_context_selector = false;
6482 : : }
6483 : 0 : else if (os->code == OMP_TRAIT_IMPLEMENTATION_REQUIRES)
6484 : : {
6485 : : /* FIXME: The "requires" selector was added in OpenMP 5.1.
6486 : : Currently only the now-deprecated syntax
6487 : : from OpenMP 5.0 is supported.
6488 : : TODO: When implementing, update modules.cc as well. */
6489 : 0 : sorry_at (gfc_get_location (&gfc_current_locus),
6490 : : "%<requires%> selector is not supported yet");
6491 : 0 : return MATCH_ERROR;
6492 : : }
6493 : : else
6494 : 0 : gcc_unreachable ();
6495 : 14 : break;
6496 : : }
6497 : 0 : default:
6498 : 0 : gcc_unreachable ();
6499 : : }
6500 : :
6501 : 404 : if (gfc_match (" )") != MATCH_YES)
6502 : : {
6503 : 2 : gfc_error ("expected %<)%> at %C");
6504 : 2 : return MATCH_ERROR;
6505 : : }
6506 : : }
6507 : 324 : else if (property_kind != OMP_TRAIT_PROPERTY_NONE
6508 : 324 : && property_kind != OMP_TRAIT_PROPERTY_CLAUSE_LIST
6509 : 8 : && property_kind != OMP_TRAIT_PROPERTY_EXTENSION)
6510 : : {
6511 : 8 : if (gfc_match (" (") != MATCH_YES)
6512 : : {
6513 : 8 : gfc_error ("expected %<(%> at %C");
6514 : 8 : return MATCH_ERROR;
6515 : : }
6516 : : }
6517 : :
6518 : 718 : if (gfc_match (" ,") != MATCH_YES)
6519 : : break;
6520 : : }
6521 : : while (1);
6522 : :
6523 : 598 : return MATCH_YES;
6524 : : }
6525 : :
6526 : : /* OpenMP 5.0:
6527 : :
6528 : : trait-set-selector[,trait-set-selector[,...]]
6529 : :
6530 : : trait-set-selector:
6531 : : trait-set-selector-name = { trait-selector[, trait-selector[, ...]] }
6532 : :
6533 : : trait-set-selector-name:
6534 : : constructor
6535 : : device
6536 : : implementation
6537 : : user */
6538 : :
6539 : : static match
6540 : 577 : gfc_match_omp_context_selector_specification (gfc_omp_set_selector **oss_head)
6541 : : {
6542 : 713 : do
6543 : : {
6544 : 645 : match m;
6545 : 645 : char buf[GFC_MAX_SYMBOL_LEN + 1];
6546 : 645 : enum omp_tss_code set = OMP_TRAIT_SET_INVALID;
6547 : :
6548 : 645 : m = gfc_match_name (buf);
6549 : 645 : if (m == MATCH_YES)
6550 : 643 : set = omp_lookup_tss_code (buf);
6551 : :
6552 : 643 : if (set == OMP_TRAIT_SET_INVALID)
6553 : : {
6554 : 5 : gfc_error ("expected context selector set name at %C");
6555 : 47 : return MATCH_ERROR;
6556 : : }
6557 : :
6558 : 640 : m = gfc_match (" =");
6559 : 640 : if (m != MATCH_YES)
6560 : : {
6561 : 1 : gfc_error ("expected %<=%> at %C");
6562 : 1 : return MATCH_ERROR;
6563 : : }
6564 : :
6565 : 639 : m = gfc_match (" {");
6566 : 639 : if (m != MATCH_YES)
6567 : : {
6568 : 2 : gfc_error ("expected %<{%> at %C");
6569 : 2 : return MATCH_ERROR;
6570 : : }
6571 : :
6572 : 637 : gfc_omp_set_selector *oss = gfc_get_omp_set_selector ();
6573 : 637 : oss->next = *oss_head;
6574 : 637 : oss->code = set;
6575 : 637 : *oss_head = oss;
6576 : :
6577 : 637 : if (gfc_match_omp_context_selector (oss) != MATCH_YES)
6578 : : return MATCH_ERROR;
6579 : :
6580 : 598 : m = gfc_match (" }");
6581 : 598 : if (m != MATCH_YES)
6582 : : {
6583 : 0 : gfc_error ("expected %<}%> at %C");
6584 : 0 : return MATCH_ERROR;
6585 : : }
6586 : :
6587 : 598 : m = gfc_match (" ,");
6588 : 598 : if (m != MATCH_YES)
6589 : : break;
6590 : 68 : }
6591 : : while (1);
6592 : :
6593 : 530 : return MATCH_YES;
6594 : : }
6595 : :
6596 : :
6597 : : match
6598 : 418 : gfc_match_omp_declare_variant (void)
6599 : : {
6600 : 418 : char buf[GFC_MAX_SYMBOL_LEN + 1];
6601 : :
6602 : 418 : if (gfc_match (" (") != MATCH_YES)
6603 : : {
6604 : 2 : gfc_error ("expected %<(%> at %C");
6605 : 2 : return MATCH_ERROR;
6606 : : }
6607 : :
6608 : 416 : gfc_symtree *base_proc_st, *variant_proc_st;
6609 : 416 : if (gfc_match_name (buf) != MATCH_YES)
6610 : : {
6611 : 2 : gfc_error ("expected name at %C");
6612 : 2 : return MATCH_ERROR;
6613 : : }
6614 : :
6615 : 414 : if (gfc_get_ha_sym_tree (buf, &base_proc_st))
6616 : : return MATCH_ERROR;
6617 : :
6618 : 414 : if (gfc_match (" :") == MATCH_YES)
6619 : : {
6620 : 15 : if (gfc_match_name (buf) != MATCH_YES)
6621 : : {
6622 : 0 : gfc_error ("expected variant name at %C");
6623 : 0 : return MATCH_ERROR;
6624 : : }
6625 : :
6626 : 15 : if (gfc_get_ha_sym_tree (buf, &variant_proc_st))
6627 : : return MATCH_ERROR;
6628 : : }
6629 : : else
6630 : : {
6631 : : /* Base procedure not specified. */
6632 : 399 : variant_proc_st = base_proc_st;
6633 : 399 : base_proc_st = NULL;
6634 : : }
6635 : :
6636 : 414 : gfc_omp_declare_variant *odv;
6637 : 414 : odv = gfc_get_omp_declare_variant ();
6638 : 414 : odv->where = gfc_current_locus;
6639 : 414 : odv->variant_proc_symtree = variant_proc_st;
6640 : 414 : odv->adjust_args_list = NULL;
6641 : 414 : odv->base_proc_symtree = base_proc_st;
6642 : 414 : odv->next = NULL;
6643 : 414 : odv->error_p = false;
6644 : :
6645 : : /* Add the new declare variant to the end of the list. */
6646 : 414 : gfc_omp_declare_variant **prev_next = &gfc_current_ns->omp_declare_variant;
6647 : 554 : while (*prev_next)
6648 : 140 : prev_next = &((*prev_next)->next);
6649 : 414 : *prev_next = odv;
6650 : :
6651 : 414 : if (gfc_match (" )") != MATCH_YES)
6652 : : {
6653 : 0 : gfc_error ("expected %<)%> at %C");
6654 : 0 : return MATCH_ERROR;
6655 : : }
6656 : :
6657 : 414 : bool has_match = false, has_adjust_args = false, has_append_args = false;
6658 : 414 : bool error_p = false;
6659 : 414 : locus adjust_args_loc;
6660 : 414 : locus append_args_loc;
6661 : :
6662 : 414 : gfc_gobble_whitespace ();
6663 : 414 : gfc_match_char (',');
6664 : 632 : for (;;)
6665 : : {
6666 : 523 : gfc_gobble_whitespace ();
6667 : :
6668 : 523 : enum clause
6669 : : {
6670 : : clause_match,
6671 : : clause_adjust_args,
6672 : : clause_append_args
6673 : : } ccode;
6674 : :
6675 : 523 : if (gfc_match ("match") == MATCH_YES)
6676 : : ccode = clause_match;
6677 : 119 : else if (gfc_match ("adjust_args") == MATCH_YES)
6678 : : {
6679 : 517 : ccode = clause_adjust_args;
6680 : : adjust_args_loc = gfc_current_locus;
6681 : : }
6682 : 38 : else if (gfc_match ("append_args") == MATCH_YES)
6683 : : {
6684 : 517 : ccode = clause_append_args;
6685 : : append_args_loc = gfc_current_locus;
6686 : : }
6687 : : else
6688 : : {
6689 : : error_p = true;
6690 : : break;
6691 : : }
6692 : :
6693 : 517 : if (gfc_match (" ( ") != MATCH_YES)
6694 : : {
6695 : 1 : gfc_error ("expected %<(%> at %C");
6696 : 1 : return MATCH_ERROR;
6697 : : }
6698 : :
6699 : 516 : if (ccode == clause_match)
6700 : : {
6701 : 403 : if (has_match)
6702 : : {
6703 : 1 : gfc_error ("%qs clause at %L specified more than once",
6704 : : "match", &gfc_current_locus);
6705 : 1 : return MATCH_ERROR;
6706 : : }
6707 : 402 : has_match = true;
6708 : 402 : if (gfc_match_omp_context_selector_specification (&odv->set_selectors)
6709 : : != MATCH_YES)
6710 : : return MATCH_ERROR;
6711 : 362 : if (gfc_match (" )") != MATCH_YES)
6712 : : {
6713 : 0 : gfc_error ("expected %<)%> at %C");
6714 : 0 : return MATCH_ERROR;
6715 : : }
6716 : : }
6717 : 113 : else if (ccode == clause_adjust_args)
6718 : : {
6719 : 81 : has_adjust_args = true;
6720 : 81 : bool need_device_ptr_p = false;
6721 : 81 : bool need_device_addr_p = false;
6722 : 81 : if (gfc_match ("nothing ") == MATCH_YES)
6723 : : ;
6724 : 58 : else if (gfc_match ("need_device_ptr ") == MATCH_YES)
6725 : : need_device_ptr_p = true;
6726 : 9 : else if (gfc_match ("need_device_addr ") == MATCH_YES)
6727 : : need_device_addr_p = true;
6728 : : else
6729 : : {
6730 : 2 : gfc_error ("expected %<nothing%>, %<need_device_ptr%> or "
6731 : : "%<need_device_addr%> at %C");
6732 : 2 : return MATCH_ERROR;
6733 : : }
6734 : 79 : if (gfc_match (": ") != MATCH_YES)
6735 : : {
6736 : 1 : gfc_error ("expected %<:%> at %C");
6737 : 1 : return MATCH_ERROR;
6738 : : }
6739 : : gfc_omp_namelist *tail = NULL;
6740 : : bool need_range = false, have_range = false;
6741 : 125 : while (true)
6742 : : {
6743 : 125 : gfc_omp_namelist *p = gfc_get_omp_namelist ();
6744 : 125 : p->where = gfc_current_locus;
6745 : 125 : p->u.adj_args.need_ptr = need_device_ptr_p;
6746 : 125 : p->u.adj_args.need_addr = need_device_addr_p;
6747 : 125 : if (tail)
6748 : : {
6749 : 47 : tail->next = p;
6750 : 47 : tail = tail->next;
6751 : : }
6752 : : else
6753 : : {
6754 : 78 : gfc_omp_namelist **q = &odv->adjust_args_list;
6755 : 78 : if (*q)
6756 : : {
6757 : 50 : for (; (*q)->next; q = &(*q)->next)
6758 : : ;
6759 : 28 : (*q)->next = p;
6760 : : }
6761 : : else
6762 : 50 : *q = p;
6763 : : tail = p;
6764 : : }
6765 : 125 : if (gfc_match (": ") == MATCH_YES)
6766 : : {
6767 : 2 : if (have_range)
6768 : : {
6769 : 0 : gfc_error ("unexpected %<:%> at %C");
6770 : 2 : return MATCH_ERROR;
6771 : : }
6772 : 2 : p->u.adj_args.range_start = have_range = true;
6773 : 2 : need_range = false;
6774 : 49 : continue;
6775 : : }
6776 : 123 : if (have_range && gfc_match (", ") == MATCH_YES)
6777 : : {
6778 : 1 : have_range = false;
6779 : 1 : continue;
6780 : : }
6781 : 122 : if (have_range && gfc_match (") ") == MATCH_YES)
6782 : : break;
6783 : 121 : locus saved_loc = gfc_current_locus;
6784 : :
6785 : : /* Without ranges, only arg names or integer literals permitted;
6786 : : handle literals here as gfc_match_expr simplifies the expr. */
6787 : 121 : if (gfc_match_literal_constant (&p->expr, true) == MATCH_YES)
6788 : : {
6789 : 17 : gfc_gobble_whitespace ();
6790 : 17 : char c = gfc_peek_ascii_char ();
6791 : 17 : if (c != ')' && c != ',' && c != ':')
6792 : : {
6793 : 1 : gfc_free_expr (p->expr);
6794 : 1 : p->expr = NULL;
6795 : 1 : gfc_current_locus = saved_loc;
6796 : : }
6797 : : }
6798 : 121 : if (!p->expr && gfc_match ("omp_num_args") == MATCH_YES)
6799 : : {
6800 : 6 : if (!have_range)
6801 : 3 : p->u.adj_args.range_start = need_range = true;
6802 : : else
6803 : : need_range = false;
6804 : :
6805 : 6 : locus saved_loc2 = gfc_current_locus;
6806 : 6 : gfc_gobble_whitespace ();
6807 : 6 : char c = gfc_peek_ascii_char ();
6808 : 6 : if (c == '+' || c == '-')
6809 : : {
6810 : 5 : if (gfc_match ("+ %e", &p->expr) == MATCH_YES)
6811 : 1 : p->u.adj_args.omp_num_args_plus = true;
6812 : 4 : else if (gfc_match ("- %e", &p->expr) == MATCH_YES)
6813 : 4 : p->u.adj_args.omp_num_args_minus = true;
6814 : 0 : else if (!gfc_error_check ())
6815 : : {
6816 : 0 : gfc_error ("expected constant integer expression "
6817 : : "at %C");
6818 : 0 : p->u.adj_args.error_p = true;
6819 : 0 : return MATCH_ERROR;
6820 : : }
6821 : 5 : p->where = gfc_get_location_range (&saved_loc, 1,
6822 : : &saved_loc, 1,
6823 : : &gfc_current_locus);
6824 : : }
6825 : : else
6826 : : {
6827 : 1 : p->where = gfc_get_location_range (&saved_loc, 1,
6828 : : &saved_loc, 1,
6829 : : &saved_loc2);
6830 : 1 : p->u.adj_args.omp_num_args_plus = true;
6831 : : }
6832 : : }
6833 : 115 : else if (!p->expr)
6834 : : {
6835 : 99 : match m = gfc_match_expr (&p->expr);
6836 : 99 : if (m != MATCH_YES)
6837 : : {
6838 : 1 : gfc_error ("expected dummy parameter name, "
6839 : : "%<omp_num_args%> or constant positive integer"
6840 : : " at %C");
6841 : 1 : p->u.adj_args.error_p = true;
6842 : 1 : return MATCH_ERROR;
6843 : : }
6844 : 98 : if (p->expr->expr_type == EXPR_CONSTANT && !have_range)
6845 : 98 : need_range = true; /* Constant expr but not literal. */
6846 : 98 : p->where = p->expr->where;
6847 : : }
6848 : : else
6849 : 16 : p->where = p->expr->where;
6850 : 120 : gfc_gobble_whitespace ();
6851 : 120 : match m = gfc_match (": ");
6852 : 120 : if (need_range && m != MATCH_YES)
6853 : : {
6854 : 1 : gfc_error ("expected %<:%> at %C");
6855 : 1 : return MATCH_ERROR;
6856 : : }
6857 : 119 : if (m == MATCH_YES)
6858 : : {
6859 : 6 : p->u.adj_args.range_start = have_range = true;
6860 : 6 : need_range = false;
6861 : 6 : continue;
6862 : : }
6863 : 113 : need_range = have_range = false;
6864 : 113 : if (gfc_match (", ") == MATCH_YES)
6865 : 38 : continue;
6866 : 75 : if (gfc_match (") ") == MATCH_YES)
6867 : : break;
6868 : : }
6869 : : }
6870 : 32 : else if (ccode == clause_append_args)
6871 : : {
6872 : 32 : if (has_append_args)
6873 : : {
6874 : 1 : gfc_error ("%qs clause at %L specified more than once",
6875 : : "append_args", &gfc_current_locus);
6876 : 1 : return MATCH_ERROR;
6877 : : }
6878 : 56 : has_append_args = true;
6879 : : gfc_omp_namelist *append_args_last = NULL;
6880 : 81 : do
6881 : : {
6882 : 56 : gfc_gobble_whitespace ();
6883 : 56 : if (gfc_match ("interop ") != MATCH_YES)
6884 : : {
6885 : 0 : gfc_error ("expected %<interop%> at %C");
6886 : 3 : return MATCH_ERROR;
6887 : : }
6888 : 56 : if (gfc_match ("( ") != MATCH_YES)
6889 : : {
6890 : 0 : gfc_error ("expected %<(%> at %C");
6891 : 0 : return MATCH_ERROR;
6892 : : }
6893 : :
6894 : 56 : bool target, targetsync;
6895 : 56 : char *type_str = NULL;
6896 : 56 : int type_str_len;
6897 : 56 : locus loc = gfc_current_locus;
6898 : 56 : if (gfc_parser_omp_clause_init_modifiers (target, targetsync,
6899 : : &type_str, type_str_len,
6900 : : false) == MATCH_ERROR)
6901 : : return MATCH_ERROR;
6902 : :
6903 : 54 : gfc_omp_namelist *n = gfc_get_omp_namelist();
6904 : 54 : n->where = loc;
6905 : 54 : n->u.init.target = target;
6906 : 54 : n->u.init.targetsync = targetsync;
6907 : 54 : n->u.init.len = type_str_len;
6908 : 54 : n->u2.init_interop = type_str;
6909 : 54 : if (odv->append_args_list)
6910 : : {
6911 : 25 : append_args_last->next = n;
6912 : 25 : append_args_last = n;
6913 : : }
6914 : : else
6915 : 29 : append_args_last = odv->append_args_list = n;
6916 : :
6917 : 54 : gfc_gobble_whitespace ();
6918 : 54 : if (gfc_match_char (',') == MATCH_YES)
6919 : 25 : continue;
6920 : 29 : if (gfc_match_char (')') == MATCH_YES)
6921 : : break;
6922 : 1 : gfc_error ("Expected %<,%> or %<)%> at %C");
6923 : 1 : return MATCH_ERROR;
6924 : : }
6925 : : while (true);
6926 : : }
6927 : 466 : gfc_gobble_whitespace ();
6928 : 466 : if (gfc_match_omp_eos () == MATCH_YES)
6929 : : break;
6930 : 109 : gfc_match_char (',');
6931 : 109 : }
6932 : :
6933 : 363 : if (error_p || (!has_match && !has_adjust_args && !has_append_args))
6934 : : {
6935 : 6 : gfc_error ("expected %<match%>, %<adjust_args%> or %<append_args%> at %C");
6936 : 6 : return MATCH_ERROR;
6937 : : }
6938 : :
6939 : 357 : if (!has_match)
6940 : : {
6941 : 3 : gfc_error ("expected %<match%> clause at %C");
6942 : 3 : return MATCH_ERROR;
6943 : : }
6944 : :
6945 : : return MATCH_YES;
6946 : : }
6947 : :
6948 : :
6949 : : static match
6950 : 160 : match_omp_metadirective (bool begin_p)
6951 : : {
6952 : 160 : locus old_loc = gfc_current_locus;
6953 : 160 : gfc_omp_variant *variants_head;
6954 : 160 : gfc_omp_variant **next_variant = &variants_head;
6955 : 160 : bool default_seen = false;
6956 : :
6957 : : /* Parse the context selectors. */
6958 : 656 : for (;;)
6959 : : {
6960 : 408 : bool default_p = false;
6961 : 408 : gfc_omp_set_selector *selectors = NULL;
6962 : :
6963 : 408 : gfc_gobble_whitespace ();
6964 : 408 : if (gfc_match_eos () == MATCH_YES)
6965 : : break;
6966 : 266 : gfc_match_char (',');
6967 : 266 : gfc_gobble_whitespace ();
6968 : :
6969 : 266 : locus variant_locus = gfc_current_locus;
6970 : :
6971 : 266 : if (gfc_match (" default ( ") == MATCH_YES)
6972 : : default_p = true;
6973 : 184 : else if (gfc_match (" otherwise ( ") == MATCH_YES)
6974 : : default_p = true;
6975 : 177 : else if (gfc_match (" when ( ") != MATCH_YES)
6976 : : {
6977 : 1 : gfc_error ("expected %<when%>, %<otherwise%>, or %<default%> at %C");
6978 : 1 : gfc_current_locus = old_loc;
6979 : 18 : return MATCH_ERROR;
6980 : : }
6981 : :
6982 : 89 : if (default_p && default_seen)
6983 : : {
6984 : 3 : gfc_error ("too many %<otherwise%> or %<default%> clauses "
6985 : : "in %<metadirective%> at %C");
6986 : 3 : gfc_current_locus = old_loc;
6987 : 3 : return MATCH_ERROR;
6988 : : }
6989 : 262 : else if (default_seen)
6990 : : {
6991 : 1 : gfc_error ("%<otherwise%> or %<default%> clause "
6992 : : "must appear last in %<metadirective%> at %C");
6993 : 1 : gfc_current_locus = old_loc;
6994 : 1 : return MATCH_ERROR;
6995 : : }
6996 : :
6997 : 261 : if (!default_p)
6998 : : {
6999 : 175 : if (gfc_match_omp_context_selector_specification (&selectors)
7000 : : != MATCH_YES)
7001 : : return MATCH_ERROR;
7002 : :
7003 : 168 : if (gfc_match (" : ") != MATCH_YES)
7004 : : {
7005 : 1 : gfc_error ("expected %<:%> at %C");
7006 : 1 : gfc_current_locus = old_loc;
7007 : 1 : return MATCH_ERROR;
7008 : : }
7009 : :
7010 : 167 : gfc_commit_symbols ();
7011 : : }
7012 : :
7013 : 253 : gfc_matching_omp_context_selector = true;
7014 : 253 : gfc_statement directive = match_omp_directive ();
7015 : 253 : gfc_matching_omp_context_selector = false;
7016 : :
7017 : 253 : if (is_omp_declarative_stmt (directive))
7018 : 0 : sorry_at (gfc_get_location (&gfc_current_locus),
7019 : : "declarative directive variants are not supported");
7020 : :
7021 : 253 : if (gfc_error_flag_test ())
7022 : : {
7023 : 2 : gfc_current_locus = old_loc;
7024 : 2 : return MATCH_ERROR;
7025 : : }
7026 : :
7027 : 251 : if (gfc_match (" )") != MATCH_YES)
7028 : : {
7029 : 0 : gfc_error ("Expected %<)%> at %C");
7030 : 0 : gfc_current_locus = old_loc;
7031 : 0 : return MATCH_ERROR;
7032 : : }
7033 : :
7034 : 251 : gfc_commit_symbols ();
7035 : :
7036 : 251 : if (begin_p
7037 : 251 : && directive != ST_NONE
7038 : 251 : && gfc_omp_end_stmt (directive) == ST_NONE)
7039 : : {
7040 : 3 : gfc_error ("variant directive used in OMP BEGIN METADIRECTIVE "
7041 : : "at %C must have a corresponding end directive");
7042 : 3 : gfc_current_locus = old_loc;
7043 : 3 : return MATCH_ERROR;
7044 : : }
7045 : :
7046 : 248 : if (default_p)
7047 : : default_seen = true;
7048 : :
7049 : 248 : gfc_omp_variant *omv = gfc_get_omp_variant ();
7050 : 248 : omv->selectors = selectors;
7051 : 248 : omv->stmt = directive;
7052 : 248 : omv->where = variant_locus;
7053 : :
7054 : 248 : if (directive == ST_NONE)
7055 : : {
7056 : : /* The directive was a 'nothing' directive. */
7057 : 15 : omv->code = gfc_get_code (EXEC_CONTINUE);
7058 : 15 : omv->code->ext.omp_clauses = NULL;
7059 : : }
7060 : : else
7061 : : {
7062 : 233 : omv->code = gfc_get_code (new_st.op);
7063 : 233 : omv->code->ext.omp_clauses = new_st.ext.omp_clauses;
7064 : : /* Prevent the OpenMP clauses from being freed via NEW_ST. */
7065 : 233 : new_st.ext.omp_clauses = NULL;
7066 : : }
7067 : :
7068 : 248 : *next_variant = omv;
7069 : 248 : next_variant = &omv->next;
7070 : 248 : }
7071 : :
7072 : 142 : if (gfc_match_omp_eos () != MATCH_YES)
7073 : : {
7074 : 0 : gfc_error ("Unexpected junk after OMP METADIRECTIVE at %C");
7075 : 0 : gfc_current_locus = old_loc;
7076 : 0 : return MATCH_ERROR;
7077 : : }
7078 : :
7079 : : /* Add a 'default (nothing)' clause if no default is explicitly given. */
7080 : 142 : if (!default_seen)
7081 : : {
7082 : 65 : gfc_omp_variant *omv = gfc_get_omp_variant ();
7083 : 65 : omv->stmt = ST_NONE;
7084 : 65 : omv->code = gfc_get_code (EXEC_CONTINUE);
7085 : 65 : omv->code->ext.omp_clauses = NULL;
7086 : 65 : omv->where = old_loc;
7087 : 65 : omv->selectors = NULL;
7088 : :
7089 : 65 : *next_variant = omv;
7090 : 65 : next_variant = &omv->next;
7091 : : }
7092 : :
7093 : 142 : new_st.op = EXEC_OMP_METADIRECTIVE;
7094 : 142 : new_st.ext.omp_variants = variants_head;
7095 : :
7096 : 142 : return MATCH_YES;
7097 : : }
7098 : :
7099 : : match
7100 : 43 : gfc_match_omp_begin_metadirective (void)
7101 : : {
7102 : 43 : return match_omp_metadirective (true);
7103 : : }
7104 : :
7105 : : match
7106 : 117 : gfc_match_omp_metadirective (void)
7107 : : {
7108 : 117 : return match_omp_metadirective (false);
7109 : : }
7110 : :
7111 : : match
7112 : 206 : gfc_match_omp_threadprivate (void)
7113 : : {
7114 : 206 : locus old_loc;
7115 : 206 : char n[GFC_MAX_SYMBOL_LEN+1];
7116 : 206 : gfc_symbol *sym;
7117 : 206 : match m;
7118 : 206 : gfc_symtree *st;
7119 : :
7120 : 206 : old_loc = gfc_current_locus;
7121 : :
7122 : 206 : m = gfc_match (" (");
7123 : 206 : if (m != MATCH_YES)
7124 : : return m;
7125 : :
7126 : 248 : for (;;)
7127 : : {
7128 : 248 : m = gfc_match_symbol (&sym, 0);
7129 : 248 : switch (m)
7130 : : {
7131 : 176 : case MATCH_YES:
7132 : 176 : if (sym->attr.in_common)
7133 : 0 : gfc_error_now ("Threadprivate variable at %C is an element of "
7134 : : "a COMMON block");
7135 : 176 : else if (!gfc_add_threadprivate (&sym->attr, sym->name, &sym->declared_at))
7136 : 1 : goto cleanup;
7137 : 175 : goto next_item;
7138 : : case MATCH_NO:
7139 : : break;
7140 : 0 : case MATCH_ERROR:
7141 : 0 : goto cleanup;
7142 : : }
7143 : :
7144 : 72 : m = gfc_match (" / %n /", n);
7145 : 72 : if (m == MATCH_ERROR)
7146 : 0 : goto cleanup;
7147 : 72 : if (m == MATCH_NO || n[0] == '\0')
7148 : 0 : goto syntax;
7149 : :
7150 : 72 : st = gfc_find_symtree (gfc_current_ns->common_root, n);
7151 : 72 : if (st == NULL)
7152 : : {
7153 : 2 : gfc_error ("COMMON block /%s/ not found at %C", n);
7154 : 2 : goto cleanup;
7155 : : }
7156 : 70 : st->n.common->threadprivate = 1;
7157 : 178 : for (sym = st->n.common->head; sym; sym = sym->common_next)
7158 : 108 : if (!gfc_add_threadprivate (&sym->attr, sym->name, &sym->declared_at))
7159 : 0 : goto cleanup;
7160 : :
7161 : 70 : next_item:
7162 : 245 : if (gfc_match_char (')') == MATCH_YES)
7163 : : break;
7164 : 42 : if (gfc_match_char (',') != MATCH_YES)
7165 : 0 : goto syntax;
7166 : : }
7167 : :
7168 : 203 : if (gfc_match_omp_eos () != MATCH_YES)
7169 : : {
7170 : 0 : gfc_error ("Unexpected junk after OMP THREADPRIVATE at %C");
7171 : 0 : goto cleanup;
7172 : : }
7173 : :
7174 : : return MATCH_YES;
7175 : :
7176 : 0 : syntax:
7177 : 0 : gfc_error ("Syntax error in !$OMP THREADPRIVATE list at %C");
7178 : :
7179 : 3 : cleanup:
7180 : 3 : gfc_current_locus = old_loc;
7181 : 3 : return MATCH_ERROR;
7182 : : }
7183 : :
7184 : :
7185 : : match
7186 : 2135 : gfc_match_omp_parallel (void)
7187 : : {
7188 : 2135 : return match_omp (EXEC_OMP_PARALLEL, OMP_PARALLEL_CLAUSES);
7189 : : }
7190 : :
7191 : :
7192 : : match
7193 : 1190 : gfc_match_omp_parallel_do (void)
7194 : : {
7195 : 1190 : return match_omp (EXEC_OMP_PARALLEL_DO,
7196 : 1190 : (OMP_PARALLEL_CLAUSES | OMP_DO_CLAUSES)
7197 : 1190 : & ~(omp_mask (OMP_CLAUSE_NOWAIT)));
7198 : : }
7199 : :
7200 : :
7201 : : match
7202 : 298 : gfc_match_omp_parallel_do_simd (void)
7203 : : {
7204 : 298 : return match_omp (EXEC_OMP_PARALLEL_DO_SIMD,
7205 : 298 : (OMP_PARALLEL_CLAUSES | OMP_DO_CLAUSES | OMP_SIMD_CLAUSES)
7206 : 298 : & ~(omp_mask (OMP_CLAUSE_NOWAIT)));
7207 : : }
7208 : :
7209 : :
7210 : : match
7211 : 14 : gfc_match_omp_parallel_masked (void)
7212 : : {
7213 : 14 : return match_omp (EXEC_OMP_PARALLEL_MASKED,
7214 : 14 : OMP_PARALLEL_CLAUSES | OMP_MASKED_CLAUSES);
7215 : : }
7216 : :
7217 : : match
7218 : 10 : gfc_match_omp_parallel_masked_taskloop (void)
7219 : : {
7220 : 10 : return match_omp (EXEC_OMP_PARALLEL_MASKED_TASKLOOP,
7221 : 10 : (OMP_PARALLEL_CLAUSES | OMP_MASKED_CLAUSES
7222 : 10 : | OMP_TASKLOOP_CLAUSES)
7223 : 10 : & ~(omp_mask (OMP_CLAUSE_IN_REDUCTION)));
7224 : : }
7225 : :
7226 : : match
7227 : 13 : gfc_match_omp_parallel_masked_taskloop_simd (void)
7228 : : {
7229 : 13 : return match_omp (EXEC_OMP_PARALLEL_MASKED_TASKLOOP_SIMD,
7230 : 13 : (OMP_PARALLEL_CLAUSES | OMP_MASKED_CLAUSES
7231 : 13 : | OMP_TASKLOOP_CLAUSES | OMP_SIMD_CLAUSES)
7232 : 13 : & ~(omp_mask (OMP_CLAUSE_IN_REDUCTION)));
7233 : : }
7234 : :
7235 : : match
7236 : 14 : gfc_match_omp_parallel_master (void)
7237 : : {
7238 : 14 : return match_omp (EXEC_OMP_PARALLEL_MASTER, OMP_PARALLEL_CLAUSES);
7239 : : }
7240 : :
7241 : : match
7242 : 15 : gfc_match_omp_parallel_master_taskloop (void)
7243 : : {
7244 : 15 : return match_omp (EXEC_OMP_PARALLEL_MASTER_TASKLOOP,
7245 : 15 : (OMP_PARALLEL_CLAUSES | OMP_TASKLOOP_CLAUSES)
7246 : 15 : & ~(omp_mask (OMP_CLAUSE_IN_REDUCTION)));
7247 : : }
7248 : :
7249 : : match
7250 : 21 : gfc_match_omp_parallel_master_taskloop_simd (void)
7251 : : {
7252 : 21 : return match_omp (EXEC_OMP_PARALLEL_MASTER_TASKLOOP_SIMD,
7253 : 21 : (OMP_PARALLEL_CLAUSES | OMP_TASKLOOP_CLAUSES
7254 : 21 : | OMP_SIMD_CLAUSES)
7255 : 21 : & ~(omp_mask (OMP_CLAUSE_IN_REDUCTION)));
7256 : : }
7257 : :
7258 : : match
7259 : 59 : gfc_match_omp_parallel_sections (void)
7260 : : {
7261 : 59 : return match_omp (EXEC_OMP_PARALLEL_SECTIONS,
7262 : 59 : (OMP_PARALLEL_CLAUSES | OMP_SECTIONS_CLAUSES)
7263 : 59 : & ~(omp_mask (OMP_CLAUSE_NOWAIT)));
7264 : : }
7265 : :
7266 : :
7267 : : match
7268 : 56 : gfc_match_omp_parallel_workshare (void)
7269 : : {
7270 : 56 : return match_omp (EXEC_OMP_PARALLEL_WORKSHARE, OMP_PARALLEL_CLAUSES);
7271 : : }
7272 : :
7273 : : void
7274 : 48063 : gfc_check_omp_requires (gfc_namespace *ns, int ref_omp_requires)
7275 : : {
7276 : 48063 : const char *msg = G_("Program unit at %L has OpenMP device "
7277 : : "constructs/routines but does not set !$OMP REQUIRES %s "
7278 : : "but other program units do");
7279 : 48063 : if (ns->omp_target_seen
7280 : 1121 : && (ns->omp_requires & OMP_REQ_TARGET_MASK)
7281 : 1121 : != (ref_omp_requires & OMP_REQ_TARGET_MASK))
7282 : : {
7283 : 6 : gcc_assert (ns->proc_name);
7284 : 6 : if ((ref_omp_requires & OMP_REQ_REVERSE_OFFLOAD)
7285 : 5 : && !(ns->omp_requires & OMP_REQ_REVERSE_OFFLOAD))
7286 : 4 : gfc_error (msg, &ns->proc_name->declared_at, "REVERSE_OFFLOAD");
7287 : 6 : if ((ref_omp_requires & OMP_REQ_UNIFIED_ADDRESS)
7288 : 1 : && !(ns->omp_requires & OMP_REQ_UNIFIED_ADDRESS))
7289 : 1 : gfc_error (msg, &ns->proc_name->declared_at, "UNIFIED_ADDRESS");
7290 : 6 : if ((ref_omp_requires & OMP_REQ_UNIFIED_SHARED_MEMORY)
7291 : 4 : && !(ns->omp_requires & OMP_REQ_UNIFIED_SHARED_MEMORY))
7292 : 2 : gfc_error (msg, &ns->proc_name->declared_at, "UNIFIED_SHARED_MEMORY");
7293 : 6 : if ((ref_omp_requires & OMP_REQ_SELF_MAPS)
7294 : 1 : && !(ns->omp_requires & OMP_REQ_UNIFIED_SHARED_MEMORY))
7295 : 1 : gfc_error (msg, &ns->proc_name->declared_at, "SELF_MAPS");
7296 : : }
7297 : 48063 : }
7298 : :
7299 : : bool
7300 : 124 : gfc_omp_requires_add_clause (gfc_omp_requires_kind clause,
7301 : : const char *clause_name, locus *loc,
7302 : : const char *module_name)
7303 : : {
7304 : 124 : gfc_namespace *prog_unit = gfc_current_ns;
7305 : 148 : while (prog_unit->parent)
7306 : : {
7307 : 25 : if (gfc_state_stack->previous
7308 : 25 : && gfc_state_stack->previous->state == COMP_INTERFACE)
7309 : : break;
7310 : : prog_unit = prog_unit->parent;
7311 : : }
7312 : :
7313 : : /* Requires added after use. */
7314 : 124 : if (prog_unit->omp_target_seen
7315 : 24 : && (clause & OMP_REQ_TARGET_MASK)
7316 : 24 : && !(prog_unit->omp_requires & clause))
7317 : : {
7318 : 0 : if (module_name)
7319 : 0 : gfc_error ("!$OMP REQUIRES clause %qs specified via module %qs use "
7320 : : "at %L comes after using a device construct/routine",
7321 : : clause_name, module_name, loc);
7322 : : else
7323 : 0 : gfc_error ("!$OMP REQUIRES clause %qs specified at %L comes after "
7324 : : "using a device construct/routine", clause_name, loc);
7325 : 0 : return false;
7326 : : }
7327 : :
7328 : : /* Overriding atomic_default_mem_order clause value. */
7329 : 124 : if ((clause & OMP_REQ_ATOMIC_MEM_ORDER_MASK)
7330 : 34 : && (prog_unit->omp_requires & OMP_REQ_ATOMIC_MEM_ORDER_MASK)
7331 : 6 : && (prog_unit->omp_requires & OMP_REQ_ATOMIC_MEM_ORDER_MASK)
7332 : 6 : != (int) clause)
7333 : : {
7334 : 3 : const char *other;
7335 : 3 : switch (prog_unit->omp_requires & OMP_REQ_ATOMIC_MEM_ORDER_MASK)
7336 : : {
7337 : : case OMP_REQ_ATOMIC_MEM_ORDER_SEQ_CST: other = "seq_cst"; break;
7338 : 0 : case OMP_REQ_ATOMIC_MEM_ORDER_ACQ_REL: other = "acq_rel"; break;
7339 : 1 : case OMP_REQ_ATOMIC_MEM_ORDER_ACQUIRE: other = "acquire"; break;
7340 : 1 : case OMP_REQ_ATOMIC_MEM_ORDER_RELAXED: other = "relaxed"; break;
7341 : 0 : case OMP_REQ_ATOMIC_MEM_ORDER_RELEASE: other = "release"; break;
7342 : 0 : default: gcc_unreachable ();
7343 : : }
7344 : :
7345 : 3 : if (module_name)
7346 : 0 : gfc_error ("!$OMP REQUIRES clause %<atomic_default_mem_order(%s)%> "
7347 : : "specified via module %qs use at %L overrides a previous "
7348 : : "%<atomic_default_mem_order(%s)%> (which might be through "
7349 : : "using a module)", clause_name, module_name, loc, other);
7350 : : else
7351 : 3 : gfc_error ("!$OMP REQUIRES clause %<atomic_default_mem_order(%s)%> "
7352 : : "specified at %L overrides a previous "
7353 : : "%<atomic_default_mem_order(%s)%> (which might be through "
7354 : : "using a module)", clause_name, loc, other);
7355 : 3 : return false;
7356 : : }
7357 : :
7358 : : /* Requires via module not at program-unit level and not repeating clause. */
7359 : 121 : if (prog_unit != gfc_current_ns && !(prog_unit->omp_requires & clause))
7360 : : {
7361 : 0 : if (clause & OMP_REQ_ATOMIC_MEM_ORDER_MASK)
7362 : 0 : gfc_error ("!$OMP REQUIRES clause %<atomic_default_mem_order(%s)%> "
7363 : : "specified via module %qs use at %L but same clause is "
7364 : : "not specified for the program unit", clause_name,
7365 : : module_name, loc);
7366 : : else
7367 : 0 : gfc_error ("!$OMP REQUIRES clause %qs specified via module %qs use at "
7368 : : "%L but same clause is not specified for the program unit",
7369 : : clause_name, module_name, loc);
7370 : 0 : return false;
7371 : : }
7372 : :
7373 : 121 : if (!gfc_state_stack->previous
7374 : 113 : || gfc_state_stack->previous->state != COMP_INTERFACE)
7375 : 120 : prog_unit->omp_requires |= clause;
7376 : : return true;
7377 : : }
7378 : :
7379 : : match
7380 : 95 : gfc_match_omp_requires (void)
7381 : : {
7382 : 95 : static const char *clauses[] = {"reverse_offload",
7383 : : "unified_address",
7384 : : "unified_shared_memory",
7385 : : "self_maps",
7386 : : "dynamic_allocators",
7387 : : "atomic_default"};
7388 : 95 : const char *clause = NULL;
7389 : 95 : int requires_clauses = 0;
7390 : 95 : bool first = true;
7391 : 95 : locus old_loc;
7392 : :
7393 : 95 : if (gfc_current_ns->parent
7394 : 7 : && (!gfc_state_stack->previous
7395 : 7 : || gfc_state_stack->previous->state != COMP_INTERFACE))
7396 : : {
7397 : 6 : gfc_error ("!$OMP REQUIRES at %C must appear in the specification part "
7398 : : "of a program unit");
7399 : 6 : return MATCH_ERROR;
7400 : : }
7401 : :
7402 : 267 : while (true)
7403 : : {
7404 : 178 : old_loc = gfc_current_locus;
7405 : 178 : gfc_omp_requires_kind requires_clause;
7406 : 89 : if ((first || gfc_match_char (',') != MATCH_YES)
7407 : 178 : && (first && gfc_match_space () != MATCH_YES))
7408 : 0 : goto error;
7409 : 178 : first = false;
7410 : 178 : gfc_gobble_whitespace ();
7411 : 178 : old_loc = gfc_current_locus;
7412 : :
7413 : 178 : if (gfc_match_omp_eos () != MATCH_NO)
7414 : : break;
7415 : 100 : if (gfc_match (clauses[0]) == MATCH_YES)
7416 : : {
7417 : 34 : clause = clauses[0];
7418 : 34 : requires_clause = OMP_REQ_REVERSE_OFFLOAD;
7419 : 34 : if (requires_clauses & OMP_REQ_REVERSE_OFFLOAD)
7420 : 1 : goto duplicate_clause;
7421 : : }
7422 : 66 : else if (gfc_match (clauses[1]) == MATCH_YES)
7423 : : {
7424 : 9 : clause = clauses[1];
7425 : 9 : requires_clause = OMP_REQ_UNIFIED_ADDRESS;
7426 : 9 : if (requires_clauses & OMP_REQ_UNIFIED_ADDRESS)
7427 : 1 : goto duplicate_clause;
7428 : : }
7429 : 57 : else if (gfc_match (clauses[2]) == MATCH_YES)
7430 : : {
7431 : 16 : clause = clauses[2];
7432 : 16 : requires_clause = OMP_REQ_UNIFIED_SHARED_MEMORY;
7433 : 16 : if (requires_clauses & OMP_REQ_UNIFIED_SHARED_MEMORY)
7434 : 1 : goto duplicate_clause;
7435 : : }
7436 : 41 : else if (gfc_match (clauses[3]) == MATCH_YES)
7437 : : {
7438 : 2 : clause = clauses[3];
7439 : 2 : requires_clause = OMP_REQ_SELF_MAPS;
7440 : 2 : if (requires_clauses & OMP_REQ_SELF_MAPS)
7441 : 0 : goto duplicate_clause;
7442 : : }
7443 : 39 : else if (gfc_match (clauses[4]) == MATCH_YES)
7444 : : {
7445 : 7 : clause = clauses[4];
7446 : 7 : requires_clause = OMP_REQ_DYNAMIC_ALLOCATORS;
7447 : 7 : if (requires_clauses & OMP_REQ_DYNAMIC_ALLOCATORS)
7448 : 1 : goto duplicate_clause;
7449 : : }
7450 : 32 : else if (gfc_match ("atomic_default_mem_order (") == MATCH_YES)
7451 : : {
7452 : 31 : clause = clauses[5];
7453 : 31 : if (requires_clauses & OMP_REQ_ATOMIC_MEM_ORDER_MASK)
7454 : 1 : goto duplicate_clause;
7455 : 30 : if (gfc_match (" seq_cst )") == MATCH_YES)
7456 : : {
7457 : : clause = "seq_cst";
7458 : : requires_clause = OMP_REQ_ATOMIC_MEM_ORDER_SEQ_CST;
7459 : : }
7460 : 18 : else if (gfc_match (" acq_rel )") == MATCH_YES)
7461 : : {
7462 : : clause = "acq_rel";
7463 : : requires_clause = OMP_REQ_ATOMIC_MEM_ORDER_ACQ_REL;
7464 : : }
7465 : 12 : else if (gfc_match (" acquire )") == MATCH_YES)
7466 : : {
7467 : : clause = "acquire";
7468 : : requires_clause = OMP_REQ_ATOMIC_MEM_ORDER_ACQUIRE;
7469 : : }
7470 : 9 : else if (gfc_match (" relaxed )") == MATCH_YES)
7471 : : {
7472 : : clause = "relaxed";
7473 : : requires_clause = OMP_REQ_ATOMIC_MEM_ORDER_RELAXED;
7474 : : }
7475 : 5 : else if (gfc_match (" release )") == MATCH_YES)
7476 : : {
7477 : : clause = "release";
7478 : : requires_clause = OMP_REQ_ATOMIC_MEM_ORDER_RELEASE;
7479 : : }
7480 : : else
7481 : : {
7482 : 2 : gfc_error ("Expected ACQ_REL, ACQUIRE, RELAXED, RELEASE or "
7483 : : "SEQ_CST for ATOMIC_DEFAULT_MEM_ORDER clause at %C");
7484 : 2 : goto error;
7485 : : }
7486 : : }
7487 : : else
7488 : 1 : goto error;
7489 : :
7490 : 92 : if (!gfc_omp_requires_add_clause (requires_clause, clause, &old_loc, NULL))
7491 : 3 : goto error;
7492 : 89 : requires_clauses |= requires_clause;
7493 : 89 : }
7494 : :
7495 : 78 : if (requires_clauses == 0)
7496 : : {
7497 : 1 : if (!gfc_error_flag_test ())
7498 : 1 : gfc_error ("Clause expected at %C");
7499 : 1 : goto error;
7500 : : }
7501 : : return MATCH_YES;
7502 : :
7503 : 5 : duplicate_clause:
7504 : 5 : gfc_error ("%qs clause at %L specified more than once", clause, &old_loc);
7505 : 12 : error:
7506 : 12 : if (!gfc_error_flag_test ())
7507 : 1 : gfc_error ("Expected UNIFIED_ADDRESS, UNIFIED_SHARED_MEMORY, SELF_MAPS, "
7508 : : "DYNAMIC_ALLOCATORS, REVERSE_OFFLOAD, or "
7509 : : "ATOMIC_DEFAULT_MEM_ORDER clause at %L", &old_loc);
7510 : : return MATCH_ERROR;
7511 : : }
7512 : :
7513 : :
7514 : : match
7515 : 51 : gfc_match_omp_scan (void)
7516 : : {
7517 : 51 : bool incl;
7518 : 51 : gfc_omp_clauses *c = gfc_get_omp_clauses ();
7519 : 51 : gfc_gobble_whitespace ();
7520 : 51 : if ((incl = (gfc_match ("inclusive") == MATCH_YES))
7521 : 51 : || gfc_match ("exclusive") == MATCH_YES)
7522 : : {
7523 : 70 : if (gfc_match_omp_variable_list (" (", &c->lists[incl ? OMP_LIST_SCAN_IN
7524 : : : OMP_LIST_SCAN_EX],
7525 : : false) != MATCH_YES)
7526 : : {
7527 : 0 : gfc_free_omp_clauses (c);
7528 : 0 : return MATCH_ERROR;
7529 : : }
7530 : : }
7531 : : else
7532 : : {
7533 : 1 : gfc_error ("Expected INCLUSIVE or EXCLUSIVE clause at %C");
7534 : 1 : gfc_free_omp_clauses (c);
7535 : 1 : return MATCH_ERROR;
7536 : : }
7537 : 50 : if (gfc_match_omp_eos () != MATCH_YES)
7538 : : {
7539 : 1 : gfc_error ("Unexpected junk after !$OMP SCAN at %C");
7540 : 1 : gfc_free_omp_clauses (c);
7541 : 1 : return MATCH_ERROR;
7542 : : }
7543 : :
7544 : 49 : new_st.op = EXEC_OMP_SCAN;
7545 : 49 : new_st.ext.omp_clauses = c;
7546 : 49 : return MATCH_YES;
7547 : : }
7548 : :
7549 : :
7550 : : match
7551 : 58 : gfc_match_omp_scope (void)
7552 : : {
7553 : 58 : return match_omp (EXEC_OMP_SCOPE, OMP_SCOPE_CLAUSES);
7554 : : }
7555 : :
7556 : :
7557 : : match
7558 : 82 : gfc_match_omp_sections (void)
7559 : : {
7560 : 82 : return match_omp (EXEC_OMP_SECTIONS, OMP_SECTIONS_CLAUSES);
7561 : : }
7562 : :
7563 : :
7564 : : match
7565 : 782 : gfc_match_omp_simd (void)
7566 : : {
7567 : 782 : return match_omp (EXEC_OMP_SIMD, OMP_SIMD_CLAUSES);
7568 : : }
7569 : :
7570 : :
7571 : : match
7572 : 569 : gfc_match_omp_single (void)
7573 : : {
7574 : 569 : return match_omp (EXEC_OMP_SINGLE, OMP_SINGLE_CLAUSES);
7575 : : }
7576 : :
7577 : :
7578 : : match
7579 : 1853 : gfc_match_omp_target (void)
7580 : : {
7581 : 1853 : return match_omp (EXEC_OMP_TARGET, OMP_TARGET_CLAUSES);
7582 : : }
7583 : :
7584 : :
7585 : : match
7586 : 1398 : gfc_match_omp_target_data (void)
7587 : : {
7588 : 1398 : return match_omp (EXEC_OMP_TARGET_DATA, OMP_TARGET_DATA_CLAUSES);
7589 : : }
7590 : :
7591 : :
7592 : : match
7593 : 351 : gfc_match_omp_target_enter_data (void)
7594 : : {
7595 : 351 : return match_omp (EXEC_OMP_TARGET_ENTER_DATA, OMP_TARGET_ENTER_DATA_CLAUSES);
7596 : : }
7597 : :
7598 : :
7599 : : match
7600 : 267 : gfc_match_omp_target_exit_data (void)
7601 : : {
7602 : 267 : return match_omp (EXEC_OMP_TARGET_EXIT_DATA, OMP_TARGET_EXIT_DATA_CLAUSES);
7603 : : }
7604 : :
7605 : :
7606 : : match
7607 : 24 : gfc_match_omp_target_parallel (void)
7608 : : {
7609 : 24 : return match_omp (EXEC_OMP_TARGET_PARALLEL,
7610 : 24 : (OMP_TARGET_CLAUSES | OMP_PARALLEL_CLAUSES)
7611 : 24 : & ~(omp_mask (OMP_CLAUSE_COPYIN)));
7612 : : }
7613 : :
7614 : :
7615 : : match
7616 : 81 : gfc_match_omp_target_parallel_do (void)
7617 : : {
7618 : 81 : return match_omp (EXEC_OMP_TARGET_PARALLEL_DO,
7619 : 81 : (OMP_TARGET_CLAUSES | OMP_PARALLEL_CLAUSES
7620 : 81 : | OMP_DO_CLAUSES) & ~(omp_mask (OMP_CLAUSE_COPYIN)));
7621 : : }
7622 : :
7623 : :
7624 : : match
7625 : 19 : gfc_match_omp_target_parallel_do_simd (void)
7626 : : {
7627 : 19 : return match_omp (EXEC_OMP_TARGET_PARALLEL_DO_SIMD,
7628 : 19 : (OMP_TARGET_CLAUSES | OMP_PARALLEL_CLAUSES | OMP_DO_CLAUSES
7629 : 19 : | OMP_SIMD_CLAUSES) & ~(omp_mask (OMP_CLAUSE_COPYIN)));
7630 : : }
7631 : :
7632 : :
7633 : : match
7634 : 34 : gfc_match_omp_target_simd (void)
7635 : : {
7636 : 34 : return match_omp (EXEC_OMP_TARGET_SIMD,
7637 : 34 : OMP_TARGET_CLAUSES | OMP_SIMD_CLAUSES);
7638 : : }
7639 : :
7640 : :
7641 : : match
7642 : 72 : gfc_match_omp_target_teams (void)
7643 : : {
7644 : 72 : return match_omp (EXEC_OMP_TARGET_TEAMS,
7645 : 72 : OMP_TARGET_CLAUSES | OMP_TEAMS_CLAUSES);
7646 : : }
7647 : :
7648 : :
7649 : : match
7650 : 19 : gfc_match_omp_target_teams_distribute (void)
7651 : : {
7652 : 19 : return match_omp (EXEC_OMP_TARGET_TEAMS_DISTRIBUTE,
7653 : 19 : OMP_TARGET_CLAUSES | OMP_TEAMS_CLAUSES
7654 : 19 : | OMP_DISTRIBUTE_CLAUSES);
7655 : : }
7656 : :
7657 : :
7658 : : match
7659 : 64 : gfc_match_omp_target_teams_distribute_parallel_do (void)
7660 : : {
7661 : 64 : return match_omp (EXEC_OMP_TARGET_TEAMS_DISTRIBUTE_PARALLEL_DO,
7662 : 64 : (OMP_TARGET_CLAUSES | OMP_TEAMS_CLAUSES
7663 : 64 : | OMP_DISTRIBUTE_CLAUSES | OMP_PARALLEL_CLAUSES
7664 : 64 : | OMP_DO_CLAUSES)
7665 : 64 : & ~(omp_mask (OMP_CLAUSE_ORDERED))
7666 : 64 : & ~(omp_mask (OMP_CLAUSE_LINEAR)));
7667 : : }
7668 : :
7669 : :
7670 : : match
7671 : 35 : gfc_match_omp_target_teams_distribute_parallel_do_simd (void)
7672 : : {
7673 : 35 : return match_omp (EXEC_OMP_TARGET_TEAMS_DISTRIBUTE_PARALLEL_DO_SIMD,
7674 : 35 : (OMP_TARGET_CLAUSES | OMP_TEAMS_CLAUSES
7675 : 35 : | OMP_DISTRIBUTE_CLAUSES | OMP_PARALLEL_CLAUSES
7676 : 35 : | OMP_DO_CLAUSES | OMP_SIMD_CLAUSES)
7677 : 35 : & ~(omp_mask (OMP_CLAUSE_ORDERED)));
7678 : : }
7679 : :
7680 : :
7681 : : match
7682 : 21 : gfc_match_omp_target_teams_distribute_simd (void)
7683 : : {
7684 : 21 : return match_omp (EXEC_OMP_TARGET_TEAMS_DISTRIBUTE_SIMD,
7685 : 21 : OMP_TARGET_CLAUSES | OMP_TEAMS_CLAUSES
7686 : 21 : | OMP_DISTRIBUTE_CLAUSES | OMP_SIMD_CLAUSES);
7687 : : }
7688 : :
7689 : :
7690 : : match
7691 : 1704 : gfc_match_omp_target_update (void)
7692 : : {
7693 : 1704 : return match_omp (EXEC_OMP_TARGET_UPDATE, OMP_TARGET_UPDATE_CLAUSES);
7694 : : }
7695 : :
7696 : :
7697 : : match
7698 : 1180 : gfc_match_omp_task (void)
7699 : : {
7700 : 1180 : return match_omp (EXEC_OMP_TASK, OMP_TASK_CLAUSES);
7701 : : }
7702 : :
7703 : :
7704 : : match
7705 : 72 : gfc_match_omp_taskloop (void)
7706 : : {
7707 : 72 : return match_omp (EXEC_OMP_TASKLOOP, OMP_TASKLOOP_CLAUSES);
7708 : : }
7709 : :
7710 : :
7711 : : match
7712 : 40 : gfc_match_omp_taskloop_simd (void)
7713 : : {
7714 : 40 : return match_omp (EXEC_OMP_TASKLOOP_SIMD,
7715 : 40 : OMP_TASKLOOP_CLAUSES | OMP_SIMD_CLAUSES);
7716 : : }
7717 : :
7718 : :
7719 : : match
7720 : 146 : gfc_match_omp_taskwait (void)
7721 : : {
7722 : 146 : if (gfc_match_omp_eos () == MATCH_YES)
7723 : : {
7724 : 133 : new_st.op = EXEC_OMP_TASKWAIT;
7725 : 133 : new_st.ext.omp_clauses = NULL;
7726 : 133 : return MATCH_YES;
7727 : : }
7728 : 13 : return match_omp (EXEC_OMP_TASKWAIT,
7729 : 13 : omp_mask (OMP_CLAUSE_DEPEND) | OMP_CLAUSE_NOWAIT);
7730 : : }
7731 : :
7732 : :
7733 : : match
7734 : 10 : gfc_match_omp_taskyield (void)
7735 : : {
7736 : 10 : if (gfc_match_omp_eos () != MATCH_YES)
7737 : : {
7738 : 0 : gfc_error ("Unexpected junk after TASKYIELD clause at %C");
7739 : 0 : return MATCH_ERROR;
7740 : : }
7741 : 10 : new_st.op = EXEC_OMP_TASKYIELD;
7742 : 10 : new_st.ext.omp_clauses = NULL;
7743 : 10 : return MATCH_YES;
7744 : : }
7745 : :
7746 : :
7747 : : match
7748 : 150 : gfc_match_omp_teams (void)
7749 : : {
7750 : 150 : return match_omp (EXEC_OMP_TEAMS, OMP_TEAMS_CLAUSES);
7751 : : }
7752 : :
7753 : :
7754 : : match
7755 : 22 : gfc_match_omp_teams_distribute (void)
7756 : : {
7757 : 22 : return match_omp (EXEC_OMP_TEAMS_DISTRIBUTE,
7758 : 22 : OMP_TEAMS_CLAUSES | OMP_DISTRIBUTE_CLAUSES);
7759 : : }
7760 : :
7761 : :
7762 : : match
7763 : 39 : gfc_match_omp_teams_distribute_parallel_do (void)
7764 : : {
7765 : 39 : return match_omp (EXEC_OMP_TEAMS_DISTRIBUTE_PARALLEL_DO,
7766 : 39 : (OMP_TEAMS_CLAUSES | OMP_DISTRIBUTE_CLAUSES
7767 : 39 : | OMP_PARALLEL_CLAUSES | OMP_DO_CLAUSES)
7768 : 39 : & ~(omp_mask (OMP_CLAUSE_ORDERED)
7769 : 39 : | OMP_CLAUSE_LINEAR | OMP_CLAUSE_NOWAIT));
7770 : : }
7771 : :
7772 : :
7773 : : match
7774 : 62 : gfc_match_omp_teams_distribute_parallel_do_simd (void)
7775 : : {
7776 : 62 : return match_omp (EXEC_OMP_TEAMS_DISTRIBUTE_PARALLEL_DO_SIMD,
7777 : 62 : (OMP_TEAMS_CLAUSES | OMP_DISTRIBUTE_CLAUSES
7778 : 62 : | OMP_PARALLEL_CLAUSES | OMP_DO_CLAUSES
7779 : 62 : | OMP_SIMD_CLAUSES)
7780 : 62 : & ~(omp_mask (OMP_CLAUSE_ORDERED) | OMP_CLAUSE_NOWAIT));
7781 : : }
7782 : :
7783 : :
7784 : : match
7785 : 44 : gfc_match_omp_teams_distribute_simd (void)
7786 : : {
7787 : 44 : return match_omp (EXEC_OMP_TEAMS_DISTRIBUTE_SIMD,
7788 : 44 : OMP_TEAMS_CLAUSES | OMP_DISTRIBUTE_CLAUSES
7789 : 44 : | OMP_SIMD_CLAUSES);
7790 : : }
7791 : :
7792 : : match
7793 : 203 : gfc_match_omp_tile (void)
7794 : : {
7795 : 203 : return match_omp (EXEC_OMP_TILE, OMP_TILE_CLAUSES);
7796 : : }
7797 : :
7798 : : match
7799 : 415 : gfc_match_omp_unroll (void)
7800 : : {
7801 : 415 : return match_omp (EXEC_OMP_UNROLL, OMP_UNROLL_CLAUSES);
7802 : : }
7803 : :
7804 : : match
7805 : 39 : gfc_match_omp_workshare (void)
7806 : : {
7807 : 39 : return match_omp (EXEC_OMP_WORKSHARE, OMP_WORKSHARE_CLAUSES);
7808 : : }
7809 : :
7810 : :
7811 : : match
7812 : 49 : gfc_match_omp_masked (void)
7813 : : {
7814 : 49 : return match_omp (EXEC_OMP_MASKED, OMP_MASKED_CLAUSES);
7815 : : }
7816 : :
7817 : : match
7818 : 10 : gfc_match_omp_masked_taskloop (void)
7819 : : {
7820 : 10 : return match_omp (EXEC_OMP_MASKED_TASKLOOP,
7821 : 10 : OMP_MASKED_CLAUSES | OMP_TASKLOOP_CLAUSES);
7822 : : }
7823 : :
7824 : : match
7825 : 15 : gfc_match_omp_masked_taskloop_simd (void)
7826 : : {
7827 : 15 : return match_omp (EXEC_OMP_MASKED_TASKLOOP_SIMD,
7828 : 15 : (OMP_MASKED_CLAUSES | OMP_TASKLOOP_CLAUSES
7829 : 15 : | OMP_SIMD_CLAUSES));
7830 : : }
7831 : :
7832 : : match
7833 : 110 : gfc_match_omp_master (void)
7834 : : {
7835 : 110 : if (gfc_match_omp_eos () != MATCH_YES)
7836 : : {
7837 : 1 : gfc_error ("Unexpected junk after $OMP MASTER statement at %C");
7838 : 1 : return MATCH_ERROR;
7839 : : }
7840 : 109 : new_st.op = EXEC_OMP_MASTER;
7841 : 109 : new_st.ext.omp_clauses = NULL;
7842 : 109 : return MATCH_YES;
7843 : : }
7844 : :
7845 : : match
7846 : 16 : gfc_match_omp_master_taskloop (void)
7847 : : {
7848 : 16 : return match_omp (EXEC_OMP_MASTER_TASKLOOP, OMP_TASKLOOP_CLAUSES);
7849 : : }
7850 : :
7851 : : match
7852 : 22 : gfc_match_omp_master_taskloop_simd (void)
7853 : : {
7854 : 22 : return match_omp (EXEC_OMP_MASTER_TASKLOOP_SIMD,
7855 : 22 : OMP_TASKLOOP_CLAUSES | OMP_SIMD_CLAUSES);
7856 : : }
7857 : :
7858 : : match
7859 : 235 : gfc_match_omp_ordered (void)
7860 : : {
7861 : 235 : return match_omp (EXEC_OMP_ORDERED, OMP_ORDERED_CLAUSES);
7862 : : }
7863 : :
7864 : : match
7865 : 24 : gfc_match_omp_nothing (void)
7866 : : {
7867 : 24 : if (gfc_match_omp_eos () != MATCH_YES)
7868 : : {
7869 : 1 : gfc_error ("Unexpected junk after $OMP NOTHING statement at %C");
7870 : 1 : return MATCH_ERROR;
7871 : : }
7872 : : /* Will use ST_NONE; therefore, no EXEC_OMP_ is needed. */
7873 : : return MATCH_YES;
7874 : : }
7875 : :
7876 : : match
7877 : 315 : gfc_match_omp_ordered_depend (void)
7878 : : {
7879 : 315 : return match_omp (EXEC_OMP_ORDERED, omp_mask (OMP_CLAUSE_DOACROSS));
7880 : : }
7881 : :
7882 : :
7883 : : /* omp atomic [clause-list]
7884 : : - atomic-clause: read | write | update
7885 : : - capture
7886 : : - memory-order-clause: seq_cst | acq_rel | release | acquire | relaxed
7887 : : - hint(hint-expr)
7888 : : - OpenMP 5.1: compare | fail (seq_cst | acquire | relaxed ) | weak
7889 : : */
7890 : :
7891 : : match
7892 : 2171 : gfc_match_omp_atomic (void)
7893 : : {
7894 : 2171 : gfc_omp_clauses *c;
7895 : 2171 : locus loc = gfc_current_locus;
7896 : :
7897 : 2171 : if (gfc_match_omp_clauses (&c, OMP_ATOMIC_CLAUSES, true, true) != MATCH_YES)
7898 : : return MATCH_ERROR;
7899 : :
7900 : 2153 : if (c->atomic_op == GFC_OMP_ATOMIC_UNSET)
7901 : 1011 : c->atomic_op = GFC_OMP_ATOMIC_UPDATE;
7902 : :
7903 : 2153 : if (c->capture && c->atomic_op != GFC_OMP_ATOMIC_UPDATE)
7904 : 3 : gfc_error ("!$OMP ATOMIC at %L with %s clause is incompatible with "
7905 : : "READ or WRITE", &loc, "CAPTURE");
7906 : 2153 : if (c->compare && c->atomic_op != GFC_OMP_ATOMIC_UPDATE)
7907 : 3 : gfc_error ("!$OMP ATOMIC at %L with %s clause is incompatible with "
7908 : : "READ or WRITE", &loc, "COMPARE");
7909 : 2153 : if (c->fail != OMP_MEMORDER_UNSET && c->atomic_op != GFC_OMP_ATOMIC_UPDATE)
7910 : 2 : gfc_error ("!$OMP ATOMIC at %L with %s clause is incompatible with "
7911 : : "READ or WRITE", &loc, "FAIL");
7912 : 2153 : if (c->weak && !c->compare)
7913 : : {
7914 : 5 : gfc_error ("!$OMP ATOMIC at %L with %s clause requires %s clause", &loc,
7915 : : "WEAK", "COMPARE");
7916 : 5 : c->weak = false;
7917 : : }
7918 : :
7919 : 2153 : if (c->memorder == OMP_MEMORDER_UNSET)
7920 : : {
7921 : 1969 : gfc_namespace *prog_unit = gfc_current_ns;
7922 : 2525 : while (prog_unit->parent)
7923 : : prog_unit = prog_unit->parent;
7924 : 1969 : switch (prog_unit->omp_requires & OMP_REQ_ATOMIC_MEM_ORDER_MASK)
7925 : : {
7926 : 1936 : case 0:
7927 : 1936 : case OMP_REQ_ATOMIC_MEM_ORDER_RELAXED:
7928 : 1936 : c->memorder = OMP_MEMORDER_RELAXED;
7929 : 1936 : break;
7930 : 7 : case OMP_REQ_ATOMIC_MEM_ORDER_SEQ_CST:
7931 : 7 : c->memorder = OMP_MEMORDER_SEQ_CST;
7932 : 7 : break;
7933 : 16 : case OMP_REQ_ATOMIC_MEM_ORDER_ACQ_REL:
7934 : 16 : if (c->capture)
7935 : 5 : c->memorder = OMP_MEMORDER_ACQ_REL;
7936 : 11 : else if (c->atomic_op == GFC_OMP_ATOMIC_READ)
7937 : 3 : c->memorder = OMP_MEMORDER_ACQUIRE;
7938 : : else
7939 : 8 : c->memorder = OMP_MEMORDER_RELEASE;
7940 : : break;
7941 : 5 : case OMP_REQ_ATOMIC_MEM_ORDER_ACQUIRE:
7942 : 5 : if (c->atomic_op == GFC_OMP_ATOMIC_WRITE)
7943 : : {
7944 : 1 : gfc_error ("!$OMP ATOMIC WRITE at %L incompatible with "
7945 : : "ACQUIRES clause implicitly provided by a "
7946 : : "REQUIRES directive", &loc);
7947 : 1 : c->memorder = OMP_MEMORDER_SEQ_CST;
7948 : : }
7949 : : else
7950 : 4 : c->memorder = OMP_MEMORDER_ACQUIRE;
7951 : : break;
7952 : 5 : case OMP_REQ_ATOMIC_MEM_ORDER_RELEASE:
7953 : 5 : if (c->atomic_op == GFC_OMP_ATOMIC_READ)
7954 : : {
7955 : 1 : gfc_error ("!$OMP ATOMIC READ at %L incompatible with "
7956 : : "RELEASE clause implicitly provided by a "
7957 : : "REQUIRES directive", &loc);
7958 : 1 : c->memorder = OMP_MEMORDER_SEQ_CST;
7959 : : }
7960 : : else
7961 : 4 : c->memorder = OMP_MEMORDER_RELEASE;
7962 : : break;
7963 : 0 : default:
7964 : 0 : gcc_unreachable ();
7965 : : }
7966 : : }
7967 : : else
7968 : 184 : switch (c->atomic_op)
7969 : : {
7970 : 29 : case GFC_OMP_ATOMIC_READ:
7971 : 29 : if (c->memorder == OMP_MEMORDER_RELEASE)
7972 : : {
7973 : 1 : gfc_error ("!$OMP ATOMIC READ at %L incompatible with "
7974 : : "RELEASE clause", &loc);
7975 : 1 : c->memorder = OMP_MEMORDER_SEQ_CST;
7976 : : }
7977 : 28 : else if (c->memorder == OMP_MEMORDER_ACQ_REL)
7978 : 1 : c->memorder = OMP_MEMORDER_ACQUIRE;
7979 : : break;
7980 : 35 : case GFC_OMP_ATOMIC_WRITE:
7981 : 35 : if (c->memorder == OMP_MEMORDER_ACQUIRE)
7982 : : {
7983 : 1 : gfc_error ("!$OMP ATOMIC WRITE at %L incompatible with "
7984 : : "ACQUIRE clause", &loc);
7985 : 1 : c->memorder = OMP_MEMORDER_SEQ_CST;
7986 : : }
7987 : 34 : else if (c->memorder == OMP_MEMORDER_ACQ_REL)
7988 : 1 : c->memorder = OMP_MEMORDER_RELEASE;
7989 : : break;
7990 : : default:
7991 : : break;
7992 : : }
7993 : 2153 : gfc_error_check ();
7994 : 2153 : new_st.ext.omp_clauses = c;
7995 : 2153 : new_st.op = EXEC_OMP_ATOMIC;
7996 : 2153 : return MATCH_YES;
7997 : : }
7998 : :
7999 : :
8000 : : /* acc atomic [ read | write | update | capture] */
8001 : :
8002 : : match
8003 : 552 : gfc_match_oacc_atomic (void)
8004 : : {
8005 : 552 : gfc_omp_clauses *c = gfc_get_omp_clauses ();
8006 : 552 : c->atomic_op = GFC_OMP_ATOMIC_UPDATE;
8007 : 552 : c->memorder = OMP_MEMORDER_RELAXED;
8008 : 552 : gfc_gobble_whitespace ();
8009 : 552 : if (gfc_match ("update") == MATCH_YES)
8010 : : ;
8011 : 373 : else if (gfc_match ("read") == MATCH_YES)
8012 : 17 : c->atomic_op = GFC_OMP_ATOMIC_READ;
8013 : 356 : else if (gfc_match ("write") == MATCH_YES)
8014 : 13 : c->atomic_op = GFC_OMP_ATOMIC_WRITE;
8015 : 343 : else if (gfc_match ("capture") == MATCH_YES)
8016 : 319 : c->capture = true;
8017 : 552 : gfc_gobble_whitespace ();
8018 : 552 : if (gfc_match_omp_eos () != MATCH_YES)
8019 : : {
8020 : 9 : gfc_error ("Unexpected junk after !$ACC ATOMIC statement at %C");
8021 : 9 : gfc_free_omp_clauses (c);
8022 : 9 : return MATCH_ERROR;
8023 : : }
8024 : 543 : new_st.ext.omp_clauses = c;
8025 : 543 : new_st.op = EXEC_OACC_ATOMIC;
8026 : 543 : return MATCH_YES;
8027 : : }
8028 : :
8029 : :
8030 : : match
8031 : 613 : gfc_match_omp_barrier (void)
8032 : : {
8033 : 613 : if (gfc_match_omp_eos () != MATCH_YES)
8034 : : {
8035 : 0 : gfc_error ("Unexpected junk after $OMP BARRIER statement at %C");
8036 : 0 : return MATCH_ERROR;
8037 : : }
8038 : 613 : new_st.op = EXEC_OMP_BARRIER;
8039 : 613 : new_st.ext.omp_clauses = NULL;
8040 : 613 : return MATCH_YES;
8041 : : }
8042 : :
8043 : :
8044 : : match
8045 : 188 : gfc_match_omp_taskgroup (void)
8046 : : {
8047 : 188 : return match_omp (EXEC_OMP_TASKGROUP, OMP_TASKGROUP_CLAUSES);
8048 : : }
8049 : :
8050 : :
8051 : : static enum gfc_omp_cancel_kind
8052 : 494 : gfc_match_omp_cancel_kind (void)
8053 : : {
8054 : 494 : if (gfc_match_space () != MATCH_YES)
8055 : : return OMP_CANCEL_UNKNOWN;
8056 : 492 : if (gfc_match ("parallel") == MATCH_YES)
8057 : : return OMP_CANCEL_PARALLEL;
8058 : 352 : if (gfc_match ("sections") == MATCH_YES)
8059 : : return OMP_CANCEL_SECTIONS;
8060 : 253 : if (gfc_match ("do") == MATCH_YES)
8061 : : return OMP_CANCEL_DO;
8062 : 123 : if (gfc_match ("taskgroup") == MATCH_YES)
8063 : : return OMP_CANCEL_TASKGROUP;
8064 : : return OMP_CANCEL_UNKNOWN;
8065 : : }
8066 : :
8067 : :
8068 : : match
8069 : 321 : gfc_match_omp_cancel (void)
8070 : : {
8071 : 321 : gfc_omp_clauses *c;
8072 : 321 : enum gfc_omp_cancel_kind kind = gfc_match_omp_cancel_kind ();
8073 : 321 : if (kind == OMP_CANCEL_UNKNOWN)
8074 : : return MATCH_ERROR;
8075 : 319 : if (gfc_match_omp_clauses (&c, omp_mask (OMP_CLAUSE_IF), false) != MATCH_YES)
8076 : : return MATCH_ERROR;
8077 : 316 : c->cancel = kind;
8078 : 316 : new_st.op = EXEC_OMP_CANCEL;
8079 : 316 : new_st.ext.omp_clauses = c;
8080 : 316 : return MATCH_YES;
8081 : : }
8082 : :
8083 : :
8084 : : match
8085 : 173 : gfc_match_omp_cancellation_point (void)
8086 : : {
8087 : 173 : gfc_omp_clauses *c;
8088 : 173 : enum gfc_omp_cancel_kind kind = gfc_match_omp_cancel_kind ();
8089 : 173 : if (kind == OMP_CANCEL_UNKNOWN)
8090 : : {
8091 : 2 : gfc_error ("Expected construct-type PARALLEL, SECTIONS, DO or TASKGROUP "
8092 : : "in $OMP CANCELLATION POINT statement at %C");
8093 : 2 : return MATCH_ERROR;
8094 : : }
8095 : 171 : if (gfc_match_omp_eos () != MATCH_YES)
8096 : : {
8097 : 0 : gfc_error ("Unexpected junk after $OMP CANCELLATION POINT statement "
8098 : : "at %C");
8099 : 0 : return MATCH_ERROR;
8100 : : }
8101 : 171 : c = gfc_get_omp_clauses ();
8102 : 171 : c->cancel = kind;
8103 : 171 : new_st.op = EXEC_OMP_CANCELLATION_POINT;
8104 : 171 : new_st.ext.omp_clauses = c;
8105 : 171 : return MATCH_YES;
8106 : : }
8107 : :
8108 : :
8109 : : match
8110 : 2374 : gfc_match_omp_end_nowait (void)
8111 : : {
8112 : 2374 : bool nowait = false;
8113 : 2374 : if (gfc_match ("% nowait") == MATCH_YES)
8114 : 258 : nowait = true;
8115 : 2374 : if (gfc_match_omp_eos () != MATCH_YES)
8116 : : {
8117 : 4 : if (nowait)
8118 : 3 : gfc_error ("Unexpected junk after NOWAIT clause at %C");
8119 : : else
8120 : 1 : gfc_error ("Unexpected junk at %C");
8121 : 4 : return MATCH_ERROR;
8122 : : }
8123 : 2370 : new_st.op = EXEC_OMP_END_NOWAIT;
8124 : 2370 : new_st.ext.omp_bool = nowait;
8125 : 2370 : return MATCH_YES;
8126 : : }
8127 : :
8128 : :
8129 : : match
8130 : 565 : gfc_match_omp_end_single (void)
8131 : : {
8132 : 565 : gfc_omp_clauses *c;
8133 : 565 : if (gfc_match_omp_clauses (&c, omp_mask (OMP_CLAUSE_COPYPRIVATE)
8134 : : | OMP_CLAUSE_NOWAIT) != MATCH_YES)
8135 : : return MATCH_ERROR;
8136 : 565 : new_st.op = EXEC_OMP_END_SINGLE;
8137 : 565 : new_st.ext.omp_clauses = c;
8138 : 565 : return MATCH_YES;
8139 : : }
8140 : :
8141 : :
8142 : : static bool
8143 : 36902 : oacc_is_loop (gfc_code *code)
8144 : : {
8145 : 36902 : return code->op == EXEC_OACC_PARALLEL_LOOP
8146 : : || code->op == EXEC_OACC_KERNELS_LOOP
8147 : 19853 : || code->op == EXEC_OACC_SERIAL_LOOP
8148 : 13451 : || code->op == EXEC_OACC_LOOP;
8149 : : }
8150 : :
8151 : : static void
8152 : 5687 : resolve_scalar_int_expr (gfc_expr *expr, const char *clause)
8153 : : {
8154 : 5687 : if (!gfc_resolve_expr (expr)
8155 : 5687 : || expr->ts.type != BT_INTEGER
8156 : 11304 : || expr->rank != 0)
8157 : 87 : gfc_error ("%s clause at %L requires a scalar INTEGER expression",
8158 : : clause, &expr->where);
8159 : 5687 : }
8160 : :
8161 : : static void
8162 : 3928 : resolve_positive_int_expr (gfc_expr *expr, const char *clause)
8163 : : {
8164 : 3928 : resolve_scalar_int_expr (expr, clause);
8165 : 3928 : if (expr->expr_type == EXPR_CONSTANT
8166 : 3507 : && expr->ts.type == BT_INTEGER
8167 : 3474 : && mpz_sgn (expr->value.integer) <= 0)
8168 : 54 : gfc_warning ((flag_openmp || flag_openmp_simd) ? OPT_Wopenmp : 0,
8169 : : "INTEGER expression of %s clause at %L must be positive",
8170 : : clause, &expr->where);
8171 : 3928 : }
8172 : :
8173 : : static void
8174 : 76 : resolve_nonnegative_int_expr (gfc_expr *expr, const char *clause)
8175 : : {
8176 : 76 : resolve_scalar_int_expr (expr, clause);
8177 : 76 : if (expr->expr_type == EXPR_CONSTANT
8178 : 8 : && expr->ts.type == BT_INTEGER
8179 : 7 : && mpz_sgn (expr->value.integer) < 0)
8180 : 2 : gfc_warning ((flag_openmp || flag_openmp_simd) ? OPT_Wopenmp : 0,
8181 : : "INTEGER expression of %s clause at %L must be non-negative",
8182 : : clause, &expr->where);
8183 : 76 : }
8184 : :
8185 : : /* Emits error when symbol is pointer, cray pointer or cray pointee
8186 : : of derived of polymorphic type. */
8187 : :
8188 : : static void
8189 : 98 : check_symbol_not_pointer (gfc_symbol *sym, locus loc, const char *name)
8190 : : {
8191 : 98 : if (sym->ts.type == BT_DERIVED && sym->attr.cray_pointer)
8192 : 0 : gfc_error ("Cray pointer object %qs of derived type in %s clause at %L",
8193 : : sym->name, name, &loc);
8194 : 98 : if (sym->ts.type == BT_DERIVED && sym->attr.cray_pointee)
8195 : 0 : gfc_error ("Cray pointee object %qs of derived type in %s clause at %L",
8196 : : sym->name, name, &loc);
8197 : :
8198 : 98 : if ((sym->ts.type == BT_ASSUMED && sym->attr.pointer)
8199 : 98 : || (sym->ts.type == BT_CLASS && CLASS_DATA (sym)
8200 : 0 : && CLASS_DATA (sym)->attr.pointer))
8201 : 0 : gfc_error ("POINTER object %qs of polymorphic type in %s clause at %L",
8202 : : sym->name, name, &loc);
8203 : 98 : if ((sym->ts.type == BT_ASSUMED && sym->attr.cray_pointer)
8204 : 98 : || (sym->ts.type == BT_CLASS && CLASS_DATA (sym)
8205 : 0 : && CLASS_DATA (sym)->attr.cray_pointer))
8206 : 0 : gfc_error ("Cray pointer object %qs of polymorphic type in %s clause at %L",
8207 : : sym->name, name, &loc);
8208 : 98 : if ((sym->ts.type == BT_ASSUMED && sym->attr.cray_pointee)
8209 : 98 : || (sym->ts.type == BT_CLASS && CLASS_DATA (sym)
8210 : 0 : && CLASS_DATA (sym)->attr.cray_pointee))
8211 : 0 : gfc_error ("Cray pointee object %qs of polymorphic type in %s clause at %L",
8212 : : sym->name, name, &loc);
8213 : 98 : }
8214 : :
8215 : : /* Emits error when symbol represents assumed size/rank array. */
8216 : :
8217 : : static void
8218 : 14831 : check_array_not_assumed (gfc_symbol *sym, locus loc, const char *name)
8219 : : {
8220 : 14831 : if (sym->as && sym->as->type == AS_ASSUMED_SIZE)
8221 : 13 : gfc_error ("Assumed size array %qs in %s clause at %L",
8222 : : sym->name, name, &loc);
8223 : 14831 : if (sym->as && sym->as->type == AS_ASSUMED_RANK)
8224 : 11 : gfc_error ("Assumed rank array %qs in %s clause at %L",
8225 : : sym->name, name, &loc);
8226 : 14831 : }
8227 : :
8228 : : static void
8229 : 5841 : resolve_oacc_data_clauses (gfc_symbol *sym, locus loc, const char *name)
8230 : : {
8231 : 0 : check_array_not_assumed (sym, loc, name);
8232 : 0 : }
8233 : :
8234 : : static void
8235 : 65 : resolve_oacc_deviceptr_clause (gfc_symbol *sym, locus loc, const char *name)
8236 : : {
8237 : 65 : if (sym->attr.pointer
8238 : 64 : || (sym->ts.type == BT_CLASS && CLASS_DATA (sym)
8239 : 0 : && CLASS_DATA (sym)->attr.class_pointer))
8240 : 1 : gfc_error ("POINTER object %qs in %s clause at %L",
8241 : : sym->name, name, &loc);
8242 : 65 : if (sym->attr.cray_pointer
8243 : 63 : || (sym->ts.type == BT_CLASS && CLASS_DATA (sym)
8244 : 0 : && CLASS_DATA (sym)->attr.cray_pointer))
8245 : 2 : gfc_error ("Cray pointer object %qs in %s clause at %L",
8246 : : sym->name, name, &loc);
8247 : 65 : if (sym->attr.cray_pointee
8248 : 63 : || (sym->ts.type == BT_CLASS && CLASS_DATA (sym)
8249 : 0 : && CLASS_DATA (sym)->attr.cray_pointee))
8250 : 2 : gfc_error ("Cray pointee object %qs in %s clause at %L",
8251 : : sym->name, name, &loc);
8252 : 65 : if (sym->attr.allocatable
8253 : 64 : || (sym->ts.type == BT_CLASS && CLASS_DATA (sym)
8254 : 0 : && CLASS_DATA (sym)->attr.allocatable))
8255 : 1 : gfc_error ("ALLOCATABLE object %qs in %s clause at %L",
8256 : : sym->name, name, &loc);
8257 : 65 : if (sym->attr.value)
8258 : 1 : gfc_error ("VALUE object %qs in %s clause at %L",
8259 : : sym->name, name, &loc);
8260 : 65 : check_array_not_assumed (sym, loc, name);
8261 : 65 : }
8262 : :
8263 : :
8264 : : struct resolve_omp_udr_callback_data
8265 : : {
8266 : : gfc_symbol *sym1, *sym2;
8267 : : };
8268 : :
8269 : :
8270 : : static int
8271 : 1413 : resolve_omp_udr_callback (gfc_expr **e, int *, void *data)
8272 : : {
8273 : 1413 : struct resolve_omp_udr_callback_data *rcd
8274 : : = (struct resolve_omp_udr_callback_data *) data;
8275 : 1413 : if ((*e)->expr_type == EXPR_VARIABLE
8276 : 801 : && ((*e)->symtree->n.sym == rcd->sym1
8277 : 255 : || (*e)->symtree->n.sym == rcd->sym2))
8278 : : {
8279 : 801 : gfc_ref *ref = gfc_get_ref ();
8280 : 801 : ref->type = REF_ARRAY;
8281 : 801 : ref->u.ar.where = (*e)->where;
8282 : 801 : ref->u.ar.as = (*e)->symtree->n.sym->as;
8283 : 801 : ref->u.ar.type = AR_FULL;
8284 : 801 : ref->u.ar.dimen = 0;
8285 : 801 : ref->next = (*e)->ref;
8286 : 801 : (*e)->ref = ref;
8287 : : }
8288 : 1413 : return 0;
8289 : : }
8290 : :
8291 : :
8292 : : static int
8293 : 2990 : resolve_omp_udr_callback2 (gfc_expr **e, int *, void *)
8294 : : {
8295 : 2990 : if ((*e)->expr_type == EXPR_FUNCTION
8296 : 360 : && (*e)->value.function.isym == NULL)
8297 : : {
8298 : 174 : gfc_symbol *sym = (*e)->symtree->n.sym;
8299 : 174 : if (!sym->attr.intrinsic
8300 : 174 : && sym->attr.if_source == IFSRC_UNKNOWN)
8301 : 4 : gfc_error ("Implicitly declared function %s used in "
8302 : : "!$OMP DECLARE REDUCTION at %L", sym->name, &(*e)->where);
8303 : : }
8304 : 2990 : return 0;
8305 : : }
8306 : :
8307 : :
8308 : : static gfc_code *
8309 : 797 : resolve_omp_udr_clause (gfc_omp_namelist *n, gfc_namespace *ns,
8310 : : gfc_symbol *sym1, gfc_symbol *sym2)
8311 : : {
8312 : 797 : gfc_code *copy;
8313 : 797 : gfc_symbol sym1_copy, sym2_copy;
8314 : :
8315 : 797 : if (ns->code->op == EXEC_ASSIGN)
8316 : : {
8317 : 625 : copy = gfc_get_code (EXEC_ASSIGN);
8318 : 625 : copy->expr1 = gfc_copy_expr (ns->code->expr1);
8319 : 625 : copy->expr2 = gfc_copy_expr (ns->code->expr2);
8320 : : }
8321 : : else
8322 : : {
8323 : 172 : copy = gfc_get_code (EXEC_CALL);
8324 : 172 : copy->symtree = ns->code->symtree;
8325 : 172 : copy->ext.actual = gfc_copy_actual_arglist (ns->code->ext.actual);
8326 : : }
8327 : 797 : copy->loc = ns->code->loc;
8328 : 797 : sym1_copy = *sym1;
8329 : 797 : sym2_copy = *sym2;
8330 : 797 : *sym1 = *n->sym;
8331 : 797 : *sym2 = *n->sym;
8332 : 797 : sym1->name = sym1_copy.name;
8333 : 797 : sym2->name = sym2_copy.name;
8334 : 797 : ns->proc_name = ns->parent->proc_name;
8335 : 797 : if (n->sym->attr.dimension)
8336 : : {
8337 : 348 : struct resolve_omp_udr_callback_data rcd;
8338 : 348 : rcd.sym1 = sym1;
8339 : 348 : rcd.sym2 = sym2;
8340 : 348 : gfc_code_walker (©, gfc_dummy_code_callback,
8341 : : resolve_omp_udr_callback, &rcd);
8342 : : }
8343 : 797 : gfc_resolve_code (copy, gfc_current_ns);
8344 : 797 : if (copy->op == EXEC_CALL && copy->resolved_isym == NULL)
8345 : : {
8346 : 172 : gfc_symbol *sym = copy->resolved_sym;
8347 : 172 : if (sym
8348 : 170 : && !sym->attr.intrinsic
8349 : 170 : && sym->attr.if_source == IFSRC_UNKNOWN)
8350 : 4 : gfc_error ("Implicitly declared subroutine %s used in "
8351 : : "!$OMP DECLARE REDUCTION at %L", sym->name,
8352 : : ©->loc);
8353 : : }
8354 : 797 : gfc_code_walker (©, gfc_dummy_code_callback,
8355 : : resolve_omp_udr_callback2, NULL);
8356 : 797 : *sym1 = sym1_copy;
8357 : 797 : *sym2 = sym2_copy;
8358 : 797 : return copy;
8359 : : }
8360 : :
8361 : : /* Assume that a constant expression in the range 1 (omp_default_mem_alloc)
8362 : : to GOMP_OMP_PREDEF_ALLOC_MAX, or GOMP_OMPX_PREDEF_ALLOC_MIN to
8363 : : GOMP_OMPX_PREDEF_ALLOC_MAX is fine. The original symbol name is already
8364 : : lost during matching via gfc_match_expr. */
8365 : : static bool
8366 : 42 : is_predefined_allocator (gfc_expr *expr)
8367 : : {
8368 : 42 : return (gfc_resolve_expr (expr)
8369 : 41 : && expr->rank == 0
8370 : 36 : && expr->ts.type == BT_INTEGER
8371 : 31 : && expr->ts.kind == gfc_c_intptr_kind
8372 : 26 : && expr->expr_type == EXPR_CONSTANT
8373 : 63 : && ((mpz_sgn (expr->value.integer) > 0
8374 : 19 : && mpz_cmp_si (expr->value.integer,
8375 : : GOMP_OMP_PREDEF_ALLOC_MAX) <= 0)
8376 : 4 : || (mpz_cmp_si (expr->value.integer,
8377 : : GOMP_OMPX_PREDEF_ALLOC_MIN) >= 0
8378 : 1 : && mpz_cmp_si (expr->value.integer,
8379 : 42 : GOMP_OMPX_PREDEF_ALLOC_MAX) <= 0)));
8380 : : }
8381 : :
8382 : : /* Resolve declarative ALLOCATE statement. Note: Common block vars only appear
8383 : : as /block/ not individual, which is ensured during parsing. */
8384 : :
8385 : : void
8386 : 55 : gfc_resolve_omp_allocate (gfc_namespace *ns, gfc_omp_namelist *list)
8387 : : {
8388 : 183 : for (gfc_omp_namelist *n = list; n; n = n->next)
8389 : : {
8390 : 128 : if (n->sym->attr.result || n->sym->result == n->sym)
8391 : : {
8392 : 1 : gfc_error ("Unexpected function-result variable %qs at %L in "
8393 : : "declarative !$OMP ALLOCATE", n->sym->name, &n->where);
8394 : 31 : continue;
8395 : : }
8396 : 127 : if (ns->omp_allocate->sym->attr.proc_pointer)
8397 : : {
8398 : 0 : gfc_error ("Procedure pointer %qs not supported with !$OMP "
8399 : : "ALLOCATE at %L", n->sym->name, &n->where);
8400 : 0 : continue;
8401 : : }
8402 : 127 : if (n->sym->attr.flavor != FL_VARIABLE)
8403 : : {
8404 : 3 : gfc_error ("Argument %qs at %L to declarative !$OMP ALLOCATE "
8405 : : "directive must be a variable", n->sym->name,
8406 : : &n->where);
8407 : 3 : continue;
8408 : : }
8409 : 124 : if (ns != n->sym->ns || n->sym->attr.use_assoc || n->sym->attr.imported)
8410 : : {
8411 : 8 : gfc_error ("Argument %qs at %L to declarative !$OMP ALLOCATE shall be"
8412 : : " in the same scope as the variable declaration",
8413 : : n->sym->name, &n->where);
8414 : 8 : continue;
8415 : : }
8416 : 116 : if (n->sym->attr.dummy)
8417 : : {
8418 : 3 : gfc_error ("Unexpected dummy argument %qs as argument at %L to "
8419 : : "declarative !$OMP ALLOCATE", n->sym->name, &n->where);
8420 : 3 : continue;
8421 : : }
8422 : 113 : if (n->sym->attr.codimension)
8423 : : {
8424 : 0 : gfc_error ("Unexpected coarray argument %qs as argument at %L to "
8425 : : "declarative !$OMP ALLOCATE", n->sym->name, &n->where);
8426 : 0 : continue;
8427 : : }
8428 : 113 : if (n->sym->attr.omp_allocate)
8429 : : {
8430 : 5 : if (n->sym->attr.in_common)
8431 : : {
8432 : 1 : gfc_error ("Duplicated common block %</%s/%> in !$OMP ALLOCATE "
8433 : 1 : "at %L", n->sym->common_head->name, &n->where);
8434 : 3 : while (n->next && n->next->sym
8435 : 4 : && n->sym->common_head == n->next->sym->common_head)
8436 : : n = n->next;
8437 : : }
8438 : : else
8439 : 4 : gfc_error ("Duplicated variable %qs in !$OMP ALLOCATE at %L",
8440 : : n->sym->name, &n->where);
8441 : 5 : continue;
8442 : : }
8443 : : /* For 'equivalence(a,b)', a 'union_type {<type> a,b} equiv.0' is created
8444 : : with a value expression for 'a' as 'equiv.0.a' (likewise for b); while
8445 : : this can be handled, EQUIVALENCE is marked as obsolescent since Fortran
8446 : : 2018 and also not widely used. However, it could be supported,
8447 : : if needed. */
8448 : 108 : if (n->sym->attr.in_equivalence)
8449 : : {
8450 : 2 : gfc_error ("Sorry, EQUIVALENCE object %qs not supported with !$OMP "
8451 : : "ALLOCATE at %L", n->sym->name, &n->where);
8452 : 2 : continue;
8453 : : }
8454 : : /* Similar for Cray pointer/pointee - they could be implemented but as
8455 : : common vendor extension but nowadays rarely used and requiring
8456 : : -fcray-pointer, there is no need to support them. */
8457 : 106 : if (n->sym->attr.cray_pointer || n->sym->attr.cray_pointee)
8458 : : {
8459 : 2 : gfc_error ("Sorry, Cray pointers and pointees such as %qs are not "
8460 : : "supported with !$OMP ALLOCATE at %L",
8461 : : n->sym->name, &n->where);
8462 : 2 : continue;
8463 : : }
8464 : 104 : n->sym->attr.omp_allocate = 1;
8465 : 104 : if ((n->sym->ts.type == BT_CLASS && n->sym->attr.class_ok
8466 : 0 : && CLASS_DATA (n->sym)->attr.allocatable)
8467 : 104 : || (n->sym->ts.type != BT_CLASS && n->sym->attr.allocatable))
8468 : 1 : gfc_error ("Unexpected allocatable variable %qs at %L in declarative "
8469 : : "!$OMP ALLOCATE directive", n->sym->name, &n->where);
8470 : 103 : else if ((n->sym->ts.type == BT_CLASS && n->sym->attr.class_ok
8471 : 0 : && CLASS_DATA (n->sym)->attr.class_pointer)
8472 : 103 : || (n->sym->ts.type != BT_CLASS && n->sym->attr.pointer))
8473 : 1 : gfc_error ("Unexpected pointer variable %qs at %L in declarative "
8474 : : "!$OMP ALLOCATE directive", n->sym->name, &n->where);
8475 : 104 : HOST_WIDE_INT alignment = 0;
8476 : 110 : if (n->u.align
8477 : 104 : && (!gfc_resolve_expr (n->u.align)
8478 : 27 : || n->u.align->ts.type != BT_INTEGER
8479 : 26 : || n->u.align->rank != 0
8480 : 24 : || n->u.align->expr_type != EXPR_CONSTANT
8481 : 23 : || gfc_extract_hwi (n->u.align, &alignment)
8482 : 23 : || !pow2p_hwi (alignment)))
8483 : : {
8484 : 6 : gfc_error ("ALIGN requires a scalar positive constant integer "
8485 : : "alignment expression at %L that is a power of two",
8486 : 6 : &n->u.align->where);
8487 : 6 : while (n->sym->attr.in_common && n->next && n->next->sym
8488 : 6 : && n->sym->common_head == n->next->sym->common_head)
8489 : : n = n->next;
8490 : 6 : continue;
8491 : : }
8492 : 98 : if (n->sym->attr.in_common || n->sym->attr.save || n->sym->ns->save_all
8493 : 55 : || (n->sym->ns->proc_name
8494 : 55 : && (n->sym->ns->proc_name->attr.flavor == FL_PROGRAM
8495 : 55 : || n->sym->ns->proc_name->attr.flavor == FL_MODULE)))
8496 : : {
8497 : 43 : bool com = n->sym->attr.in_common;
8498 : 43 : if (!n->u2.allocator)
8499 : 1 : gfc_error ("An ALLOCATOR clause is required as the list item "
8500 : : "%<%s%s%s%> at %L has the SAVE attribute", com ? "/" : "",
8501 : 0 : com ? n->sym->common_head->name : n->sym->name,
8502 : : com ? "/" : "", &n->where);
8503 : 42 : else if (!is_predefined_allocator (n->u2.allocator))
8504 : 24 : gfc_error ("Predefined allocator required in ALLOCATOR clause at %L"
8505 : : " as the list item %<%s%s%s%> at %L has the SAVE attribute",
8506 : 24 : &n->u2.allocator->where, com ? "/" : "",
8507 : 24 : com ? n->sym->common_head->name : n->sym->name,
8508 : : com ? "/" : "", &n->where);
8509 : 19 : while (n->sym->attr.in_common && n->next && n->next->sym
8510 : 64 : && n->sym->common_head == n->next->sym->common_head)
8511 : : n = n->next;
8512 : : }
8513 : 55 : else if (n->u2.allocator
8514 : 55 : && (!gfc_resolve_expr (n->u2.allocator)
8515 : 20 : || n->u2.allocator->ts.type != BT_INTEGER
8516 : 19 : || n->u2.allocator->rank != 0
8517 : 18 : || n->u2.allocator->ts.kind != gfc_c_intptr_kind))
8518 : 3 : gfc_error ("Expected integer expression of the "
8519 : : "%<omp_allocator_handle_kind%> kind at %L",
8520 : 3 : &n->u2.allocator->where);
8521 : : }
8522 : 55 : }
8523 : :
8524 : : /* Resolve ASSUME's and ASSUMES' assumption clauses. Note that absent/contains
8525 : : is handled during parse time in omp_verify_merge_absent_contains. */
8526 : :
8527 : : void
8528 : 29 : gfc_resolve_omp_assumptions (gfc_omp_assumptions *assume)
8529 : : {
8530 : 46 : for (gfc_expr_list *el = assume->holds; el; el = el->next)
8531 : 17 : if (!gfc_resolve_expr (el->expr)
8532 : 17 : || el->expr->ts.type != BT_LOGICAL
8533 : 32 : || el->expr->rank != 0)
8534 : 4 : gfc_error ("HOLDS expression at %L must be a scalar logical expression",
8535 : 4 : &el->expr->where);
8536 : 29 : }
8537 : :
8538 : :
8539 : : /* OpenMP directive resolving routines. */
8540 : :
8541 : : static void
8542 : 31920 : resolve_omp_clauses (gfc_code *code, gfc_omp_clauses *omp_clauses,
8543 : : gfc_namespace *ns, bool openacc = false)
8544 : : {
8545 : 31920 : gfc_omp_namelist *n, *last;
8546 : 31920 : gfc_expr_list *el;
8547 : 31920 : int list;
8548 : 31920 : int ifc;
8549 : 31920 : bool if_without_mod = false;
8550 : 31920 : gfc_omp_linear_op linear_op = OMP_LINEAR_DEFAULT;
8551 : 31920 : static const char *clause_names[]
8552 : : = { "PRIVATE", "FIRSTPRIVATE", "LASTPRIVATE", "COPYPRIVATE", "SHARED",
8553 : : "COPYIN", "UNIFORM", "AFFINITY", "ALIGNED", "LINEAR", "DEPEND", "MAP",
8554 : : "TO", "FROM", "INCLUSIVE", "EXCLUSIVE",
8555 : : "REDUCTION", "REDUCTION" /*inscan*/, "REDUCTION" /*task*/,
8556 : : "IN_REDUCTION", "TASK_REDUCTION",
8557 : : "DEVICE_RESIDENT", "LINK", "USE_DEVICE",
8558 : : "CACHE", "IS_DEVICE_PTR", "USE_DEVICE_PTR", "USE_DEVICE_ADDR",
8559 : : "NONTEMPORAL", "ALLOCATE", "HAS_DEVICE_ADDR", "ENTER",
8560 : : "USES_ALLOCATORS", "INIT", "USE", "DESTROY", "INTEROP", "ADJUST_ARGS" };
8561 : 31920 : STATIC_ASSERT (ARRAY_SIZE (clause_names) == OMP_LIST_NUM);
8562 : :
8563 : 31920 : if (omp_clauses == NULL)
8564 : : return;
8565 : :
8566 : 31920 : if (ns == NULL)
8567 : 31499 : ns = gfc_current_ns;
8568 : :
8569 : 31920 : if (omp_clauses->orderedc && omp_clauses->orderedc < omp_clauses->collapse)
8570 : 0 : gfc_error ("ORDERED clause parameter is less than COLLAPSE at %L",
8571 : : &code->loc);
8572 : 31920 : if (omp_clauses->order_concurrent && omp_clauses->ordered)
8573 : 4 : gfc_error ("ORDER clause must not be used together with ORDERED at %L",
8574 : : &code->loc);
8575 : 31920 : if (omp_clauses->if_expr)
8576 : : {
8577 : 1181 : gfc_expr *expr = omp_clauses->if_expr;
8578 : 1181 : if (!gfc_resolve_expr (expr)
8579 : 1181 : || expr->ts.type != BT_LOGICAL || expr->rank != 0)
8580 : 16 : gfc_error ("IF clause at %L requires a scalar LOGICAL expression",
8581 : : &expr->where);
8582 : : if_without_mod = true;
8583 : : }
8584 : 351120 : for (ifc = 0; ifc < OMP_IF_LAST; ifc++)
8585 : 319200 : if (omp_clauses->if_exprs[ifc])
8586 : : {
8587 : 137 : gfc_expr *expr = omp_clauses->if_exprs[ifc];
8588 : 137 : bool ok = true;
8589 : 137 : if (!gfc_resolve_expr (expr)
8590 : 137 : || expr->ts.type != BT_LOGICAL || expr->rank != 0)
8591 : 0 : gfc_error ("IF clause at %L requires a scalar LOGICAL expression",
8592 : : &expr->where);
8593 : 137 : else if (if_without_mod)
8594 : : {
8595 : 1 : gfc_error ("IF clause without modifier at %L used together with "
8596 : : "IF clauses with modifiers",
8597 : 1 : &omp_clauses->if_expr->where);
8598 : 1 : if_without_mod = false;
8599 : : }
8600 : : else
8601 : 136 : switch (code->op)
8602 : : {
8603 : 13 : case EXEC_OMP_CANCEL:
8604 : 13 : ok = ifc == OMP_IF_CANCEL;
8605 : 13 : break;
8606 : :
8607 : 16 : case EXEC_OMP_PARALLEL:
8608 : 16 : case EXEC_OMP_PARALLEL_DO:
8609 : 16 : case EXEC_OMP_PARALLEL_LOOP:
8610 : 16 : case EXEC_OMP_PARALLEL_MASKED:
8611 : 16 : case EXEC_OMP_PARALLEL_MASTER:
8612 : 16 : case EXEC_OMP_PARALLEL_SECTIONS:
8613 : 16 : case EXEC_OMP_PARALLEL_WORKSHARE:
8614 : 16 : case EXEC_OMP_DISTRIBUTE_PARALLEL_DO:
8615 : 16 : case EXEC_OMP_TEAMS_DISTRIBUTE_PARALLEL_DO:
8616 : 16 : ok = ifc == OMP_IF_PARALLEL;
8617 : 16 : break;
8618 : :
8619 : 28 : case EXEC_OMP_PARALLEL_DO_SIMD:
8620 : 28 : case EXEC_OMP_DISTRIBUTE_PARALLEL_DO_SIMD:
8621 : 28 : case EXEC_OMP_TEAMS_DISTRIBUTE_PARALLEL_DO_SIMD:
8622 : 28 : ok = ifc == OMP_IF_PARALLEL || ifc == OMP_IF_SIMD;
8623 : 28 : break;
8624 : :
8625 : 8 : case EXEC_OMP_PARALLEL_MASKED_TASKLOOP:
8626 : 8 : case EXEC_OMP_PARALLEL_MASTER_TASKLOOP:
8627 : 8 : ok = ifc == OMP_IF_PARALLEL || ifc == OMP_IF_TASKLOOP;
8628 : 8 : break;
8629 : :
8630 : 12 : case EXEC_OMP_PARALLEL_MASKED_TASKLOOP_SIMD:
8631 : 12 : case EXEC_OMP_PARALLEL_MASTER_TASKLOOP_SIMD:
8632 : 12 : ok = (ifc == OMP_IF_PARALLEL
8633 : 12 : || ifc == OMP_IF_TASKLOOP
8634 : : || ifc == OMP_IF_SIMD);
8635 : : break;
8636 : :
8637 : 0 : case EXEC_OMP_SIMD:
8638 : 0 : case EXEC_OMP_DO_SIMD:
8639 : 0 : case EXEC_OMP_DISTRIBUTE_SIMD:
8640 : 0 : case EXEC_OMP_TEAMS_DISTRIBUTE_SIMD:
8641 : 0 : ok = ifc == OMP_IF_SIMD;
8642 : 0 : break;
8643 : :
8644 : 1 : case EXEC_OMP_TASK:
8645 : 1 : ok = ifc == OMP_IF_TASK;
8646 : 1 : break;
8647 : :
8648 : 5 : case EXEC_OMP_TASKLOOP:
8649 : 5 : case EXEC_OMP_MASKED_TASKLOOP:
8650 : 5 : case EXEC_OMP_MASTER_TASKLOOP:
8651 : 5 : ok = ifc == OMP_IF_TASKLOOP;
8652 : 5 : break;
8653 : :
8654 : 20 : case EXEC_OMP_TASKLOOP_SIMD:
8655 : 20 : case EXEC_OMP_MASKED_TASKLOOP_SIMD:
8656 : 20 : case EXEC_OMP_MASTER_TASKLOOP_SIMD:
8657 : 20 : ok = ifc == OMP_IF_TASKLOOP || ifc == OMP_IF_SIMD;
8658 : 20 : break;
8659 : :
8660 : 5 : case EXEC_OMP_TARGET:
8661 : 5 : case EXEC_OMP_TARGET_TEAMS:
8662 : 5 : case EXEC_OMP_TARGET_TEAMS_DISTRIBUTE:
8663 : 5 : case EXEC_OMP_TARGET_TEAMS_LOOP:
8664 : 5 : ok = ifc == OMP_IF_TARGET;
8665 : 5 : break;
8666 : :
8667 : 4 : case EXEC_OMP_TARGET_TEAMS_DISTRIBUTE_SIMD:
8668 : 4 : case EXEC_OMP_TARGET_SIMD:
8669 : 4 : ok = ifc == OMP_IF_TARGET || ifc == OMP_IF_SIMD;
8670 : 4 : break;
8671 : :
8672 : 1 : case EXEC_OMP_TARGET_DATA:
8673 : 1 : ok = ifc == OMP_IF_TARGET_DATA;
8674 : 1 : break;
8675 : :
8676 : 1 : case EXEC_OMP_TARGET_UPDATE:
8677 : 1 : ok = ifc == OMP_IF_TARGET_UPDATE;
8678 : 1 : break;
8679 : :
8680 : 1 : case EXEC_OMP_TARGET_ENTER_DATA:
8681 : 1 : ok = ifc == OMP_IF_TARGET_ENTER_DATA;
8682 : 1 : break;
8683 : :
8684 : 1 : case EXEC_OMP_TARGET_EXIT_DATA:
8685 : 1 : ok = ifc == OMP_IF_TARGET_EXIT_DATA;
8686 : 1 : break;
8687 : :
8688 : 10 : case EXEC_OMP_TARGET_TEAMS_DISTRIBUTE_PARALLEL_DO:
8689 : 10 : case EXEC_OMP_TARGET_PARALLEL:
8690 : 10 : case EXEC_OMP_TARGET_PARALLEL_DO:
8691 : 10 : case EXEC_OMP_TARGET_PARALLEL_LOOP:
8692 : 10 : ok = ifc == OMP_IF_TARGET || ifc == OMP_IF_PARALLEL;
8693 : 10 : break;
8694 : :
8695 : 10 : case EXEC_OMP_TARGET_PARALLEL_DO_SIMD:
8696 : 10 : case EXEC_OMP_TARGET_TEAMS_DISTRIBUTE_PARALLEL_DO_SIMD:
8697 : 10 : ok = (ifc == OMP_IF_TARGET
8698 : 10 : || ifc == OMP_IF_PARALLEL
8699 : : || ifc == OMP_IF_SIMD);
8700 : : break;
8701 : :
8702 : : default:
8703 : : ok = false;
8704 : : break;
8705 : : }
8706 : 115 : if (!ok)
8707 : : {
8708 : 2 : static const char *ifs[] = {
8709 : : "CANCEL",
8710 : : "PARALLEL",
8711 : : "SIMD",
8712 : : "TASK",
8713 : : "TASKLOOP",
8714 : : "TARGET",
8715 : : "TARGET DATA",
8716 : : "TARGET UPDATE",
8717 : : "TARGET ENTER DATA",
8718 : : "TARGET EXIT DATA"
8719 : : };
8720 : 2 : gfc_error ("IF clause modifier %s at %L not appropriate for "
8721 : : "the current OpenMP construct", ifs[ifc], &expr->where);
8722 : : }
8723 : : }
8724 : :
8725 : 31920 : if (omp_clauses->self_expr)
8726 : : {
8727 : 177 : gfc_expr *expr = omp_clauses->self_expr;
8728 : 177 : if (!gfc_resolve_expr (expr)
8729 : 177 : || expr->ts.type != BT_LOGICAL || expr->rank != 0)
8730 : 6 : gfc_error ("SELF clause at %L requires a scalar LOGICAL expression",
8731 : : &expr->where);
8732 : : }
8733 : :
8734 : 31920 : if (omp_clauses->final_expr)
8735 : : {
8736 : 64 : gfc_expr *expr = omp_clauses->final_expr;
8737 : 64 : if (!gfc_resolve_expr (expr)
8738 : 64 : || expr->ts.type != BT_LOGICAL || expr->rank != 0)
8739 : 0 : gfc_error ("FINAL clause at %L requires a scalar LOGICAL expression",
8740 : : &expr->where);
8741 : : }
8742 : 31920 : if (omp_clauses->novariants)
8743 : : {
8744 : 9 : gfc_expr *expr = omp_clauses->novariants;
8745 : 18 : if (!gfc_resolve_expr (expr) || expr->ts.type != BT_LOGICAL
8746 : 17 : || expr->rank != 0)
8747 : 1 : gfc_error (
8748 : : "NOVARIANTS clause at %L requires a scalar LOGICAL expression",
8749 : : &expr->where);
8750 : 31920 : if_without_mod = true;
8751 : : }
8752 : 31920 : if (omp_clauses->nocontext)
8753 : : {
8754 : 12 : gfc_expr *expr = omp_clauses->nocontext;
8755 : 24 : if (!gfc_resolve_expr (expr) || expr->ts.type != BT_LOGICAL
8756 : 23 : || expr->rank != 0)
8757 : 1 : gfc_error (
8758 : : "NOCONTEXT clause at %L requires a scalar LOGICAL expression",
8759 : : &expr->where);
8760 : 31920 : if_without_mod = true;
8761 : : }
8762 : 31920 : if (omp_clauses->num_threads)
8763 : 950 : resolve_positive_int_expr (omp_clauses->num_threads, "NUM_THREADS");
8764 : 31920 : if (omp_clauses->chunk_size)
8765 : : {
8766 : 510 : gfc_expr *expr = omp_clauses->chunk_size;
8767 : 510 : if (!gfc_resolve_expr (expr)
8768 : 510 : || expr->ts.type != BT_INTEGER || expr->rank != 0)
8769 : 0 : gfc_error ("SCHEDULE clause's chunk_size at %L requires "
8770 : : "a scalar INTEGER expression", &expr->where);
8771 : 510 : else if (expr->expr_type == EXPR_CONSTANT
8772 : : && expr->ts.type == BT_INTEGER
8773 : 485 : && mpz_sgn (expr->value.integer) <= 0)
8774 : 2 : gfc_warning (OPT_Wopenmp, "INTEGER expression of SCHEDULE clause's "
8775 : : "chunk_size at %L must be positive", &expr->where);
8776 : : }
8777 : 31920 : if (omp_clauses->sched_kind != OMP_SCHED_NONE
8778 : 891 : && omp_clauses->sched_nonmonotonic)
8779 : : {
8780 : 34 : if (omp_clauses->sched_monotonic)
8781 : 2 : gfc_error ("Both MONOTONIC and NONMONOTONIC schedule modifiers "
8782 : : "specified at %L", &code->loc);
8783 : 32 : else if (omp_clauses->ordered)
8784 : 4 : gfc_error ("NONMONOTONIC schedule modifier specified with ORDERED "
8785 : : "clause at %L", &code->loc);
8786 : : }
8787 : :
8788 : 31920 : if (omp_clauses->depobj
8789 : 31920 : && (!gfc_resolve_expr (omp_clauses->depobj)
8790 : 115 : || omp_clauses->depobj->ts.type != BT_INTEGER
8791 : 114 : || omp_clauses->depobj->ts.kind != 2 * gfc_index_integer_kind
8792 : 113 : || omp_clauses->depobj->rank != 0))
8793 : 4 : gfc_error ("DEPOBJ in DEPOBJ construct at %L shall be a scalar integer "
8794 : 4 : "of OMP_DEPEND_KIND kind", &omp_clauses->depobj->where);
8795 : :
8796 : : /* Check that no symbol appears on multiple clauses, except that
8797 : : a symbol can appear on both firstprivate and lastprivate. */
8798 : 1244880 : for (list = 0; list < OMP_LIST_NUM; list++)
8799 : 1257343 : for (n = omp_clauses->lists[list]; n; n = n->next)
8800 : : {
8801 : 44383 : if (!n->sym) /* omp_all_memory. */
8802 : 47 : continue;
8803 : 44336 : n->sym->mark = 0;
8804 : 44336 : n->sym->comp_mark = 0;
8805 : 44336 : n->sym->data_mark = 0;
8806 : 44336 : n->sym->dev_mark = 0;
8807 : 44336 : n->sym->gen_mark = 0;
8808 : 44336 : n->sym->reduc_mark = 0;
8809 : 44336 : if (n->sym->attr.flavor == FL_VARIABLE
8810 : 266 : || n->sym->attr.proc_pointer
8811 : 225 : || (!code && (!n->sym->attr.dummy || n->sym->ns != ns)))
8812 : : {
8813 : 44111 : if (!code && (!n->sym->attr.dummy || n->sym->ns != ns))
8814 : 0 : gfc_error ("Variable %qs is not a dummy argument at %L",
8815 : : n->sym->name, &n->where);
8816 : 44111 : continue;
8817 : : }
8818 : 225 : if (n->sym->attr.flavor == FL_PROCEDURE
8819 : 153 : && n->sym->result == n->sym
8820 : 138 : && n->sym->attr.function)
8821 : : {
8822 : 138 : if (ns->proc_name == n->sym
8823 : 44 : || (ns->parent && ns->parent->proc_name == n->sym))
8824 : 101 : continue;
8825 : 37 : if (ns->proc_name->attr.entry_master)
8826 : : {
8827 : 32 : gfc_entry_list *el = ns->entries;
8828 : 51 : for (; el; el = el->next)
8829 : 51 : if (el->sym == n->sym)
8830 : : break;
8831 : 32 : if (el)
8832 : 32 : continue;
8833 : : }
8834 : 5 : if (ns->parent
8835 : 3 : && ns->parent->proc_name->attr.entry_master)
8836 : : {
8837 : 2 : gfc_entry_list *el = ns->parent->entries;
8838 : 3 : for (; el; el = el->next)
8839 : 3 : if (el->sym == n->sym)
8840 : : break;
8841 : 2 : if (el)
8842 : 2 : continue;
8843 : : }
8844 : : }
8845 : 90 : if (list == OMP_LIST_MAP
8846 : 18 : && n->sym->attr.flavor == FL_PARAMETER)
8847 : : {
8848 : : /* OpenACC since 3.4 permits for Fortran named constants, but
8849 : : permits removing then as optimization is not needed and such
8850 : : ignore them. Likewise below for FIRSTPRIVATE. */
8851 : 12 : if (openacc)
8852 : 10 : gfc_warning (OPT_Wsurprising, "Clause for object %qs at %L is "
8853 : : "ignored as parameters need not be copied",
8854 : : n->sym->name, &n->where);
8855 : : else
8856 : 2 : gfc_error ("Object %qs is not a variable at %L; parameters"
8857 : : " cannot be and need not be mapped", n->sym->name,
8858 : : &n->where);
8859 : : }
8860 : 78 : else if (openacc && n->sym->attr.flavor == FL_PARAMETER)
8861 : 9 : gfc_warning (OPT_Wsurprising, "Clause for object %qs at %L is ignored"
8862 : : " as it is a parameter", n->sym->name, &n->where);
8863 : 69 : else if (list != OMP_LIST_USES_ALLOCATORS)
8864 : 30 : gfc_error ("Object %qs is not a variable at %L", n->sym->name,
8865 : : &n->where);
8866 : : }
8867 : 31920 : if (omp_clauses->lists[OMP_LIST_REDUCTION_INSCAN])
8868 : : {
8869 : 69 : locus *loc = &omp_clauses->lists[OMP_LIST_REDUCTION_INSCAN]->where;
8870 : 69 : if (code->op != EXEC_OMP_DO
8871 : : && code->op != EXEC_OMP_SIMD
8872 : : && code->op != EXEC_OMP_DO_SIMD
8873 : : && code->op != EXEC_OMP_PARALLEL_DO
8874 : : && code->op != EXEC_OMP_PARALLEL_DO_SIMD)
8875 : 23 : gfc_error ("%<inscan%> REDUCTION clause on construct other than DO, "
8876 : : "SIMD, DO SIMD, PARALLEL DO, PARALLEL DO SIMD at %L",
8877 : : loc);
8878 : 69 : if (omp_clauses->ordered)
8879 : 2 : gfc_error ("ORDERED clause specified together with %<inscan%> "
8880 : : "REDUCTION clause at %L", loc);
8881 : 69 : if (omp_clauses->sched_kind != OMP_SCHED_NONE)
8882 : 3 : gfc_error ("SCHEDULE clause specified together with %<inscan%> "
8883 : : "REDUCTION clause at %L", loc);
8884 : : }
8885 : :
8886 : 1244880 : for (list = 0; list < OMP_LIST_NUM; list++)
8887 : 1212960 : if (list != OMP_LIST_FIRSTPRIVATE
8888 : 1212960 : && list != OMP_LIST_LASTPRIVATE
8889 : 1212960 : && list != OMP_LIST_ALIGNED
8890 : 1117200 : && list != OMP_LIST_DEPEND
8891 : 1117200 : && list != OMP_LIST_FROM
8892 : 1053360 : && list != OMP_LIST_TO
8893 : 1053360 : && list != OMP_LIST_INTEROP
8894 : 989520 : && (list != OMP_LIST_REDUCTION || !openacc)
8895 : 976903 : && list != OMP_LIST_ALLOCATE)
8896 : 978672 : for (n = omp_clauses->lists[list]; n; n = n->next)
8897 : : {
8898 : 33689 : bool component_ref_p = false;
8899 : :
8900 : : /* Allow multiple components of the same (e.g. derived-type)
8901 : : variable here. Duplicate components are detected elsewhere. */
8902 : 33689 : if (n->expr && n->expr->expr_type == EXPR_VARIABLE)
8903 : 13516 : for (gfc_ref *ref = n->expr->ref; ref; ref = ref->next)
8904 : 7884 : if (ref->type == REF_COMPONENT)
8905 : 2363 : component_ref_p = true;
8906 : 33689 : if ((list == OMP_LIST_IS_DEVICE_PTR
8907 : 33689 : || list == OMP_LIST_HAS_DEVICE_ADDR)
8908 : 301 : && !component_ref_p)
8909 : : {
8910 : 301 : if (n->sym->gen_mark
8911 : 299 : || n->sym->dev_mark
8912 : 298 : || n->sym->reduc_mark
8913 : 298 : || n->sym->mark)
8914 : 5 : gfc_error ("Symbol %qs present on multiple clauses at %L",
8915 : : n->sym->name, &n->where);
8916 : : else
8917 : 296 : n->sym->dev_mark = 1;
8918 : : }
8919 : 33388 : else if ((list == OMP_LIST_USE_DEVICE_PTR
8920 : 33388 : || list == OMP_LIST_USE_DEVICE_ADDR
8921 : 33388 : || list == OMP_LIST_PRIVATE
8922 : : || list == OMP_LIST_SHARED)
8923 : 12801 : && !component_ref_p)
8924 : : {
8925 : 12801 : if (n->sym->gen_mark || n->sym->dev_mark || n->sym->reduc_mark)
8926 : 13 : gfc_error ("Symbol %qs present on multiple clauses at %L",
8927 : : n->sym->name, &n->where);
8928 : : else
8929 : : {
8930 : 12788 : n->sym->gen_mark = 1;
8931 : : /* Set both generic and device bits if we have
8932 : : use_device_*(x) or shared(x). This allows us to diagnose
8933 : : "map(x) private(x)" below. */
8934 : 12788 : if (list != OMP_LIST_PRIVATE)
8935 : 3438 : n->sym->dev_mark = 1;
8936 : : }
8937 : : }
8938 : 20587 : else if ((list == OMP_LIST_REDUCTION
8939 : 20587 : || list == OMP_LIST_REDUCTION_TASK
8940 : 18132 : || list == OMP_LIST_REDUCTION_INSCAN
8941 : 18132 : || list == OMP_LIST_IN_REDUCTION
8942 : 17919 : || list == OMP_LIST_TASK_REDUCTION)
8943 : 2668 : && !component_ref_p)
8944 : : {
8945 : : /* Attempts to mix reduction types are diagnosed below. */
8946 : 2668 : if (n->sym->gen_mark || n->sym->dev_mark)
8947 : 2 : gfc_error ("Symbol %qs present on multiple clauses at %L",
8948 : : n->sym->name, &n->where);
8949 : 2668 : n->sym->reduc_mark = 1;
8950 : : }
8951 : 17919 : else if ((!component_ref_p && n->sym->comp_mark)
8952 : 2084 : || (component_ref_p && n->sym->mark))
8953 : : {
8954 : 28 : if (openacc)
8955 : 3 : gfc_error ("Symbol %qs has mixed component and non-component "
8956 : 3 : "accesses at %L", n->sym->name, &n->where);
8957 : : }
8958 : 17891 : else if (n->sym->mark)
8959 : 89 : gfc_error ("Symbol %qs present on multiple clauses at %L",
8960 : : n->sym->name, &n->where);
8961 : : else
8962 : : {
8963 : 17802 : if (component_ref_p)
8964 : 2057 : n->sym->comp_mark = 1;
8965 : : else
8966 : 15745 : n->sym->mark = 1;
8967 : : }
8968 : : }
8969 : :
8970 : 31920 : if (code
8971 : 31702 : && code->op == EXEC_OMP_INTEROP
8972 : 63 : && omp_clauses->lists[OMP_LIST_DEPEND])
8973 : : {
8974 : 12 : if (!omp_clauses->lists[OMP_LIST_INIT]
8975 : 5 : && !omp_clauses->lists[OMP_LIST_USE]
8976 : 1 : && !omp_clauses->lists[OMP_LIST_DESTROY])
8977 : : {
8978 : 1 : gfc_error ("DEPEND clause at %L requires action clause with "
8979 : : "%<targetsync%> interop-type",
8980 : : &omp_clauses->lists[OMP_LIST_DEPEND]->where);
8981 : : }
8982 : 22 : for (n = omp_clauses->lists[OMP_LIST_INIT]; n; n = n->next)
8983 : 12 : if (!n->u.init.targetsync)
8984 : : {
8985 : 2 : gfc_error ("DEPEND clause at %L requires %<targetsync%> "
8986 : : "interop-type, lacking it for %qs at %L",
8987 : 2 : &omp_clauses->lists[OMP_LIST_DEPEND]->where,
8988 : 2 : n->sym->name, &n->where);
8989 : 2 : break;
8990 : : }
8991 : : }
8992 : 31702 : if (code && (code->op == EXEC_OMP_INTEROP || code->op == EXEC_OMP_DISPATCH))
8993 : 1085 : for (list = OMP_LIST_INIT; list <= OMP_LIST_INTEROP; list++)
8994 : 1123 : for (n = omp_clauses->lists[list]; n; n = n->next)
8995 : : {
8996 : 255 : if (n->sym->ts.type != BT_INTEGER
8997 : 252 : || n->sym->ts.kind != gfc_index_integer_kind
8998 : 248 : || n->sym->attr.dimension
8999 : 243 : || n->sym->attr.flavor != FL_VARIABLE)
9000 : 16 : gfc_error ("%qs at %L in %qs clause must be a scalar integer "
9001 : : "variable of %<omp_interop_kind%> kind", n->sym->name,
9002 : : &n->where, clause_names[list]);
9003 : 255 : if (list != OMP_LIST_USE && list != OMP_LIST_INTEROP
9004 : 109 : && n->sym->attr.intent == INTENT_IN)
9005 : 2 : gfc_error ("%qs at %L in %qs clause must be definable",
9006 : : n->sym->name, &n->where, clause_names[list]);
9007 : : }
9008 : :
9009 : : /* Detect specifically the case where we have "map(x) private(x)" and raise
9010 : : an error. If we have "...simd" combined directives though, the "private"
9011 : : applies to the simd part, so this is permitted though. */
9012 : 41278 : for (n = omp_clauses->lists[OMP_LIST_PRIVATE]; n; n = n->next)
9013 : 9358 : if (n->sym->mark
9014 : 6 : && n->sym->gen_mark
9015 : 6 : && !n->sym->dev_mark
9016 : 6 : && !n->sym->reduc_mark
9017 : 5 : && code->op != EXEC_OMP_TARGET_SIMD
9018 : : && code->op != EXEC_OMP_TARGET_PARALLEL_DO_SIMD
9019 : : && code->op != EXEC_OMP_TARGET_TEAMS_DISTRIBUTE_SIMD
9020 : : && code->op != EXEC_OMP_TARGET_TEAMS_DISTRIBUTE_PARALLEL_DO_SIMD)
9021 : 1 : gfc_error ("Symbol %qs present on multiple clauses at %L",
9022 : : n->sym->name, &n->where);
9023 : :
9024 : : gcc_assert (OMP_LIST_LASTPRIVATE == OMP_LIST_FIRSTPRIVATE + 1);
9025 : 95760 : for (list = OMP_LIST_FIRSTPRIVATE; list <= OMP_LIST_LASTPRIVATE; list++)
9026 : 67924 : for (n = omp_clauses->lists[list]; n; n = n->next)
9027 : 4084 : if (n->sym->data_mark || n->sym->gen_mark || n->sym->dev_mark)
9028 : : {
9029 : 9 : gfc_error ("Symbol %qs present on multiple clauses at %L",
9030 : : n->sym->name, &n->where);
9031 : 9 : n->sym->data_mark = n->sym->gen_mark = n->sym->dev_mark = 0;
9032 : : }
9033 : 4075 : else if (n->sym->mark
9034 : 16 : && code->op != EXEC_OMP_TARGET_TEAMS
9035 : : && code->op != EXEC_OMP_TARGET_TEAMS_DISTRIBUTE
9036 : : && code->op != EXEC_OMP_TARGET_TEAMS_LOOP
9037 : : && code->op != EXEC_OMP_TARGET_TEAMS_DISTRIBUTE_SIMD
9038 : : && code->op != EXEC_OMP_TARGET_TEAMS_DISTRIBUTE_PARALLEL_DO
9039 : : && code->op != EXEC_OMP_TARGET_PARALLEL
9040 : : && code->op != EXEC_OMP_TARGET_PARALLEL_DO
9041 : : && code->op != EXEC_OMP_TARGET_PARALLEL_LOOP
9042 : : && code->op != EXEC_OMP_TARGET_PARALLEL_DO_SIMD
9043 : : && code->op != EXEC_OMP_TARGET_TEAMS_DISTRIBUTE_PARALLEL_DO_SIMD)
9044 : 5 : gfc_error ("Symbol %qs present on both data and map clauses "
9045 : : "at %L", n->sym->name, &n->where);
9046 : :
9047 : 33698 : for (n = omp_clauses->lists[OMP_LIST_FIRSTPRIVATE]; n; n = n->next)
9048 : : {
9049 : 1778 : if (n->sym->data_mark || n->sym->gen_mark || n->sym->dev_mark)
9050 : 7 : gfc_error ("Symbol %qs present on multiple clauses at %L",
9051 : : n->sym->name, &n->where);
9052 : : else
9053 : 1771 : n->sym->data_mark = 1;
9054 : : }
9055 : 34226 : for (n = omp_clauses->lists[OMP_LIST_LASTPRIVATE]; n; n = n->next)
9056 : 2306 : n->sym->data_mark = 0;
9057 : :
9058 : 34226 : for (n = omp_clauses->lists[OMP_LIST_LASTPRIVATE]; n; n = n->next)
9059 : : {
9060 : 2306 : if (n->sym->data_mark || n->sym->gen_mark || n->sym->dev_mark)
9061 : 0 : gfc_error ("Symbol %qs present on multiple clauses at %L",
9062 : : n->sym->name, &n->where);
9063 : : else
9064 : 2306 : n->sym->data_mark = 1;
9065 : : }
9066 : :
9067 : 32070 : for (n = omp_clauses->lists[OMP_LIST_ALIGNED]; n; n = n->next)
9068 : 150 : n->sym->mark = 0;
9069 : :
9070 : 32070 : for (n = omp_clauses->lists[OMP_LIST_ALIGNED]; n; n = n->next)
9071 : : {
9072 : 150 : if (n->sym->mark)
9073 : 0 : gfc_error ("Symbol %qs present on multiple clauses at %L",
9074 : : n->sym->name, &n->where);
9075 : : else
9076 : 150 : n->sym->mark = 1;
9077 : : }
9078 : :
9079 : 31920 : if (omp_clauses->lists[OMP_LIST_ALLOCATE])
9080 : : {
9081 : 696 : for (n = omp_clauses->lists[OMP_LIST_ALLOCATE]; n; n = n->next)
9082 : : {
9083 : 462 : if (n->u2.allocator
9084 : 462 : && (!gfc_resolve_expr (n->u2.allocator)
9085 : 238 : || n->u2.allocator->ts.type != BT_INTEGER
9086 : 236 : || n->u2.allocator->rank != 0
9087 : 235 : || n->u2.allocator->ts.kind != gfc_c_intptr_kind))
9088 : : {
9089 : 8 : gfc_error ("Expected integer expression of the "
9090 : : "%<omp_allocator_handle_kind%> kind at %L",
9091 : 8 : &n->u2.allocator->where);
9092 : 28 : break;
9093 : : }
9094 : 454 : if (!n->u.align)
9095 : 394 : continue;
9096 : 60 : HOST_WIDE_INT alignment = 0;
9097 : 60 : if (!gfc_resolve_expr (n->u.align)
9098 : 60 : || n->u.align->ts.type != BT_INTEGER
9099 : 57 : || n->u.align->rank != 0
9100 : 54 : || n->u.align->expr_type != EXPR_CONSTANT
9101 : 51 : || gfc_extract_hwi (n->u.align, &alignment)
9102 : 51 : || alignment <= 0
9103 : 111 : || !pow2p_hwi (alignment))
9104 : : {
9105 : 12 : gfc_error ("ALIGN requires a scalar positive constant integer "
9106 : : "alignment expression at %L that is a power of two",
9107 : 12 : &n->u.align->where);
9108 : 12 : break;
9109 : : }
9110 : : }
9111 : :
9112 : : /* Check for 2 things here.
9113 : : 1. There is no duplication of variable in allocate clause.
9114 : : 2. Variable in allocate clause are also present in some
9115 : : privatization clase (non-composite case). */
9116 : 716 : for (n = omp_clauses->lists[OMP_LIST_ALLOCATE]; n; n = n->next)
9117 : 462 : if (n->sym)
9118 : 436 : n->sym->mark = 0;
9119 : :
9120 : : gfc_omp_namelist *prev = NULL;
9121 : 716 : for (n = omp_clauses->lists[OMP_LIST_ALLOCATE]; n; )
9122 : : {
9123 : 462 : if (n->sym == NULL)
9124 : : {
9125 : 26 : n = n->next;
9126 : 26 : continue;
9127 : : }
9128 : 436 : if (n->sym->mark == 1)
9129 : : {
9130 : 3 : gfc_warning (OPT_Wopenmp, "%qs appears more than once in "
9131 : : "%<allocate%> at %L" , n->sym->name, &n->where);
9132 : : /* We have already seen this variable so it is a duplicate.
9133 : : Remove it. */
9134 : 3 : if (prev != NULL && prev->next == n)
9135 : : {
9136 : 3 : prev->next = n->next;
9137 : 3 : n->next = NULL;
9138 : 3 : gfc_free_omp_namelist (n, false, true, false, false);
9139 : 3 : n = prev->next;
9140 : : }
9141 : 3 : continue;
9142 : : }
9143 : 433 : n->sym->mark = 1;
9144 : 433 : prev = n;
9145 : 433 : n = n->next;
9146 : : }
9147 : :
9148 : : /* Non-composite constructs. */
9149 : 254 : if (code && code->op < EXEC_OMP_DO_SIMD)
9150 : : {
9151 : 4524 : for (list = 0; list < OMP_LIST_NUM; list++)
9152 : 4408 : switch (list)
9153 : : {
9154 : 1044 : case OMP_LIST_PRIVATE:
9155 : 1044 : case OMP_LIST_FIRSTPRIVATE:
9156 : 1044 : case OMP_LIST_LASTPRIVATE:
9157 : 1044 : case OMP_LIST_REDUCTION:
9158 : 1044 : case OMP_LIST_REDUCTION_INSCAN:
9159 : 1044 : case OMP_LIST_REDUCTION_TASK:
9160 : 1044 : case OMP_LIST_IN_REDUCTION:
9161 : 1044 : case OMP_LIST_TASK_REDUCTION:
9162 : 1044 : case OMP_LIST_LINEAR:
9163 : 1337 : for (n = omp_clauses->lists[list]; n; n = n->next)
9164 : 293 : n->sym->mark = 0;
9165 : : break;
9166 : : default:
9167 : : break;
9168 : : }
9169 : :
9170 : 401 : for (n = omp_clauses->lists[OMP_LIST_ALLOCATE]; n; n = n->next)
9171 : 285 : if (n->sym->mark == 1)
9172 : 4 : gfc_error ("%qs specified in %<allocate%> clause at %L but not "
9173 : : "in an explicit privatization clause",
9174 : : n->sym->name, &n->where);
9175 : : }
9176 : : if (code
9177 : 254 : && (code->op == EXEC_OMP_ALLOCATORS || code->op == EXEC_OMP_ALLOCATE)
9178 : 72 : && code->block
9179 : 71 : && code->block->next
9180 : 70 : && code->block->next->op == EXEC_ALLOCATE)
9181 : : {
9182 : 67 : gfc_alloc *a;
9183 : 67 : gfc_omp_namelist *n_null = NULL;
9184 : 67 : bool missing_allocator = false;
9185 : 67 : gfc_symbol *missing_allocator_sym = NULL;
9186 : 159 : for (n = omp_clauses->lists[OMP_LIST_ALLOCATE]; n; n = n->next)
9187 : : {
9188 : 92 : if (n->u2.allocator == NULL)
9189 : : {
9190 : 76 : if (!missing_allocator_sym)
9191 : 58 : missing_allocator_sym = n->sym;
9192 : : missing_allocator = true;
9193 : : }
9194 : 92 : if (n->sym == NULL)
9195 : : {
9196 : 26 : n_null = n;
9197 : 26 : continue;
9198 : : }
9199 : 66 : if (n->sym->attr.codimension)
9200 : 2 : gfc_error ("Unexpected coarray %qs in %<allocate%> at %L",
9201 : : n->sym->name, &n->where);
9202 : 102 : for (a = code->block->next->ext.alloc.list; a; a = a->next)
9203 : 100 : if (a->expr->expr_type == EXPR_VARIABLE
9204 : 100 : && a->expr->symtree->n.sym == n->sym)
9205 : : {
9206 : 64 : gfc_ref *ref;
9207 : 80 : for (ref = a->expr->ref; ref; ref = ref->next)
9208 : 16 : if (ref->type == REF_COMPONENT)
9209 : : break;
9210 : : if (ref == NULL)
9211 : : break;
9212 : : }
9213 : 66 : if (a == NULL)
9214 : 2 : gfc_error ("%qs specified in %<allocate%> at %L but not "
9215 : : "in the associated ALLOCATE statement",
9216 : 2 : n->sym->name, &n->where);
9217 : : }
9218 : : /* If there is an ALLOCATE directive without list argument, a
9219 : : namelist with its allocator/align clauses and n->sym = NULL is
9220 : : created during parsing; here, we add all not otherwise specified
9221 : : items from the Fortran allocate to that list.
9222 : : For an ALLOCATORS directive, not listed items use the normal
9223 : : Fortran way.
9224 : : The behavior of an ALLOCATE directive that does not list all
9225 : : arguments but there is no directive without list argument is not
9226 : : well specified. Thus, we reject such code below. In OpenMP 5.2
9227 : : the executable ALLOCATE directive is deprecated and in 6.0
9228 : : deleted such that no spec clarification is to be expected. */
9229 : 123 : for (a = code->block->next->ext.alloc.list; a; a = a->next)
9230 : 88 : if (a->expr->expr_type == EXPR_VARIABLE)
9231 : : {
9232 : 153 : for (n = omp_clauses->lists[OMP_LIST_ALLOCATE]; n; n = n->next)
9233 : 121 : if (a->expr->symtree->n.sym == n->sym)
9234 : : {
9235 : 56 : gfc_ref *ref;
9236 : 70 : for (ref = a->expr->ref; ref; ref = ref->next)
9237 : 14 : if (ref->type == REF_COMPONENT)
9238 : : break;
9239 : : if (ref == NULL)
9240 : : break;
9241 : : }
9242 : 88 : if (n == NULL && n_null == NULL)
9243 : : {
9244 : : /* OK for ALLOCATORS but for ALLOCATE: Unspecified whether
9245 : : that should use the default allocator of OpenMP or the
9246 : : Fortran allocator. Thus, just reject it. */
9247 : 7 : if (code->op == EXEC_OMP_ALLOCATE)
9248 : 1 : gfc_error ("%qs listed in %<allocate%> statement at %L "
9249 : : "but it is neither explicitly in listed in "
9250 : : "the %<!$OMP ALLOCATE%> directive nor exists"
9251 : : " a directive without argument list",
9252 : 1 : a->expr->symtree->n.sym->name,
9253 : : &a->expr->where);
9254 : : break;
9255 : : }
9256 : 81 : if (n == NULL)
9257 : : {
9258 : 25 : if (a->expr->symtree->n.sym->attr.codimension)
9259 : 1 : gfc_error ("Unexpected coarray %qs in %<allocate%> at "
9260 : : "%L, implicitly listed in %<!$OMP ALLOCATE%>"
9261 : : " at %L", a->expr->symtree->n.sym->name,
9262 : : &a->expr->where, &n_null->where);
9263 : : break;
9264 : : }
9265 : : }
9266 : 67 : gfc_namespace *prog_unit = ns;
9267 : 86 : while (prog_unit->parent)
9268 : : prog_unit = prog_unit->parent;
9269 : : gfc_namespace *fn_ns = ns;
9270 : 71 : while (fn_ns)
9271 : : {
9272 : 69 : if (ns->proc_name
9273 : 69 : && (ns->proc_name->attr.subroutine
9274 : 6 : || ns->proc_name->attr.function))
9275 : : break;
9276 : 4 : fn_ns = fn_ns->parent;
9277 : : }
9278 : 67 : if (missing_allocator
9279 : 57 : && !(prog_unit->omp_requires & OMP_REQ_DYNAMIC_ALLOCATORS)
9280 : 57 : && ((fn_ns && fn_ns->proc_name->attr.omp_declare_target)
9281 : 54 : || omp_clauses->contained_in_target_construct))
9282 : : {
9283 : 6 : if (code->op == EXEC_OMP_ALLOCATORS)
9284 : 2 : gfc_error ("ALLOCATORS directive at %L inside a target region "
9285 : : "must specify an ALLOCATOR modifier for %qs",
9286 : : &code->loc, missing_allocator_sym->name);
9287 : 4 : else if (missing_allocator_sym)
9288 : 2 : gfc_error ("ALLOCATE directive at %L inside a target region "
9289 : : "must specify an ALLOCATOR clause for %qs",
9290 : : &code->loc, missing_allocator_sym->name);
9291 : : else
9292 : 2 : gfc_error ("ALLOCATE directive at %L inside a target region "
9293 : : "must specify an ALLOCATOR clause", &code->loc);
9294 : : }
9295 : :
9296 : : }
9297 : : }
9298 : :
9299 : : /* OpenACC reductions. */
9300 : 31920 : if (openacc)
9301 : : {
9302 : 14753 : for (n = omp_clauses->lists[OMP_LIST_REDUCTION]; n; n = n->next)
9303 : 2136 : n->sym->mark = 0;
9304 : :
9305 : 14753 : for (n = omp_clauses->lists[OMP_LIST_REDUCTION]; n; n = n->next)
9306 : : {
9307 : 2136 : if (n->sym->mark)
9308 : 0 : gfc_error ("Symbol %qs present on multiple clauses at %L",
9309 : : n->sym->name, &n->where);
9310 : : else
9311 : 2136 : n->sym->mark = 1;
9312 : :
9313 : : /* OpenACC does not support reductions on arrays. */
9314 : 2136 : if (n->sym->as)
9315 : 71 : gfc_error ("Array %qs is not permitted in reduction at %L",
9316 : : n->sym->name, &n->where);
9317 : : }
9318 : : }
9319 : :
9320 : 32674 : for (n = omp_clauses->lists[OMP_LIST_TO]; n; n = n->next)
9321 : 754 : n->sym->mark = 0;
9322 : 32951 : for (n = omp_clauses->lists[OMP_LIST_FROM]; n; n = n->next)
9323 : 1031 : if (n->expr == NULL)
9324 : 1015 : n->sym->mark = 1;
9325 : 32674 : for (n = omp_clauses->lists[OMP_LIST_TO]; n; n = n->next)
9326 : : {
9327 : 754 : if (n->expr == NULL && n->sym->mark)
9328 : 0 : gfc_error ("Symbol %qs present on both FROM and TO clauses at %L",
9329 : : n->sym->name, &n->where);
9330 : : else
9331 : 754 : n->sym->mark = 1;
9332 : : }
9333 : :
9334 : : bool has_inscan = false, has_notinscan = false;
9335 : 1244880 : for (list = 0; list < OMP_LIST_NUM; list++)
9336 : 1212960 : if ((n = omp_clauses->lists[list]) != NULL)
9337 : : {
9338 : 28593 : const char *name = clause_names[list];
9339 : :
9340 : 28593 : switch (list)
9341 : : {
9342 : : case OMP_LIST_COPYIN:
9343 : 267 : for (; n != NULL; n = n->next)
9344 : : {
9345 : 170 : if (!n->sym->attr.threadprivate)
9346 : 0 : gfc_error ("Non-THREADPRIVATE object %qs in COPYIN clause"
9347 : : " at %L", n->sym->name, &n->where);
9348 : : }
9349 : : break;
9350 : 83 : case OMP_LIST_COPYPRIVATE:
9351 : 83 : if (omp_clauses->nowait)
9352 : 6 : gfc_error ("NOWAIT clause must not be used with COPYPRIVATE "
9353 : : "clause at %L", &n->where);
9354 : 376 : for (; n != NULL; n = n->next)
9355 : : {
9356 : 293 : if (n->sym->as && n->sym->as->type == AS_ASSUMED_SIZE)
9357 : 0 : gfc_error ("Assumed size array %qs in COPYPRIVATE clause "
9358 : : "at %L", n->sym->name, &n->where);
9359 : 293 : if (n->sym->attr.pointer && n->sym->attr.intent == INTENT_IN)
9360 : 1 : gfc_error ("INTENT(IN) POINTER %qs in COPYPRIVATE clause "
9361 : : "at %L", n->sym->name, &n->where);
9362 : : }
9363 : : break;
9364 : : case OMP_LIST_SHARED:
9365 : 2574 : for (; n != NULL; n = n->next)
9366 : : {
9367 : 1624 : if (n->sym->attr.threadprivate)
9368 : 0 : gfc_error ("THREADPRIVATE object %qs in SHARED clause at "
9369 : : "%L", n->sym->name, &n->where);
9370 : 1624 : if (n->sym->attr.cray_pointee)
9371 : 1 : gfc_error ("Cray pointee %qs in SHARED clause at %L",
9372 : : n->sym->name, &n->where);
9373 : 1624 : if (n->sym->attr.associate_var)
9374 : 8 : gfc_error ("Associate name %qs in SHARED clause at %L",
9375 : 8 : n->sym->attr.select_type_temporary
9376 : 4 : ? n->sym->assoc->target->symtree->n.sym->name
9377 : : : n->sym->name, &n->where);
9378 : 1624 : if (omp_clauses->detach
9379 : 1 : && n->sym == omp_clauses->detach->symtree->n.sym)
9380 : 1 : gfc_error ("DETACH event handle %qs in SHARED clause at %L",
9381 : : n->sym->name, &n->where);
9382 : : }
9383 : : break;
9384 : : case OMP_LIST_ALIGNED:
9385 : 256 : for (; n != NULL; n = n->next)
9386 : : {
9387 : 150 : if (!n->sym->attr.pointer
9388 : 45 : && !n->sym->attr.allocatable
9389 : 30 : && !n->sym->attr.cray_pointer
9390 : 18 : && (n->sym->ts.type != BT_DERIVED
9391 : 18 : || (n->sym->ts.u.derived->from_intmod
9392 : : != INTMOD_ISO_C_BINDING)
9393 : 18 : || (n->sym->ts.u.derived->intmod_sym_id
9394 : : != ISOCBINDING_PTR)))
9395 : 0 : gfc_error ("%qs in ALIGNED clause must be POINTER, "
9396 : : "ALLOCATABLE, Cray pointer or C_PTR at %L",
9397 : : n->sym->name, &n->where);
9398 : 150 : else if (n->expr)
9399 : : {
9400 : 147 : if (!gfc_resolve_expr (n->expr)
9401 : 147 : || n->expr->ts.type != BT_INTEGER
9402 : 146 : || n->expr->rank != 0
9403 : 146 : || n->expr->expr_type != EXPR_CONSTANT
9404 : 292 : || mpz_sgn (n->expr->value.integer) <= 0)
9405 : 4 : gfc_error ("%qs in ALIGNED clause at %L requires a scalar"
9406 : : " positive constant integer alignment "
9407 : 4 : "expression", n->sym->name, &n->where);
9408 : : }
9409 : : }
9410 : : break;
9411 : : case OMP_LIST_AFFINITY:
9412 : : case OMP_LIST_DEPEND:
9413 : : case OMP_LIST_MAP:
9414 : : case OMP_LIST_TO:
9415 : : case OMP_LIST_FROM:
9416 : : case OMP_LIST_CACHE:
9417 : 31542 : for (; n != NULL; n = n->next)
9418 : : {
9419 : 19793 : if ((list == OMP_LIST_DEPEND || list == OMP_LIST_AFFINITY)
9420 : 1994 : && n->u2.ns && !n->u2.ns->resolved)
9421 : : {
9422 : 53 : n->u2.ns->resolved = 1;
9423 : 53 : for (gfc_symbol *sym = n->u2.ns->omp_affinity_iterators;
9424 : 110 : sym; sym = sym->tlink)
9425 : : {
9426 : 57 : gfc_constructor *c;
9427 : 57 : c = gfc_constructor_first (sym->value->value.constructor);
9428 : 57 : if (!gfc_resolve_expr (c->expr)
9429 : 57 : || c->expr->ts.type != BT_INTEGER
9430 : 112 : || c->expr->rank != 0)
9431 : 2 : gfc_error ("Scalar integer expression for range begin"
9432 : 2 : " expected at %L", &c->expr->where);
9433 : 57 : c = gfc_constructor_next (c);
9434 : 57 : if (!gfc_resolve_expr (c->expr)
9435 : 57 : || c->expr->ts.type != BT_INTEGER
9436 : 112 : || c->expr->rank != 0)
9437 : 2 : gfc_error ("Scalar integer expression for range end "
9438 : 2 : "expected at %L", &c->expr->where);
9439 : 57 : c = gfc_constructor_next (c);
9440 : 57 : if (c && (!gfc_resolve_expr (c->expr)
9441 : 16 : || c->expr->ts.type != BT_INTEGER
9442 : 14 : || c->expr->rank != 0))
9443 : 2 : gfc_error ("Scalar integer expression for range step "
9444 : 2 : "expected at %L", &c->expr->where);
9445 : 55 : else if (c
9446 : 14 : && c->expr->expr_type == EXPR_CONSTANT
9447 : 12 : && mpz_cmp_si (c->expr->value.integer, 0) == 0)
9448 : 2 : gfc_error ("Nonzero range step expected at %L",
9449 : : &c->expr->where);
9450 : : }
9451 : : }
9452 : :
9453 : 1994 : if (list == OMP_LIST_DEPEND)
9454 : : {
9455 : 3191 : if (n->u.depend_doacross_op == OMP_DEPEND_SINK_FIRST
9456 : : || n->u.depend_doacross_op == OMP_DOACROSS_SINK_FIRST
9457 : 1959 : || n->u.depend_doacross_op == OMP_DOACROSS_SINK)
9458 : : {
9459 : 1232 : if (omp_clauses->doacross_source)
9460 : : {
9461 : 0 : gfc_error ("Dependence-type SINK used together with"
9462 : : " SOURCE on the same construct at %L",
9463 : : &n->where);
9464 : 0 : omp_clauses->doacross_source = false;
9465 : : }
9466 : 1232 : else if (n->expr)
9467 : : {
9468 : 571 : if (!gfc_resolve_expr (n->expr)
9469 : 571 : || n->expr->ts.type != BT_INTEGER
9470 : 1142 : || n->expr->rank != 0)
9471 : 0 : gfc_error ("SINK addend not a constant integer "
9472 : : "at %L", &n->where);
9473 : : }
9474 : 1232 : if (n->sym == NULL
9475 : 4 : && (n->expr == NULL
9476 : 3 : || mpz_cmp_si (n->expr->value.integer, -1) != 0))
9477 : 2 : gfc_error ("omp_cur_iteration at %L requires %<-1%> "
9478 : : "as logical offset", &n->where);
9479 : 1232 : continue;
9480 : : }
9481 : 727 : else if (n->u.depend_doacross_op == OMP_DEPEND_DEPOBJ
9482 : 38 : && !n->expr
9483 : 22 : && (n->sym->ts.type != BT_INTEGER
9484 : 22 : || n->sym->ts.kind
9485 : 22 : != 2 * gfc_index_integer_kind
9486 : 22 : || n->sym->attr.dimension))
9487 : 0 : gfc_error ("Locator %qs at %L in DEPEND clause of depobj "
9488 : : "type shall be a scalar integer of "
9489 : : "OMP_DEPEND_KIND kind", n->sym->name,
9490 : : &n->where);
9491 : 727 : else if (n->u.depend_doacross_op == OMP_DEPEND_DEPOBJ
9492 : 38 : && n->expr
9493 : 743 : && (!gfc_resolve_expr (n->expr)
9494 : 16 : || n->expr->ts.type != BT_INTEGER
9495 : 16 : || n->expr->ts.kind
9496 : 16 : != 2 * gfc_index_integer_kind
9497 : 16 : || n->expr->rank != 0))
9498 : 0 : gfc_error ("Locator at %L in DEPEND clause of depobj "
9499 : : "type shall be a scalar integer of "
9500 : 0 : "OMP_DEPEND_KIND kind", &n->expr->where);
9501 : : }
9502 : 18561 : gfc_ref *lastref = NULL, *lastslice = NULL;
9503 : 18561 : bool resolved = false;
9504 : 18561 : if (n->expr)
9505 : : {
9506 : 5881 : lastref = n->expr->ref;
9507 : 5881 : resolved = gfc_resolve_expr (n->expr);
9508 : :
9509 : : /* Look through component refs to find last array
9510 : : reference. */
9511 : 5881 : if (resolved)
9512 : : {
9513 : 14010 : for (gfc_ref *ref = n->expr->ref; ref; ref = ref->next)
9514 : 8147 : if (ref->type == REF_COMPONENT
9515 : : || ref->type == REF_SUBSTRING
9516 : 8147 : || ref->type == REF_INQUIRY)
9517 : : lastref = ref;
9518 : 5738 : else if (ref->type == REF_ARRAY)
9519 : : {
9520 : 11929 : for (int i = 0; i < ref->u.ar.dimen; i++)
9521 : 6191 : if (ref->u.ar.dimen_type[i] == DIMEN_RANGE)
9522 : 5404 : lastslice = ref;
9523 : :
9524 : : lastref = ref;
9525 : : }
9526 : :
9527 : : /* The "!$acc cache" directive allows rectangular
9528 : : subarrays to be specified, with some restrictions
9529 : : on the form of bounds (not implemented).
9530 : : Only raise an error here if we're really sure the
9531 : : array isn't contiguous. An expression such as
9532 : : arr(-n:n,-n:n) could be contiguous even if it looks
9533 : : like it may not be. */
9534 : 5863 : if (code->op != EXEC_OACC_UPDATE
9535 : 5081 : && list != OMP_LIST_CACHE
9536 : 5081 : && list != OMP_LIST_DEPEND
9537 : 4762 : && !gfc_is_simply_contiguous (n->expr, false, true)
9538 : 1407 : && gfc_is_not_contiguous (n->expr)
9539 : 5876 : && !(lastslice
9540 : 13 : && (lastslice->next
9541 : 3 : || lastslice->type != REF_ARRAY)))
9542 : 3 : gfc_error ("Array is not contiguous at %L",
9543 : : &n->where);
9544 : : }
9545 : : }
9546 : 18561 : if (openacc
9547 : 18561 : && list == OMP_LIST_MAP
9548 : 9562 : && (n->u.map.op == OMP_MAP_ATTACH
9549 : 9496 : || n->u.map.op == OMP_MAP_DETACH))
9550 : : {
9551 : 109 : symbol_attribute attr;
9552 : 109 : if (n->expr)
9553 : 99 : attr = gfc_expr_attr (n->expr);
9554 : : else
9555 : 10 : attr = n->sym->attr;
9556 : 109 : if (!attr.pointer && !attr.allocatable)
9557 : 7 : gfc_error ("%qs clause argument must be ALLOCATABLE or "
9558 : : "a POINTER at %L",
9559 : 7 : (n->u.map.op == OMP_MAP_ATTACH) ? "attach"
9560 : : : "detach", &n->where);
9561 : : }
9562 : 18561 : if (lastref
9563 : 12692 : || (n->expr
9564 : 12 : && (!resolved || n->expr->expr_type != EXPR_VARIABLE)))
9565 : : {
9566 : 5881 : if (!lastslice
9567 : 5881 : && lastref
9568 : 890 : && lastref->type == REF_SUBSTRING)
9569 : 11 : gfc_error ("Unexpected substring reference in %s clause "
9570 : : "at %L", name, &n->where);
9571 : 5870 : else if (!lastslice
9572 : : && lastref
9573 : 879 : && lastref->type == REF_INQUIRY)
9574 : : {
9575 : 12 : gcc_assert (lastref->u.i == INQUIRY_RE
9576 : : || lastref->u.i == INQUIRY_IM);
9577 : 12 : gfc_error ("Unexpected complex-parts designator "
9578 : : "reference in %s clause at %L",
9579 : : name, &n->where);
9580 : : }
9581 : 5858 : else if (!resolved
9582 : 5840 : || n->expr->expr_type != EXPR_VARIABLE
9583 : 5828 : || (lastslice
9584 : 4979 : && (lastslice->next
9585 : 4963 : || lastslice->type != REF_ARRAY)))
9586 : 46 : gfc_error ("%qs in %s clause at %L is not a proper "
9587 : 46 : "array section", n->sym->name, name,
9588 : : &n->where);
9589 : : else if (lastslice)
9590 : : {
9591 : : int i;
9592 : : gfc_array_ref *ar = &lastslice->u.ar;
9593 : 10364 : for (i = 0; i < ar->dimen; i++)
9594 : 5402 : if (ar->stride[i] && code->op != EXEC_OACC_UPDATE)
9595 : : {
9596 : 1 : gfc_error ("Stride should not be specified for "
9597 : : "array section in %s clause at %L",
9598 : : name, &n->where);
9599 : 1 : break;
9600 : : }
9601 : 5401 : else if (ar->dimen_type[i] != DIMEN_ELEMENT
9602 : 5401 : && ar->dimen_type[i] != DIMEN_RANGE)
9603 : : {
9604 : 0 : gfc_error ("%qs in %s clause at %L is not a "
9605 : : "proper array section",
9606 : 0 : n->sym->name, name, &n->where);
9607 : 0 : break;
9608 : : }
9609 : 5401 : else if ((list == OMP_LIST_DEPEND
9610 : : || list == OMP_LIST_AFFINITY)
9611 : 160 : && ar->start[i]
9612 : 133 : && ar->start[i]->expr_type == EXPR_CONSTANT
9613 : 97 : && ar->end[i]
9614 : 72 : && ar->end[i]->expr_type == EXPR_CONSTANT
9615 : 72 : && mpz_cmp (ar->start[i]->value.integer,
9616 : 72 : ar->end[i]->value.integer) > 0)
9617 : : {
9618 : 0 : gfc_error ("%qs in %s clause at %L is a "
9619 : : "zero size array section",
9620 : 0 : n->sym->name,
9621 : : list == OMP_LIST_DEPEND
9622 : : ? "DEPEND" : "AFFINITY", &n->where);
9623 : 0 : break;
9624 : : }
9625 : : }
9626 : : }
9627 : 12680 : else if (openacc)
9628 : : {
9629 : 5906 : if (list == OMP_LIST_MAP
9630 : 5891 : && n->u.map.op == OMP_MAP_FORCE_DEVICEPTR)
9631 : 65 : resolve_oacc_deviceptr_clause (n->sym, n->where, name);
9632 : : else
9633 : 5841 : resolve_oacc_data_clauses (n->sym, n->where, name);
9634 : : }
9635 : 6774 : else if (list != OMP_LIST_DEPEND
9636 : 6281 : && n->sym->as
9637 : 2996 : && n->sym->as->type == AS_ASSUMED_SIZE)
9638 : 5 : gfc_error ("Assumed size array %qs in %s clause at %L",
9639 : : n->sym->name, name, &n->where);
9640 : 18561 : if (list == OMP_LIST_MAP && !openacc)
9641 : 6351 : switch (code->op)
9642 : : {
9643 : 5572 : case EXEC_OMP_TARGET:
9644 : 5572 : case EXEC_OMP_TARGET_PARALLEL:
9645 : 5572 : case EXEC_OMP_TARGET_PARALLEL_DO:
9646 : 5572 : case EXEC_OMP_TARGET_PARALLEL_DO_SIMD:
9647 : 5572 : case EXEC_OMP_TARGET_PARALLEL_LOOP:
9648 : 5572 : case EXEC_OMP_TARGET_SIMD:
9649 : 5572 : case EXEC_OMP_TARGET_TEAMS:
9650 : 5572 : case EXEC_OMP_TARGET_TEAMS_DISTRIBUTE:
9651 : 5572 : case EXEC_OMP_TARGET_TEAMS_DISTRIBUTE_PARALLEL_DO:
9652 : 5572 : case EXEC_OMP_TARGET_TEAMS_DISTRIBUTE_PARALLEL_DO_SIMD:
9653 : 5572 : case EXEC_OMP_TARGET_TEAMS_DISTRIBUTE_SIMD:
9654 : 5572 : case EXEC_OMP_TARGET_TEAMS_LOOP:
9655 : 5572 : case EXEC_OMP_TARGET_DATA:
9656 : 5572 : switch (n->u.map.op)
9657 : : {
9658 : : case OMP_MAP_TO:
9659 : : case OMP_MAP_ALWAYS_TO:
9660 : : case OMP_MAP_PRESENT_TO:
9661 : : case OMP_MAP_ALWAYS_PRESENT_TO:
9662 : : case OMP_MAP_FROM:
9663 : : case OMP_MAP_ALWAYS_FROM:
9664 : : case OMP_MAP_PRESENT_FROM:
9665 : : case OMP_MAP_ALWAYS_PRESENT_FROM:
9666 : : case OMP_MAP_TOFROM:
9667 : : case OMP_MAP_ALWAYS_TOFROM:
9668 : : case OMP_MAP_PRESENT_TOFROM:
9669 : : case OMP_MAP_ALWAYS_PRESENT_TOFROM:
9670 : : case OMP_MAP_ALLOC:
9671 : : case OMP_MAP_PRESENT_ALLOC:
9672 : : break;
9673 : 2 : default:
9674 : 2 : gfc_error ("TARGET%s with map-type other than TO, "
9675 : : "FROM, TOFROM, or ALLOC on MAP clause "
9676 : : "at %L",
9677 : : code->op == EXEC_OMP_TARGET_DATA
9678 : : ? " DATA" : "", &n->where);
9679 : 2 : break;
9680 : : }
9681 : : break;
9682 : 448 : case EXEC_OMP_TARGET_ENTER_DATA:
9683 : 448 : switch (n->u.map.op)
9684 : : {
9685 : : case OMP_MAP_TO:
9686 : : case OMP_MAP_ALWAYS_TO:
9687 : : case OMP_MAP_PRESENT_TO:
9688 : : case OMP_MAP_ALWAYS_PRESENT_TO:
9689 : : case OMP_MAP_ALLOC:
9690 : : case OMP_MAP_PRESENT_ALLOC:
9691 : : break;
9692 : 58 : case OMP_MAP_TOFROM:
9693 : 58 : n->u.map.op = OMP_MAP_TO;
9694 : 58 : break;
9695 : 3 : case OMP_MAP_ALWAYS_TOFROM:
9696 : 3 : n->u.map.op = OMP_MAP_ALWAYS_TO;
9697 : 3 : break;
9698 : 2 : case OMP_MAP_PRESENT_TOFROM:
9699 : 2 : n->u.map.op = OMP_MAP_PRESENT_TO;
9700 : 2 : break;
9701 : 2 : case OMP_MAP_ALWAYS_PRESENT_TOFROM:
9702 : 2 : n->u.map.op = OMP_MAP_ALWAYS_PRESENT_TO;
9703 : 2 : break;
9704 : 2 : default:
9705 : 2 : gfc_error ("TARGET ENTER DATA with map-type other "
9706 : : "than TO, TOFROM or ALLOC on MAP clause "
9707 : : "at %L", &n->where);
9708 : 2 : break;
9709 : : }
9710 : : break;
9711 : 331 : case EXEC_OMP_TARGET_EXIT_DATA:
9712 : 331 : switch (n->u.map.op)
9713 : : {
9714 : : case OMP_MAP_FROM:
9715 : : case OMP_MAP_ALWAYS_FROM:
9716 : : case OMP_MAP_PRESENT_FROM:
9717 : : case OMP_MAP_ALWAYS_PRESENT_FROM:
9718 : : case OMP_MAP_RELEASE:
9719 : : case OMP_MAP_DELETE:
9720 : : break;
9721 : 16 : case OMP_MAP_TOFROM:
9722 : 16 : n->u.map.op = OMP_MAP_FROM;
9723 : 16 : break;
9724 : 1 : case OMP_MAP_ALWAYS_TOFROM:
9725 : 1 : n->u.map.op = OMP_MAP_ALWAYS_FROM;
9726 : 1 : break;
9727 : 0 : case OMP_MAP_PRESENT_TOFROM:
9728 : 0 : n->u.map.op = OMP_MAP_PRESENT_FROM;
9729 : 0 : break;
9730 : 0 : case OMP_MAP_ALWAYS_PRESENT_TOFROM:
9731 : 0 : n->u.map.op = OMP_MAP_ALWAYS_PRESENT_FROM;
9732 : 0 : break;
9733 : 2 : default:
9734 : 2 : gfc_error ("TARGET EXIT DATA with map-type other "
9735 : : "than FROM, TOFROM, RELEASE, or DELETE on "
9736 : : "MAP clause at %L", &n->where);
9737 : 2 : break;
9738 : : }
9739 : : break;
9740 : : default:
9741 : : break;
9742 : : }
9743 : : }
9744 : :
9745 : 11749 : if (list != OMP_LIST_DEPEND)
9746 : 28740 : for (n = omp_clauses->lists[list]; n != NULL; n = n->next)
9747 : : {
9748 : 17834 : n->sym->attr.referenced = 1;
9749 : 17834 : if (n->sym->attr.threadprivate)
9750 : 1 : gfc_error ("THREADPRIVATE object %qs in %s clause at %L",
9751 : : n->sym->name, name, &n->where);
9752 : 17834 : if (n->sym->attr.cray_pointee)
9753 : 14 : gfc_error ("Cray pointee %qs in %s clause at %L",
9754 : : n->sym->name, name, &n->where);
9755 : : }
9756 : : break;
9757 : : case OMP_LIST_IS_DEVICE_PTR:
9758 : : last = NULL;
9759 : 377 : for (n = omp_clauses->lists[list]; n != NULL; )
9760 : : {
9761 : 257 : if ((n->sym->ts.type != BT_DERIVED
9762 : 71 : || !n->sym->ts.u.derived->ts.is_iso_c
9763 : 71 : || (n->sym->ts.u.derived->intmod_sym_id
9764 : : != ISOCBINDING_PTR))
9765 : 187 : && code->op == EXEC_OMP_DISPATCH)
9766 : : /* Non-TARGET (i.e. DISPATCH) requires a C_PTR. */
9767 : 3 : gfc_error ("List item %qs in %s clause at %L must be of "
9768 : : "TYPE(C_PTR)", n->sym->name, name, &n->where);
9769 : 254 : else if (n->sym->ts.type != BT_DERIVED
9770 : 70 : || !n->sym->ts.u.derived->ts.is_iso_c
9771 : 70 : || (n->sym->ts.u.derived->intmod_sym_id
9772 : : != ISOCBINDING_PTR))
9773 : : {
9774 : : /* For TARGET, non-C_PTR are deprecated and handled as
9775 : : has_device_addr. */
9776 : 184 : gfc_omp_namelist *n2 = n;
9777 : 184 : n = n->next;
9778 : 184 : if (last)
9779 : 0 : last->next = n;
9780 : : else
9781 : 184 : omp_clauses->lists[list] = n;
9782 : 184 : n2->next = omp_clauses->lists[OMP_LIST_HAS_DEVICE_ADDR];
9783 : 184 : omp_clauses->lists[OMP_LIST_HAS_DEVICE_ADDR] = n2;
9784 : 184 : continue;
9785 : 184 : }
9786 : 73 : last = n;
9787 : 73 : n = n->next;
9788 : : }
9789 : : break;
9790 : : case OMP_LIST_HAS_DEVICE_ADDR:
9791 : : case OMP_LIST_USE_DEVICE_ADDR:
9792 : : break;
9793 : : case OMP_LIST_USE_DEVICE_PTR:
9794 : : /* Non-C_PTR are deprecated and handled as use_device_ADDR. */
9795 : : last = NULL;
9796 : 475 : for (n = omp_clauses->lists[list]; n != NULL; )
9797 : : {
9798 : 312 : gfc_omp_namelist *n2 = n;
9799 : 312 : if (n->sym->ts.type != BT_DERIVED
9800 : 18 : || !n->sym->ts.u.derived->ts.is_iso_c)
9801 : : {
9802 : 294 : n = n->next;
9803 : 294 : if (last)
9804 : 0 : last->next = n;
9805 : : else
9806 : 294 : omp_clauses->lists[list] = n;
9807 : 294 : n2->next = omp_clauses->lists[OMP_LIST_USE_DEVICE_ADDR];
9808 : 294 : omp_clauses->lists[OMP_LIST_USE_DEVICE_ADDR] = n2;
9809 : 294 : continue;
9810 : : }
9811 : 18 : last = n;
9812 : 18 : n = n->next;
9813 : : }
9814 : : break;
9815 : 39 : case OMP_LIST_USES_ALLOCATORS:
9816 : 39 : {
9817 : 39 : if (n != NULL
9818 : 39 : && n->u.memspace_sym
9819 : 13 : && (n->u.memspace_sym->attr.flavor != FL_PARAMETER
9820 : 12 : || n->u.memspace_sym->ts.type != BT_INTEGER
9821 : 12 : || n->u.memspace_sym->ts.kind != gfc_c_intptr_kind
9822 : 12 : || n->u.memspace_sym->attr.dimension
9823 : 12 : || (!startswith (n->u.memspace_sym->name, "omp_")
9824 : 0 : && !startswith (n->u.memspace_sym->name, "ompx_"))
9825 : 12 : || !endswith (n->u.memspace_sym->name, "_mem_space")))
9826 : 2 : gfc_error ("Memspace %qs at %L in USES_ALLOCATORS must be "
9827 : : "a predefined memory space",
9828 : : n->u.memspace_sym->name, &n->where);
9829 : 117 : for (; n != NULL; n = n->next)
9830 : : {
9831 : 84 : if (n->sym->ts.type != BT_INTEGER
9832 : 84 : || n->sym->ts.kind != gfc_c_intptr_kind
9833 : 83 : || n->sym->attr.dimension)
9834 : 2 : gfc_error ("Allocator %qs at %L in USES_ALLOCATORS must "
9835 : : "be a scalar integer of kind "
9836 : : "%<omp_allocator_handle_kind%>", n->sym->name,
9837 : : &n->where);
9838 : 82 : else if (n->sym->attr.flavor != FL_VARIABLE
9839 : 82 : && ((!startswith (n->sym->name, "omp_")
9840 : 0 : && !startswith (n->sym->name, "ompx_"))
9841 : 39 : || !endswith (n->sym->name, "_mem_alloc")))
9842 : 1 : gfc_error ("Allocator %qs at %L in USES_ALLOCATORS must "
9843 : : "either a variable or a predefined allocator",
9844 : : n->sym->name, &n->where);
9845 : 81 : else if ((n->u.memspace_sym || n->u2.traits_sym)
9846 : 42 : && n->sym->attr.flavor != FL_VARIABLE)
9847 : 3 : gfc_error ("A memory space or traits array may not be "
9848 : : "specified for predefined allocator %qs at %L",
9849 : : n->sym->name, &n->where);
9850 : 84 : if (n->u2.traits_sym
9851 : 37 : && (n->u2.traits_sym->attr.flavor != FL_PARAMETER
9852 : 35 : || !n->u2.traits_sym->attr.dimension
9853 : 33 : || n->u2.traits_sym->as->rank != 1
9854 : 33 : || n->u2.traits_sym->ts.type != BT_DERIVED
9855 : 31 : || strcmp (n->u2.traits_sym->ts.u.derived->name,
9856 : : "omp_alloctrait") != 0))
9857 : : {
9858 : 6 : gfc_error ("Traits array %qs in USES_ALLOCATORS %L must "
9859 : : "be a one-dimensional named constant array of "
9860 : : "type %<omp_alloctrait%>",
9861 : : n->u2.traits_sym->name, &n->where);
9862 : 6 : break;
9863 : : }
9864 : : }
9865 : : break;
9866 : : }
9867 : : default:
9868 : 34390 : for (; n != NULL; n = n->next)
9869 : : {
9870 : 20146 : if (n->sym == NULL)
9871 : : {
9872 : 26 : gcc_assert (code->op == EXEC_OMP_ALLOCATORS
9873 : : || code->op == EXEC_OMP_ALLOCATE);
9874 : 26 : continue;
9875 : : }
9876 : 20120 : bool bad = false;
9877 : 20120 : bool is_reduction = (list == OMP_LIST_REDUCTION
9878 : : || list == OMP_LIST_REDUCTION_INSCAN
9879 : : || list == OMP_LIST_REDUCTION_TASK
9880 : : || list == OMP_LIST_IN_REDUCTION
9881 : 20120 : || list == OMP_LIST_TASK_REDUCTION);
9882 : 20120 : if (list == OMP_LIST_REDUCTION_INSCAN)
9883 : : has_inscan = true;
9884 : 20048 : else if (is_reduction)
9885 : 4732 : has_notinscan = true;
9886 : 20120 : if (has_inscan && has_notinscan && is_reduction)
9887 : : {
9888 : 3 : gfc_error ("%<inscan%> and non-%<inscan%> %<reduction%> "
9889 : : "clauses on the same construct at %L",
9890 : : &n->where);
9891 : 3 : break;
9892 : : }
9893 : 20117 : if (n->sym->attr.threadprivate)
9894 : 1 : gfc_error ("THREADPRIVATE object %qs in %s clause at %L",
9895 : : n->sym->name, name, &n->where);
9896 : 20117 : if (n->sym->attr.cray_pointee)
9897 : 14 : gfc_error ("Cray pointee %qs in %s clause at %L",
9898 : : n->sym->name, name, &n->where);
9899 : 20117 : if (n->sym->attr.associate_var)
9900 : 22 : gfc_error ("Associate name %qs in %s clause at %L",
9901 : 22 : n->sym->attr.select_type_temporary
9902 : 4 : ? n->sym->assoc->target->symtree->n.sym->name
9903 : : : n->sym->name, name, &n->where);
9904 : 20117 : if (list != OMP_LIST_PRIVATE && is_reduction)
9905 : : {
9906 : 4801 : if (n->sym->attr.proc_pointer)
9907 : 1 : gfc_error ("Procedure pointer %qs in %s clause at %L",
9908 : : n->sym->name, name, &n->where);
9909 : 4801 : if (n->sym->attr.pointer)
9910 : 3 : gfc_error ("POINTER object %qs in %s clause at %L",
9911 : : n->sym->name, name, &n->where);
9912 : 4801 : if (n->sym->attr.cray_pointer)
9913 : 5 : gfc_error ("Cray pointer %qs in %s clause at %L",
9914 : : n->sym->name, name, &n->where);
9915 : : }
9916 : 20117 : if (code
9917 : 20117 : && (oacc_is_loop (code)
9918 : : || code->op == EXEC_OACC_PARALLEL
9919 : : || code->op == EXEC_OACC_SERIAL))
9920 : 8737 : check_array_not_assumed (n->sym, n->where, name);
9921 : 11380 : else if (list != OMP_LIST_UNIFORM
9922 : 11263 : && n->sym->as && n->sym->as->type == AS_ASSUMED_SIZE)
9923 : 2 : gfc_error ("Assumed size array %qs in %s clause at %L",
9924 : : n->sym->name, name, &n->where);
9925 : 20117 : if (n->sym->attr.in_namelist && !is_reduction)
9926 : 0 : gfc_error ("Variable %qs in %s clause is used in "
9927 : : "NAMELIST statement at %L",
9928 : : n->sym->name, name, &n->where);
9929 : 20117 : if (n->sym->attr.pointer && n->sym->attr.intent == INTENT_IN)
9930 : 3 : switch (list)
9931 : : {
9932 : 3 : case OMP_LIST_PRIVATE:
9933 : 3 : case OMP_LIST_LASTPRIVATE:
9934 : 3 : case OMP_LIST_LINEAR:
9935 : : /* case OMP_LIST_REDUCTION: */
9936 : 3 : gfc_error ("INTENT(IN) POINTER %qs in %s clause at %L",
9937 : : n->sym->name, name, &n->where);
9938 : 3 : break;
9939 : : default:
9940 : : break;
9941 : : }
9942 : 20117 : if (omp_clauses->detach
9943 : 3 : && (list == OMP_LIST_PRIVATE
9944 : : || list == OMP_LIST_FIRSTPRIVATE
9945 : : || list == OMP_LIST_LASTPRIVATE)
9946 : 3 : && n->sym == omp_clauses->detach->symtree->n.sym)
9947 : 1 : gfc_error ("DETACH event handle %qs in %s clause at %L",
9948 : : n->sym->name, name, &n->where);
9949 : :
9950 : 20117 : if (!openacc
9951 : 20117 : && (list == OMP_LIST_PRIVATE
9952 : 20117 : || list == OMP_LIST_FIRSTPRIVATE)
9953 : 4535 : && ((n->sym->ts.type == BT_DERIVED
9954 : 146 : && n->sym->ts.u.derived->attr.alloc_comp)
9955 : 4425 : || n->sym->ts.type == BT_CLASS))
9956 : 158 : switch (code->op)
9957 : : {
9958 : 8 : case EXEC_OMP_TARGET:
9959 : 8 : case EXEC_OMP_TARGET_PARALLEL:
9960 : 8 : case EXEC_OMP_TARGET_PARALLEL_DO:
9961 : 8 : case EXEC_OMP_TARGET_PARALLEL_DO_SIMD:
9962 : 8 : case EXEC_OMP_TARGET_PARALLEL_LOOP:
9963 : 8 : case EXEC_OMP_TARGET_SIMD:
9964 : 8 : case EXEC_OMP_TARGET_TEAMS:
9965 : 8 : case EXEC_OMP_TARGET_TEAMS_DISTRIBUTE:
9966 : 8 : case EXEC_OMP_TARGET_TEAMS_DISTRIBUTE_PARALLEL_DO:
9967 : 8 : case EXEC_OMP_TARGET_TEAMS_DISTRIBUTE_PARALLEL_DO_SIMD:
9968 : 8 : case EXEC_OMP_TARGET_TEAMS_DISTRIBUTE_SIMD:
9969 : 8 : case EXEC_OMP_TARGET_TEAMS_LOOP:
9970 : 8 : if (n->sym->ts.type == BT_DERIVED
9971 : 2 : && n->sym->ts.u.derived->attr.alloc_comp)
9972 : 3 : gfc_error ("Sorry, list item %qs at %L with allocatable"
9973 : : " components is not yet supported in %s "
9974 : : "clause", n->sym->name, &n->where,
9975 : : list == OMP_LIST_PRIVATE ? "PRIVATE"
9976 : : : "FIRSTPRIVATE");
9977 : : else
9978 : 9 : gfc_error ("Polymorphic list item %qs at %L in %s "
9979 : : "clause has unspecified behavior and "
9980 : : "unsupported", n->sym->name, &n->where,
9981 : : list == OMP_LIST_PRIVATE ? "PRIVATE"
9982 : : : "FIRSTPRIVATE");
9983 : : break;
9984 : : default:
9985 : : break;
9986 : : }
9987 : :
9988 : 20117 : switch (list)
9989 : : {
9990 : 103 : case OMP_LIST_REDUCTION_TASK:
9991 : 103 : if (code
9992 : 103 : && (code->op == EXEC_OMP_LOOP
9993 : : || code->op == EXEC_OMP_TASKLOOP
9994 : : || code->op == EXEC_OMP_TASKLOOP_SIMD
9995 : : || code->op == EXEC_OMP_MASKED_TASKLOOP
9996 : : || code->op == EXEC_OMP_MASKED_TASKLOOP_SIMD
9997 : : || code->op == EXEC_OMP_MASTER_TASKLOOP
9998 : : || code->op == EXEC_OMP_MASTER_TASKLOOP_SIMD
9999 : : || code->op == EXEC_OMP_PARALLEL_LOOP
10000 : : || code->op == EXEC_OMP_PARALLEL_MASKED_TASKLOOP
10001 : : || code->op == EXEC_OMP_PARALLEL_MASKED_TASKLOOP_SIMD
10002 : : || code->op == EXEC_OMP_PARALLEL_MASTER_TASKLOOP
10003 : : || code->op == EXEC_OMP_PARALLEL_MASTER_TASKLOOP_SIMD
10004 : : || code->op == EXEC_OMP_TARGET_PARALLEL_LOOP
10005 : : || code->op == EXEC_OMP_TARGET_TEAMS_LOOP
10006 : : || code->op == EXEC_OMP_TEAMS
10007 : : || code->op == EXEC_OMP_TEAMS_DISTRIBUTE
10008 : : || code->op == EXEC_OMP_TEAMS_LOOP))
10009 : : {
10010 : 17 : gfc_error ("Only DEFAULT permitted as reduction-"
10011 : : "modifier in REDUCTION clause at %L",
10012 : : &n->where);
10013 : 17 : break;
10014 : : }
10015 : 4784 : gcc_fallthrough ();
10016 : 4784 : case OMP_LIST_REDUCTION:
10017 : 4784 : case OMP_LIST_IN_REDUCTION:
10018 : 4784 : case OMP_LIST_TASK_REDUCTION:
10019 : 4784 : case OMP_LIST_REDUCTION_INSCAN:
10020 : 4784 : switch (n->u.reduction_op)
10021 : : {
10022 : 2650 : case OMP_REDUCTION_PLUS:
10023 : 2650 : case OMP_REDUCTION_TIMES:
10024 : 2650 : case OMP_REDUCTION_MINUS:
10025 : 2650 : if (!gfc_numeric_ts (&n->sym->ts))
10026 : : bad = true;
10027 : : break;
10028 : 1112 : case OMP_REDUCTION_AND:
10029 : 1112 : case OMP_REDUCTION_OR:
10030 : 1112 : case OMP_REDUCTION_EQV:
10031 : 1112 : case OMP_REDUCTION_NEQV:
10032 : 1112 : if (n->sym->ts.type != BT_LOGICAL)
10033 : : bad = true;
10034 : : break;
10035 : 480 : case OMP_REDUCTION_MAX:
10036 : 480 : case OMP_REDUCTION_MIN:
10037 : 480 : if (n->sym->ts.type != BT_INTEGER
10038 : 212 : && n->sym->ts.type != BT_REAL)
10039 : : bad = true;
10040 : : break;
10041 : 192 : case OMP_REDUCTION_IAND:
10042 : 192 : case OMP_REDUCTION_IOR:
10043 : 192 : case OMP_REDUCTION_IEOR:
10044 : 192 : if (n->sym->ts.type != BT_INTEGER)
10045 : : bad = true;
10046 : : break;
10047 : : case OMP_REDUCTION_USER:
10048 : : bad = true;
10049 : : break;
10050 : : default:
10051 : : break;
10052 : : }
10053 : : if (!bad)
10054 : 4213 : n->u2.udr = NULL;
10055 : : else
10056 : : {
10057 : 571 : const char *udr_name = NULL;
10058 : 571 : if (n->u2.udr)
10059 : : {
10060 : 467 : udr_name = n->u2.udr->udr->name;
10061 : 467 : n->u2.udr->udr
10062 : 934 : = gfc_find_omp_udr (NULL, udr_name,
10063 : 467 : &n->sym->ts);
10064 : 467 : if (n->u2.udr->udr == NULL)
10065 : : {
10066 : 0 : free (n->u2.udr);
10067 : 0 : n->u2.udr = NULL;
10068 : : }
10069 : : }
10070 : 571 : if (n->u2.udr == NULL)
10071 : : {
10072 : 104 : if (udr_name == NULL)
10073 : 104 : switch (n->u.reduction_op)
10074 : : {
10075 : 50 : case OMP_REDUCTION_PLUS:
10076 : 50 : case OMP_REDUCTION_TIMES:
10077 : 50 : case OMP_REDUCTION_MINUS:
10078 : 50 : case OMP_REDUCTION_AND:
10079 : 50 : case OMP_REDUCTION_OR:
10080 : 50 : case OMP_REDUCTION_EQV:
10081 : 50 : case OMP_REDUCTION_NEQV:
10082 : 50 : udr_name = gfc_op2string ((gfc_intrinsic_op)
10083 : : n->u.reduction_op);
10084 : 50 : break;
10085 : : case OMP_REDUCTION_MAX:
10086 : : udr_name = "max";
10087 : : break;
10088 : 9 : case OMP_REDUCTION_MIN:
10089 : 9 : udr_name = "min";
10090 : 9 : break;
10091 : 12 : case OMP_REDUCTION_IAND:
10092 : 12 : udr_name = "iand";
10093 : 12 : break;
10094 : 12 : case OMP_REDUCTION_IOR:
10095 : 12 : udr_name = "ior";
10096 : 12 : break;
10097 : 9 : case OMP_REDUCTION_IEOR:
10098 : 9 : udr_name = "ieor";
10099 : 9 : break;
10100 : 0 : default:
10101 : 0 : gcc_unreachable ();
10102 : : }
10103 : 104 : gfc_error ("!$OMP DECLARE REDUCTION %s not found "
10104 : : "for type %s at %L", udr_name,
10105 : 104 : gfc_typename (&n->sym->ts), &n->where);
10106 : : }
10107 : : else
10108 : : {
10109 : 467 : gfc_omp_udr *udr = n->u2.udr->udr;
10110 : 467 : n->u.reduction_op = OMP_REDUCTION_USER;
10111 : 467 : n->u2.udr->combiner
10112 : 934 : = resolve_omp_udr_clause (n, udr->combiner_ns,
10113 : 467 : udr->omp_out,
10114 : 467 : udr->omp_in);
10115 : 467 : if (udr->initializer_ns)
10116 : 330 : n->u2.udr->initializer
10117 : 330 : = resolve_omp_udr_clause (n,
10118 : : udr->initializer_ns,
10119 : 330 : udr->omp_priv,
10120 : 330 : udr->omp_orig);
10121 : : }
10122 : : }
10123 : : break;
10124 : 873 : case OMP_LIST_LINEAR:
10125 : 873 : if (code
10126 : 726 : && n->u.linear.op != OMP_LINEAR_DEFAULT
10127 : 23 : && n->u.linear.op != linear_op)
10128 : : {
10129 : 23 : if (n->u.linear.old_modifier)
10130 : : {
10131 : 9 : gfc_error ("LINEAR clause modifier used on DO or "
10132 : : "SIMD construct at %L", &n->where);
10133 : 9 : linear_op = n->u.linear.op;
10134 : : }
10135 : 14 : else if (n->u.linear.op != OMP_LINEAR_VAL)
10136 : : {
10137 : 6 : gfc_error ("LINEAR clause modifier other than VAL "
10138 : : "used on DO or SIMD construct at %L",
10139 : : &n->where);
10140 : 6 : linear_op = n->u.linear.op;
10141 : : }
10142 : : }
10143 : 850 : else if (n->u.linear.op != OMP_LINEAR_REF
10144 : 800 : && n->sym->ts.type != BT_INTEGER)
10145 : 1 : gfc_error ("LINEAR variable %qs must be INTEGER "
10146 : : "at %L", n->sym->name, &n->where);
10147 : 849 : else if ((n->u.linear.op == OMP_LINEAR_REF
10148 : 799 : || n->u.linear.op == OMP_LINEAR_UVAL)
10149 : 61 : && n->sym->attr.value)
10150 : 0 : gfc_error ("LINEAR dummy argument %qs with VALUE "
10151 : : "attribute with %s modifier at %L",
10152 : : n->sym->name,
10153 : : n->u.linear.op == OMP_LINEAR_REF
10154 : : ? "REF" : "UVAL", &n->where);
10155 : 849 : else if (n->expr)
10156 : : {
10157 : 830 : gfc_expr *expr = n->expr;
10158 : 830 : if (!gfc_resolve_expr (expr)
10159 : 830 : || expr->ts.type != BT_INTEGER
10160 : 1660 : || expr->rank != 0)
10161 : 0 : gfc_error ("%qs in LINEAR clause at %L requires "
10162 : : "a scalar integer linear-step expression",
10163 : 0 : n->sym->name, &n->where);
10164 : 830 : else if (!code && expr->expr_type != EXPR_CONSTANT)
10165 : : {
10166 : 11 : if (expr->expr_type == EXPR_VARIABLE
10167 : 7 : && expr->symtree->n.sym->attr.dummy
10168 : 6 : && expr->symtree->n.sym->ns == ns)
10169 : : {
10170 : 6 : gfc_omp_namelist *n2;
10171 : 6 : for (n2 = omp_clauses->lists[OMP_LIST_UNIFORM];
10172 : 6 : n2; n2 = n2->next)
10173 : 6 : if (n2->sym == expr->symtree->n.sym)
10174 : : break;
10175 : 6 : if (n2)
10176 : : break;
10177 : : }
10178 : 5 : gfc_error ("%qs in LINEAR clause at %L requires "
10179 : : "a constant integer linear-step "
10180 : : "expression or dummy argument "
10181 : : "specified in UNIFORM clause",
10182 : 5 : n->sym->name, &n->where);
10183 : : }
10184 : : }
10185 : : break;
10186 : : /* Workaround for PR middle-end/26316, nothing really needs
10187 : : to be done here for OMP_LIST_PRIVATE. */
10188 : 9358 : case OMP_LIST_PRIVATE:
10189 : 9358 : gcc_assert (code && code->op != EXEC_NOP);
10190 : : break;
10191 : 98 : case OMP_LIST_USE_DEVICE:
10192 : 98 : if (n->sym->attr.allocatable
10193 : 98 : || (n->sym->ts.type == BT_CLASS && CLASS_DATA (n->sym)
10194 : 0 : && CLASS_DATA (n->sym)->attr.allocatable))
10195 : 0 : gfc_error ("ALLOCATABLE object %qs in %s clause at %L",
10196 : : n->sym->name, name, &n->where);
10197 : 98 : if (n->sym->ts.type == BT_CLASS
10198 : 0 : && CLASS_DATA (n->sym)
10199 : 0 : && CLASS_DATA (n->sym)->attr.class_pointer)
10200 : 0 : gfc_error ("POINTER object %qs of polymorphic type in "
10201 : : "%s clause at %L", n->sym->name, name,
10202 : : &n->where);
10203 : 98 : if (n->sym->attr.cray_pointer)
10204 : 2 : gfc_error ("Cray pointer object %qs in %s clause at %L",
10205 : : n->sym->name, name, &n->where);
10206 : 96 : else if (n->sym->attr.cray_pointee)
10207 : 2 : gfc_error ("Cray pointee object %qs in %s clause at %L",
10208 : : n->sym->name, name, &n->where);
10209 : 94 : else if (n->sym->attr.flavor == FL_VARIABLE
10210 : 93 : && !n->sym->as
10211 : 54 : && !n->sym->attr.pointer)
10212 : 13 : gfc_error ("%s clause variable %qs at %L is neither "
10213 : : "a POINTER nor an array", name,
10214 : : n->sym->name, &n->where);
10215 : : /* FALLTHRU */
10216 : 98 : case OMP_LIST_DEVICE_RESIDENT:
10217 : 98 : check_symbol_not_pointer (n->sym, n->where, name);
10218 : 98 : check_array_not_assumed (n->sym, n->where, name);
10219 : 98 : break;
10220 : : default:
10221 : : break;
10222 : : }
10223 : : }
10224 : : break;
10225 : : }
10226 : : }
10227 : : /* OpenMP 5.1: use_device_ptr acts like use_device_addr, except for
10228 : : type(c_ptr). */
10229 : 31920 : if (omp_clauses->lists[OMP_LIST_USE_DEVICE_PTR])
10230 : : {
10231 : 9 : gfc_omp_namelist *n_prev, *n_next, *n_addr;
10232 : 9 : n_addr = omp_clauses->lists[OMP_LIST_USE_DEVICE_ADDR];
10233 : 28 : for (; n_addr && n_addr->next; n_addr = n_addr->next)
10234 : : ;
10235 : : n_prev = NULL;
10236 : : n = omp_clauses->lists[OMP_LIST_USE_DEVICE_PTR];
10237 : 27 : while (n)
10238 : : {
10239 : 18 : n_next = n->next;
10240 : 18 : if (n->sym->ts.type != BT_DERIVED
10241 : 18 : || n->sym->ts.u.derived->ts.f90_type != BT_VOID)
10242 : : {
10243 : 0 : n->next = NULL;
10244 : 0 : if (n_addr)
10245 : 0 : n_addr->next = n;
10246 : : else
10247 : 0 : omp_clauses->lists[OMP_LIST_USE_DEVICE_ADDR] = n;
10248 : 0 : n_addr = n;
10249 : 0 : if (n_prev)
10250 : 0 : n_prev->next = n_next;
10251 : : else
10252 : 0 : omp_clauses->lists[OMP_LIST_USE_DEVICE_PTR] = n_next;
10253 : : }
10254 : : else
10255 : : n_prev = n;
10256 : : n = n_next;
10257 : : }
10258 : : }
10259 : 31920 : if (omp_clauses->safelen_expr)
10260 : 93 : resolve_positive_int_expr (omp_clauses->safelen_expr, "SAFELEN");
10261 : 31920 : if (omp_clauses->simdlen_expr)
10262 : 123 : resolve_positive_int_expr (omp_clauses->simdlen_expr, "SIMDLEN");
10263 : 31920 : if (omp_clauses->num_teams_lower)
10264 : 21 : resolve_positive_int_expr (omp_clauses->num_teams_lower, "NUM_TEAMS");
10265 : 31920 : if (omp_clauses->num_teams_upper)
10266 : 127 : resolve_positive_int_expr (omp_clauses->num_teams_upper, "NUM_TEAMS");
10267 : 31920 : if (omp_clauses->num_teams_lower
10268 : 21 : && omp_clauses->num_teams_lower->expr_type == EXPR_CONSTANT
10269 : 7 : && omp_clauses->num_teams_upper->expr_type == EXPR_CONSTANT
10270 : 7 : && mpz_cmp (omp_clauses->num_teams_lower->value.integer,
10271 : 7 : omp_clauses->num_teams_upper->value.integer) > 0)
10272 : 2 : gfc_warning (OPT_Wopenmp, "NUM_TEAMS lower bound at %L larger than upper "
10273 : : "bound at %L", &omp_clauses->num_teams_lower->where,
10274 : : &omp_clauses->num_teams_upper->where);
10275 : 31920 : if (omp_clauses->device)
10276 : 315 : resolve_scalar_int_expr (omp_clauses->device, "DEVICE");
10277 : 31920 : if (omp_clauses->filter)
10278 : 42 : resolve_nonnegative_int_expr (omp_clauses->filter, "FILTER");
10279 : 31920 : if (omp_clauses->hint)
10280 : : {
10281 : 42 : resolve_scalar_int_expr (omp_clauses->hint, "HINT");
10282 : 42 : if (omp_clauses->hint->ts.type != BT_INTEGER
10283 : 40 : || omp_clauses->hint->expr_type != EXPR_CONSTANT
10284 : 38 : || mpz_sgn (omp_clauses->hint->value.integer) < 0)
10285 : 5 : gfc_error ("Value of HINT clause at %L shall be a valid "
10286 : : "constant hint expression", &omp_clauses->hint->where);
10287 : : }
10288 : 31920 : if (omp_clauses->priority)
10289 : 34 : resolve_nonnegative_int_expr (omp_clauses->priority, "PRIORITY");
10290 : 31920 : if (omp_clauses->dist_chunk_size)
10291 : : {
10292 : 83 : gfc_expr *expr = omp_clauses->dist_chunk_size;
10293 : 83 : if (!gfc_resolve_expr (expr)
10294 : 83 : || expr->ts.type != BT_INTEGER || expr->rank != 0)
10295 : 0 : gfc_error ("DIST_SCHEDULE clause's chunk_size at %L requires "
10296 : : "a scalar INTEGER expression", &expr->where);
10297 : : }
10298 : 31920 : if (omp_clauses->thread_limit)
10299 : 72 : resolve_positive_int_expr (omp_clauses->thread_limit, "THREAD_LIMIT");
10300 : 31920 : if (omp_clauses->grainsize)
10301 : 34 : resolve_positive_int_expr (omp_clauses->grainsize, "GRAINSIZE");
10302 : 31920 : if (omp_clauses->num_tasks)
10303 : 26 : resolve_positive_int_expr (omp_clauses->num_tasks, "NUM_TASKS");
10304 : 31920 : if (omp_clauses->grainsize && omp_clauses->num_tasks)
10305 : 1 : gfc_error ("%<GRAINSIZE%> clause at %L must not be used together with "
10306 : : "%<NUM_TASKS%> clause", &omp_clauses->grainsize->where);
10307 : 31920 : if (omp_clauses->lists[OMP_LIST_REDUCTION] && omp_clauses->nogroup)
10308 : 1 : gfc_error ("%<REDUCTION%> clause at %L must not be used together with "
10309 : : "%<NOGROUP%> clause",
10310 : : &omp_clauses->lists[OMP_LIST_REDUCTION]->where);
10311 : 31920 : if (omp_clauses->full && omp_clauses->partial)
10312 : 0 : gfc_error ("%<FULL%> clause at %C must not be used together with "
10313 : : "%<PARTIAL%> clause");
10314 : 31920 : if (omp_clauses->async)
10315 : 610 : if (omp_clauses->async_expr)
10316 : 610 : resolve_scalar_int_expr (omp_clauses->async_expr, "ASYNC");
10317 : 31920 : if (omp_clauses->num_gangs_expr)
10318 : 682 : resolve_positive_int_expr (omp_clauses->num_gangs_expr, "NUM_GANGS");
10319 : 31920 : if (omp_clauses->num_workers_expr)
10320 : 599 : resolve_positive_int_expr (omp_clauses->num_workers_expr, "NUM_WORKERS");
10321 : 31920 : if (omp_clauses->vector_length_expr)
10322 : 569 : resolve_positive_int_expr (omp_clauses->vector_length_expr,
10323 : : "VECTOR_LENGTH");
10324 : 31920 : if (omp_clauses->gang_num_expr)
10325 : 114 : resolve_positive_int_expr (omp_clauses->gang_num_expr, "GANG");
10326 : 31920 : if (omp_clauses->gang_static_expr)
10327 : 94 : resolve_positive_int_expr (omp_clauses->gang_static_expr, "GANG");
10328 : 31920 : if (omp_clauses->worker_expr)
10329 : 101 : resolve_positive_int_expr (omp_clauses->worker_expr, "WORKER");
10330 : 31920 : if (omp_clauses->vector_expr)
10331 : 132 : resolve_positive_int_expr (omp_clauses->vector_expr, "VECTOR");
10332 : 32259 : for (el = omp_clauses->wait_list; el; el = el->next)
10333 : 339 : resolve_scalar_int_expr (el->expr, "WAIT");
10334 : 31920 : if (omp_clauses->collapse && omp_clauses->tile_list)
10335 : 4 : gfc_error ("Incompatible use of TILE and COLLAPSE at %L", &code->loc);
10336 : 31920 : if (omp_clauses->message)
10337 : : {
10338 : 45 : gfc_expr *expr = omp_clauses->message;
10339 : 45 : if (!gfc_resolve_expr (expr)
10340 : 45 : || expr->ts.kind != gfc_default_character_kind
10341 : 87 : || expr->ts.type != BT_CHARACTER || expr->rank != 0)
10342 : 4 : gfc_error ("MESSAGE clause at %L requires a scalar default-kind "
10343 : : "CHARACTER expression", &expr->where);
10344 : : }
10345 : 31920 : if (!openacc
10346 : 31920 : && code
10347 : 19085 : && omp_clauses->lists[OMP_LIST_MAP] == NULL
10348 : 15757 : && omp_clauses->lists[OMP_LIST_USE_DEVICE_PTR] == NULL
10349 : 15754 : && omp_clauses->lists[OMP_LIST_USE_DEVICE_ADDR] == NULL)
10350 : : {
10351 : 15731 : const char *p = NULL;
10352 : 15731 : switch (code->op)
10353 : : {
10354 : 1 : case EXEC_OMP_TARGET_ENTER_DATA: p = "TARGET ENTER DATA"; break;
10355 : 1 : case EXEC_OMP_TARGET_EXIT_DATA: p = "TARGET EXIT DATA"; break;
10356 : : default: break;
10357 : : }
10358 : 15731 : if (code->op == EXEC_OMP_TARGET_DATA)
10359 : 1 : gfc_error ("TARGET DATA must contain at least one MAP, USE_DEVICE_PTR, "
10360 : : "or USE_DEVICE_ADDR clause at %L", &code->loc);
10361 : 15730 : else if (p)
10362 : 2 : gfc_error ("%s must contain at least one MAP clause at %L",
10363 : : p, &code->loc);
10364 : : }
10365 : 31920 : if (omp_clauses->sizes_list)
10366 : : {
10367 : : gfc_expr_list *el;
10368 : 572 : for (el = omp_clauses->sizes_list; el; el = el->next)
10369 : : {
10370 : 377 : resolve_scalar_int_expr (el->expr, "SIZES");
10371 : 377 : if (el->expr->expr_type != EXPR_CONSTANT)
10372 : 1 : gfc_error ("SIZES requires constant expression at %L",
10373 : : &el->expr->where);
10374 : 376 : else if (el->expr->expr_type == EXPR_CONSTANT
10375 : 376 : && el->expr->ts.type == BT_INTEGER
10376 : 376 : && mpz_sgn (el->expr->value.integer) <= 0)
10377 : 2 : gfc_error ("INTEGER expression of %s clause at %L must be "
10378 : : "positive", "SIZES", &el->expr->where);
10379 : : }
10380 : : }
10381 : :
10382 : 31920 : if (!openacc && omp_clauses->detach)
10383 : : {
10384 : 125 : if (!gfc_resolve_expr (omp_clauses->detach)
10385 : 125 : || omp_clauses->detach->ts.type != BT_INTEGER
10386 : 124 : || omp_clauses->detach->ts.kind != gfc_c_intptr_kind
10387 : 248 : || omp_clauses->detach->rank != 0)
10388 : 3 : gfc_error ("%qs at %L should be a scalar of type "
10389 : : "integer(kind=omp_event_handle_kind)",
10390 : 3 : omp_clauses->detach->symtree->n.sym->name,
10391 : 3 : &omp_clauses->detach->where);
10392 : 122 : else if (omp_clauses->detach->symtree->n.sym->attr.dimension > 0)
10393 : 1 : gfc_error ("The event handle at %L must not be an array element",
10394 : : &omp_clauses->detach->where);
10395 : 121 : else if (omp_clauses->detach->symtree->n.sym->ts.type == BT_DERIVED
10396 : 120 : || omp_clauses->detach->symtree->n.sym->ts.type == BT_CLASS)
10397 : 1 : gfc_error ("The event handle at %L must not be part of "
10398 : : "a derived type or class", &omp_clauses->detach->where);
10399 : :
10400 : 125 : if (omp_clauses->mergeable)
10401 : 2 : gfc_error ("%<DETACH%> clause at %L must not be used together with "
10402 : 2 : "%<MERGEABLE%> clause", &omp_clauses->detach->where);
10403 : : }
10404 : :
10405 : 12617 : if (openacc
10406 : 12617 : && code->op == EXEC_OACC_HOST_DATA
10407 : 60 : && omp_clauses->lists[OMP_LIST_USE_DEVICE] == NULL)
10408 : 1 : gfc_error ("%<host_data%> construct at %L requires %<use_device%> clause",
10409 : : &code->loc);
10410 : :
10411 : 31920 : if (omp_clauses->assume)
10412 : 16 : gfc_resolve_omp_assumptions (omp_clauses->assume);
10413 : : }
10414 : :
10415 : :
10416 : : /* Return true if SYM is ever referenced in EXPR except in the SE node. */
10417 : :
10418 : : static bool
10419 : 4991 : expr_references_sym (gfc_expr *e, gfc_symbol *s, gfc_expr *se)
10420 : : {
10421 : 6617 : gfc_actual_arglist *arg;
10422 : 6617 : if (e == NULL || e == se)
10423 : : return false;
10424 : 5366 : switch (e->expr_type)
10425 : : {
10426 : 3120 : case EXPR_CONSTANT:
10427 : 3120 : case EXPR_NULL:
10428 : 3120 : case EXPR_VARIABLE:
10429 : 3120 : case EXPR_STRUCTURE:
10430 : 3120 : case EXPR_ARRAY:
10431 : 3120 : if (e->symtree != NULL
10432 : 1152 : && e->symtree->n.sym == s)
10433 : : return true;
10434 : : return false;
10435 : 0 : case EXPR_SUBSTRING:
10436 : 0 : if (e->ref != NULL
10437 : 0 : && (expr_references_sym (e->ref->u.ss.start, s, se)
10438 : 0 : || expr_references_sym (e->ref->u.ss.end, s, se)))
10439 : 0 : return true;
10440 : : return false;
10441 : 1735 : case EXPR_OP:
10442 : 1735 : if (expr_references_sym (e->value.op.op2, s, se))
10443 : : return true;
10444 : 1626 : return expr_references_sym (e->value.op.op1, s, se);
10445 : 511 : case EXPR_FUNCTION:
10446 : 896 : for (arg = e->value.function.actual; arg; arg = arg->next)
10447 : 586 : if (expr_references_sym (arg->expr, s, se))
10448 : : return true;
10449 : : return false;
10450 : 0 : default:
10451 : 0 : gcc_unreachable ();
10452 : : }
10453 : : }
10454 : :
10455 : :
10456 : : /* If EXPR is a conversion function that widens the type
10457 : : if WIDENING is true or narrows the type if NARROW is true,
10458 : : return the inner expression, otherwise return NULL. */
10459 : :
10460 : : static gfc_expr *
10461 : 5911 : is_conversion (gfc_expr *expr, bool narrowing, bool widening)
10462 : : {
10463 : 5911 : gfc_typespec *ts1, *ts2;
10464 : :
10465 : 5911 : if (expr->expr_type != EXPR_FUNCTION
10466 : 917 : || expr->value.function.isym == NULL
10467 : 894 : || expr->value.function.esym != NULL
10468 : 894 : || expr->value.function.isym->id != GFC_ISYM_CONVERSION
10469 : 388 : || (!narrowing && !widening))
10470 : : return NULL;
10471 : :
10472 : 388 : if (narrowing && widening)
10473 : 267 : return expr->value.function.actual->expr;
10474 : :
10475 : 121 : if (widening)
10476 : : {
10477 : 121 : ts1 = &expr->ts;
10478 : 121 : ts2 = &expr->value.function.actual->expr->ts;
10479 : : }
10480 : : else
10481 : : {
10482 : 0 : ts1 = &expr->value.function.actual->expr->ts;
10483 : 0 : ts2 = &expr->ts;
10484 : : }
10485 : :
10486 : 121 : if (ts1->type > ts2->type
10487 : 49 : || (ts1->type == ts2->type && ts1->kind > ts2->kind))
10488 : 121 : return expr->value.function.actual->expr;
10489 : :
10490 : : return NULL;
10491 : : }
10492 : :
10493 : : static bool
10494 : 6855 : is_scalar_intrinsic_expr (gfc_expr *expr, bool must_be_var, bool conv_ok)
10495 : : {
10496 : 6855 : if (must_be_var
10497 : 4020 : && (expr->expr_type != EXPR_VARIABLE || !expr->symtree))
10498 : : {
10499 : 37 : if (!conv_ok)
10500 : : return false;
10501 : 37 : gfc_expr *conv = is_conversion (expr, true, true);
10502 : 37 : if (!conv)
10503 : : return false;
10504 : 36 : if (conv->expr_type != EXPR_VARIABLE || !conv->symtree)
10505 : : return false;
10506 : : }
10507 : 6852 : return (expr->rank == 0
10508 : 6848 : && !gfc_is_coindexed (expr)
10509 : 13700 : && (expr->ts.type == BT_INTEGER
10510 : : || expr->ts.type == BT_REAL
10511 : : || expr->ts.type == BT_COMPLEX
10512 : : || expr->ts.type == BT_LOGICAL));
10513 : : }
10514 : :
10515 : : static void
10516 : 2697 : resolve_omp_atomic (gfc_code *code)
10517 : : {
10518 : 2697 : gfc_code *atomic_code = code->block;
10519 : 2697 : gfc_symbol *var;
10520 : 2697 : gfc_expr *stmt_expr2, *capt_expr2;
10521 : 2697 : gfc_omp_atomic_op aop
10522 : 2697 : = (gfc_omp_atomic_op) (atomic_code->ext.omp_clauses->atomic_op
10523 : : & GFC_OMP_ATOMIC_MASK);
10524 : 2697 : gfc_code *stmt = NULL, *capture_stmt = NULL, *tailing_stmt = NULL;
10525 : 2697 : gfc_expr *comp_cond = NULL;
10526 : 2697 : locus *loc = NULL;
10527 : :
10528 : 2697 : code = code->block->next;
10529 : : /* resolve_blocks asserts this is initially EXEC_ASSIGN or EXEC_IF
10530 : : If it changed to EXEC_NOP, assume an error has been emitted already. */
10531 : 2697 : if (code->op == EXEC_NOP)
10532 : : return;
10533 : :
10534 : 2696 : if (atomic_code->ext.omp_clauses->compare
10535 : 156 : && atomic_code->ext.omp_clauses->capture)
10536 : : {
10537 : : /* Must be either "if (x == e) then; x = d; else; v = x; end if"
10538 : : or "v = expr" followed/preceded by
10539 : : "if (x == e) then; x = d; end if" or "if (x == e) x = d". */
10540 : 103 : gfc_code *next = code;
10541 : 103 : if (code->op == EXEC_ASSIGN)
10542 : : {
10543 : 19 : capture_stmt = code;
10544 : 19 : next = code->next;
10545 : : }
10546 : 103 : if (next->op == EXEC_IF
10547 : 103 : && next->block
10548 : 103 : && next->block->op == EXEC_IF
10549 : 103 : && next->block->next
10550 : 102 : && next->block->next->op == EXEC_ASSIGN)
10551 : : {
10552 : 102 : comp_cond = next->block->expr1;
10553 : 102 : stmt = next->block->next;
10554 : 102 : if (stmt->next)
10555 : : {
10556 : 0 : loc = &stmt->loc;
10557 : 0 : goto unexpected;
10558 : : }
10559 : : }
10560 : 1 : else if (capture_stmt)
10561 : : {
10562 : 0 : gfc_error ("Expected IF at %L in atomic compare capture",
10563 : : &next->loc);
10564 : 0 : return;
10565 : : }
10566 : 103 : if (stmt && !capture_stmt && next->block->block)
10567 : : {
10568 : 64 : if (next->block->block->expr1)
10569 : : {
10570 : 0 : gfc_error ("Expected ELSE at %L in atomic compare capture",
10571 : : &next->block->block->expr1->where);
10572 : 0 : return;
10573 : : }
10574 : 64 : if (!code->block->block->next
10575 : 64 : || code->block->block->next->op != EXEC_ASSIGN)
10576 : : {
10577 : 0 : loc = (code->block->block->next ? &code->block->block->next->loc
10578 : : : &code->block->block->loc);
10579 : 0 : goto unexpected;
10580 : : }
10581 : 64 : capture_stmt = code->block->block->next;
10582 : 64 : if (capture_stmt->next)
10583 : : {
10584 : 0 : loc = &capture_stmt->next->loc;
10585 : 0 : goto unexpected;
10586 : : }
10587 : : }
10588 : 103 : if (stmt && !capture_stmt && next->next->op == EXEC_ASSIGN)
10589 : : capture_stmt = next->next;
10590 : 84 : else if (!capture_stmt)
10591 : : {
10592 : 1 : loc = &code->loc;
10593 : 1 : goto unexpected;
10594 : : }
10595 : : }
10596 : 2593 : else if (atomic_code->ext.omp_clauses->compare)
10597 : : {
10598 : : /* Must be: "if (x == e) then; x = d; end if" or "if (x == e) x = d". */
10599 : 53 : if (code->op == EXEC_IF
10600 : 53 : && code->block
10601 : 53 : && code->block->op == EXEC_IF
10602 : 53 : && code->block->next
10603 : 51 : && code->block->next->op == EXEC_ASSIGN)
10604 : : {
10605 : 51 : comp_cond = code->block->expr1;
10606 : 51 : stmt = code->block->next;
10607 : 51 : if (stmt->next || code->block->block)
10608 : : {
10609 : 0 : loc = stmt->next ? &stmt->next->loc : &code->block->block->loc;
10610 : 0 : goto unexpected;
10611 : : }
10612 : : }
10613 : : else
10614 : : {
10615 : 2 : loc = &code->loc;
10616 : 2 : goto unexpected;
10617 : : }
10618 : : }
10619 : 2540 : else if (atomic_code->ext.omp_clauses->capture)
10620 : : {
10621 : : /* Must be: "v = x" followed/preceded by "x = ...". */
10622 : 489 : if (code->op != EXEC_ASSIGN)
10623 : 0 : goto unexpected;
10624 : 489 : if (code->next->op != EXEC_ASSIGN)
10625 : : {
10626 : 0 : loc = &code->next->loc;
10627 : 0 : goto unexpected;
10628 : : }
10629 : 489 : gfc_expr *expr2, *expr2_next;
10630 : 489 : expr2 = is_conversion (code->expr2, true, true);
10631 : 489 : if (expr2 == NULL)
10632 : 447 : expr2 = code->expr2;
10633 : 489 : expr2_next = is_conversion (code->next->expr2, true, true);
10634 : 489 : if (expr2_next == NULL)
10635 : 478 : expr2_next = code->next->expr2;
10636 : 489 : if (code->expr1->expr_type == EXPR_VARIABLE
10637 : 489 : && code->next->expr1->expr_type == EXPR_VARIABLE
10638 : 489 : && expr2->expr_type == EXPR_VARIABLE
10639 : 243 : && expr2_next->expr_type == EXPR_VARIABLE)
10640 : : {
10641 : 1 : if (code->expr1->symtree->n.sym == expr2_next->symtree->n.sym)
10642 : : {
10643 : : stmt = code;
10644 : : capture_stmt = code->next;
10645 : : }
10646 : : else
10647 : : {
10648 : 489 : capture_stmt = code;
10649 : 489 : stmt = code->next;
10650 : : }
10651 : : }
10652 : 488 : else if (expr2->expr_type == EXPR_VARIABLE)
10653 : : {
10654 : : capture_stmt = code;
10655 : : stmt = code->next;
10656 : : }
10657 : : else
10658 : : {
10659 : 247 : stmt = code;
10660 : 247 : capture_stmt = code->next;
10661 : : }
10662 : : /* Shall be NULL but can happen for invalid code. */
10663 : 489 : tailing_stmt = code->next->next;
10664 : : }
10665 : : else
10666 : : {
10667 : : /* x = ... */
10668 : 2051 : stmt = code;
10669 : 2051 : if (!atomic_code->ext.omp_clauses->compare && stmt->op != EXEC_ASSIGN)
10670 : 1 : goto unexpected;
10671 : : /* Shall be NULL but can happen for invalid code. */
10672 : 2050 : tailing_stmt = code->next;
10673 : : }
10674 : :
10675 : 2692 : if (comp_cond)
10676 : : {
10677 : 153 : if (comp_cond->expr_type != EXPR_OP
10678 : 153 : || (comp_cond->value.op.op != INTRINSIC_EQ
10679 : : && comp_cond->value.op.op != INTRINSIC_EQ_OS
10680 : : && comp_cond->value.op.op != INTRINSIC_EQV))
10681 : : {
10682 : 0 : gfc_error ("Expected %<==%>, %<.EQ.%> or %<.EQV.%> atomic comparison "
10683 : : "expression at %L", &comp_cond->where);
10684 : 0 : return;
10685 : : }
10686 : 153 : if (!is_scalar_intrinsic_expr (comp_cond->value.op.op1, true, true))
10687 : : {
10688 : 1 : gfc_error ("Expected scalar intrinsic variable at %L in atomic "
10689 : 1 : "comparison", &comp_cond->value.op.op1->where);
10690 : 1 : return;
10691 : : }
10692 : 152 : if (!gfc_resolve_expr (comp_cond->value.op.op2))
10693 : : return;
10694 : 152 : if (!is_scalar_intrinsic_expr (comp_cond->value.op.op2, false, false))
10695 : : {
10696 : 0 : gfc_error ("Expected scalar intrinsic expression at %L in atomic "
10697 : 0 : "comparison", &comp_cond->value.op.op1->where);
10698 : 0 : return;
10699 : : }
10700 : : }
10701 : :
10702 : 2691 : if (!is_scalar_intrinsic_expr (stmt->expr1, true, false))
10703 : : {
10704 : 4 : gfc_error ("!$OMP ATOMIC statement must set a scalar variable of "
10705 : 4 : "intrinsic type at %L", &stmt->expr1->where);
10706 : 4 : return;
10707 : : }
10708 : :
10709 : 2687 : if (!gfc_resolve_expr (stmt->expr2))
10710 : : return;
10711 : 2683 : if (!is_scalar_intrinsic_expr (stmt->expr2, false, false))
10712 : : {
10713 : 0 : gfc_error ("!$OMP ATOMIC statement must assign an expression of "
10714 : 0 : "intrinsic type at %L", &stmt->expr2->where);
10715 : 0 : return;
10716 : : }
10717 : :
10718 : 2683 : if (gfc_expr_attr (stmt->expr1).allocatable)
10719 : : {
10720 : 0 : gfc_error ("!$OMP ATOMIC with ALLOCATABLE variable at %L",
10721 : 0 : &stmt->expr1->where);
10722 : 0 : return;
10723 : : }
10724 : :
10725 : : /* Should be diagnosed above already. */
10726 : 2683 : gcc_assert (tailing_stmt == NULL);
10727 : :
10728 : 2683 : var = stmt->expr1->symtree->n.sym;
10729 : 2683 : stmt_expr2 = is_conversion (stmt->expr2, true, true);
10730 : 2683 : if (stmt_expr2 == NULL)
10731 : 2527 : stmt_expr2 = stmt->expr2;
10732 : :
10733 : 2683 : switch (aop)
10734 : : {
10735 : 503 : case GFC_OMP_ATOMIC_READ:
10736 : 503 : if (stmt_expr2->expr_type != EXPR_VARIABLE)
10737 : 0 : gfc_error ("!$OMP ATOMIC READ statement must read from a scalar "
10738 : : "variable of intrinsic type at %L", &stmt_expr2->where);
10739 : : return;
10740 : 421 : case GFC_OMP_ATOMIC_WRITE:
10741 : 421 : if (expr_references_sym (stmt_expr2, var, NULL))
10742 : 0 : gfc_error ("expr in !$OMP ATOMIC WRITE assignment var = expr "
10743 : : "must be scalar and cannot reference var at %L",
10744 : : &stmt_expr2->where);
10745 : : return;
10746 : 1759 : default:
10747 : 1759 : break;
10748 : : }
10749 : :
10750 : 1759 : if (atomic_code->ext.omp_clauses->capture)
10751 : : {
10752 : 588 : if (!is_scalar_intrinsic_expr (capture_stmt->expr1, true, false))
10753 : : {
10754 : 0 : gfc_error ("!$OMP ATOMIC capture-statement must set a scalar "
10755 : : "variable of intrinsic type at %L",
10756 : 0 : &capture_stmt->expr1->where);
10757 : 0 : return;
10758 : : }
10759 : :
10760 : 588 : if (!is_scalar_intrinsic_expr (capture_stmt->expr2, true, true))
10761 : : {
10762 : 2 : gfc_error ("!$OMP ATOMIC capture-statement requires a scalar variable"
10763 : 2 : " of intrinsic type at %L", &capture_stmt->expr2->where);
10764 : 2 : return;
10765 : : }
10766 : 586 : capt_expr2 = is_conversion (capture_stmt->expr2, true, true);
10767 : 586 : if (capt_expr2 == NULL)
10768 : 564 : capt_expr2 = capture_stmt->expr2;
10769 : :
10770 : 586 : if (capt_expr2->symtree->n.sym != var)
10771 : : {
10772 : 1 : gfc_error ("!$OMP ATOMIC CAPTURE capture statement reads from "
10773 : : "different variable than update statement writes "
10774 : : "into at %L", &capture_stmt->expr2->where);
10775 : 1 : return;
10776 : : }
10777 : : }
10778 : :
10779 : 1756 : if (atomic_code->ext.omp_clauses->compare)
10780 : : {
10781 : 149 : gfc_expr *var_expr;
10782 : 149 : if (comp_cond->value.op.op1->expr_type == EXPR_VARIABLE)
10783 : : var_expr = comp_cond->value.op.op1;
10784 : : else
10785 : 12 : var_expr = comp_cond->value.op.op1->value.function.actual->expr;
10786 : 149 : if (var_expr->symtree->n.sym != var)
10787 : : {
10788 : 2 : gfc_error ("For !$OMP ATOMIC COMPARE, the first operand in comparison"
10789 : : " at %L must be the variable %qs that the update statement"
10790 : : " writes into at %L", &var_expr->where, var->name,
10791 : 2 : &stmt->expr1->where);
10792 : 2 : return;
10793 : : }
10794 : 147 : if (stmt_expr2->rank != 0 || expr_references_sym (stmt_expr2, var, NULL))
10795 : : {
10796 : 1 : gfc_error ("expr in !$OMP ATOMIC COMPARE assignment var = expr "
10797 : : "must be scalar and cannot reference var at %L",
10798 : : &stmt_expr2->where);
10799 : 1 : return;
10800 : : }
10801 : : }
10802 : 1607 : else if (atomic_code->ext.omp_clauses->capture
10803 : 1607 : && !expr_references_sym (stmt_expr2, var, NULL))
10804 : 22 : atomic_code->ext.omp_clauses->atomic_op
10805 : 22 : = (gfc_omp_atomic_op) (atomic_code->ext.omp_clauses->atomic_op
10806 : : | GFC_OMP_ATOMIC_SWAP);
10807 : 1585 : else if (stmt_expr2->expr_type == EXPR_OP)
10808 : : {
10809 : 1229 : gfc_expr *v = NULL, *e, *c;
10810 : 1229 : gfc_intrinsic_op op = stmt_expr2->value.op.op;
10811 : 1229 : gfc_intrinsic_op alt_op = INTRINSIC_NONE;
10812 : :
10813 : 1229 : if (atomic_code->ext.omp_clauses->fail != OMP_MEMORDER_UNSET)
10814 : 3 : gfc_error ("!$OMP ATOMIC UPDATE at %L with FAIL clause requires either"
10815 : : " the COMPARE clause or using the intrinsic MIN/MAX "
10816 : : "procedure", &atomic_code->loc);
10817 : 1229 : switch (op)
10818 : : {
10819 : 742 : case INTRINSIC_PLUS:
10820 : 742 : alt_op = INTRINSIC_MINUS;
10821 : 742 : break;
10822 : 94 : case INTRINSIC_TIMES:
10823 : 94 : alt_op = INTRINSIC_DIVIDE;
10824 : 94 : break;
10825 : 120 : case INTRINSIC_MINUS:
10826 : 120 : alt_op = INTRINSIC_PLUS;
10827 : 120 : break;
10828 : 94 : case INTRINSIC_DIVIDE:
10829 : 94 : alt_op = INTRINSIC_TIMES;
10830 : 94 : break;
10831 : : case INTRINSIC_AND:
10832 : : case INTRINSIC_OR:
10833 : : break;
10834 : 43 : case INTRINSIC_EQV:
10835 : 43 : alt_op = INTRINSIC_NEQV;
10836 : 43 : break;
10837 : 43 : case INTRINSIC_NEQV:
10838 : 43 : alt_op = INTRINSIC_EQV;
10839 : 43 : break;
10840 : 1 : default:
10841 : 1 : gfc_error ("!$OMP ATOMIC assignment operator must be binary "
10842 : : "+, *, -, /, .AND., .OR., .EQV. or .NEQV. at %L",
10843 : : &stmt_expr2->where);
10844 : 1 : return;
10845 : : }
10846 : :
10847 : : /* Check for var = var op expr resp. var = expr op var where
10848 : : expr doesn't reference var and var op expr is mathematically
10849 : : equivalent to var op (expr) resp. expr op var equivalent to
10850 : : (expr) op var. We rely here on the fact that the matcher
10851 : : for x op1 y op2 z where op1 and op2 have equal precedence
10852 : : returns (x op1 y) op2 z. */
10853 : 1228 : e = stmt_expr2->value.op.op2;
10854 : 1228 : if (e->expr_type == EXPR_VARIABLE
10855 : 288 : && e->symtree != NULL
10856 : 288 : && e->symtree->n.sym == var)
10857 : : v = e;
10858 : 999 : else if ((c = is_conversion (e, false, true)) != NULL
10859 : 48 : && c->expr_type == EXPR_VARIABLE
10860 : 48 : && c->symtree != NULL
10861 : 1047 : && c->symtree->n.sym == var)
10862 : : v = c;
10863 : : else
10864 : : {
10865 : 951 : gfc_expr **p = NULL, **q;
10866 : 1049 : for (q = &stmt_expr2->value.op.op1; (e = *q) != NULL; )
10867 : 1049 : if (e->expr_type == EXPR_VARIABLE
10868 : 948 : && e->symtree != NULL
10869 : 948 : && e->symtree->n.sym == var)
10870 : : {
10871 : : v = e;
10872 : : break;
10873 : : }
10874 : 101 : else if ((c = is_conversion (e, false, true)) != NULL)
10875 : 60 : q = &e->value.function.actual->expr;
10876 : 41 : else if (e->expr_type != EXPR_OP
10877 : 41 : || (e->value.op.op != op
10878 : 15 : && e->value.op.op != alt_op)
10879 : 38 : || e->rank != 0)
10880 : : break;
10881 : : else
10882 : : {
10883 : 38 : p = q;
10884 : 38 : q = &e->value.op.op1;
10885 : : }
10886 : :
10887 : 951 : if (v == NULL)
10888 : : {
10889 : 3 : gfc_error ("!$OMP ATOMIC assignment must be var = var op expr "
10890 : : "or var = expr op var at %L", &stmt_expr2->where);
10891 : 3 : return;
10892 : : }
10893 : :
10894 : 948 : if (p != NULL)
10895 : : {
10896 : 38 : e = *p;
10897 : 38 : switch (e->value.op.op)
10898 : : {
10899 : 8 : case INTRINSIC_MINUS:
10900 : 8 : case INTRINSIC_DIVIDE:
10901 : 8 : case INTRINSIC_EQV:
10902 : 8 : case INTRINSIC_NEQV:
10903 : 8 : gfc_error ("!$OMP ATOMIC var = var op expr not "
10904 : : "mathematically equivalent to var = var op "
10905 : : "(expr) at %L", &stmt_expr2->where);
10906 : 8 : break;
10907 : : default:
10908 : : break;
10909 : : }
10910 : :
10911 : : /* Canonicalize into var = var op (expr). */
10912 : 38 : *p = e->value.op.op2;
10913 : 38 : e->value.op.op2 = stmt_expr2;
10914 : 38 : e->ts = stmt_expr2->ts;
10915 : 38 : if (stmt->expr2 == stmt_expr2)
10916 : 26 : stmt->expr2 = stmt_expr2 = e;
10917 : : else
10918 : 12 : stmt->expr2->value.function.actual->expr = stmt_expr2 = e;
10919 : :
10920 : 38 : if (!gfc_compare_types (&stmt_expr2->value.op.op1->ts,
10921 : : &stmt_expr2->ts))
10922 : : {
10923 : 24 : for (p = &stmt_expr2->value.op.op1; *p != v;
10924 : 12 : p = &(*p)->value.function.actual->expr)
10925 : : ;
10926 : 12 : *p = NULL;
10927 : 12 : gfc_free_expr (stmt_expr2->value.op.op1);
10928 : 12 : stmt_expr2->value.op.op1 = v;
10929 : 12 : gfc_convert_type (v, &stmt_expr2->ts, 2);
10930 : : }
10931 : : }
10932 : : }
10933 : :
10934 : 1225 : if (e->rank != 0 || expr_references_sym (stmt->expr2, var, v))
10935 : : {
10936 : 1 : gfc_error ("expr in !$OMP ATOMIC assignment var = var op expr "
10937 : : "must be scalar and cannot reference var at %L",
10938 : : &stmt_expr2->where);
10939 : 1 : return;
10940 : : }
10941 : : }
10942 : 356 : else if (stmt_expr2->expr_type == EXPR_FUNCTION
10943 : 355 : && stmt_expr2->value.function.isym != NULL
10944 : 355 : && stmt_expr2->value.function.esym == NULL
10945 : 355 : && stmt_expr2->value.function.actual != NULL
10946 : 355 : && stmt_expr2->value.function.actual->next != NULL)
10947 : : {
10948 : 355 : gfc_actual_arglist *arg, *var_arg;
10949 : :
10950 : 355 : switch (stmt_expr2->value.function.isym->id)
10951 : : {
10952 : : case GFC_ISYM_MIN:
10953 : : case GFC_ISYM_MAX:
10954 : : break;
10955 : 147 : case GFC_ISYM_IAND:
10956 : 147 : case GFC_ISYM_IOR:
10957 : 147 : case GFC_ISYM_IEOR:
10958 : 147 : if (stmt_expr2->value.function.actual->next->next != NULL)
10959 : : {
10960 : 0 : gfc_error ("!$OMP ATOMIC assignment intrinsic IAND, IOR "
10961 : : "or IEOR must have two arguments at %L",
10962 : : &stmt_expr2->where);
10963 : 0 : return;
10964 : : }
10965 : : break;
10966 : 1 : default:
10967 : 1 : gfc_error ("!$OMP ATOMIC assignment intrinsic must be "
10968 : : "MIN, MAX, IAND, IOR or IEOR at %L",
10969 : : &stmt_expr2->where);
10970 : 1 : return;
10971 : : }
10972 : :
10973 : : var_arg = NULL;
10974 : 1088 : for (arg = stmt_expr2->value.function.actual; arg; arg = arg->next)
10975 : : {
10976 : 741 : gfc_expr *e = NULL;
10977 : 741 : if (arg == stmt_expr2->value.function.actual
10978 : 387 : || (var_arg == NULL && arg->next == NULL))
10979 : : {
10980 : 527 : e = is_conversion (arg->expr, false, true);
10981 : 527 : if (!e)
10982 : 514 : e = arg->expr;
10983 : 527 : if (e->expr_type == EXPR_VARIABLE
10984 : 453 : && e->symtree != NULL
10985 : 453 : && e->symtree->n.sym == var)
10986 : 741 : var_arg = arg;
10987 : : }
10988 : 741 : if ((!var_arg || !e) && expr_references_sym (arg->expr, var, NULL))
10989 : : {
10990 : 7 : gfc_error ("!$OMP ATOMIC intrinsic arguments except one must "
10991 : : "not reference %qs at %L",
10992 : : var->name, &arg->expr->where);
10993 : 7 : return;
10994 : : }
10995 : 734 : if (arg->expr->rank != 0)
10996 : : {
10997 : 0 : gfc_error ("!$OMP ATOMIC intrinsic arguments must be scalar "
10998 : : "at %L", &arg->expr->where);
10999 : 0 : return;
11000 : : }
11001 : : }
11002 : :
11003 : 347 : if (var_arg == NULL)
11004 : : {
11005 : 1 : gfc_error ("First or last !$OMP ATOMIC intrinsic argument must "
11006 : : "be %qs at %L", var->name, &stmt_expr2->where);
11007 : 1 : return;
11008 : : }
11009 : :
11010 : 346 : if (var_arg != stmt_expr2->value.function.actual)
11011 : : {
11012 : : /* Canonicalize, so that var comes first. */
11013 : 172 : gcc_assert (var_arg->next == NULL);
11014 : : for (arg = stmt_expr2->value.function.actual;
11015 : 185 : arg->next != var_arg; arg = arg->next)
11016 : : ;
11017 : 172 : var_arg->next = stmt_expr2->value.function.actual;
11018 : 172 : stmt_expr2->value.function.actual = var_arg;
11019 : 172 : arg->next = NULL;
11020 : : }
11021 : : }
11022 : : else
11023 : 1 : gfc_error ("!$OMP ATOMIC assignment must have an operator or "
11024 : : "intrinsic on right hand side at %L", &stmt_expr2->where);
11025 : : return;
11026 : :
11027 : 4 : unexpected:
11028 : 4 : gfc_error ("unexpected !$OMP ATOMIC expression at %L",
11029 : : loc ? loc : &code->loc);
11030 : 4 : return;
11031 : : }
11032 : :
11033 : :
11034 : : static struct fortran_omp_context
11035 : : {
11036 : : gfc_code *code;
11037 : : hash_set<gfc_symbol *> *sharing_clauses;
11038 : : hash_set<gfc_symbol *> *private_iterators;
11039 : : struct fortran_omp_context *previous;
11040 : : bool is_openmp;
11041 : : } *omp_current_ctx;
11042 : : static gfc_code *omp_current_do_code;
11043 : : static int omp_current_do_collapse;
11044 : :
11045 : : /* Forward declaration for mutually recursive functions. */
11046 : : static gfc_code *
11047 : : find_nested_loop_in_block (gfc_code *block);
11048 : :
11049 : : /* Return the first nested DO loop in CHAIN, or NULL if there
11050 : : isn't one. Does no error checking on intervening code. */
11051 : :
11052 : : static gfc_code *
11053 : 27476 : find_nested_loop_in_chain (gfc_code *chain)
11054 : : {
11055 : 27476 : gfc_code *code;
11056 : :
11057 : 27476 : if (!chain)
11058 : : return NULL;
11059 : :
11060 : 31637 : for (code = chain; code; code = code->next)
11061 : 31216 : switch (code->op)
11062 : : {
11063 : : case EXEC_DO:
11064 : : case EXEC_OMP_TILE:
11065 : : case EXEC_OMP_UNROLL:
11066 : : return code;
11067 : 621 : case EXEC_BLOCK:
11068 : 621 : if (gfc_code *c = find_nested_loop_in_block (code))
11069 : : return c;
11070 : : break;
11071 : : default:
11072 : : break;
11073 : : }
11074 : : return NULL;
11075 : : }
11076 : :
11077 : : /* Return the first nested DO loop in BLOCK, or NULL if there
11078 : : isn't one. Does no error checking on intervening code. */
11079 : : static gfc_code *
11080 : 939 : find_nested_loop_in_block (gfc_code *block)
11081 : : {
11082 : 939 : gfc_namespace *ns;
11083 : 939 : gcc_assert (block->op == EXEC_BLOCK);
11084 : 939 : ns = block->ext.block.ns;
11085 : 939 : gcc_assert (ns);
11086 : 939 : return find_nested_loop_in_chain (ns->code);
11087 : : }
11088 : :
11089 : : void
11090 : 5410 : gfc_resolve_omp_do_blocks (gfc_code *code, gfc_namespace *ns)
11091 : : {
11092 : 5410 : if (code->block->next && code->block->next->op == EXEC_DO)
11093 : : {
11094 : 5057 : int i;
11095 : :
11096 : 5057 : omp_current_do_code = code->block->next;
11097 : 5057 : if (code->ext.omp_clauses->orderedc)
11098 : 141 : omp_current_do_collapse = code->ext.omp_clauses->orderedc;
11099 : 4916 : else if (code->ext.omp_clauses->collapse)
11100 : 1120 : omp_current_do_collapse = code->ext.omp_clauses->collapse;
11101 : 3796 : else if (code->ext.omp_clauses->sizes_list)
11102 : 175 : omp_current_do_collapse
11103 : 175 : = gfc_expr_list_len (code->ext.omp_clauses->sizes_list);
11104 : : else
11105 : 3621 : omp_current_do_collapse = 1;
11106 : 5057 : if (code->ext.omp_clauses->lists[OMP_LIST_REDUCTION_INSCAN])
11107 : : {
11108 : : /* Checking that there is a matching EXEC_OMP_SCAN in the
11109 : : innermost body cannot be deferred to resolve_omp_do because
11110 : : we process directives nested in the loop before we get
11111 : : there. */
11112 : 60 : locus *loc
11113 : : = &code->ext.omp_clauses->lists[OMP_LIST_REDUCTION_INSCAN]->where;
11114 : 60 : gfc_code *c;
11115 : :
11116 : 80 : for (i = 1, c = omp_current_do_code;
11117 : 80 : i < omp_current_do_collapse; i++)
11118 : : {
11119 : 22 : c = find_nested_loop_in_chain (c->block->next);
11120 : 22 : if (!c || c->op != EXEC_DO || c->block == NULL)
11121 : : break;
11122 : : }
11123 : :
11124 : : /* Skip this if we don't have enough nested loops. That
11125 : : problem will be diagnosed elsewhere. */
11126 : 60 : if (c && c->op == EXEC_DO)
11127 : : {
11128 : 58 : gfc_code *block = c->block ? c->block->next : NULL;
11129 : 58 : if (block && block->op != EXEC_OMP_SCAN)
11130 : 54 : while (block && block->next
11131 : 54 : && block->next->op != EXEC_OMP_SCAN)
11132 : : block = block->next;
11133 : 43 : if (!block
11134 : 46 : || (block->op != EXEC_OMP_SCAN
11135 : 43 : && (!block->next || block->next->op != EXEC_OMP_SCAN)))
11136 : 19 : gfc_error ("With INSCAN at %L, expected loop body with "
11137 : : "!$OMP SCAN between two "
11138 : : "structured block sequences", loc);
11139 : : else
11140 : : {
11141 : 39 : if (block->op == EXEC_OMP_SCAN)
11142 : 3 : gfc_warning (OPT_Wopenmp,
11143 : : "!$OMP SCAN at %L with zero executable "
11144 : : "statements in preceding structured block "
11145 : : "sequence", &block->loc);
11146 : 39 : if ((block->op == EXEC_OMP_SCAN && !block->next)
11147 : 38 : || (block->next && block->next->op == EXEC_OMP_SCAN
11148 : 36 : && !block->next->next))
11149 : 3 : gfc_warning (OPT_Wopenmp,
11150 : : "!$OMP SCAN at %L with zero executable "
11151 : : "statements in succeeding structured block "
11152 : : "sequence", block->op == EXEC_OMP_SCAN
11153 : 1 : ? &block->loc : &block->next->loc);
11154 : : }
11155 : 58 : if (block && block->op != EXEC_OMP_SCAN)
11156 : 43 : block = block->next;
11157 : 46 : if (block && block->op == EXEC_OMP_SCAN)
11158 : : /* Mark 'omp scan' as checked; flag will be unset later. */
11159 : 39 : block->ext.omp_clauses->if_present = true;
11160 : : }
11161 : : }
11162 : : }
11163 : 5410 : gfc_resolve_blocks (code->block, ns);
11164 : 5410 : omp_current_do_collapse = 0;
11165 : 5410 : omp_current_do_code = NULL;
11166 : 5410 : }
11167 : :
11168 : :
11169 : : void
11170 : 6009 : gfc_resolve_omp_parallel_blocks (gfc_code *code, gfc_namespace *ns)
11171 : : {
11172 : 6009 : struct fortran_omp_context ctx;
11173 : 6009 : gfc_omp_clauses *omp_clauses = code->ext.omp_clauses;
11174 : 6009 : gfc_omp_namelist *n;
11175 : 6009 : int list;
11176 : :
11177 : 6009 : ctx.code = code;
11178 : 6009 : ctx.sharing_clauses = new hash_set<gfc_symbol *>;
11179 : 6009 : ctx.private_iterators = new hash_set<gfc_symbol *>;
11180 : 6009 : ctx.previous = omp_current_ctx;
11181 : 6009 : ctx.is_openmp = true;
11182 : 6009 : omp_current_ctx = &ctx;
11183 : :
11184 : 234351 : for (list = 0; list < OMP_LIST_NUM; list++)
11185 : 228342 : switch (list)
11186 : : {
11187 : 60090 : case OMP_LIST_SHARED:
11188 : 60090 : case OMP_LIST_PRIVATE:
11189 : 60090 : case OMP_LIST_FIRSTPRIVATE:
11190 : 60090 : case OMP_LIST_LASTPRIVATE:
11191 : 60090 : case OMP_LIST_REDUCTION:
11192 : 60090 : case OMP_LIST_REDUCTION_INSCAN:
11193 : 60090 : case OMP_LIST_REDUCTION_TASK:
11194 : 60090 : case OMP_LIST_IN_REDUCTION:
11195 : 60090 : case OMP_LIST_TASK_REDUCTION:
11196 : 60090 : case OMP_LIST_LINEAR:
11197 : 69002 : for (n = omp_clauses->lists[list]; n; n = n->next)
11198 : 8912 : ctx.sharing_clauses->add (n->sym);
11199 : : break;
11200 : : default:
11201 : : break;
11202 : : }
11203 : :
11204 : 6009 : switch (code->op)
11205 : : {
11206 : 2348 : case EXEC_OMP_DISTRIBUTE_PARALLEL_DO:
11207 : 2348 : case EXEC_OMP_DISTRIBUTE_PARALLEL_DO_SIMD:
11208 : 2348 : case EXEC_OMP_MASKED_TASKLOOP:
11209 : 2348 : case EXEC_OMP_MASKED_TASKLOOP_SIMD:
11210 : 2348 : case EXEC_OMP_MASTER_TASKLOOP:
11211 : 2348 : case EXEC_OMP_MASTER_TASKLOOP_SIMD:
11212 : 2348 : case EXEC_OMP_PARALLEL_DO:
11213 : 2348 : case EXEC_OMP_PARALLEL_DO_SIMD:
11214 : 2348 : case EXEC_OMP_PARALLEL_LOOP:
11215 : 2348 : case EXEC_OMP_PARALLEL_MASKED_TASKLOOP:
11216 : 2348 : case EXEC_OMP_PARALLEL_MASKED_TASKLOOP_SIMD:
11217 : 2348 : case EXEC_OMP_PARALLEL_MASTER_TASKLOOP:
11218 : 2348 : case EXEC_OMP_PARALLEL_MASTER_TASKLOOP_SIMD:
11219 : 2348 : case EXEC_OMP_TARGET_PARALLEL_DO:
11220 : 2348 : case EXEC_OMP_TARGET_PARALLEL_DO_SIMD:
11221 : 2348 : case EXEC_OMP_TARGET_PARALLEL_LOOP:
11222 : 2348 : case EXEC_OMP_TARGET_TEAMS_DISTRIBUTE:
11223 : 2348 : case EXEC_OMP_TARGET_TEAMS_DISTRIBUTE_PARALLEL_DO:
11224 : 2348 : case EXEC_OMP_TARGET_TEAMS_DISTRIBUTE_PARALLEL_DO_SIMD:
11225 : 2348 : case EXEC_OMP_TARGET_TEAMS_DISTRIBUTE_SIMD:
11226 : 2348 : case EXEC_OMP_TARGET_TEAMS_LOOP:
11227 : 2348 : case EXEC_OMP_TASKLOOP:
11228 : 2348 : case EXEC_OMP_TASKLOOP_SIMD:
11229 : 2348 : case EXEC_OMP_TEAMS_DISTRIBUTE:
11230 : 2348 : case EXEC_OMP_TEAMS_DISTRIBUTE_PARALLEL_DO:
11231 : 2348 : case EXEC_OMP_TEAMS_DISTRIBUTE_PARALLEL_DO_SIMD:
11232 : 2348 : case EXEC_OMP_TEAMS_DISTRIBUTE_SIMD:
11233 : 2348 : case EXEC_OMP_TEAMS_LOOP:
11234 : 2348 : gfc_resolve_omp_do_blocks (code, ns);
11235 : 2348 : break;
11236 : 3661 : default:
11237 : 3661 : gfc_resolve_blocks (code->block, ns);
11238 : : }
11239 : :
11240 : 6009 : omp_current_ctx = ctx.previous;
11241 : 12018 : delete ctx.sharing_clauses;
11242 : 12018 : delete ctx.private_iterators;
11243 : 6009 : }
11244 : :
11245 : :
11246 : : /* Save and clear openmp.cc private state. */
11247 : :
11248 : : void
11249 : 280766 : gfc_omp_save_and_clear_state (struct gfc_omp_saved_state *state)
11250 : : {
11251 : 280766 : state->ptrs[0] = omp_current_ctx;
11252 : 280766 : state->ptrs[1] = omp_current_do_code;
11253 : 280766 : state->ints[0] = omp_current_do_collapse;
11254 : 280766 : omp_current_ctx = NULL;
11255 : 280766 : omp_current_do_code = NULL;
11256 : 280766 : omp_current_do_collapse = 0;
11257 : 280766 : }
11258 : :
11259 : :
11260 : : /* Restore openmp.cc private state from the saved state. */
11261 : :
11262 : : void
11263 : 280765 : gfc_omp_restore_state (struct gfc_omp_saved_state *state)
11264 : : {
11265 : 280765 : omp_current_ctx = (struct fortran_omp_context *) state->ptrs[0];
11266 : 280765 : omp_current_do_code = (gfc_code *) state->ptrs[1];
11267 : 280765 : omp_current_do_collapse = state->ints[0];
11268 : 280765 : }
11269 : :
11270 : :
11271 : : /* Note a DO iterator variable. This is special in !$omp parallel
11272 : : construct, where they are predetermined private. */
11273 : :
11274 : : void
11275 : 32497 : gfc_resolve_do_iterator (gfc_code *code, gfc_symbol *sym, bool add_clause)
11276 : : {
11277 : 32497 : if (omp_current_ctx == NULL)
11278 : : return;
11279 : :
11280 : 13082 : int i = omp_current_do_collapse;
11281 : 13082 : gfc_code *c = omp_current_do_code;
11282 : :
11283 : 13082 : if (sym->attr.threadprivate)
11284 : : return;
11285 : :
11286 : : /* !$omp do and !$omp parallel do iteration variable is predetermined
11287 : : private just in the !$omp do resp. !$omp parallel do construct,
11288 : : with no implications for the outer parallel constructs. */
11289 : :
11290 : 17916 : while (i-- >= 1 && c)
11291 : : {
11292 : 9479 : if (code == c)
11293 : : return;
11294 : 4834 : c = find_nested_loop_in_chain (c->block->next);
11295 : 4834 : if (c && (c->op == EXEC_OMP_TILE || c->op == EXEC_OMP_UNROLL))
11296 : : return;
11297 : : }
11298 : :
11299 : : /* An openacc context may represent a data clause. Abort if so. */
11300 : 8437 : if (!omp_current_ctx->is_openmp && !oacc_is_loop (omp_current_ctx->code))
11301 : : return;
11302 : :
11303 : 7459 : if (omp_current_ctx->sharing_clauses->contains (sym))
11304 : : return;
11305 : :
11306 : 6457 : if (! omp_current_ctx->private_iterators->add (sym) && add_clause)
11307 : : {
11308 : 6270 : gfc_omp_clauses *omp_clauses = omp_current_ctx->code->ext.omp_clauses;
11309 : 6270 : gfc_omp_namelist *p;
11310 : :
11311 : 6270 : p = gfc_get_omp_namelist ();
11312 : 6270 : p->sym = sym;
11313 : 6270 : p->where = omp_current_ctx->code->loc;
11314 : 6270 : p->next = omp_clauses->lists[OMP_LIST_PRIVATE];
11315 : 6270 : omp_clauses->lists[OMP_LIST_PRIVATE] = p;
11316 : : }
11317 : : }
11318 : :
11319 : : static void
11320 : 698 : handle_local_var (gfc_symbol *sym)
11321 : : {
11322 : 698 : if (sym->attr.flavor != FL_VARIABLE
11323 : 178 : || sym->as != NULL
11324 : 137 : || (sym->ts.type != BT_INTEGER && sym->ts.type != BT_REAL))
11325 : : return;
11326 : 71 : gfc_resolve_do_iterator (sym->ns->code, sym, false);
11327 : : }
11328 : :
11329 : : void
11330 : 325721 : gfc_resolve_omp_local_vars (gfc_namespace *ns)
11331 : : {
11332 : 325721 : if (omp_current_ctx)
11333 : 452 : gfc_traverse_ns (ns, handle_local_var);
11334 : 325721 : }
11335 : :
11336 : :
11337 : : /* Error checking on intervening code uses a code walker. */
11338 : :
11339 : : struct icode_error_state
11340 : : {
11341 : : const char *name;
11342 : : bool errorp;
11343 : : gfc_code *nested;
11344 : : gfc_code *next;
11345 : : };
11346 : :
11347 : : static int
11348 : 944 : icode_code_error_callback (gfc_code **codep,
11349 : : int *walk_subtrees ATTRIBUTE_UNUSED, void *opaque)
11350 : : {
11351 : 944 : gfc_code *code = *codep;
11352 : 944 : icode_error_state *state = (icode_error_state *)opaque;
11353 : :
11354 : : /* gfc_code_walker walks down CODE's next chain as well as
11355 : : walking things that are actually nested in CODE. We need to
11356 : : special-case traversal of outer blocks, so stop immediately if we
11357 : : are heading down such a next chain. */
11358 : 944 : if (code == state->next)
11359 : : return 1;
11360 : :
11361 : 647 : switch (code->op)
11362 : : {
11363 : 1 : case EXEC_DO:
11364 : 1 : case EXEC_DO_WHILE:
11365 : 1 : case EXEC_DO_CONCURRENT:
11366 : 1 : gfc_error ("%s cannot contain loop in intervening code at %L",
11367 : : state->name, &code->loc);
11368 : 1 : state->errorp = true;
11369 : 1 : break;
11370 : 0 : case EXEC_CYCLE:
11371 : 0 : case EXEC_EXIT:
11372 : : /* Errors have already been diagnosed in match_exit_cycle. */
11373 : 0 : state->errorp = true;
11374 : 0 : break;
11375 : : case EXEC_OMP_ASSUME:
11376 : : case EXEC_OMP_METADIRECTIVE:
11377 : : /* Per OpenMP 6.0, some non-executable directives are allowed in
11378 : : intervening code. */
11379 : : break;
11380 : 477 : case EXEC_CALL:
11381 : : /* Per OpenMP 5.2, the "omp_" prefix is reserved, so we don't have to
11382 : : consider the possibility that some locally-bound definition
11383 : : overrides the runtime routine. */
11384 : 477 : if (code->resolved_sym
11385 : 477 : && omp_runtime_api_procname (code->resolved_sym->name))
11386 : : {
11387 : 1 : gfc_error ("%s cannot contain OpenMP API call in intervening code "
11388 : : "at %L",
11389 : : state->name, &code->loc);
11390 : 1 : state->errorp = true;
11391 : : }
11392 : : break;
11393 : 168 : default:
11394 : 168 : if (code->op >= EXEC_OMP_FIRST_OPENMP_EXEC
11395 : 168 : && code->op <= EXEC_OMP_LAST_OPENMP_EXEC)
11396 : : {
11397 : 2 : gfc_error ("%s cannot contain OpenMP directive in intervening code "
11398 : : "at %L",
11399 : : state->name, &code->loc);
11400 : 2 : state->errorp = true;
11401 : : }
11402 : : }
11403 : : return 0;
11404 : : }
11405 : :
11406 : : static int
11407 : 1081 : icode_expr_error_callback (gfc_expr **expr,
11408 : : int *walk_subtrees ATTRIBUTE_UNUSED, void *opaque)
11409 : : {
11410 : 1081 : icode_error_state *state = (icode_error_state *)opaque;
11411 : :
11412 : 1081 : switch ((*expr)->expr_type)
11413 : : {
11414 : : /* As for EXPR_CALL with "omp_"-prefixed symbols. */
11415 : 2 : case EXPR_FUNCTION:
11416 : 2 : {
11417 : 2 : gfc_symbol *sym = (*expr)->value.function.esym;
11418 : 2 : if (sym && omp_runtime_api_procname (sym->name))
11419 : : {
11420 : 1 : gfc_error ("%s cannot contain OpenMP API call in intervening code "
11421 : : "at %L",
11422 : 1 : state->name, &((*expr)->where));
11423 : 1 : state->errorp = true;
11424 : : }
11425 : : }
11426 : :
11427 : : break;
11428 : : default:
11429 : : break;
11430 : : }
11431 : :
11432 : : /* FIXME: The description of canonical loop form in the OpenMP standard
11433 : : also says "array expressions" are not permitted in intervening code.
11434 : : That term is not defined in either the OpenMP spec or the Fortran
11435 : : standard, although the latter uses it informally to refer to any
11436 : : expression that is not scalar-valued. It is also apparently not the
11437 : : thing GCC internally calls EXPR_ARRAY. It seems the intent of the
11438 : : OpenMP restriction is to disallow elemental operations/intrinsics
11439 : : (including things that are not expressions, like assignment
11440 : : statements) that generate implicit loops over array operands
11441 : : (even if the result is a scalar), but even if the spec said
11442 : : that there is no list of all the cases that would be forbidden.
11443 : : This is OpenMP issue 3326. */
11444 : :
11445 : 1081 : return 0;
11446 : : }
11447 : :
11448 : : static void
11449 : 267 : diagnose_intervening_code_errors_1 (gfc_code *chain,
11450 : : struct icode_error_state *state)
11451 : : {
11452 : 267 : gfc_code *code;
11453 : 1080 : for (code = chain; code; code = code->next)
11454 : : {
11455 : 813 : if (code == state->nested)
11456 : : /* Do not walk the nested loop or its body, we are only
11457 : : interested in intervening code. */
11458 : : ;
11459 : 636 : else if (code->op == EXEC_BLOCK
11460 : 636 : && find_nested_loop_in_block (code) == state->nested)
11461 : : /* This block contains the nested loop, recurse on its
11462 : : statements. */
11463 : : {
11464 : 90 : gfc_namespace* ns = code->ext.block.ns;
11465 : 90 : diagnose_intervening_code_errors_1 (ns->code, state);
11466 : : }
11467 : : else
11468 : : /* Treat the whole statement as a unit. */
11469 : : {
11470 : 546 : gfc_code *temp = state->next;
11471 : 546 : state->next = code->next;
11472 : 546 : gfc_code_walker (&code, icode_code_error_callback,
11473 : : icode_expr_error_callback, state);
11474 : 546 : state->next = temp;
11475 : : }
11476 : : }
11477 : 267 : }
11478 : :
11479 : : /* Diagnose intervening code errors in BLOCK with nested loop NESTED.
11480 : : NAME is the user-friendly name of the OMP directive, used for error
11481 : : messages. Returns true if any error was found. */
11482 : : static bool
11483 : 177 : diagnose_intervening_code_errors (gfc_code *chain, const char *name,
11484 : : gfc_code *nested)
11485 : : {
11486 : 177 : struct icode_error_state state;
11487 : 177 : state.name = name;
11488 : 177 : state.errorp = false;
11489 : 177 : state.nested = nested;
11490 : 177 : state.next = NULL;
11491 : 0 : diagnose_intervening_code_errors_1 (chain, &state);
11492 : 177 : return state.errorp;
11493 : : }
11494 : :
11495 : : /* Helper function for restructure_intervening_code: wrap CHAIN in
11496 : : a marker to indicate that it is a structured block sequence. That
11497 : : information will be used later on (in omp-low.cc) for error checking. */
11498 : : static gfc_code *
11499 : 461 : make_structured_block (gfc_code *chain)
11500 : : {
11501 : 461 : gcc_assert (chain);
11502 : 461 : gfc_namespace *ns = gfc_build_block_ns (gfc_current_ns);
11503 : 461 : gfc_code *result = gfc_get_code (EXEC_BLOCK);
11504 : 461 : result->op = EXEC_BLOCK;
11505 : 461 : result->ext.block.ns = ns;
11506 : 461 : result->ext.block.assoc = NULL;
11507 : 461 : result->loc = chain->loc;
11508 : 461 : ns->omp_structured_block = 1;
11509 : 461 : ns->code = chain;
11510 : 461 : return result;
11511 : : }
11512 : :
11513 : : /* Push intervening code surrounding a loop, including nested scopes,
11514 : : into the body of the loop. CHAINP is the pointer to the head of
11515 : : the next-chain to scan, OUTER_LOOP is the EXEC_DO for the next outer
11516 : : loop level, and COLLAPSE is the number of nested loops we need to
11517 : : process.
11518 : : Note that CHAINP may point at outer_loop->block->next when we
11519 : : are scanning the body of a loop, but if there is an intervening block
11520 : : CHAINP points into the block's chain rather than its enclosing outer
11521 : : loop. This is why OUTER_LOOP is passed separately. */
11522 : : static gfc_code *
11523 : 7159 : restructure_intervening_code (gfc_code **chainp, gfc_code *outer_loop,
11524 : : int count)
11525 : : {
11526 : 7159 : gfc_code *code;
11527 : 7159 : gfc_code *head = *chainp;
11528 : 7159 : gfc_code *tail = NULL;
11529 : 7159 : gfc_code *innermost_loop = NULL;
11530 : :
11531 : 7423 : for (code = *chainp; code; code = code->next, chainp = &(*chainp)->next)
11532 : : {
11533 : 7423 : if (code->op == EXEC_DO)
11534 : : {
11535 : : /* Cut CODE free from its chain, leaving the ends dangling. */
11536 : 7075 : *chainp = NULL;
11537 : 7075 : tail = code->next;
11538 : 7075 : code->next = NULL;
11539 : :
11540 : 7075 : if (count == 1)
11541 : : innermost_loop = code;
11542 : : else
11543 : 2089 : innermost_loop
11544 : 2089 : = restructure_intervening_code (&code->block->next,
11545 : : code, count - 1);
11546 : : break;
11547 : : }
11548 : 348 : else if (code->op == EXEC_BLOCK
11549 : 348 : && find_nested_loop_in_block (code))
11550 : : {
11551 : 84 : gfc_namespace *ns = code->ext.block.ns;
11552 : :
11553 : : /* Cut CODE free from its chain, leaving the ends dangling. */
11554 : 84 : *chainp = NULL;
11555 : 84 : tail = code->next;
11556 : 84 : code->next = NULL;
11557 : :
11558 : 84 : innermost_loop
11559 : 84 : = restructure_intervening_code (&ns->code, outer_loop,
11560 : : count);
11561 : :
11562 : : /* At this point we have already pulled out the nested loop and
11563 : : pointed outer_loop at it, and moved the intervening code that
11564 : : was previously in the block into the body of innermost_loop.
11565 : : Now we want to move the BLOCK itself so it wraps the entire
11566 : : current body of innermost_loop. */
11567 : 84 : ns->code = innermost_loop->block->next;
11568 : 84 : innermost_loop->block->next = code;
11569 : 84 : break;
11570 : : }
11571 : : }
11572 : :
11573 : 2173 : gcc_assert (innermost_loop);
11574 : :
11575 : : /* Now we have split the intervening code into two parts:
11576 : : head is the start of the part before the loop/block, terminating
11577 : : at *chainp, and tail is the part after it. Mark each part as
11578 : : a structured block sequence, and splice the two parts around the
11579 : : existing body of the innermost loop. */
11580 : 7159 : if (head != code)
11581 : : {
11582 : 222 : gfc_code *block = make_structured_block (head);
11583 : 222 : if (innermost_loop->block->next)
11584 : 221 : gfc_append_code (block, innermost_loop->block->next);
11585 : 222 : innermost_loop->block->next = block;
11586 : : }
11587 : 7159 : if (tail)
11588 : : {
11589 : 239 : gfc_code *block = make_structured_block (tail);
11590 : 239 : if (innermost_loop->block->next)
11591 : 237 : gfc_append_code (innermost_loop->block->next, block);
11592 : : else
11593 : 2 : innermost_loop->block->next = block;
11594 : : }
11595 : :
11596 : : /* For loops, finally splice CODE into OUTER_LOOP. We already handled
11597 : : relinking EXEC_BLOCK above. */
11598 : 7159 : if (code->op == EXEC_DO && outer_loop)
11599 : 7075 : outer_loop->block->next = code;
11600 : :
11601 : 7159 : return innermost_loop;
11602 : : }
11603 : :
11604 : : /* CODE is an OMP loop construct. Return true if VAR matches an iteration
11605 : : variable outer to level DEPTH. */
11606 : : static bool
11607 : 8072 : is_outer_iteration_variable (gfc_code *code, int depth, gfc_symbol *var)
11608 : : {
11609 : 8072 : int i;
11610 : 8072 : gfc_code *do_code = code;
11611 : :
11612 : 12598 : for (i = 1; i < depth; i++)
11613 : : {
11614 : 5027 : do_code = find_nested_loop_in_chain (do_code->block->next);
11615 : 5027 : gcc_assert (do_code);
11616 : 5027 : if (do_code->op == EXEC_OMP_TILE || do_code->op == EXEC_OMP_UNROLL)
11617 : : {
11618 : 51 : --i;
11619 : 51 : continue;
11620 : : }
11621 : 4976 : gfc_symbol *ivar = do_code->ext.iterator->var->symtree->n.sym;
11622 : 4976 : if (var == ivar)
11623 : : return true;
11624 : : }
11625 : : return false;
11626 : : }
11627 : :
11628 : : /* Forward declaration for recursive functions. */
11629 : : static gfc_code *
11630 : : check_nested_loop_in_block (gfc_code *block, gfc_expr *expr, gfc_symbol *sym,
11631 : : bool *bad);
11632 : :
11633 : : /* Like find_nested_loop_in_chain, but additionally check that EXPR
11634 : : does not reference any variables bound in intervening EXEC_BLOCKs
11635 : : and that SYM is not bound in such intervening blocks. Either EXPR or SYM
11636 : : may be null. Sets *BAD to true if either test fails. */
11637 : : static gfc_code *
11638 : 48117 : check_nested_loop_in_chain (gfc_code *chain, gfc_expr *expr, gfc_symbol *sym,
11639 : : bool *bad)
11640 : : {
11641 : 51721 : for (gfc_code *code = chain; code; code = code->next)
11642 : : {
11643 : 51433 : if (code->op == EXEC_DO)
11644 : : return code;
11645 : 4123 : else if (code->op == EXEC_OMP_TILE || code->op == EXEC_OMP_UNROLL)
11646 : 1682 : return check_nested_loop_in_chain (code->block->next, expr, sym, bad);
11647 : 2441 : else if (code->op == EXEC_BLOCK)
11648 : : {
11649 : 807 : gfc_code *c = check_nested_loop_in_block (code, expr, sym, bad);
11650 : 807 : if (c)
11651 : : return c;
11652 : : }
11653 : : }
11654 : : return NULL;
11655 : : }
11656 : :
11657 : : /* Code walker for block symtrees. It doesn't take any kind of state
11658 : : argument, so use a static variable. */
11659 : : static struct check_nested_loop_in_block_state_t {
11660 : : gfc_expr *expr;
11661 : : gfc_symbol *sym;
11662 : : bool *bad;
11663 : : } check_nested_loop_in_block_state;
11664 : :
11665 : : static void
11666 : 766 : check_nested_loop_in_block_symbol (gfc_symbol *sym)
11667 : : {
11668 : 766 : if (sym == check_nested_loop_in_block_state.sym
11669 : 766 : || (check_nested_loop_in_block_state.expr
11670 : 567 : && gfc_find_sym_in_expr (sym,
11671 : : check_nested_loop_in_block_state.expr)))
11672 : 5 : *check_nested_loop_in_block_state.bad = true;
11673 : 766 : }
11674 : :
11675 : : /* Return the first nested DO loop in BLOCK, or NULL if there
11676 : : isn't one. Set *BAD to true if EXPR references any variables in BLOCK, or
11677 : : SYM is bound in BLOCK. Either EXPR or SYM may be null. */
11678 : : static gfc_code *
11679 : 807 : check_nested_loop_in_block (gfc_code *block, gfc_expr *expr,
11680 : : gfc_symbol *sym, bool *bad)
11681 : : {
11682 : 807 : gfc_namespace *ns;
11683 : 807 : gcc_assert (block->op == EXEC_BLOCK);
11684 : 807 : ns = block->ext.block.ns;
11685 : 807 : gcc_assert (ns);
11686 : :
11687 : : /* Skip the check if this block doesn't contain the nested loop, or
11688 : : if we already know it's bad. */
11689 : 807 : gfc_code *result = check_nested_loop_in_chain (ns->code, expr, sym, bad);
11690 : 807 : if (result && !*bad)
11691 : : {
11692 : 519 : check_nested_loop_in_block_state.expr = expr;
11693 : 519 : check_nested_loop_in_block_state.sym = sym;
11694 : 519 : check_nested_loop_in_block_state.bad = bad;
11695 : 519 : gfc_traverse_ns (ns, check_nested_loop_in_block_symbol);
11696 : 519 : check_nested_loop_in_block_state.expr = NULL;
11697 : 519 : check_nested_loop_in_block_state.sym = NULL;
11698 : 519 : check_nested_loop_in_block_state.bad = NULL;
11699 : : }
11700 : 807 : return result;
11701 : : }
11702 : :
11703 : : /* CODE is an OMP loop construct. Return true if EXPR references
11704 : : any variables bound in intervening code, to level DEPTH. */
11705 : : static bool
11706 : 22684 : expr_uses_intervening_var (gfc_code *code, int depth, gfc_expr *expr)
11707 : : {
11708 : 22684 : int i;
11709 : 22684 : gfc_code *do_code = code;
11710 : :
11711 : 58144 : for (i = 0; i < depth; i++)
11712 : : {
11713 : 35463 : bool bad = false;
11714 : 35463 : do_code = check_nested_loop_in_chain (do_code->block->next,
11715 : : expr, NULL, &bad);
11716 : 35463 : if (bad)
11717 : 3 : return true;
11718 : : }
11719 : : return false;
11720 : : }
11721 : :
11722 : : /* CODE is an OMP loop construct. Return true if SYM is bound in
11723 : : intervening code, to level DEPTH. */
11724 : : static bool
11725 : 7571 : is_intervening_var (gfc_code *code, int depth, gfc_symbol *sym)
11726 : : {
11727 : 7571 : int i;
11728 : 7571 : gfc_code *do_code = code;
11729 : :
11730 : 19416 : for (i = 0; i < depth; i++)
11731 : : {
11732 : 11847 : bool bad = false;
11733 : 11847 : do_code = check_nested_loop_in_chain (do_code->block->next,
11734 : : NULL, sym, &bad);
11735 : 11847 : if (bad)
11736 : 2 : return true;
11737 : : }
11738 : : return false;
11739 : : }
11740 : :
11741 : : /* CODE is an OMP loop construct. Return true if EXPR does not reference
11742 : : any iteration variables outer to level DEPTH. */
11743 : : static bool
11744 : 23763 : expr_is_invariant (gfc_code *code, int depth, gfc_expr *expr)
11745 : : {
11746 : 23763 : int i;
11747 : 23763 : gfc_code *do_code = code;
11748 : :
11749 : 37082 : for (i = 1; i < depth; i++)
11750 : : {
11751 : 14385 : do_code = find_nested_loop_in_chain (do_code->block->next);
11752 : 14385 : gcc_assert (do_code);
11753 : 14385 : if (do_code->op == EXEC_OMP_TILE || do_code->op == EXEC_OMP_UNROLL)
11754 : : {
11755 : 136 : --i;
11756 : 136 : continue;
11757 : : }
11758 : 14249 : gfc_symbol *ivar = do_code->ext.iterator->var->symtree->n.sym;
11759 : 14249 : if (gfc_find_sym_in_expr (ivar, expr))
11760 : : return false;
11761 : : }
11762 : : return true;
11763 : : }
11764 : :
11765 : : /* CODE is an OMP loop construct. Return true if EXPR matches one of the
11766 : : canonical forms for a bound expression. It may include references to
11767 : : an iteration variable outer to level DEPTH; set OUTER_VARP if so. */
11768 : : static bool
11769 : 15133 : bound_expr_is_canonical (gfc_code *code, int depth, gfc_expr *expr,
11770 : : gfc_symbol **outer_varp)
11771 : : {
11772 : 15133 : gfc_expr *expr2 = NULL;
11773 : :
11774 : : /* Rectangular case. */
11775 : 15133 : if (depth == 0 || expr_is_invariant (code, depth, expr))
11776 : 14565 : return true;
11777 : :
11778 : : /* Any simple variable that didn't pass expr_is_invariant must be
11779 : : an outer_var. */
11780 : 568 : if (expr->expr_type == EXPR_VARIABLE && expr->rank == 0)
11781 : : {
11782 : 63 : *outer_varp = expr->symtree->n.sym;
11783 : 63 : return true;
11784 : : }
11785 : :
11786 : : /* All other permitted forms are binary operators. */
11787 : 505 : if (expr->expr_type != EXPR_OP)
11788 : : return false;
11789 : :
11790 : : /* Check for plus/minus a loop invariant expr. */
11791 : 503 : if (expr->value.op.op == INTRINSIC_PLUS
11792 : 503 : || expr->value.op.op == INTRINSIC_MINUS)
11793 : : {
11794 : 483 : if (expr_is_invariant (code, depth, expr->value.op.op1))
11795 : 48 : expr2 = expr->value.op.op2;
11796 : 435 : else if (expr_is_invariant (code, depth, expr->value.op.op2))
11797 : 434 : expr2 = expr->value.op.op1;
11798 : : else
11799 : : return false;
11800 : : }
11801 : : else
11802 : : expr2 = expr;
11803 : :
11804 : : /* Check for a product with a loop-invariant expr. */
11805 : 502 : if (expr2->expr_type == EXPR_OP
11806 : 96 : && expr2->value.op.op == INTRINSIC_TIMES)
11807 : : {
11808 : 96 : if (expr_is_invariant (code, depth, expr2->value.op.op1))
11809 : 40 : expr2 = expr2->value.op.op2;
11810 : 56 : else if (expr_is_invariant (code, depth, expr2->value.op.op2))
11811 : 53 : expr2 = expr2->value.op.op1;
11812 : : else
11813 : : return false;
11814 : : }
11815 : :
11816 : : /* What's left must be a reference to an outer loop variable. */
11817 : 499 : if (expr2->expr_type == EXPR_VARIABLE
11818 : 499 : && expr2->rank == 0
11819 : 998 : && is_outer_iteration_variable (code, depth, expr2->symtree->n.sym))
11820 : : {
11821 : 499 : *outer_varp = expr2->symtree->n.sym;
11822 : 499 : return true;
11823 : : }
11824 : :
11825 : : return false;
11826 : : }
11827 : :
11828 : : static void
11829 : 5410 : resolve_omp_do (gfc_code *code)
11830 : : {
11831 : 5410 : gfc_code *do_code, *next;
11832 : 5410 : int list, i, count, non_generated_count;
11833 : 5410 : gfc_omp_namelist *n;
11834 : 5410 : gfc_symbol *dovar;
11835 : 5410 : const char *name;
11836 : 5410 : bool is_simd = false;
11837 : 5410 : bool errorp = false;
11838 : 5410 : bool perfect_nesting_errorp = false;
11839 : 5410 : bool imperfect = false;
11840 : :
11841 : 5410 : switch (code->op)
11842 : : {
11843 : : case EXEC_OMP_DISTRIBUTE: name = "!$OMP DISTRIBUTE"; break;
11844 : 49 : case EXEC_OMP_DISTRIBUTE_PARALLEL_DO:
11845 : 49 : name = "!$OMP DISTRIBUTE PARALLEL DO";
11846 : 49 : break;
11847 : 32 : case EXEC_OMP_DISTRIBUTE_PARALLEL_DO_SIMD:
11848 : 32 : name = "!$OMP DISTRIBUTE PARALLEL DO SIMD";
11849 : 32 : is_simd = true;
11850 : 32 : break;
11851 : 50 : case EXEC_OMP_DISTRIBUTE_SIMD:
11852 : 50 : name = "!$OMP DISTRIBUTE SIMD";
11853 : 50 : is_simd = true;
11854 : 50 : break;
11855 : 1334 : case EXEC_OMP_DO: name = "!$OMP DO"; break;
11856 : 134 : case EXEC_OMP_DO_SIMD: name = "!$OMP DO SIMD"; is_simd = true; break;
11857 : 64 : case EXEC_OMP_LOOP: name = "!$OMP LOOP"; break;
11858 : 1207 : case EXEC_OMP_PARALLEL_DO: name = "!$OMP PARALLEL DO"; break;
11859 : 304 : case EXEC_OMP_PARALLEL_DO_SIMD:
11860 : 304 : name = "!$OMP PARALLEL DO SIMD";
11861 : 304 : is_simd = true;
11862 : 304 : break;
11863 : 46 : case EXEC_OMP_PARALLEL_LOOP: name = "!$OMP PARALLEL LOOP"; break;
11864 : 7 : case EXEC_OMP_PARALLEL_MASKED_TASKLOOP:
11865 : 7 : name = "!$OMP PARALLEL MASKED TASKLOOP";
11866 : 7 : break;
11867 : 10 : case EXEC_OMP_PARALLEL_MASKED_TASKLOOP_SIMD:
11868 : 10 : name = "!$OMP PARALLEL MASKED TASKLOOP SIMD";
11869 : 10 : is_simd = true;
11870 : 10 : break;
11871 : 12 : case EXEC_OMP_PARALLEL_MASTER_TASKLOOP:
11872 : 12 : name = "!$OMP PARALLEL MASTER TASKLOOP";
11873 : 12 : break;
11874 : 18 : case EXEC_OMP_PARALLEL_MASTER_TASKLOOP_SIMD:
11875 : 18 : name = "!$OMP PARALLEL MASTER TASKLOOP SIMD";
11876 : 18 : is_simd = true;
11877 : 18 : break;
11878 : 8 : case EXEC_OMP_MASKED_TASKLOOP: name = "!$OMP MASKED TASKLOOP"; break;
11879 : 13 : case EXEC_OMP_MASKED_TASKLOOP_SIMD:
11880 : 13 : name = "!$OMP MASKED TASKLOOP SIMD";
11881 : 13 : is_simd = true;
11882 : 13 : break;
11883 : 14 : case EXEC_OMP_MASTER_TASKLOOP: name = "!$OMP MASTER TASKLOOP"; break;
11884 : 20 : case EXEC_OMP_MASTER_TASKLOOP_SIMD:
11885 : 20 : name = "!$OMP MASTER TASKLOOP SIMD";
11886 : 20 : is_simd = true;
11887 : 20 : break;
11888 : 783 : case EXEC_OMP_SIMD: name = "!$OMP SIMD"; is_simd = true; break;
11889 : 88 : case EXEC_OMP_TARGET_PARALLEL_DO: name = "!$OMP TARGET PARALLEL DO"; break;
11890 : 19 : case EXEC_OMP_TARGET_PARALLEL_DO_SIMD:
11891 : 19 : name = "!$OMP TARGET PARALLEL DO SIMD";
11892 : 19 : is_simd = true;
11893 : 19 : break;
11894 : 16 : case EXEC_OMP_TARGET_PARALLEL_LOOP:
11895 : 16 : name = "!$OMP TARGET PARALLEL LOOP";
11896 : 16 : break;
11897 : 33 : case EXEC_OMP_TARGET_SIMD:
11898 : 33 : name = "!$OMP TARGET SIMD";
11899 : 33 : is_simd = true;
11900 : 33 : break;
11901 : 20 : case EXEC_OMP_TARGET_TEAMS_DISTRIBUTE:
11902 : 20 : name = "!$OMP TARGET TEAMS DISTRIBUTE";
11903 : 20 : break;
11904 : 75 : case EXEC_OMP_TARGET_TEAMS_DISTRIBUTE_PARALLEL_DO:
11905 : 75 : name = "!$OMP TARGET TEAMS DISTRIBUTE PARALLEL DO";
11906 : 75 : break;
11907 : 37 : case EXEC_OMP_TARGET_TEAMS_DISTRIBUTE_PARALLEL_DO_SIMD:
11908 : 37 : name = "!$OMP TARGET TEAMS DISTRIBUTE PARALLEL DO SIMD";
11909 : 37 : is_simd = true;
11910 : 37 : break;
11911 : 20 : case EXEC_OMP_TARGET_TEAMS_DISTRIBUTE_SIMD:
11912 : 20 : name = "!$OMP TARGET TEAMS DISTRIBUTE SIMD";
11913 : 20 : is_simd = true;
11914 : 20 : break;
11915 : 19 : case EXEC_OMP_TARGET_TEAMS_LOOP: name = "!$OMP TARGET TEAMS LOOP"; break;
11916 : 69 : case EXEC_OMP_TASKLOOP: name = "!$OMP TASKLOOP"; break;
11917 : 38 : case EXEC_OMP_TASKLOOP_SIMD:
11918 : 38 : name = "!$OMP TASKLOOP SIMD";
11919 : 38 : is_simd = true;
11920 : 38 : break;
11921 : 20 : case EXEC_OMP_TEAMS_DISTRIBUTE: name = "!$OMP TEAMS DISTRIBUTE"; break;
11922 : 37 : case EXEC_OMP_TEAMS_DISTRIBUTE_PARALLEL_DO:
11923 : 37 : name = "!$OMP TEAMS DISTRIBUTE PARALLEL DO";
11924 : 37 : break;
11925 : 60 : case EXEC_OMP_TEAMS_DISTRIBUTE_PARALLEL_DO_SIMD:
11926 : 60 : name = "!$OMP TEAMS DISTRIBUTE PARALLEL DO SIMD";
11927 : 60 : is_simd = true;
11928 : 60 : break;
11929 : 42 : case EXEC_OMP_TEAMS_DISTRIBUTE_SIMD:
11930 : 42 : name = "!$OMP TEAMS DISTRIBUTE SIMD";
11931 : 42 : is_simd = true;
11932 : 42 : break;
11933 : 48 : case EXEC_OMP_TEAMS_LOOP: name = "!$OMP TEAMS LOOP"; break;
11934 : 195 : case EXEC_OMP_TILE: name = "!$OMP TILE"; break;
11935 : 415 : case EXEC_OMP_UNROLL: name = "!$OMP UNROLL"; break;
11936 : 0 : default: gcc_unreachable ();
11937 : : }
11938 : :
11939 : 5410 : if (code->ext.omp_clauses)
11940 : 5410 : resolve_omp_clauses (code, code->ext.omp_clauses, NULL);
11941 : :
11942 : 5410 : if (code->op == EXEC_OMP_TILE && code->ext.omp_clauses->sizes_list == NULL)
11943 : 0 : gfc_error ("SIZES clause is required on !$OMP TILE construct at %L",
11944 : : &code->loc);
11945 : :
11946 : 5410 : do_code = code->block->next;
11947 : 5410 : if (code->ext.omp_clauses->orderedc)
11948 : : count = code->ext.omp_clauses->orderedc;
11949 : 5267 : else if (code->ext.omp_clauses->sizes_list)
11950 : 195 : count = gfc_expr_list_len (code->ext.omp_clauses->sizes_list);
11951 : : else
11952 : : {
11953 : 5072 : count = code->ext.omp_clauses->collapse;
11954 : 5072 : if (count <= 0)
11955 : : count = 1;
11956 : : }
11957 : :
11958 : 5410 : non_generated_count = count;
11959 : : /* While the spec defines the loop nest depth independently of the COLLAPSE
11960 : : clause, in practice the middle end only pays attention to the COLLAPSE
11961 : : depth and treats any further inner loops as the final-loop-body. So
11962 : : here we also check canonical loop nest form only for the number of
11963 : : outer loops specified by the COLLAPSE clause too. */
11964 : 8049 : for (i = 1; i <= count; i++)
11965 : : {
11966 : 8049 : gfc_symbol *start_var = NULL, *end_var = NULL;
11967 : : /* Parse errors are not recoverable. */
11968 : 8049 : if (do_code->op == EXEC_DO_WHILE)
11969 : : {
11970 : 6 : gfc_error ("%s cannot be a DO WHILE or DO without loop control "
11971 : : "at %L", name, &do_code->loc);
11972 : 106 : goto fail;
11973 : : }
11974 : 8043 : if (do_code->op == EXEC_DO_CONCURRENT)
11975 : : {
11976 : 4 : gfc_error ("%s cannot be a DO CONCURRENT loop at %L", name,
11977 : : &do_code->loc);
11978 : 4 : goto fail;
11979 : : }
11980 : 8039 : if (do_code->op == EXEC_OMP_TILE || do_code->op == EXEC_OMP_UNROLL)
11981 : : {
11982 : 466 : if (do_code->op == EXEC_OMP_UNROLL)
11983 : : {
11984 : 308 : if (!do_code->ext.omp_clauses->partial)
11985 : : {
11986 : 53 : gfc_error ("Generated loop of UNROLL construct at %L "
11987 : : "without PARTIAL clause does not have "
11988 : : "canonical form", &do_code->loc);
11989 : 53 : goto fail;
11990 : : }
11991 : 255 : else if (i != count)
11992 : : {
11993 : 5 : gfc_error ("UNROLL construct at %L with PARTIAL clause "
11994 : : "generates just one loop with canonical form "
11995 : : "but %d loops are needed",
11996 : 5 : &do_code->loc, count - i + 1);
11997 : 5 : goto fail;
11998 : : }
11999 : : }
12000 : 158 : else if (do_code->op == EXEC_OMP_TILE)
12001 : : {
12002 : 158 : if (do_code->ext.omp_clauses->sizes_list == NULL)
12003 : : /* This should have been diagnosed earlier already. */
12004 : 0 : return;
12005 : 158 : int l = gfc_expr_list_len (do_code->ext.omp_clauses->sizes_list);
12006 : 158 : if (count - i + 1 > l)
12007 : : {
12008 : 14 : gfc_error ("TILE construct at %L generates %d loops "
12009 : : "with canonical form but %d loops are needed",
12010 : : &do_code->loc, l, count - i + 1);
12011 : 14 : goto fail;
12012 : : }
12013 : : }
12014 : 394 : if (do_code->ext.omp_clauses && do_code->ext.omp_clauses->erroneous)
12015 : 17 : goto fail;
12016 : 377 : if (imperfect && !perfect_nesting_errorp)
12017 : : {
12018 : 4 : sorry_at (gfc_get_location (&do_code->loc),
12019 : : "Imperfectly nested loop using generated loops");
12020 : 4 : errorp = true;
12021 : : }
12022 : 377 : if (non_generated_count == count)
12023 : 329 : non_generated_count = i - 1;
12024 : 377 : --i;
12025 : 377 : do_code = do_code->block->next;
12026 : 377 : continue;
12027 : 377 : }
12028 : 7573 : gcc_assert (do_code->op == EXEC_DO);
12029 : 7573 : if (do_code->ext.iterator->var->ts.type != BT_INTEGER)
12030 : : {
12031 : 3 : gfc_error ("%s iteration variable must be of type integer at %L",
12032 : : name, &do_code->loc);
12033 : 3 : errorp = true;
12034 : : }
12035 : 7573 : dovar = do_code->ext.iterator->var->symtree->n.sym;
12036 : 7573 : if (dovar->attr.threadprivate)
12037 : : {
12038 : 0 : gfc_error ("%s iteration variable must not be THREADPRIVATE "
12039 : : "at %L", name, &do_code->loc);
12040 : 0 : errorp = true;
12041 : : }
12042 : 7573 : if (code->ext.omp_clauses)
12043 : 295347 : for (list = 0; list < OMP_LIST_NUM; list++)
12044 : 94962 : if (!is_simd || code->ext.omp_clauses->collapse > 1
12045 : 287774 : ? (list != OMP_LIST_PRIVATE && list != OMP_LIST_LASTPRIVATE
12046 : 247722 : && list != OMP_LIST_ALLOCATE)
12047 : 40052 : : (list != OMP_LIST_PRIVATE && list != OMP_LIST_LASTPRIVATE
12048 : 40052 : && list != OMP_LIST_ALLOCATE && list != OMP_LIST_LINEAR))
12049 : 268374 : for (n = code->ext.omp_clauses->lists[list]; n; n = n->next)
12050 : 4373 : if (dovar == n->sym)
12051 : : {
12052 : 5 : if (!is_simd || code->ext.omp_clauses->collapse > 1)
12053 : 4 : gfc_error ("%s iteration variable present on clause "
12054 : : "other than PRIVATE, LASTPRIVATE or "
12055 : : "ALLOCATE at %L", name, &do_code->loc);
12056 : : else
12057 : 1 : gfc_error ("%s iteration variable present on clause "
12058 : : "other than PRIVATE, LASTPRIVATE, ALLOCATE or "
12059 : : "LINEAR at %L", name, &do_code->loc);
12060 : : errorp = true;
12061 : : }
12062 : 7573 : if (is_outer_iteration_variable (code, i, dovar))
12063 : : {
12064 : 2 : gfc_error ("%s iteration variable used in more than one loop at %L",
12065 : : name, &do_code->loc);
12066 : 2 : errorp = true;
12067 : : }
12068 : 7571 : else if (is_intervening_var (code, i, dovar))
12069 : : {
12070 : 2 : gfc_error ("%s iteration variable at %L is bound in "
12071 : : "intervening code",
12072 : : name, &do_code->loc);
12073 : 2 : errorp = true;
12074 : : }
12075 : 7569 : else if (!bound_expr_is_canonical (code, i,
12076 : 7569 : do_code->ext.iterator->start,
12077 : : &start_var))
12078 : : {
12079 : 4 : gfc_error ("%s loop start expression not in canonical form at %L",
12080 : : name, &do_code->loc);
12081 : 4 : errorp = true;
12082 : : }
12083 : 7565 : else if (expr_uses_intervening_var (code, i,
12084 : 7565 : do_code->ext.iterator->start))
12085 : : {
12086 : 1 : gfc_error ("%s loop start expression at %L uses variable bound in "
12087 : : "intervening code",
12088 : : name, &do_code->loc);
12089 : 1 : errorp = true;
12090 : : }
12091 : 7564 : else if (!bound_expr_is_canonical (code, i,
12092 : 7564 : do_code->ext.iterator->end,
12093 : : &end_var))
12094 : : {
12095 : 2 : gfc_error ("%s loop end expression not in canonical form at %L",
12096 : : name, &do_code->loc);
12097 : 2 : errorp = true;
12098 : : }
12099 : 7562 : else if (expr_uses_intervening_var (code, i,
12100 : 7562 : do_code->ext.iterator->end))
12101 : : {
12102 : 1 : gfc_error ("%s loop end expression at %L uses variable bound in "
12103 : : "intervening code",
12104 : : name, &do_code->loc);
12105 : 1 : errorp = true;
12106 : : }
12107 : 7561 : else if (start_var && end_var && start_var != end_var)
12108 : : {
12109 : 1 : gfc_error ("%s loop bounds reference different "
12110 : : "iteration variables at %L", name, &do_code->loc);
12111 : 1 : errorp = true;
12112 : : }
12113 : 7560 : else if (!expr_is_invariant (code, i, do_code->ext.iterator->step))
12114 : : {
12115 : 3 : gfc_error ("%s loop increment not in canonical form at %L",
12116 : : name, &do_code->loc);
12117 : 3 : errorp = true;
12118 : : }
12119 : 7557 : else if (expr_uses_intervening_var (code, i,
12120 : 7557 : do_code->ext.iterator->step))
12121 : : {
12122 : 1 : gfc_error ("%s loop increment expression at %L uses variable "
12123 : : "bound in intervening code",
12124 : : name, &do_code->loc);
12125 : 1 : errorp = true;
12126 : : }
12127 : 7573 : if (start_var || end_var)
12128 : : {
12129 : 528 : code->ext.omp_clauses->non_rectangular = 1;
12130 : 528 : if (i > non_generated_count)
12131 : : {
12132 : 3 : sorry_at (gfc_get_location (&do_code->loc),
12133 : : "Non-rectangular loops from generated loops "
12134 : : "unsupported");
12135 : 3 : errorp = true;
12136 : : }
12137 : : }
12138 : :
12139 : : /* Only parse loop body into nested loop and intervening code if
12140 : : there are supposed to be more loops in the nest to collapse. */
12141 : 7573 : if (i == count)
12142 : : break;
12143 : :
12144 : 2269 : next = find_nested_loop_in_chain (do_code->block->next);
12145 : :
12146 : 2269 : if (!next)
12147 : : {
12148 : : /* Parse error, can't recover from this. */
12149 : 7 : gfc_error ("not enough DO loops for collapsed %s (level %d) at %L",
12150 : : name, i, &code->loc);
12151 : 7 : goto fail;
12152 : : }
12153 : 2262 : else if (next != do_code->block->next
12154 : 2102 : || (next->next && next->next->op != EXEC_CONTINUE))
12155 : : /* Imperfectly nested loop found. */
12156 : : {
12157 : : /* Only diagnose violation of imperfect nesting constraints once. */
12158 : 177 : if (!perfect_nesting_errorp)
12159 : : {
12160 : 176 : if (code->ext.omp_clauses->orderedc)
12161 : : {
12162 : 3 : gfc_error ("%s inner loops must be perfectly nested with "
12163 : : "ORDERED clause at %L",
12164 : : name, &code->loc);
12165 : 3 : perfect_nesting_errorp = true;
12166 : : }
12167 : 173 : else if (code->ext.omp_clauses->lists[OMP_LIST_REDUCTION_INSCAN])
12168 : : {
12169 : 2 : gfc_error ("%s inner loops must be perfectly nested with "
12170 : : "REDUCTION INSCAN clause at %L",
12171 : : name, &code->loc);
12172 : 2 : perfect_nesting_errorp = true;
12173 : : }
12174 : 171 : else if (code->op == EXEC_OMP_TILE)
12175 : : {
12176 : 8 : gfc_error ("%s inner loops must be perfectly nested at %L",
12177 : : name, &code->loc);
12178 : 8 : perfect_nesting_errorp = true;
12179 : : }
12180 : 13 : if (perfect_nesting_errorp)
12181 : : errorp = true;
12182 : : }
12183 : 177 : if (diagnose_intervening_code_errors (do_code->block->next,
12184 : : name, next))
12185 : 5 : errorp = true;
12186 : : imperfect = true;
12187 : : }
12188 : 2262 : do_code = next;
12189 : : }
12190 : :
12191 : : /* Give up now if we found any constraint violations. */
12192 : 5304 : if (errorp)
12193 : : {
12194 : 48 : fail:
12195 : 154 : if (code->ext.omp_clauses)
12196 : 154 : code->ext.omp_clauses->erroneous = 1;
12197 : 154 : return;
12198 : : }
12199 : :
12200 : 5256 : if (non_generated_count)
12201 : 4986 : restructure_intervening_code (&code->block->next, code,
12202 : : non_generated_count);
12203 : : }
12204 : :
12205 : : /* Resolve the context selector. In particular, SKIP_P is set to true,
12206 : : the context can never be matched. */
12207 : :
12208 : : static void
12209 : 763 : gfc_resolve_omp_context_selector (gfc_omp_set_selector *oss,
12210 : : bool is_metadirective, bool *skip_p)
12211 : : {
12212 : 763 : if (skip_p)
12213 : 310 : *skip_p = false;
12214 : 1452 : for (gfc_omp_set_selector *set_selector = oss; set_selector;
12215 : 689 : set_selector = set_selector->next)
12216 : 1485 : for (gfc_omp_selector *os = set_selector->trait_selectors; os; os = os->next)
12217 : : {
12218 : 814 : if (os->score)
12219 : : {
12220 : 52 : if (!gfc_resolve_expr (os->score)
12221 : 52 : || os->score->ts.type != BT_INTEGER
12222 : 104 : || os->score->rank != 0)
12223 : : {
12224 : 0 : gfc_error ("%<score%> argument must be constant integer "
12225 : 0 : "expression at %L", &os->score->where);
12226 : 0 : gfc_free_expr (os->score);
12227 : 0 : os->score = nullptr;
12228 : : }
12229 : 52 : else if (os->score->expr_type == EXPR_CONSTANT
12230 : 52 : && mpz_sgn (os->score->value.integer) < 0)
12231 : : {
12232 : 1 : gfc_error ("%<score%> argument must be non-negative at %L",
12233 : : &os->score->where);
12234 : 1 : gfc_free_expr (os->score);
12235 : 1 : os->score = nullptr;
12236 : : }
12237 : : }
12238 : :
12239 : 814 : if (os->code == OMP_TRAIT_INVALID)
12240 : : break;
12241 : 796 : enum omp_tp_type property_kind = omp_ts_map[os->code].tp_type;
12242 : 796 : gfc_omp_trait_property *otp = os->properties;
12243 : :
12244 : 796 : if (!otp)
12245 : 409 : continue;
12246 : 387 : switch (property_kind)
12247 : : {
12248 : 139 : case OMP_TRAIT_PROPERTY_DEV_NUM_EXPR:
12249 : 139 : case OMP_TRAIT_PROPERTY_BOOL_EXPR:
12250 : 139 : if (!gfc_resolve_expr (otp->expr)
12251 : 138 : || (property_kind == OMP_TRAIT_PROPERTY_BOOL_EXPR
12252 : 124 : && otp->expr->ts.type != BT_LOGICAL)
12253 : 137 : || (property_kind == OMP_TRAIT_PROPERTY_DEV_NUM_EXPR
12254 : 14 : && otp->expr->ts.type != BT_INTEGER)
12255 : 137 : || otp->expr->rank != 0
12256 : 276 : || (!is_metadirective && otp->expr->expr_type != EXPR_CONSTANT))
12257 : : {
12258 : 3 : if (is_metadirective)
12259 : : {
12260 : 0 : if (property_kind == OMP_TRAIT_PROPERTY_BOOL_EXPR)
12261 : 0 : gfc_error ("property must be a "
12262 : : "logical expression at %L",
12263 : 0 : &otp->expr->where);
12264 : : else
12265 : 0 : gfc_error ("property must be an "
12266 : : "integer expression at %L",
12267 : 0 : &otp->expr->where);
12268 : : }
12269 : : else
12270 : : {
12271 : 3 : if (property_kind == OMP_TRAIT_PROPERTY_BOOL_EXPR)
12272 : 2 : gfc_error ("property must be a constant "
12273 : : "logical expression at %L",
12274 : 2 : &otp->expr->where);
12275 : : else
12276 : 1 : gfc_error ("property must be a constant "
12277 : : "integer expression at %L",
12278 : 1 : &otp->expr->where);
12279 : : }
12280 : : /* Prevent later ICEs. */
12281 : 3 : gfc_expr *e;
12282 : 3 : if (property_kind == OMP_TRAIT_PROPERTY_BOOL_EXPR)
12283 : 2 : e = gfc_get_logical_expr (gfc_default_logical_kind,
12284 : 2 : &otp->expr->where, true);
12285 : : else
12286 : 1 : e = gfc_get_int_expr (gfc_default_integer_kind,
12287 : 1 : &otp->expr->where, 0);
12288 : 3 : gfc_free_expr (otp->expr);
12289 : 3 : otp->expr = e;
12290 : 3 : continue;
12291 : 3 : }
12292 : : /* Device number must be conforming, which includes
12293 : : omp_initial_device (-1), omp_invalid_device (-4),
12294 : : and omp_default_device (-5). */
12295 : 136 : if (property_kind == OMP_TRAIT_PROPERTY_DEV_NUM_EXPR
12296 : 14 : && otp->expr->expr_type == EXPR_CONSTANT
12297 : 5 : && mpz_sgn (otp->expr->value.integer) < 0
12298 : 3 : && mpz_cmp_si (otp->expr->value.integer, -1) != 0
12299 : 2 : && mpz_cmp_si (otp->expr->value.integer, -4) != 0
12300 : 1 : && mpz_cmp_si (otp->expr->value.integer, -5) != 0)
12301 : 1 : gfc_error ("property must be a conforming device number at %L",
12302 : : &otp->expr->where);
12303 : : break;
12304 : : default:
12305 : : break;
12306 : : }
12307 : : /* This only handles one specific case: User condition.
12308 : : FIXME: Handle more cases by calling omp_context_selector_matches;
12309 : : unfortunately, we cannot generate the tree here as, e.g., PARM_DECL
12310 : : backend decl are not available at this stage - but might be used in,
12311 : : e.g. user conditions. See PR122361. */
12312 : 384 : if (skip_p && otp
12313 : 138 : && os->code == OMP_TRAIT_USER_CONDITION
12314 : 81 : && otp->expr->expr_type == EXPR_CONSTANT
12315 : 14 : && otp->expr->value.logical == false)
12316 : 12 : *skip_p = true;
12317 : : }
12318 : 763 : }
12319 : :
12320 : :
12321 : : static void
12322 : 138 : resolve_omp_metadirective (gfc_code *code, gfc_namespace *ns)
12323 : : {
12324 : 138 : gfc_omp_variant *variant = code->ext.omp_variants;
12325 : 138 : gfc_omp_variant *prev_variant = variant;
12326 : :
12327 : 448 : while (variant)
12328 : : {
12329 : 310 : bool skip;
12330 : 310 : gfc_resolve_omp_context_selector (variant->selectors, true, &skip);
12331 : 310 : gfc_code *variant_code = variant->code;
12332 : 310 : gfc_resolve_code (variant_code, ns);
12333 : 310 : if (skip)
12334 : : {
12335 : : /* The following should only be true if an error occurred
12336 : : as the 'otherwise' clause should always match. */
12337 : 12 : if (variant == code->ext.omp_variants && !variant->next)
12338 : : break;
12339 : 12 : gfc_omp_variant *tmp = variant;
12340 : 12 : if (variant == code->ext.omp_variants)
12341 : 11 : variant = prev_variant = code->ext.omp_variants = variant->next;
12342 : : else
12343 : 1 : variant = prev_variant->next = variant->next;
12344 : 12 : gfc_free_omp_set_selector_list (tmp->selectors);
12345 : 12 : free (tmp);
12346 : : }
12347 : : else
12348 : : {
12349 : 298 : prev_variant = variant;
12350 : 298 : variant = variant->next;
12351 : : }
12352 : : }
12353 : : /* Replace metadirective by its body if only 'nothing' remains. */
12354 : 138 : if (!code->ext.omp_variants->next && code->ext.omp_variants->stmt == ST_NONE)
12355 : : {
12356 : 11 : gfc_code *next = code->next;
12357 : 11 : gfc_code *inner = code->ext.omp_variants->code;
12358 : 11 : gfc_free_omp_set_selector_list (code->ext.omp_variants->selectors);
12359 : 11 : free (code->ext.omp_variants);
12360 : 11 : *code = *inner;
12361 : 11 : free (inner);
12362 : 11 : while (code->next)
12363 : : code = code->next;
12364 : 11 : code->next = next;
12365 : : }
12366 : 138 : }
12367 : :
12368 : :
12369 : : static gfc_statement
12370 : 63 : omp_code_to_statement (gfc_code *code)
12371 : : {
12372 : 63 : switch (code->op)
12373 : : {
12374 : : case EXEC_OMP_PARALLEL:
12375 : : return ST_OMP_PARALLEL;
12376 : 0 : case EXEC_OMP_PARALLEL_MASKED:
12377 : 0 : return ST_OMP_PARALLEL_MASKED;
12378 : 0 : case EXEC_OMP_PARALLEL_MASKED_TASKLOOP:
12379 : 0 : return ST_OMP_PARALLEL_MASKED_TASKLOOP;
12380 : 0 : case EXEC_OMP_PARALLEL_MASKED_TASKLOOP_SIMD:
12381 : 0 : return ST_OMP_PARALLEL_MASKED_TASKLOOP_SIMD;
12382 : 0 : case EXEC_OMP_PARALLEL_MASTER:
12383 : 0 : return ST_OMP_PARALLEL_MASTER;
12384 : 0 : case EXEC_OMP_PARALLEL_MASTER_TASKLOOP:
12385 : 0 : return ST_OMP_PARALLEL_MASTER_TASKLOOP;
12386 : 0 : case EXEC_OMP_PARALLEL_MASTER_TASKLOOP_SIMD:
12387 : 0 : return ST_OMP_PARALLEL_MASTER_TASKLOOP_SIMD;
12388 : 1 : case EXEC_OMP_PARALLEL_SECTIONS:
12389 : 1 : return ST_OMP_PARALLEL_SECTIONS;
12390 : 1 : case EXEC_OMP_SECTIONS:
12391 : 1 : return ST_OMP_SECTIONS;
12392 : 1 : case EXEC_OMP_ORDERED:
12393 : 1 : return ST_OMP_ORDERED;
12394 : 1 : case EXEC_OMP_CRITICAL:
12395 : 1 : return ST_OMP_CRITICAL;
12396 : 0 : case EXEC_OMP_MASKED:
12397 : 0 : return ST_OMP_MASKED;
12398 : 0 : case EXEC_OMP_MASKED_TASKLOOP:
12399 : 0 : return ST_OMP_MASKED_TASKLOOP;
12400 : 0 : case EXEC_OMP_MASKED_TASKLOOP_SIMD:
12401 : 0 : return ST_OMP_MASKED_TASKLOOP_SIMD;
12402 : 1 : case EXEC_OMP_MASTER:
12403 : 1 : return ST_OMP_MASTER;
12404 : 0 : case EXEC_OMP_MASTER_TASKLOOP:
12405 : 0 : return ST_OMP_MASTER_TASKLOOP;
12406 : 0 : case EXEC_OMP_MASTER_TASKLOOP_SIMD:
12407 : 0 : return ST_OMP_MASTER_TASKLOOP_SIMD;
12408 : 1 : case EXEC_OMP_SINGLE:
12409 : 1 : return ST_OMP_SINGLE;
12410 : 1 : case EXEC_OMP_TASK:
12411 : 1 : return ST_OMP_TASK;
12412 : 1 : case EXEC_OMP_WORKSHARE:
12413 : 1 : return ST_OMP_WORKSHARE;
12414 : 1 : case EXEC_OMP_PARALLEL_WORKSHARE:
12415 : 1 : return ST_OMP_PARALLEL_WORKSHARE;
12416 : 3 : case EXEC_OMP_DO:
12417 : 3 : return ST_OMP_DO;
12418 : 0 : case EXEC_OMP_LOOP:
12419 : 0 : return ST_OMP_LOOP;
12420 : 0 : case EXEC_OMP_ALLOCATE:
12421 : 0 : return ST_OMP_ALLOCATE_EXEC;
12422 : 0 : case EXEC_OMP_ALLOCATORS:
12423 : 0 : return ST_OMP_ALLOCATORS;
12424 : 0 : case EXEC_OMP_ASSUME:
12425 : 0 : return ST_OMP_ASSUME;
12426 : 1 : case EXEC_OMP_ATOMIC:
12427 : 1 : return ST_OMP_ATOMIC;
12428 : 1 : case EXEC_OMP_BARRIER:
12429 : 1 : return ST_OMP_BARRIER;
12430 : 1 : case EXEC_OMP_CANCEL:
12431 : 1 : return ST_OMP_CANCEL;
12432 : 1 : case EXEC_OMP_CANCELLATION_POINT:
12433 : 1 : return ST_OMP_CANCELLATION_POINT;
12434 : 0 : case EXEC_OMP_ERROR:
12435 : 0 : return ST_OMP_ERROR;
12436 : 1 : case EXEC_OMP_FLUSH:
12437 : 1 : return ST_OMP_FLUSH;
12438 : 0 : case EXEC_OMP_INTEROP:
12439 : 0 : return ST_OMP_INTEROP;
12440 : 1 : case EXEC_OMP_DISTRIBUTE:
12441 : 1 : return ST_OMP_DISTRIBUTE;
12442 : 1 : case EXEC_OMP_DISTRIBUTE_PARALLEL_DO:
12443 : 1 : return ST_OMP_DISTRIBUTE_PARALLEL_DO;
12444 : 1 : case EXEC_OMP_DISTRIBUTE_PARALLEL_DO_SIMD:
12445 : 1 : return ST_OMP_DISTRIBUTE_PARALLEL_DO_SIMD;
12446 : 1 : case EXEC_OMP_DISTRIBUTE_SIMD:
12447 : 1 : return ST_OMP_DISTRIBUTE_SIMD;
12448 : 1 : case EXEC_OMP_DO_SIMD:
12449 : 1 : return ST_OMP_DO_SIMD;
12450 : 0 : case EXEC_OMP_SCAN:
12451 : 0 : return ST_OMP_SCAN;
12452 : 0 : case EXEC_OMP_SCOPE:
12453 : 0 : return ST_OMP_SCOPE;
12454 : 1 : case EXEC_OMP_SIMD:
12455 : 1 : return ST_OMP_SIMD;
12456 : 1 : case EXEC_OMP_TARGET:
12457 : 1 : return ST_OMP_TARGET;
12458 : 1 : case EXEC_OMP_TARGET_DATA:
12459 : 1 : return ST_OMP_TARGET_DATA;
12460 : 1 : case EXEC_OMP_TARGET_ENTER_DATA:
12461 : 1 : return ST_OMP_TARGET_ENTER_DATA;
12462 : 1 : case EXEC_OMP_TARGET_EXIT_DATA:
12463 : 1 : return ST_OMP_TARGET_EXIT_DATA;
12464 : 1 : case EXEC_OMP_TARGET_PARALLEL:
12465 : 1 : return ST_OMP_TARGET_PARALLEL;
12466 : 1 : case EXEC_OMP_TARGET_PARALLEL_DO:
12467 : 1 : return ST_OMP_TARGET_PARALLEL_DO;
12468 : 1 : case EXEC_OMP_TARGET_PARALLEL_DO_SIMD:
12469 : 1 : return ST_OMP_TARGET_PARALLEL_DO_SIMD;
12470 : 0 : case EXEC_OMP_TARGET_PARALLEL_LOOP:
12471 : 0 : return ST_OMP_TARGET_PARALLEL_LOOP;
12472 : 1 : case EXEC_OMP_TARGET_SIMD:
12473 : 1 : return ST_OMP_TARGET_SIMD;
12474 : 1 : case EXEC_OMP_TARGET_TEAMS:
12475 : 1 : return ST_OMP_TARGET_TEAMS;
12476 : 1 : case EXEC_OMP_TARGET_TEAMS_DISTRIBUTE:
12477 : 1 : return ST_OMP_TARGET_TEAMS_DISTRIBUTE;
12478 : 1 : case EXEC_OMP_TARGET_TEAMS_DISTRIBUTE_PARALLEL_DO:
12479 : 1 : return ST_OMP_TARGET_TEAMS_DISTRIBUTE_PARALLEL_DO;
12480 : 1 : case EXEC_OMP_TARGET_TEAMS_DISTRIBUTE_PARALLEL_DO_SIMD:
12481 : 1 : return ST_OMP_TARGET_TEAMS_DISTRIBUTE_PARALLEL_DO_SIMD;
12482 : 1 : case EXEC_OMP_TARGET_TEAMS_DISTRIBUTE_SIMD:
12483 : 1 : return ST_OMP_TARGET_TEAMS_DISTRIBUTE_SIMD;
12484 : 0 : case EXEC_OMP_TARGET_TEAMS_LOOP:
12485 : 0 : return ST_OMP_TARGET_TEAMS_LOOP;
12486 : 1 : case EXEC_OMP_TARGET_UPDATE:
12487 : 1 : return ST_OMP_TARGET_UPDATE;
12488 : 1 : case EXEC_OMP_TASKGROUP:
12489 : 1 : return ST_OMP_TASKGROUP;
12490 : 1 : case EXEC_OMP_TASKLOOP:
12491 : 1 : return ST_OMP_TASKLOOP;
12492 : 1 : case EXEC_OMP_TASKLOOP_SIMD:
12493 : 1 : return ST_OMP_TASKLOOP_SIMD;
12494 : 1 : case EXEC_OMP_TASKWAIT:
12495 : 1 : return ST_OMP_TASKWAIT;
12496 : 1 : case EXEC_OMP_TASKYIELD:
12497 : 1 : return ST_OMP_TASKYIELD;
12498 : 1 : case EXEC_OMP_TEAMS:
12499 : 1 : return ST_OMP_TEAMS;
12500 : 1 : case EXEC_OMP_TEAMS_DISTRIBUTE:
12501 : 1 : return ST_OMP_TEAMS_DISTRIBUTE;
12502 : 1 : case EXEC_OMP_TEAMS_DISTRIBUTE_PARALLEL_DO:
12503 : 1 : return ST_OMP_TEAMS_DISTRIBUTE_PARALLEL_DO;
12504 : 1 : case EXEC_OMP_TEAMS_DISTRIBUTE_PARALLEL_DO_SIMD:
12505 : 1 : return ST_OMP_TEAMS_DISTRIBUTE_PARALLEL_DO_SIMD;
12506 : 1 : case EXEC_OMP_TEAMS_DISTRIBUTE_SIMD:
12507 : 1 : return ST_OMP_TEAMS_DISTRIBUTE_SIMD;
12508 : 0 : case EXEC_OMP_TEAMS_LOOP:
12509 : 0 : return ST_OMP_TEAMS_LOOP;
12510 : 6 : case EXEC_OMP_PARALLEL_DO:
12511 : 6 : return ST_OMP_PARALLEL_DO;
12512 : 1 : case EXEC_OMP_PARALLEL_DO_SIMD:
12513 : 1 : return ST_OMP_PARALLEL_DO_SIMD;
12514 : 0 : case EXEC_OMP_PARALLEL_LOOP:
12515 : 0 : return ST_OMP_PARALLEL_LOOP;
12516 : 1 : case EXEC_OMP_DEPOBJ:
12517 : 1 : return ST_OMP_DEPOBJ;
12518 : 0 : case EXEC_OMP_TILE:
12519 : 0 : return ST_OMP_TILE;
12520 : 0 : case EXEC_OMP_UNROLL:
12521 : 0 : return ST_OMP_UNROLL;
12522 : 0 : case EXEC_OMP_DISPATCH:
12523 : 0 : return ST_OMP_DISPATCH;
12524 : 0 : default:
12525 : 0 : gcc_unreachable ();
12526 : : }
12527 : : }
12528 : :
12529 : : static gfc_statement
12530 : 63 : oacc_code_to_statement (gfc_code *code)
12531 : : {
12532 : 63 : switch (code->op)
12533 : : {
12534 : : case EXEC_OACC_PARALLEL:
12535 : : return ST_OACC_PARALLEL;
12536 : : case EXEC_OACC_KERNELS:
12537 : : return ST_OACC_KERNELS;
12538 : : case EXEC_OACC_SERIAL:
12539 : : return ST_OACC_SERIAL;
12540 : : case EXEC_OACC_DATA:
12541 : : return ST_OACC_DATA;
12542 : : case EXEC_OACC_HOST_DATA:
12543 : : return ST_OACC_HOST_DATA;
12544 : : case EXEC_OACC_PARALLEL_LOOP:
12545 : : return ST_OACC_PARALLEL_LOOP;
12546 : : case EXEC_OACC_KERNELS_LOOP:
12547 : : return ST_OACC_KERNELS_LOOP;
12548 : : case EXEC_OACC_SERIAL_LOOP:
12549 : : return ST_OACC_SERIAL_LOOP;
12550 : : case EXEC_OACC_LOOP:
12551 : : return ST_OACC_LOOP;
12552 : : case EXEC_OACC_ATOMIC:
12553 : : return ST_OACC_ATOMIC;
12554 : : case EXEC_OACC_ROUTINE:
12555 : : return ST_OACC_ROUTINE;
12556 : : case EXEC_OACC_UPDATE:
12557 : : return ST_OACC_UPDATE;
12558 : : case EXEC_OACC_WAIT:
12559 : : return ST_OACC_WAIT;
12560 : : case EXEC_OACC_CACHE:
12561 : : return ST_OACC_CACHE;
12562 : : case EXEC_OACC_ENTER_DATA:
12563 : : return ST_OACC_ENTER_DATA;
12564 : : case EXEC_OACC_EXIT_DATA:
12565 : : return ST_OACC_EXIT_DATA;
12566 : : case EXEC_OACC_DECLARE:
12567 : : return ST_OACC_DECLARE;
12568 : 0 : default:
12569 : 0 : gcc_unreachable ();
12570 : : }
12571 : : }
12572 : :
12573 : : static void
12574 : 13160 : resolve_oacc_directive_inside_omp_region (gfc_code *code)
12575 : : {
12576 : 13160 : if (omp_current_ctx != NULL && omp_current_ctx->is_openmp)
12577 : : {
12578 : 11 : gfc_statement st = omp_code_to_statement (omp_current_ctx->code);
12579 : 11 : gfc_statement oacc_st = oacc_code_to_statement (code);
12580 : 11 : gfc_error ("The %s directive cannot be specified within "
12581 : : "a %s region at %L", gfc_ascii_statement (oacc_st),
12582 : : gfc_ascii_statement (st), &code->loc);
12583 : : }
12584 : 13160 : }
12585 : :
12586 : : static void
12587 : 20523 : resolve_omp_directive_inside_oacc_region (gfc_code *code)
12588 : : {
12589 : 20523 : if (omp_current_ctx != NULL && !omp_current_ctx->is_openmp)
12590 : : {
12591 : 52 : gfc_statement st = oacc_code_to_statement (omp_current_ctx->code);
12592 : 52 : gfc_statement omp_st = omp_code_to_statement (code);
12593 : 52 : gfc_error ("The %s directive cannot be specified within "
12594 : : "a %s region at %L", gfc_ascii_statement (omp_st),
12595 : : gfc_ascii_statement (st), &code->loc);
12596 : : }
12597 : 20523 : }
12598 : :
12599 : :
12600 : : static void
12601 : 5270 : resolve_oacc_nested_loops (gfc_code *code, gfc_code* do_code, int collapse,
12602 : : const char *clause)
12603 : : {
12604 : 5270 : gfc_symbol *dovar;
12605 : 5270 : gfc_code *c;
12606 : 5270 : int i;
12607 : :
12608 : 5790 : for (i = 1; i <= collapse; i++)
12609 : : {
12610 : 5790 : if (do_code->op == EXEC_DO_WHILE)
12611 : : {
12612 : 10 : gfc_error ("!$ACC LOOP cannot be a DO WHILE or DO without loop control "
12613 : : "at %L", &do_code->loc);
12614 : 10 : break;
12615 : : }
12616 : 5780 : if (do_code->op == EXEC_DO_CONCURRENT)
12617 : : {
12618 : 3 : gfc_error ("!$ACC LOOP cannot be a DO CONCURRENT loop at %L",
12619 : : &do_code->loc);
12620 : 3 : break;
12621 : : }
12622 : 5777 : gcc_assert (do_code->op == EXEC_DO);
12623 : 5777 : if (do_code->ext.iterator->var->ts.type != BT_INTEGER)
12624 : 6 : gfc_error ("!$ACC LOOP iteration variable must be of type integer at %L",
12625 : : &do_code->loc);
12626 : 5777 : dovar = do_code->ext.iterator->var->symtree->n.sym;
12627 : 5777 : if (i > 1)
12628 : : {
12629 : 518 : gfc_code *do_code2 = code->block->next;
12630 : 518 : int j;
12631 : :
12632 : 1218 : for (j = 1; j < i; j++)
12633 : : {
12634 : 710 : gfc_symbol *ivar = do_code2->ext.iterator->var->symtree->n.sym;
12635 : 710 : if (dovar == ivar
12636 : 710 : || gfc_find_sym_in_expr (ivar, do_code->ext.iterator->start)
12637 : 701 : || gfc_find_sym_in_expr (ivar, do_code->ext.iterator->end)
12638 : 1410 : || gfc_find_sym_in_expr (ivar, do_code->ext.iterator->step))
12639 : : {
12640 : 10 : gfc_error ("!$ACC LOOP %s loops don't form rectangular "
12641 : : "iteration space at %L", clause, &do_code->loc);
12642 : 10 : break;
12643 : : }
12644 : 700 : do_code2 = do_code2->block->next;
12645 : : }
12646 : : }
12647 : 5777 : if (i == collapse)
12648 : : break;
12649 : 577 : for (c = do_code->next; c; c = c->next)
12650 : 48 : if (c->op != EXEC_NOP && c->op != EXEC_CONTINUE)
12651 : : {
12652 : 0 : gfc_error ("%s !$ACC LOOP loops not perfectly nested at %L",
12653 : : clause, &c->loc);
12654 : 0 : break;
12655 : : }
12656 : 529 : if (c)
12657 : : break;
12658 : 529 : do_code = do_code->block;
12659 : 529 : if (do_code->op != EXEC_DO && do_code->op != EXEC_DO_WHILE
12660 : 0 : && do_code->op != EXEC_DO_CONCURRENT)
12661 : : {
12662 : 0 : gfc_error ("not enough DO loops for %s !$ACC LOOP at %L",
12663 : : clause, &code->loc);
12664 : 0 : break;
12665 : : }
12666 : 529 : do_code = do_code->next;
12667 : 529 : if (do_code == NULL
12668 : 522 : || (do_code->op != EXEC_DO && do_code->op != EXEC_DO_WHILE
12669 : 2 : && do_code->op != EXEC_DO_CONCURRENT))
12670 : : {
12671 : 9 : gfc_error ("not enough DO loops for %s !$ACC LOOP at %L",
12672 : : clause, &code->loc);
12673 : 9 : break;
12674 : : }
12675 : : }
12676 : 5270 : }
12677 : :
12678 : :
12679 : : static void
12680 : 10115 : resolve_oacc_loop_blocks (gfc_code *code)
12681 : : {
12682 : 10115 : if (!oacc_is_loop (code))
12683 : : return;
12684 : :
12685 : 5270 : if (code->ext.omp_clauses->tile_list && code->ext.omp_clauses->gang
12686 : 24 : && code->ext.omp_clauses->worker && code->ext.omp_clauses->vector)
12687 : 0 : gfc_error ("Tiled loop cannot be parallelized across gangs, workers and "
12688 : : "vectors at the same time at %L", &code->loc);
12689 : :
12690 : 5270 : if (code->ext.omp_clauses->tile_list)
12691 : : {
12692 : : gfc_expr_list *el;
12693 : 501 : for (el = code->ext.omp_clauses->tile_list; el; el = el->next)
12694 : : {
12695 : 304 : if (el->expr == NULL)
12696 : : {
12697 : : /* NULL expressions are used to represent '*' arguments.
12698 : : Convert those to a 0 expressions. */
12699 : 113 : el->expr = gfc_get_constant_expr (BT_INTEGER,
12700 : : gfc_default_integer_kind,
12701 : : &code->loc);
12702 : 113 : mpz_set_si (el->expr->value.integer, 0);
12703 : : }
12704 : : else
12705 : : {
12706 : 191 : resolve_positive_int_expr (el->expr, "TILE");
12707 : 191 : if (el->expr->expr_type != EXPR_CONSTANT)
12708 : 14 : gfc_error ("TILE requires constant expression at %L",
12709 : : &code->loc);
12710 : : }
12711 : : }
12712 : : }
12713 : : }
12714 : :
12715 : :
12716 : : void
12717 : 10115 : gfc_resolve_oacc_blocks (gfc_code *code, gfc_namespace *ns)
12718 : : {
12719 : 10115 : fortran_omp_context ctx;
12720 : 10115 : gfc_omp_clauses *omp_clauses = code->ext.omp_clauses;
12721 : 10115 : gfc_omp_namelist *n;
12722 : 10115 : int list;
12723 : :
12724 : 10115 : resolve_oacc_loop_blocks (code);
12725 : :
12726 : 10115 : ctx.code = code;
12727 : 10115 : ctx.sharing_clauses = new hash_set<gfc_symbol *>;
12728 : 10115 : ctx.private_iterators = new hash_set<gfc_symbol *>;
12729 : 10115 : ctx.previous = omp_current_ctx;
12730 : 10115 : ctx.is_openmp = false;
12731 : 10115 : omp_current_ctx = &ctx;
12732 : :
12733 : 394485 : for (list = 0; list < OMP_LIST_NUM; list++)
12734 : 384370 : switch (list)
12735 : : {
12736 : 10115 : case OMP_LIST_PRIVATE:
12737 : 10704 : for (n = omp_clauses->lists[list]; n; n = n->next)
12738 : 589 : ctx.sharing_clauses->add (n->sym);
12739 : : break;
12740 : : default:
12741 : : break;
12742 : : }
12743 : :
12744 : 10115 : gfc_resolve_blocks (code->block, ns);
12745 : :
12746 : 10115 : omp_current_ctx = ctx.previous;
12747 : 20230 : delete ctx.sharing_clauses;
12748 : 20230 : delete ctx.private_iterators;
12749 : 10115 : }
12750 : :
12751 : :
12752 : : static void
12753 : 5270 : resolve_oacc_loop (gfc_code *code)
12754 : : {
12755 : 5270 : gfc_code *do_code;
12756 : 5270 : int collapse;
12757 : :
12758 : 5270 : if (code->ext.omp_clauses)
12759 : 5270 : resolve_omp_clauses (code, code->ext.omp_clauses, NULL, true);
12760 : :
12761 : 5270 : do_code = code->block->next;
12762 : 5270 : collapse = code->ext.omp_clauses->collapse;
12763 : :
12764 : : /* Both collapsed and tiled loops are lowered the same way, but are not
12765 : : compatible. In gfc_trans_omp_do, the tile is prioritized. */
12766 : 5270 : if (code->ext.omp_clauses->tile_list)
12767 : : {
12768 : : int num = 0;
12769 : : gfc_expr_list *el;
12770 : 501 : for (el = code->ext.omp_clauses->tile_list; el; el = el->next)
12771 : 304 : ++num;
12772 : 197 : resolve_oacc_nested_loops (code, code->block->next, num, "tiled");
12773 : 197 : return;
12774 : : }
12775 : :
12776 : 5073 : if (collapse <= 0)
12777 : : collapse = 1;
12778 : 5073 : resolve_oacc_nested_loops (code, do_code, collapse, "collapsed");
12779 : : }
12780 : :
12781 : : void
12782 : 325721 : gfc_resolve_oacc_declare (gfc_namespace *ns)
12783 : : {
12784 : 325721 : int list;
12785 : 325721 : gfc_omp_namelist *n;
12786 : 325721 : gfc_oacc_declare *oc;
12787 : :
12788 : 325721 : if (ns->oacc_declare == NULL)
12789 : : return;
12790 : :
12791 : 286 : for (oc = ns->oacc_declare; oc; oc = oc->next)
12792 : : {
12793 : 6240 : for (list = 0; list < OMP_LIST_NUM; list++)
12794 : 6332 : for (n = oc->clauses->lists[list]; n; n = n->next)
12795 : : {
12796 : 252 : n->sym->mark = 0;
12797 : 252 : if (n->sym->attr.flavor != FL_VARIABLE
12798 : 16 : && (n->sym->attr.flavor != FL_PROCEDURE
12799 : 8 : || n->sym->result != n->sym))
12800 : : {
12801 : 14 : if (n->sym->attr.flavor != FL_PARAMETER)
12802 : : {
12803 : 8 : gfc_error ("Object %qs is not a variable at %L",
12804 : : n->sym->name, &oc->loc);
12805 : 8 : continue;
12806 : : }
12807 : : /* Note that OpenACC 3.4 permits name constants, but the
12808 : : implementation is permitted to ignore the clause;
12809 : : as semantically, device_resident kind of makes sense
12810 : : (and the wording with it is a bit odd), the warning
12811 : : is suppressed. */
12812 : 6 : if (list != OMP_LIST_DEVICE_RESIDENT)
12813 : 5 : gfc_warning (OPT_Wsurprising, "Object %qs at %L is ignored as"
12814 : : " parameters need not be copied", n->sym->name,
12815 : : &oc->loc);
12816 : : }
12817 : :
12818 : 244 : if (n->expr && n->expr->ref->type == REF_ARRAY)
12819 : : {
12820 : 1 : gfc_error ("Array sections: %qs not allowed in"
12821 : 1 : " !$ACC DECLARE at %L", n->sym->name, &oc->loc);
12822 : 1 : continue;
12823 : : }
12824 : : }
12825 : :
12826 : 250 : for (n = oc->clauses->lists[OMP_LIST_DEVICE_RESIDENT]; n; n = n->next)
12827 : 90 : check_array_not_assumed (n->sym, oc->loc, "DEVICE_RESIDENT");
12828 : : }
12829 : :
12830 : 286 : for (oc = ns->oacc_declare; oc; oc = oc->next)
12831 : : {
12832 : 6240 : for (list = 0; list < OMP_LIST_NUM; list++)
12833 : 6332 : for (n = oc->clauses->lists[list]; n; n = n->next)
12834 : : {
12835 : 252 : if (n->sym->mark)
12836 : : {
12837 : 9 : gfc_error ("Symbol %qs present on multiple clauses at %L",
12838 : : n->sym->name, &oc->loc);
12839 : 9 : continue;
12840 : : }
12841 : : else
12842 : 243 : n->sym->mark = 1;
12843 : : }
12844 : : }
12845 : :
12846 : 286 : for (oc = ns->oacc_declare; oc; oc = oc->next)
12847 : : {
12848 : 6240 : for (list = 0; list < OMP_LIST_NUM; list++)
12849 : 6332 : for (n = oc->clauses->lists[list]; n; n = n->next)
12850 : 252 : n->sym->mark = 0;
12851 : : }
12852 : : }
12853 : :
12854 : :
12855 : : void
12856 : 325721 : gfc_resolve_oacc_routines (gfc_namespace *ns)
12857 : : {
12858 : 325721 : for (gfc_oacc_routine_name *orn = ns->oacc_routine_names;
12859 : 325821 : orn;
12860 : 100 : orn = orn->next)
12861 : : {
12862 : 100 : gfc_symbol *sym = orn->sym;
12863 : 100 : if (!sym->attr.external
12864 : 29 : && !sym->attr.function
12865 : 27 : && !sym->attr.subroutine)
12866 : : {
12867 : 7 : gfc_error ("NAME %qs does not refer to a subroutine or function"
12868 : : " in !$ACC ROUTINE ( NAME ) at %L", sym->name, &orn->loc);
12869 : 7 : continue;
12870 : : }
12871 : 93 : if (!gfc_add_omp_declare_target (&sym->attr, sym->name, &orn->loc))
12872 : : {
12873 : 20 : gfc_error ("NAME %qs invalid"
12874 : : " in !$ACC ROUTINE ( NAME ) at %L", sym->name, &orn->loc);
12875 : 20 : continue;
12876 : : }
12877 : : }
12878 : 325721 : }
12879 : :
12880 : :
12881 : : void
12882 : 13160 : gfc_resolve_oacc_directive (gfc_code *code, gfc_namespace *ns ATTRIBUTE_UNUSED)
12883 : : {
12884 : 13160 : resolve_oacc_directive_inside_omp_region (code);
12885 : :
12886 : 13160 : switch (code->op)
12887 : : {
12888 : 7347 : case EXEC_OACC_PARALLEL:
12889 : 7347 : case EXEC_OACC_KERNELS:
12890 : 7347 : case EXEC_OACC_SERIAL:
12891 : 7347 : case EXEC_OACC_DATA:
12892 : 7347 : case EXEC_OACC_HOST_DATA:
12893 : 7347 : case EXEC_OACC_UPDATE:
12894 : 7347 : case EXEC_OACC_ENTER_DATA:
12895 : 7347 : case EXEC_OACC_EXIT_DATA:
12896 : 7347 : case EXEC_OACC_WAIT:
12897 : 7347 : case EXEC_OACC_CACHE:
12898 : 7347 : resolve_omp_clauses (code, code->ext.omp_clauses, NULL, true);
12899 : 7347 : break;
12900 : 5270 : case EXEC_OACC_PARALLEL_LOOP:
12901 : 5270 : case EXEC_OACC_KERNELS_LOOP:
12902 : 5270 : case EXEC_OACC_SERIAL_LOOP:
12903 : 5270 : case EXEC_OACC_LOOP:
12904 : 5270 : resolve_oacc_loop (code);
12905 : 5270 : break;
12906 : 543 : case EXEC_OACC_ATOMIC:
12907 : 543 : resolve_omp_atomic (code);
12908 : 543 : break;
12909 : : default:
12910 : : break;
12911 : : }
12912 : 13160 : }
12913 : :
12914 : :
12915 : : static void
12916 : 1798 : resolve_omp_target (gfc_code *code)
12917 : : {
12918 : : #define GFC_IS_TEAMS_CONSTRUCT(op) \
12919 : : (op == EXEC_OMP_TEAMS \
12920 : : || op == EXEC_OMP_TEAMS_DISTRIBUTE \
12921 : : || op == EXEC_OMP_TEAMS_DISTRIBUTE_SIMD \
12922 : : || op == EXEC_OMP_TEAMS_DISTRIBUTE_PARALLEL_DO \
12923 : : || op == EXEC_OMP_TEAMS_DISTRIBUTE_PARALLEL_DO_SIMD \
12924 : : || op == EXEC_OMP_TEAMS_LOOP)
12925 : :
12926 : 1798 : if (!code->ext.omp_clauses->contains_teams_construct)
12927 : : return;
12928 : 203 : gfc_code *c = code->block->next;
12929 : 203 : if (c->op == EXEC_BLOCK)
12930 : 30 : c = c->ext.block.ns->code;
12931 : 203 : if (code->ext.omp_clauses->target_first_st_is_teams_or_meta)
12932 : : {
12933 : 192 : if (c->op == EXEC_OMP_METADIRECTIVE)
12934 : : {
12935 : 15 : struct gfc_omp_variant *mc
12936 : : = c->ext.omp_variants;
12937 : : /* All mc->(next...->)code should be identical with regards
12938 : : to the diagnostic below. */
12939 : 16 : do
12940 : : {
12941 : 16 : if (mc->stmt != ST_NONE
12942 : 15 : && GFC_IS_TEAMS_CONSTRUCT (mc->code->op))
12943 : : {
12944 : 14 : if (c->next == NULL && mc->code->next == NULL)
12945 : : return;
12946 : : c = mc->code;
12947 : : break;
12948 : : }
12949 : 2 : mc = mc->next;
12950 : : }
12951 : 2 : while (mc);
12952 : : }
12953 : 177 : else if (GFC_IS_TEAMS_CONSTRUCT (c->op) && c->next == NULL)
12954 : : return;
12955 : : }
12956 : :
12957 : 31 : while (c && !GFC_IS_TEAMS_CONSTRUCT (c->op))
12958 : 8 : c = c->next;
12959 : 23 : if (c)
12960 : 19 : gfc_error ("!$OMP TARGET region at %L with a nested TEAMS at %L may not "
12961 : : "contain any other statement, declaration or directive outside "
12962 : : "of the single TEAMS construct", &c->loc, &code->loc);
12963 : : else
12964 : 4 : gfc_error ("!$OMP TARGET region at %L with a nested TEAMS may not "
12965 : : "contain any other statement, declaration or directive outside "
12966 : : "of the single TEAMS construct", &code->loc);
12967 : : #undef GFC_IS_TEAMS_CONSTRUCT
12968 : : }
12969 : :
12970 : : static void
12971 : 154 : resolve_omp_dispatch (gfc_code *code)
12972 : : {
12973 : 154 : gfc_code *next = code->block->next;
12974 : 154 : if (next == NULL)
12975 : : return;
12976 : :
12977 : 151 : gfc_exec_op op = next->op;
12978 : 151 : gcc_assert (op == EXEC_CALL || op == EXEC_ASSIGN);
12979 : 151 : if (op != EXEC_CALL
12980 : 74 : && (op != EXEC_ASSIGN || next->expr2->expr_type != EXPR_FUNCTION))
12981 : 3 : gfc_error (
12982 : : "%<OMP DISPATCH%> directive at %L must be followed by a procedure "
12983 : : "call with optional assignment",
12984 : : &code->loc);
12985 : :
12986 : 77 : if ((op == EXEC_CALL && next->resolved_sym != NULL
12987 : 76 : && next->resolved_sym->attr.proc_pointer)
12988 : 150 : || (op == EXEC_ASSIGN && gfc_expr_attr (next->expr2).proc_pointer))
12989 : 1 : gfc_error ("%<OMP DISPATCH%> directive at %L cannot be followed by a "
12990 : : "procedure pointer",
12991 : : &code->loc);
12992 : : }
12993 : :
12994 : : /* Resolve OpenMP directive clauses and check various requirements
12995 : : of each directive. */
12996 : :
12997 : : void
12998 : 20523 : gfc_resolve_omp_directive (gfc_code *code, gfc_namespace *ns)
12999 : : {
13000 : 20523 : resolve_omp_directive_inside_oacc_region (code);
13001 : :
13002 : 20523 : if (code->op != EXEC_OMP_ATOMIC)
13003 : 18369 : gfc_maybe_initialize_eh ();
13004 : :
13005 : 20523 : switch (code->op)
13006 : : {
13007 : 5410 : case EXEC_OMP_DISTRIBUTE:
13008 : 5410 : case EXEC_OMP_DISTRIBUTE_PARALLEL_DO:
13009 : 5410 : case EXEC_OMP_DISTRIBUTE_PARALLEL_DO_SIMD:
13010 : 5410 : case EXEC_OMP_DISTRIBUTE_SIMD:
13011 : 5410 : case EXEC_OMP_DO:
13012 : 5410 : case EXEC_OMP_DO_SIMD:
13013 : 5410 : case EXEC_OMP_LOOP:
13014 : 5410 : case EXEC_OMP_PARALLEL_DO:
13015 : 5410 : case EXEC_OMP_PARALLEL_DO_SIMD:
13016 : 5410 : case EXEC_OMP_PARALLEL_LOOP:
13017 : 5410 : case EXEC_OMP_PARALLEL_MASKED_TASKLOOP:
13018 : 5410 : case EXEC_OMP_PARALLEL_MASKED_TASKLOOP_SIMD:
13019 : 5410 : case EXEC_OMP_PARALLEL_MASTER_TASKLOOP:
13020 : 5410 : case EXEC_OMP_PARALLEL_MASTER_TASKLOOP_SIMD:
13021 : 5410 : case EXEC_OMP_MASKED_TASKLOOP:
13022 : 5410 : case EXEC_OMP_MASKED_TASKLOOP_SIMD:
13023 : 5410 : case EXEC_OMP_MASTER_TASKLOOP:
13024 : 5410 : case EXEC_OMP_MASTER_TASKLOOP_SIMD:
13025 : 5410 : case EXEC_OMP_SIMD:
13026 : 5410 : case EXEC_OMP_TARGET_PARALLEL_DO:
13027 : 5410 : case EXEC_OMP_TARGET_PARALLEL_DO_SIMD:
13028 : 5410 : case EXEC_OMP_TARGET_PARALLEL_LOOP:
13029 : 5410 : case EXEC_OMP_TARGET_SIMD:
13030 : 5410 : case EXEC_OMP_TARGET_TEAMS_DISTRIBUTE:
13031 : 5410 : case EXEC_OMP_TARGET_TEAMS_DISTRIBUTE_PARALLEL_DO:
13032 : 5410 : case EXEC_OMP_TARGET_TEAMS_DISTRIBUTE_PARALLEL_DO_SIMD:
13033 : 5410 : case EXEC_OMP_TARGET_TEAMS_DISTRIBUTE_SIMD:
13034 : 5410 : case EXEC_OMP_TARGET_TEAMS_LOOP:
13035 : 5410 : case EXEC_OMP_TASKLOOP:
13036 : 5410 : case EXEC_OMP_TASKLOOP_SIMD:
13037 : 5410 : case EXEC_OMP_TEAMS_DISTRIBUTE:
13038 : 5410 : case EXEC_OMP_TEAMS_DISTRIBUTE_PARALLEL_DO:
13039 : 5410 : case EXEC_OMP_TEAMS_DISTRIBUTE_PARALLEL_DO_SIMD:
13040 : 5410 : case EXEC_OMP_TEAMS_DISTRIBUTE_SIMD:
13041 : 5410 : case EXEC_OMP_TEAMS_LOOP:
13042 : 5410 : case EXEC_OMP_TILE:
13043 : 5410 : case EXEC_OMP_UNROLL:
13044 : 5410 : resolve_omp_do (code);
13045 : 5410 : break;
13046 : 1798 : case EXEC_OMP_TARGET:
13047 : 1798 : resolve_omp_target (code);
13048 : 9588 : gcc_fallthrough ();
13049 : 9588 : case EXEC_OMP_ALLOCATE:
13050 : 9588 : case EXEC_OMP_ALLOCATORS:
13051 : 9588 : case EXEC_OMP_ASSUME:
13052 : 9588 : case EXEC_OMP_CANCEL:
13053 : 9588 : case EXEC_OMP_ERROR:
13054 : 9588 : case EXEC_OMP_INTEROP:
13055 : 9588 : case EXEC_OMP_MASKED:
13056 : 9588 : case EXEC_OMP_ORDERED:
13057 : 9588 : case EXEC_OMP_PARALLEL_WORKSHARE:
13058 : 9588 : case EXEC_OMP_PARALLEL:
13059 : 9588 : case EXEC_OMP_PARALLEL_MASKED:
13060 : 9588 : case EXEC_OMP_PARALLEL_MASTER:
13061 : 9588 : case EXEC_OMP_PARALLEL_SECTIONS:
13062 : 9588 : case EXEC_OMP_SCOPE:
13063 : 9588 : case EXEC_OMP_SECTIONS:
13064 : 9588 : case EXEC_OMP_SINGLE:
13065 : 9588 : case EXEC_OMP_TARGET_DATA:
13066 : 9588 : case EXEC_OMP_TARGET_ENTER_DATA:
13067 : 9588 : case EXEC_OMP_TARGET_EXIT_DATA:
13068 : 9588 : case EXEC_OMP_TARGET_PARALLEL:
13069 : 9588 : case EXEC_OMP_TARGET_TEAMS:
13070 : 9588 : case EXEC_OMP_TASK:
13071 : 9588 : case EXEC_OMP_TASKWAIT:
13072 : 9588 : case EXEC_OMP_TEAMS:
13073 : 9588 : case EXEC_OMP_WORKSHARE:
13074 : 9588 : case EXEC_OMP_DEPOBJ:
13075 : 9588 : if (code->ext.omp_clauses)
13076 : 9455 : resolve_omp_clauses (code, code->ext.omp_clauses, NULL);
13077 : : break;
13078 : 1704 : case EXEC_OMP_TARGET_UPDATE:
13079 : 1704 : if (code->ext.omp_clauses)
13080 : 1704 : resolve_omp_clauses (code, code->ext.omp_clauses, NULL);
13081 : 1704 : if (code->ext.omp_clauses == NULL
13082 : 1704 : || (code->ext.omp_clauses->lists[OMP_LIST_TO] == NULL
13083 : 992 : && code->ext.omp_clauses->lists[OMP_LIST_FROM] == NULL))
13084 : 0 : gfc_error ("OMP TARGET UPDATE at %L requires at least one TO or "
13085 : : "FROM clause", &code->loc);
13086 : : break;
13087 : 2154 : case EXEC_OMP_ATOMIC:
13088 : 2154 : resolve_omp_clauses (code, code->block->ext.omp_clauses, NULL);
13089 : 2154 : resolve_omp_atomic (code);
13090 : 2154 : break;
13091 : 159 : case EXEC_OMP_CRITICAL:
13092 : 159 : resolve_omp_clauses (code, code->ext.omp_clauses, NULL);
13093 : 159 : if (!code->ext.omp_clauses->critical_name
13094 : 112 : && code->ext.omp_clauses->hint
13095 : 3 : && code->ext.omp_clauses->hint->ts.type == BT_INTEGER
13096 : 3 : && code->ext.omp_clauses->hint->expr_type == EXPR_CONSTANT
13097 : 3 : && mpz_sgn (code->ext.omp_clauses->hint->value.integer) != 0)
13098 : 1 : gfc_error ("OMP CRITICAL at %L with HINT clause requires a NAME, "
13099 : : "except when omp_sync_hint_none is used", &code->loc);
13100 : : break;
13101 : 49 : case EXEC_OMP_SCAN:
13102 : : /* Flag is only used to checking, hence, it is unset afterwards. */
13103 : 49 : if (!code->ext.omp_clauses->if_present)
13104 : 10 : gfc_error ("Unexpected !$OMP SCAN at %L outside loop construct with "
13105 : : "%<inscan%> REDUCTION clause", &code->loc);
13106 : 49 : code->ext.omp_clauses->if_present = false;
13107 : 49 : resolve_omp_clauses (code, code->ext.omp_clauses, ns);
13108 : 49 : break;
13109 : 154 : case EXEC_OMP_DISPATCH:
13110 : 154 : if (code->ext.omp_clauses)
13111 : 154 : resolve_omp_clauses (code, code->ext.omp_clauses, ns);
13112 : 154 : resolve_omp_dispatch (code);
13113 : 154 : break;
13114 : 138 : case EXEC_OMP_METADIRECTIVE:
13115 : 138 : resolve_omp_metadirective (code, ns);
13116 : 138 : break;
13117 : : default:
13118 : : break;
13119 : : }
13120 : 20523 : }
13121 : :
13122 : : /* Resolve !$omp declare {variant|simd} constructs in NS.
13123 : : Note that !$omp declare target is resolved in resolve_symbol. */
13124 : :
13125 : : void
13126 : 336401 : gfc_resolve_omp_declare (gfc_namespace *ns)
13127 : : {
13128 : 336401 : gfc_omp_declare_simd *ods;
13129 : 336637 : for (ods = ns->omp_declare_simd; ods; ods = ods->next)
13130 : : {
13131 : 236 : if (ods->proc_name != NULL
13132 : 196 : && ods->proc_name != ns->proc_name)
13133 : 6 : gfc_error ("!$OMP DECLARE SIMD should refer to containing procedure "
13134 : : "%qs at %L", ns->proc_name->name, &ods->where);
13135 : 236 : if (ods->clauses)
13136 : 218 : resolve_omp_clauses (NULL, ods->clauses, ns);
13137 : : }
13138 : :
13139 : 336401 : gfc_omp_declare_variant *odv;
13140 : 336401 : gfc_omp_namelist *range_begin = NULL;
13141 : :
13142 : 336854 : for (odv = ns->omp_declare_variant; odv; odv = odv->next)
13143 : 453 : gfc_resolve_omp_context_selector (odv->set_selectors, false, nullptr);
13144 : 336854 : for (odv = ns->omp_declare_variant; odv; odv = odv->next)
13145 : 656 : for (gfc_omp_namelist *n = odv->adjust_args_list; n != NULL; n = n->next)
13146 : : {
13147 : 203 : if ((n->expr == NULL
13148 : 6 : && (range_begin
13149 : 4 : || n->u.adj_args.range_start
13150 : 1 : || n->u.adj_args.omp_num_args_plus
13151 : 1 : || n->u.adj_args.omp_num_args_minus))
13152 : 198 : || n->u.adj_args.error_p)
13153 : : {
13154 : : }
13155 : 197 : else if (range_begin
13156 : 191 : || n->u.adj_args.range_start
13157 : 186 : || n->u.adj_args.omp_num_args_plus
13158 : 186 : || n->u.adj_args.omp_num_args_minus)
13159 : : {
13160 : 11 : if (!n->expr
13161 : 11 : || !gfc_resolve_expr (n->expr)
13162 : 11 : || n->expr->expr_type != EXPR_CONSTANT
13163 : 10 : || n->expr->ts.type != BT_INTEGER
13164 : 10 : || n->expr->rank != 0
13165 : 10 : || mpz_sgn (n->expr->value.integer) < 0
13166 : 20 : || ((n->u.adj_args.omp_num_args_plus
13167 : 8 : || n->u.adj_args.omp_num_args_minus)
13168 : 5 : && mpz_sgn (n->expr->value.integer) == 0))
13169 : : {
13170 : 2 : if (n->u.adj_args.omp_num_args_plus
13171 : 2 : || n->u.adj_args.omp_num_args_minus)
13172 : 0 : gfc_error ("Expected constant non-negative scalar integer "
13173 : : "offset expression at %L", &n->where);
13174 : : else
13175 : 2 : gfc_error ("For range-based %<adjust_args%>, a constant "
13176 : : "positive scalar integer expression is required "
13177 : : "at %L", &n->where);
13178 : : }
13179 : : }
13180 : 186 : else if (n->expr
13181 : 186 : && n->expr->expr_type == EXPR_CONSTANT
13182 : 21 : && n->expr->ts.type == BT_INTEGER
13183 : 20 : && mpz_sgn (n->expr->value.integer) > 0)
13184 : : {
13185 : : }
13186 : 166 : else if (!n->expr
13187 : 166 : || !gfc_resolve_expr (n->expr)
13188 : 331 : || n->expr->expr_type != EXPR_VARIABLE)
13189 : 2 : gfc_error ("Expected dummy parameter name or a positive integer "
13190 : : "at %L", &n->where);
13191 : 164 : else if (n->expr->expr_type == EXPR_VARIABLE)
13192 : 164 : n->sym = n->expr->symtree->n.sym;
13193 : :
13194 : 203 : range_begin = n->u.adj_args.range_start ? n : NULL;
13195 : : }
13196 : 336401 : }
13197 : :
13198 : : struct omp_udr_callback_data
13199 : : {
13200 : : gfc_omp_udr *omp_udr;
13201 : : bool is_initializer;
13202 : : };
13203 : :
13204 : : static int
13205 : 3598 : omp_udr_callback (gfc_expr **e, int *walk_subtrees ATTRIBUTE_UNUSED,
13206 : : void *data)
13207 : : {
13208 : 3598 : struct omp_udr_callback_data *cd = (struct omp_udr_callback_data *) data;
13209 : 3598 : if ((*e)->expr_type == EXPR_VARIABLE)
13210 : : {
13211 : 2203 : if (cd->is_initializer)
13212 : : {
13213 : 535 : if ((*e)->symtree->n.sym != cd->omp_udr->omp_priv
13214 : 140 : && (*e)->symtree->n.sym != cd->omp_udr->omp_orig)
13215 : 4 : gfc_error ("Variable other than OMP_PRIV or OMP_ORIG used in "
13216 : : "INITIALIZER clause of !$OMP DECLARE REDUCTION at %L",
13217 : : &(*e)->where);
13218 : : }
13219 : : else
13220 : : {
13221 : 1668 : if ((*e)->symtree->n.sym != cd->omp_udr->omp_out
13222 : 597 : && (*e)->symtree->n.sym != cd->omp_udr->omp_in)
13223 : 6 : gfc_error ("Variable other than OMP_OUT or OMP_IN used in "
13224 : : "combiner of !$OMP DECLARE REDUCTION at %L",
13225 : : &(*e)->where);
13226 : : }
13227 : : }
13228 : 3598 : return 0;
13229 : : }
13230 : :
13231 : : /* Resolve !$omp declare reduction constructs. */
13232 : :
13233 : : static void
13234 : 600 : gfc_resolve_omp_udr (gfc_omp_udr *omp_udr)
13235 : : {
13236 : 600 : gfc_actual_arglist *a;
13237 : 600 : const char *predef_name = NULL;
13238 : :
13239 : 600 : switch (omp_udr->rop)
13240 : : {
13241 : 599 : case OMP_REDUCTION_PLUS:
13242 : 599 : case OMP_REDUCTION_TIMES:
13243 : 599 : case OMP_REDUCTION_MINUS:
13244 : 599 : case OMP_REDUCTION_AND:
13245 : 599 : case OMP_REDUCTION_OR:
13246 : 599 : case OMP_REDUCTION_EQV:
13247 : 599 : case OMP_REDUCTION_NEQV:
13248 : 599 : case OMP_REDUCTION_MAX:
13249 : 599 : case OMP_REDUCTION_USER:
13250 : 599 : break;
13251 : 1 : default:
13252 : 1 : gfc_error ("Invalid operator for !$OMP DECLARE REDUCTION %s at %L",
13253 : : omp_udr->name, &omp_udr->where);
13254 : 22 : return;
13255 : : }
13256 : :
13257 : 599 : if (gfc_omp_udr_predef (omp_udr->rop, omp_udr->name,
13258 : : &omp_udr->ts, &predef_name))
13259 : : {
13260 : 18 : if (predef_name)
13261 : 18 : gfc_error_now ("Redefinition of predefined %s "
13262 : : "!$OMP DECLARE REDUCTION at %L",
13263 : : predef_name, &omp_udr->where);
13264 : : else
13265 : 0 : gfc_error_now ("Redefinition of predefined "
13266 : : "!$OMP DECLARE REDUCTION at %L", &omp_udr->where);
13267 : 18 : return;
13268 : : }
13269 : :
13270 : 581 : if (omp_udr->ts.type == BT_CHARACTER
13271 : 62 : && omp_udr->ts.u.cl->length
13272 : 32 : && omp_udr->ts.u.cl->length->expr_type != EXPR_CONSTANT)
13273 : : {
13274 : 1 : gfc_error ("CHARACTER length in !$OMP DECLARE REDUCTION %s not "
13275 : : "constant at %L", omp_udr->name, &omp_udr->where);
13276 : 1 : return;
13277 : : }
13278 : :
13279 : 580 : struct omp_udr_callback_data cd;
13280 : 580 : cd.omp_udr = omp_udr;
13281 : 580 : cd.is_initializer = false;
13282 : 580 : gfc_code_walker (&omp_udr->combiner_ns->code, gfc_dummy_code_callback,
13283 : : omp_udr_callback, &cd);
13284 : 580 : if (omp_udr->combiner_ns->code->op == EXEC_CALL)
13285 : : {
13286 : 346 : for (a = omp_udr->combiner_ns->code->ext.actual; a; a = a->next)
13287 : 237 : if (a->expr == NULL)
13288 : : break;
13289 : 110 : if (a)
13290 : 1 : gfc_error ("Subroutine call with alternate returns in combiner "
13291 : : "of !$OMP DECLARE REDUCTION at %L",
13292 : : &omp_udr->combiner_ns->code->loc);
13293 : : }
13294 : 580 : if (omp_udr->initializer_ns)
13295 : : {
13296 : 373 : cd.is_initializer = true;
13297 : 373 : gfc_code_walker (&omp_udr->initializer_ns->code, gfc_dummy_code_callback,
13298 : : omp_udr_callback, &cd);
13299 : 373 : if (omp_udr->initializer_ns->code->op == EXEC_CALL)
13300 : : {
13301 : 377 : for (a = omp_udr->initializer_ns->code->ext.actual; a; a = a->next)
13302 : 243 : if (a->expr == NULL)
13303 : : break;
13304 : 135 : if (a)
13305 : 1 : gfc_error ("Subroutine call with alternate returns in "
13306 : : "INITIALIZER clause of !$OMP DECLARE REDUCTION "
13307 : : "at %L", &omp_udr->initializer_ns->code->loc);
13308 : 136 : for (a = omp_udr->initializer_ns->code->ext.actual; a; a = a->next)
13309 : 135 : if (a->expr
13310 : 135 : && a->expr->expr_type == EXPR_VARIABLE
13311 : 135 : && a->expr->symtree->n.sym == omp_udr->omp_priv
13312 : 134 : && a->expr->ref == NULL)
13313 : : break;
13314 : 135 : if (a == NULL)
13315 : 1 : gfc_error ("One of actual subroutine arguments in INITIALIZER "
13316 : : "clause of !$OMP DECLARE REDUCTION must be OMP_PRIV "
13317 : : "at %L", &omp_udr->initializer_ns->code->loc);
13318 : : }
13319 : : }
13320 : 207 : else if (omp_udr->ts.type == BT_DERIVED
13321 : 207 : && !gfc_has_default_initializer (omp_udr->ts.u.derived))
13322 : : {
13323 : 1 : gfc_error ("Missing INITIALIZER clause for !$OMP DECLARE REDUCTION "
13324 : : "of derived type without default initializer at %L",
13325 : : &omp_udr->where);
13326 : 1 : return;
13327 : : }
13328 : : }
13329 : :
13330 : : void
13331 : 337409 : gfc_resolve_omp_udrs (gfc_symtree *st)
13332 : : {
13333 : 337409 : gfc_omp_udr *omp_udr;
13334 : :
13335 : 337409 : if (st == NULL)
13336 : : return;
13337 : 504 : gfc_resolve_omp_udrs (st->left);
13338 : 504 : gfc_resolve_omp_udrs (st->right);
13339 : 1104 : for (omp_udr = st->n.omp_udr; omp_udr; omp_udr = omp_udr->next)
13340 : 600 : gfc_resolve_omp_udr (omp_udr);
13341 : : }
|
