Line data Source code
1 : /* OpenMP directive matching and resolving.
2 : Copyright (C) 2005-2026 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 : {"groupprivate", GFC_OMP_DIR_DECLARATIVE, ST_OMP_GROUPPRIVATE},
88 : /* {"interchange", GFC_OMP_DIR_EXECUTABLE, ST_OMP_INTERCHANGE}, */
89 : {"interop", GFC_OMP_DIR_EXECUTABLE, ST_OMP_INTEROP},
90 : {"loop", GFC_OMP_DIR_EXECUTABLE, ST_OMP_LOOP},
91 : {"masked", GFC_OMP_DIR_EXECUTABLE, ST_OMP_MASKED},
92 : {"metadirective", GFC_OMP_DIR_META, ST_OMP_METADIRECTIVE},
93 : /* Note: gfc_match_omp_nothing returns ST_NONE. */
94 : {"nothing", GFC_OMP_DIR_UTILITY, ST_OMP_NOTHING},
95 : /* Special case; for now map to the first one.
96 : ordered-blockassoc = ST_OMP_ORDERED
97 : ordered-standalone = ST_OMP_ORDERED_DEPEND + depend/doacross. */
98 : {"ordered", GFC_OMP_DIR_EXECUTABLE, ST_OMP_ORDERED},
99 : {"parallel", GFC_OMP_DIR_EXECUTABLE, ST_OMP_PARALLEL},
100 : {"requires", GFC_OMP_DIR_INFORMATIONAL, ST_OMP_REQUIRES},
101 : {"scan", GFC_OMP_DIR_SUBSIDIARY, ST_OMP_SCAN},
102 : {"scope", GFC_OMP_DIR_EXECUTABLE, ST_OMP_SCOPE},
103 : {"sections", GFC_OMP_DIR_EXECUTABLE, ST_OMP_SECTIONS},
104 : {"section", GFC_OMP_DIR_SUBSIDIARY, ST_OMP_SECTION},
105 : {"simd", GFC_OMP_DIR_EXECUTABLE, ST_OMP_SIMD},
106 : {"single", GFC_OMP_DIR_EXECUTABLE, ST_OMP_SINGLE},
107 : /* {"split", GFC_OMP_DIR_EXECUTABLE, ST_OMP_SPLIT}, */
108 : /* {"strip", GFC_OMP_DIR_EXECUTABLE, ST_OMP_STRIP}, */
109 : {"target data", GFC_OMP_DIR_EXECUTABLE, ST_OMP_TARGET_DATA},
110 : {"target enter data", GFC_OMP_DIR_EXECUTABLE, ST_OMP_TARGET_ENTER_DATA},
111 : {"target exit data", GFC_OMP_DIR_EXECUTABLE, ST_OMP_TARGET_EXIT_DATA},
112 : {"target update", GFC_OMP_DIR_EXECUTABLE, ST_OMP_TARGET_UPDATE},
113 : {"target", GFC_OMP_DIR_EXECUTABLE, ST_OMP_TARGET},
114 : /* {"taskgraph", GFC_OMP_DIR_EXECUTABLE, ST_OMP_TASKGRAPH}, */
115 : /* {"task iteration", GFC_OMP_DIR_EXECUTABLE, ST_OMP_TASK_ITERATION}, */
116 : {"taskloop", GFC_OMP_DIR_EXECUTABLE, ST_OMP_TASKLOOP},
117 : {"taskwait", GFC_OMP_DIR_EXECUTABLE, ST_OMP_TASKWAIT},
118 : {"taskyield", GFC_OMP_DIR_EXECUTABLE, ST_OMP_TASKYIELD},
119 : {"task", GFC_OMP_DIR_EXECUTABLE, ST_OMP_TASK},
120 : {"teams", GFC_OMP_DIR_EXECUTABLE, ST_OMP_TEAMS},
121 : {"threadprivate", GFC_OMP_DIR_DECLARATIVE, ST_OMP_THREADPRIVATE},
122 : {"tile", GFC_OMP_DIR_EXECUTABLE, ST_OMP_TILE},
123 : {"unroll", GFC_OMP_DIR_EXECUTABLE, ST_OMP_UNROLL},
124 : /* {"workdistribute", GFC_OMP_DIR_EXECUTABLE, ST_OMP_WORKDISTRIBUTE}, */
125 : {"workshare", GFC_OMP_DIR_EXECUTABLE, ST_OMP_WORKSHARE},
126 : };
127 :
128 :
129 : /* Match an end of OpenMP directive. End of OpenMP directive is optional
130 : whitespace, followed by '\n' or comment '!'. In the special case where a
131 : context selector is being matched, match against ')' instead. */
132 :
133 : static match
134 54739 : gfc_match_omp_eos (void)
135 : {
136 54739 : locus old_loc;
137 54739 : char c;
138 :
139 54739 : old_loc = gfc_current_locus;
140 54739 : gfc_gobble_whitespace ();
141 :
142 54739 : if (gfc_matching_omp_context_selector)
143 : {
144 269 : if (gfc_peek_ascii_char () == ')')
145 : return MATCH_YES;
146 : }
147 : else
148 : {
149 54470 : c = gfc_next_ascii_char ();
150 54470 : switch (c)
151 : {
152 0 : case '!':
153 0 : do
154 0 : c = gfc_next_ascii_char ();
155 0 : while (c != '\n');
156 : /* Fall through */
157 :
158 52765 : case '\n':
159 52765 : return MATCH_YES;
160 : }
161 : }
162 :
163 1706 : gfc_current_locus = old_loc;
164 1706 : return MATCH_NO;
165 : }
166 :
167 : match
168 13141 : gfc_match_omp_eos_error (void)
169 : {
170 13141 : if (gfc_match_omp_eos() == MATCH_YES)
171 : return MATCH_YES;
172 :
173 35 : gfc_error ("Unexpected junk at %C");
174 35 : return MATCH_ERROR;
175 : }
176 :
177 :
178 : /* Free an omp_clauses structure. */
179 :
180 : void
181 60856 : gfc_free_omp_clauses (gfc_omp_clauses *c)
182 : {
183 60856 : int i;
184 60856 : if (c == NULL)
185 : return;
186 :
187 34244 : gfc_free_expr (c->if_expr);
188 410928 : for (i = 0; i < OMP_IF_LAST; i++)
189 342440 : gfc_free_expr (c->if_exprs[i]);
190 34244 : gfc_free_expr (c->self_expr);
191 34244 : gfc_free_expr (c->final_expr);
192 34244 : gfc_free_expr (c->num_threads);
193 34244 : gfc_free_expr (c->chunk_size);
194 34244 : gfc_free_expr (c->safelen_expr);
195 34244 : gfc_free_expr (c->simdlen_expr);
196 34244 : gfc_free_expr (c->num_teams_lower);
197 34244 : gfc_free_expr (c->num_teams_upper);
198 34244 : gfc_free_expr (c->device);
199 34244 : gfc_free_expr (c->dyn_groupprivate);
200 34244 : gfc_free_expr (c->thread_limit);
201 34244 : gfc_free_expr (c->dist_chunk_size);
202 34244 : gfc_free_expr (c->grainsize);
203 34244 : gfc_free_expr (c->hint);
204 34244 : gfc_free_expr (c->num_tasks);
205 34244 : gfc_free_expr (c->priority);
206 34244 : gfc_free_expr (c->detach);
207 34244 : gfc_free_expr (c->novariants);
208 34244 : gfc_free_expr (c->nocontext);
209 34244 : gfc_free_expr (c->async_expr);
210 34244 : gfc_free_expr (c->gang_num_expr);
211 34244 : gfc_free_expr (c->gang_static_expr);
212 34244 : gfc_free_expr (c->worker_expr);
213 34244 : gfc_free_expr (c->vector_expr);
214 34244 : gfc_free_expr (c->num_gangs_expr);
215 34244 : gfc_free_expr (c->num_workers_expr);
216 34244 : gfc_free_expr (c->vector_length_expr);
217 1404004 : for (i = 0; i < OMP_LIST_NUM; i++)
218 1335516 : gfc_free_omp_namelist (c->lists[i],
219 1335516 : i == OMP_LIST_AFFINITY || i == OMP_LIST_DEPEND,
220 : i == OMP_LIST_ALLOCATE,
221 : i == OMP_LIST_USES_ALLOCATORS,
222 : i == OMP_LIST_INIT);
223 34244 : gfc_free_expr_list (c->wait_list);
224 34244 : gfc_free_expr_list (c->tile_list);
225 34244 : gfc_free_expr_list (c->sizes_list);
226 34244 : free (const_cast<char *> (c->critical_name));
227 34244 : if (c->assume)
228 : {
229 23 : free (c->assume->absent);
230 23 : free (c->assume->contains);
231 23 : gfc_free_expr_list (c->assume->holds);
232 23 : free (c->assume);
233 : }
234 34244 : free (c);
235 : }
236 :
237 : /* Free oacc_declare structures. */
238 :
239 : void
240 76 : gfc_free_oacc_declare_clauses (struct gfc_oacc_declare *oc)
241 : {
242 76 : struct gfc_oacc_declare *decl = oc;
243 :
244 76 : do
245 : {
246 76 : struct gfc_oacc_declare *next;
247 :
248 76 : next = decl->next;
249 76 : gfc_free_omp_clauses (decl->clauses);
250 76 : free (decl);
251 76 : decl = next;
252 : }
253 76 : while (decl);
254 76 : }
255 :
256 : /* Free expression list. */
257 : void
258 103678 : gfc_free_expr_list (gfc_expr_list *list)
259 : {
260 103678 : gfc_expr_list *n;
261 :
262 105081 : for (; list; list = n)
263 : {
264 1403 : n = list->next;
265 1403 : free (list);
266 : }
267 103678 : }
268 :
269 : /* Free an !$omp declare simd construct list. */
270 :
271 : void
272 236 : gfc_free_omp_declare_simd (gfc_omp_declare_simd *ods)
273 : {
274 236 : if (ods)
275 : {
276 236 : gfc_free_omp_clauses (ods->clauses);
277 236 : free (ods);
278 : }
279 236 : }
280 :
281 : void
282 515764 : gfc_free_omp_declare_simd_list (gfc_omp_declare_simd *list)
283 : {
284 516000 : while (list)
285 : {
286 236 : gfc_omp_declare_simd *current = list;
287 236 : list = list->next;
288 236 : gfc_free_omp_declare_simd (current);
289 : }
290 515764 : }
291 :
292 : static void
293 727 : gfc_free_omp_trait_property_list (gfc_omp_trait_property *list)
294 : {
295 1134 : while (list)
296 : {
297 407 : gfc_omp_trait_property *current = list;
298 407 : list = list->next;
299 407 : switch (current->property_kind)
300 : {
301 24 : case OMP_TRAIT_PROPERTY_ID:
302 24 : free (current->name);
303 24 : break;
304 261 : case OMP_TRAIT_PROPERTY_NAME_LIST:
305 261 : if (current->is_name)
306 168 : free (current->name);
307 : break;
308 15 : case OMP_TRAIT_PROPERTY_CLAUSE_LIST:
309 15 : gfc_free_omp_clauses (current->clauses);
310 15 : break;
311 : default:
312 : break;
313 : }
314 407 : free (current);
315 : }
316 727 : }
317 :
318 : static void
319 599 : gfc_free_omp_selector_list (gfc_omp_selector *list)
320 : {
321 1326 : while (list)
322 : {
323 727 : gfc_omp_selector *current = list;
324 727 : list = list->next;
325 727 : gfc_free_omp_trait_property_list (current->properties);
326 727 : free (current);
327 : }
328 599 : }
329 :
330 : static void
331 667 : gfc_free_omp_set_selector_list (gfc_omp_set_selector *list)
332 : {
333 1266 : while (list)
334 : {
335 599 : gfc_omp_set_selector *current = list;
336 599 : list = list->next;
337 599 : gfc_free_omp_selector_list (current->trait_selectors);
338 599 : free (current);
339 : }
340 667 : }
341 :
342 : /* Free an !$omp declare variant construct list. */
343 :
344 : void
345 515764 : gfc_free_omp_declare_variant_list (gfc_omp_declare_variant *list)
346 : {
347 516217 : while (list)
348 : {
349 453 : gfc_omp_declare_variant *current = list;
350 453 : list = list->next;
351 453 : gfc_free_omp_set_selector_list (current->set_selectors);
352 453 : gfc_free_omp_namelist (current->adjust_args_list, false, false, false,
353 : false);
354 453 : free (current);
355 : }
356 515764 : }
357 :
358 : /* Free an !$omp declare reduction. */
359 :
360 : void
361 1118 : gfc_free_omp_udr (gfc_omp_udr *omp_udr)
362 : {
363 1118 : if (omp_udr)
364 : {
365 607 : gfc_free_omp_udr (omp_udr->next);
366 607 : gfc_free_namespace (omp_udr->combiner_ns);
367 607 : if (omp_udr->initializer_ns)
368 377 : gfc_free_namespace (omp_udr->initializer_ns);
369 607 : free (omp_udr);
370 : }
371 1118 : }
372 :
373 : /* Free variants of an !$omp metadirective construct. */
374 :
375 : void
376 93 : gfc_free_omp_variants (gfc_omp_variant *variant)
377 : {
378 284 : while (variant)
379 : {
380 191 : gfc_omp_variant *next_variant = variant->next;
381 191 : gfc_free_omp_set_selector_list (variant->selectors);
382 191 : free (variant);
383 191 : variant = next_variant;
384 : }
385 93 : }
386 :
387 : static gfc_omp_udr *
388 4709 : gfc_find_omp_udr (gfc_namespace *ns, const char *name, gfc_typespec *ts)
389 : {
390 4709 : gfc_symtree *st;
391 :
392 4709 : if (ns == NULL)
393 467 : ns = gfc_current_ns;
394 5657 : do
395 : {
396 5657 : gfc_omp_udr *omp_udr;
397 :
398 5657 : st = gfc_find_symtree (ns->omp_udr_root, name);
399 5657 : if (st != NULL)
400 : {
401 934 : for (omp_udr = st->n.omp_udr; omp_udr; omp_udr = omp_udr->next)
402 934 : if (ts == NULL)
403 : return omp_udr;
404 567 : else if (gfc_compare_types (&omp_udr->ts, ts))
405 : {
406 479 : if (ts->type == BT_CHARACTER)
407 : {
408 60 : if (omp_udr->ts.u.cl->length == NULL)
409 : return omp_udr;
410 36 : if (ts->u.cl->length == NULL)
411 0 : continue;
412 36 : if (gfc_compare_expr (omp_udr->ts.u.cl->length,
413 : ts->u.cl->length,
414 : INTRINSIC_EQ) != 0)
415 12 : continue;
416 : }
417 443 : return omp_udr;
418 : }
419 : }
420 :
421 : /* Don't escape an interface block. */
422 4823 : if (ns && !ns->has_import_set
423 4823 : && ns->proc_name && ns->proc_name->attr.if_source == IFSRC_IFBODY)
424 : break;
425 :
426 4823 : ns = ns->parent;
427 : }
428 4823 : while (ns != NULL);
429 :
430 : return NULL;
431 : }
432 :
433 :
434 : /* Match a variable/common block list and construct a namelist from it;
435 : if has_all_memory != NULL, *has_all_memory is set and omp_all_memory
436 : yields a list->sym NULL entry. */
437 :
438 : static match
439 30914 : gfc_match_omp_variable_list (const char *str, gfc_omp_namelist **list,
440 : bool allow_common, bool *end_colon = NULL,
441 : gfc_omp_namelist ***headp = NULL,
442 : bool allow_sections = false,
443 : bool allow_derived = false,
444 : bool *has_all_memory = NULL,
445 : bool reject_common_vars = false,
446 : bool reverse_order = false)
447 : {
448 30914 : gfc_omp_namelist *head, *tail, *p;
449 30914 : locus old_loc, cur_loc;
450 30914 : char n[GFC_MAX_SYMBOL_LEN+1];
451 30914 : gfc_symbol *sym;
452 30914 : match m;
453 30914 : gfc_symtree *st;
454 :
455 30914 : head = tail = NULL;
456 :
457 30914 : old_loc = gfc_current_locus;
458 30914 : if (has_all_memory)
459 705 : *has_all_memory = false;
460 30914 : m = gfc_match (str);
461 30914 : if (m != MATCH_YES)
462 : return m;
463 :
464 37567 : for (;;)
465 : {
466 37567 : gfc_gobble_whitespace ();
467 37567 : cur_loc = gfc_current_locus;
468 :
469 37567 : m = gfc_match_name (n);
470 37567 : if (m == MATCH_YES && strcmp (n, "omp_all_memory") == 0)
471 : {
472 23 : locus loc = gfc_get_location_range (NULL, 0, &cur_loc, 1,
473 : &gfc_current_locus);
474 23 : if (!has_all_memory)
475 : {
476 2 : gfc_error ("%<omp_all_memory%> at %L not permitted in this "
477 : "clause", &loc);
478 2 : goto cleanup;
479 : }
480 21 : *has_all_memory = true;
481 21 : p = gfc_get_omp_namelist ();
482 21 : if (head == NULL)
483 : head = tail = p;
484 : else
485 : {
486 3 : tail->next = p;
487 3 : tail = tail->next;
488 : }
489 21 : tail->where = loc;
490 21 : goto next_item;
491 : }
492 37290 : if (m == MATCH_YES)
493 : {
494 37290 : gfc_symtree *st;
495 37290 : if ((m = gfc_get_ha_sym_tree (n, &st) ? MATCH_ERROR : MATCH_YES)
496 : == MATCH_YES)
497 37290 : sym = st->n.sym;
498 : }
499 37544 : switch (m)
500 : {
501 37290 : case MATCH_YES:
502 37290 : gfc_expr *expr;
503 37290 : expr = NULL;
504 37290 : gfc_gobble_whitespace ();
505 22747 : if ((allow_sections && gfc_peek_ascii_char () == '(')
506 55948 : || (allow_derived && gfc_peek_ascii_char () == '%'))
507 : {
508 6316 : gfc_current_locus = cur_loc;
509 6316 : m = gfc_match_variable (&expr, 0);
510 6316 : switch (m)
511 : {
512 4 : case MATCH_ERROR:
513 12 : goto cleanup;
514 0 : case MATCH_NO:
515 0 : goto syntax;
516 6312 : default:
517 6312 : break;
518 : }
519 6312 : if (gfc_is_coindexed (expr))
520 : {
521 5 : gfc_error ("List item shall not be coindexed at %L",
522 5 : &expr->where);
523 5 : goto cleanup;
524 : }
525 : }
526 37281 : gfc_set_sym_referenced (sym);
527 37281 : p = gfc_get_omp_namelist ();
528 37281 : if (head == NULL)
529 : head = tail = p;
530 10059 : else if (reverse_order)
531 : {
532 57 : p->next = head;
533 57 : head = p;
534 : }
535 : else
536 : {
537 10002 : tail->next = p;
538 10002 : tail = tail->next;
539 : }
540 37281 : p->sym = sym;
541 37281 : p->expr = expr;
542 37281 : p->where = gfc_get_location_range (NULL, 0, &cur_loc, 1,
543 : &gfc_current_locus);
544 37281 : if (reject_common_vars && sym->attr.in_common)
545 : {
546 3 : gcc_assert (allow_common);
547 3 : gfc_error ("%qs at %L is part of the common block %</%s/%> and "
548 : "may only be specificed implicitly via the named "
549 : "common block", sym->name, &cur_loc,
550 3 : sym->common_head->name);
551 3 : goto cleanup;
552 : }
553 37278 : goto next_item;
554 254 : case MATCH_NO:
555 254 : break;
556 0 : case MATCH_ERROR:
557 0 : goto cleanup;
558 : }
559 :
560 254 : if (!allow_common)
561 10 : goto syntax;
562 :
563 244 : m = gfc_match ("/ %n /", n);
564 244 : if (m == MATCH_ERROR)
565 0 : goto cleanup;
566 244 : if (m == MATCH_NO)
567 19 : goto syntax;
568 :
569 225 : cur_loc = gfc_get_location_range (NULL, 0, &cur_loc, 1,
570 : &gfc_current_locus);
571 225 : st = gfc_find_symtree (gfc_current_ns->common_root, n);
572 225 : if (st == NULL)
573 : {
574 2 : gfc_error ("COMMON block %</%s/%> not found at %L", n, &cur_loc);
575 2 : goto cleanup;
576 : }
577 724 : for (sym = st->n.common->head; sym; sym = sym->common_next)
578 : {
579 501 : gfc_set_sym_referenced (sym);
580 501 : p = gfc_get_omp_namelist ();
581 501 : if (head == NULL)
582 : head = tail = p;
583 325 : else if (reverse_order)
584 : {
585 0 : p->next = head;
586 0 : head = p;
587 : }
588 : else
589 : {
590 325 : tail->next = p;
591 325 : tail = tail->next;
592 : }
593 501 : p->sym = sym;
594 501 : p->where = cur_loc;
595 : }
596 :
597 223 : next_item:
598 37522 : if (end_colon && gfc_match_char (':') == MATCH_YES)
599 : {
600 793 : *end_colon = true;
601 793 : break;
602 : }
603 36729 : if (gfc_match_char (')') == MATCH_YES)
604 : break;
605 10128 : if (gfc_match_char (',') != MATCH_YES)
606 19 : goto syntax;
607 : }
608 :
609 36908 : while (*list)
610 9514 : list = &(*list)->next;
611 :
612 27394 : *list = head;
613 27394 : if (headp)
614 21564 : *headp = list;
615 : return MATCH_YES;
616 :
617 48 : syntax:
618 48 : gfc_error ("Syntax error in OpenMP variable list at %C");
619 :
620 64 : cleanup:
621 64 : gfc_free_omp_namelist (head, false, false, false, false);
622 64 : gfc_current_locus = old_loc;
623 64 : return MATCH_ERROR;
624 : }
625 :
626 : /* Match a variable/procedure/common block list and construct a namelist
627 : from it. */
628 :
629 : static match
630 360 : gfc_match_omp_to_link (const char *str, gfc_omp_namelist **list)
631 : {
632 360 : gfc_omp_namelist *head, *tail, *p;
633 360 : locus old_loc, cur_loc;
634 360 : char n[GFC_MAX_SYMBOL_LEN+1];
635 360 : gfc_symbol *sym;
636 360 : match m;
637 360 : gfc_symtree *st;
638 :
639 360 : head = tail = NULL;
640 :
641 360 : old_loc = gfc_current_locus;
642 :
643 360 : m = gfc_match (str);
644 360 : if (m != MATCH_YES)
645 : return m;
646 :
647 544 : for (;;)
648 : {
649 544 : cur_loc = gfc_current_locus;
650 544 : m = gfc_match_symbol (&sym, 1);
651 544 : switch (m)
652 : {
653 503 : case MATCH_YES:
654 503 : p = gfc_get_omp_namelist ();
655 503 : if (head == NULL)
656 : head = tail = p;
657 : else
658 : {
659 192 : tail->next = p;
660 192 : tail = tail->next;
661 : }
662 503 : tail->sym = sym;
663 503 : tail->where = cur_loc;
664 503 : goto next_item;
665 : case MATCH_NO:
666 : break;
667 0 : case MATCH_ERROR:
668 0 : goto cleanup;
669 : }
670 :
671 41 : m = gfc_match (" / %n /", n);
672 41 : if (m == MATCH_ERROR)
673 0 : goto cleanup;
674 41 : if (m == MATCH_NO)
675 0 : goto syntax;
676 :
677 41 : st = gfc_find_symtree (gfc_current_ns->common_root, n);
678 41 : if (st == NULL)
679 : {
680 0 : gfc_error ("COMMON block /%s/ not found at %C", n);
681 0 : goto cleanup;
682 : }
683 41 : p = gfc_get_omp_namelist ();
684 41 : if (head == NULL)
685 : head = tail = p;
686 : else
687 : {
688 4 : tail->next = p;
689 4 : tail = tail->next;
690 : }
691 41 : tail->u.common = st->n.common;
692 41 : tail->where = cur_loc;
693 :
694 544 : next_item:
695 544 : if (gfc_match_char (')') == MATCH_YES)
696 : break;
697 196 : if (gfc_match_char (',') != MATCH_YES)
698 0 : goto syntax;
699 : }
700 :
701 359 : while (*list)
702 11 : list = &(*list)->next;
703 :
704 348 : *list = head;
705 348 : return MATCH_YES;
706 :
707 0 : syntax:
708 0 : gfc_error ("Syntax error in OpenMP variable list at %C");
709 :
710 0 : cleanup:
711 0 : gfc_free_omp_namelist (head, false, false, false, false);
712 0 : gfc_current_locus = old_loc;
713 0 : return MATCH_ERROR;
714 : }
715 :
716 : /* Match detach(event-handle). */
717 :
718 : static match
719 126 : gfc_match_omp_detach (gfc_expr **expr)
720 : {
721 126 : locus old_loc = gfc_current_locus;
722 :
723 126 : if (gfc_match ("detach ( ") != MATCH_YES)
724 0 : goto syntax_error;
725 :
726 126 : if (gfc_match_variable (expr, 0) != MATCH_YES)
727 0 : goto syntax_error;
728 :
729 126 : if (gfc_match_char (')') != MATCH_YES)
730 0 : goto syntax_error;
731 :
732 : return MATCH_YES;
733 :
734 0 : syntax_error:
735 0 : gfc_error ("Syntax error in OpenMP detach clause at %C");
736 0 : gfc_current_locus = old_loc;
737 0 : return MATCH_ERROR;
738 :
739 : }
740 :
741 : /* Match doacross(sink : ...) construct a namelist from it;
742 : if depend is true, match legacy 'depend(sink : ...)'. */
743 :
744 : static match
745 241 : gfc_match_omp_doacross_sink (gfc_omp_namelist **list, bool depend)
746 : {
747 241 : char n[GFC_MAX_SYMBOL_LEN+1];
748 241 : gfc_omp_namelist *head, *tail, *p;
749 241 : locus old_loc, cur_loc;
750 241 : gfc_symbol *sym;
751 :
752 241 : head = tail = NULL;
753 :
754 241 : old_loc = gfc_current_locus;
755 :
756 2231 : for (;;)
757 : {
758 1236 : gfc_gobble_whitespace ();
759 1236 : cur_loc = gfc_current_locus;
760 :
761 1236 : if (gfc_match_name (n) != MATCH_YES)
762 1 : goto syntax;
763 1235 : locus loc = gfc_get_location_range (NULL, 0, &cur_loc, 1,
764 : &gfc_current_locus);
765 1235 : if (UNLIKELY (strcmp (n, "omp_all_memory") == 0))
766 : {
767 1 : gfc_error ("%<omp_all_memory%> used with dependence-type "
768 : "other than OUT or INOUT at %L", &loc);
769 1 : goto cleanup;
770 : }
771 1234 : sym = NULL;
772 1234 : if (!(strcmp (n, "omp_cur_iteration") == 0))
773 : {
774 1229 : gfc_symtree *st;
775 1229 : if (gfc_get_ha_sym_tree (n, &st))
776 0 : goto syntax;
777 1229 : sym = st->n.sym;
778 1229 : gfc_set_sym_referenced (sym);
779 : }
780 1234 : p = gfc_get_omp_namelist ();
781 1234 : if (head == NULL)
782 : {
783 239 : head = tail = p;
784 253 : head->u.depend_doacross_op = (depend ? OMP_DEPEND_SINK_FIRST
785 : : OMP_DOACROSS_SINK_FIRST);
786 : }
787 : else
788 : {
789 995 : tail->next = p;
790 995 : tail = tail->next;
791 995 : tail->u.depend_doacross_op = OMP_DOACROSS_SINK;
792 : }
793 1234 : tail->sym = sym;
794 1234 : tail->expr = NULL;
795 1234 : tail->where = loc;
796 1234 : if (gfc_match_char ('+') == MATCH_YES)
797 : {
798 154 : if (gfc_match_literal_constant (&tail->expr, 0) != MATCH_YES)
799 0 : goto syntax;
800 : }
801 1080 : else if (gfc_match_char ('-') == MATCH_YES)
802 : {
803 418 : if (gfc_match_literal_constant (&tail->expr, 0) != MATCH_YES)
804 1 : goto syntax;
805 417 : tail->expr = gfc_uminus (tail->expr);
806 : }
807 1233 : if (gfc_match_char (')') == MATCH_YES)
808 : break;
809 995 : if (gfc_match_char (',') != MATCH_YES)
810 0 : goto syntax;
811 995 : }
812 :
813 1030 : while (*list)
814 792 : list = &(*list)->next;
815 :
816 238 : *list = head;
817 238 : return MATCH_YES;
818 :
819 2 : syntax:
820 2 : gfc_error ("Syntax error in OpenMP SINK dependence-type list at %C");
821 :
822 3 : cleanup:
823 3 : gfc_free_omp_namelist (head, false, false, false, false);
824 3 : gfc_current_locus = old_loc;
825 3 : return MATCH_ERROR;
826 : }
827 :
828 : static match
829 819 : match_omp_oacc_expr_list (const char *str, gfc_expr_list **list,
830 : bool allow_asterisk, bool is_omp)
831 : {
832 819 : gfc_expr_list *head, *tail, *p;
833 819 : locus old_loc;
834 819 : gfc_expr *expr;
835 819 : match m;
836 :
837 819 : head = tail = NULL;
838 :
839 819 : old_loc = gfc_current_locus;
840 :
841 819 : m = gfc_match (str);
842 819 : if (m != MATCH_YES)
843 : return m;
844 :
845 1030 : for (;;)
846 : {
847 1030 : m = gfc_match_expr (&expr);
848 1030 : if (m == MATCH_YES || allow_asterisk)
849 : {
850 1018 : p = gfc_get_expr_list ();
851 1018 : if (head == NULL)
852 : head = tail = p;
853 : else
854 : {
855 335 : tail->next = p;
856 335 : tail = tail->next;
857 : }
858 1018 : if (m == MATCH_YES)
859 885 : tail->expr = expr;
860 133 : else if (gfc_match (" *") != MATCH_YES)
861 18 : goto syntax;
862 1000 : goto next_item;
863 : }
864 12 : if (m == MATCH_ERROR)
865 0 : goto cleanup;
866 12 : goto syntax;
867 :
868 1000 : next_item:
869 1000 : if (gfc_match_char (')') == MATCH_YES)
870 : break;
871 346 : if (gfc_match_char (',') != MATCH_YES)
872 6 : goto syntax;
873 : }
874 :
875 660 : while (*list)
876 6 : list = &(*list)->next;
877 :
878 654 : *list = head;
879 654 : return MATCH_YES;
880 :
881 36 : syntax:
882 36 : if (is_omp)
883 7 : gfc_error ("Syntax error in OpenMP expression list at %C");
884 : else
885 29 : gfc_error ("Syntax error in OpenACC expression list at %C");
886 :
887 36 : cleanup:
888 36 : gfc_free_expr_list (head);
889 36 : gfc_current_locus = old_loc;
890 36 : return MATCH_ERROR;
891 : }
892 :
893 : static match
894 3055 : match_oacc_clause_gwv (gfc_omp_clauses *cp, unsigned gwv)
895 : {
896 3055 : match ret = MATCH_YES;
897 :
898 3055 : if (gfc_match (" ( ") != MATCH_YES)
899 : return MATCH_NO;
900 :
901 470 : if (gwv == GOMP_DIM_GANG)
902 : {
903 : /* The gang clause accepts two optional arguments, num and static.
904 : The num argument may either be explicit (num: <val>) or
905 : implicit without (<val> without num:). */
906 :
907 457 : while (ret == MATCH_YES)
908 : {
909 236 : if (gfc_match (" static :") == MATCH_YES)
910 : {
911 114 : if (cp->gang_static)
912 : return MATCH_ERROR;
913 : else
914 113 : cp->gang_static = true;
915 113 : if (gfc_match_char ('*') == MATCH_YES)
916 18 : cp->gang_static_expr = NULL;
917 95 : else if (gfc_match (" %e ", &cp->gang_static_expr) != MATCH_YES)
918 : return MATCH_ERROR;
919 : }
920 : else
921 : {
922 122 : if (cp->gang_num_expr)
923 : return MATCH_ERROR;
924 :
925 : /* The 'num' argument is optional. */
926 121 : gfc_match (" num :");
927 :
928 121 : if (gfc_match (" %e ", &cp->gang_num_expr) != MATCH_YES)
929 : return MATCH_ERROR;
930 : }
931 :
932 231 : ret = gfc_match (" , ");
933 : }
934 : }
935 244 : else if (gwv == GOMP_DIM_WORKER)
936 : {
937 : /* The 'num' argument is optional. */
938 107 : gfc_match (" num :");
939 :
940 107 : if (gfc_match (" %e ", &cp->worker_expr) != MATCH_YES)
941 : return MATCH_ERROR;
942 : }
943 137 : else if (gwv == GOMP_DIM_VECTOR)
944 : {
945 : /* The 'length' argument is optional. */
946 137 : gfc_match (" length :");
947 :
948 137 : if (gfc_match (" %e ", &cp->vector_expr) != MATCH_YES)
949 : return MATCH_ERROR;
950 : }
951 : else
952 0 : gfc_fatal_error ("Unexpected OpenACC parallelism.");
953 :
954 459 : return gfc_match (" )");
955 : }
956 :
957 : static match
958 8 : gfc_match_oacc_clause_link (const char *str, gfc_omp_namelist **list)
959 : {
960 8 : gfc_omp_namelist *head = NULL;
961 8 : gfc_omp_namelist *tail, *p;
962 8 : locus old_loc;
963 8 : char n[GFC_MAX_SYMBOL_LEN+1];
964 8 : gfc_symbol *sym;
965 8 : match m;
966 8 : gfc_symtree *st;
967 :
968 8 : old_loc = gfc_current_locus;
969 :
970 8 : m = gfc_match (str);
971 8 : if (m != MATCH_YES)
972 : return m;
973 :
974 8 : m = gfc_match (" (");
975 :
976 14 : for (;;)
977 : {
978 14 : m = gfc_match_symbol (&sym, 0);
979 14 : switch (m)
980 : {
981 8 : case MATCH_YES:
982 8 : if (sym->attr.in_common)
983 : {
984 2 : gfc_error_now ("Variable at %C is an element of a COMMON block");
985 2 : goto cleanup;
986 : }
987 6 : gfc_set_sym_referenced (sym);
988 6 : p = gfc_get_omp_namelist ();
989 6 : if (head == NULL)
990 : head = tail = p;
991 : else
992 : {
993 4 : tail->next = p;
994 4 : tail = tail->next;
995 : }
996 6 : tail->sym = sym;
997 6 : tail->expr = NULL;
998 6 : tail->where = gfc_current_locus;
999 6 : goto next_item;
1000 : case MATCH_NO:
1001 : break;
1002 :
1003 0 : case MATCH_ERROR:
1004 0 : goto cleanup;
1005 : }
1006 :
1007 6 : m = gfc_match (" / %n /", n);
1008 6 : if (m == MATCH_ERROR)
1009 0 : goto cleanup;
1010 6 : if (m == MATCH_NO || n[0] == '\0')
1011 0 : goto syntax;
1012 :
1013 6 : st = gfc_find_symtree (gfc_current_ns->common_root, n);
1014 6 : if (st == NULL)
1015 : {
1016 1 : gfc_error ("COMMON block /%s/ not found at %C", n);
1017 1 : goto cleanup;
1018 : }
1019 :
1020 20 : for (sym = st->n.common->head; sym; sym = sym->common_next)
1021 : {
1022 15 : gfc_set_sym_referenced (sym);
1023 15 : p = gfc_get_omp_namelist ();
1024 15 : if (head == NULL)
1025 : head = tail = p;
1026 : else
1027 : {
1028 12 : tail->next = p;
1029 12 : tail = tail->next;
1030 : }
1031 15 : tail->sym = sym;
1032 15 : tail->where = gfc_current_locus;
1033 : }
1034 :
1035 5 : next_item:
1036 11 : if (gfc_match_char (')') == MATCH_YES)
1037 : break;
1038 6 : if (gfc_match_char (',') != MATCH_YES)
1039 0 : goto syntax;
1040 : }
1041 :
1042 5 : if (gfc_match_omp_eos () != MATCH_YES)
1043 : {
1044 1 : gfc_error ("Unexpected junk after !$ACC DECLARE at %C");
1045 1 : goto cleanup;
1046 : }
1047 :
1048 4 : while (*list)
1049 0 : list = &(*list)->next;
1050 4 : *list = head;
1051 4 : return MATCH_YES;
1052 :
1053 0 : syntax:
1054 0 : gfc_error ("Syntax error in !$ACC DECLARE list at %C");
1055 :
1056 4 : cleanup:
1057 4 : gfc_current_locus = old_loc;
1058 4 : return MATCH_ERROR;
1059 : }
1060 :
1061 : /* OpenMP clauses. */
1062 : enum omp_mask1
1063 : {
1064 : OMP_CLAUSE_PRIVATE,
1065 : OMP_CLAUSE_FIRSTPRIVATE,
1066 : OMP_CLAUSE_LASTPRIVATE,
1067 : OMP_CLAUSE_COPYPRIVATE,
1068 : OMP_CLAUSE_SHARED,
1069 : OMP_CLAUSE_COPYIN,
1070 : OMP_CLAUSE_REDUCTION,
1071 : OMP_CLAUSE_IN_REDUCTION,
1072 : OMP_CLAUSE_TASK_REDUCTION,
1073 : OMP_CLAUSE_IF,
1074 : OMP_CLAUSE_NUM_THREADS,
1075 : OMP_CLAUSE_SCHEDULE,
1076 : OMP_CLAUSE_DEFAULT,
1077 : OMP_CLAUSE_ORDER,
1078 : OMP_CLAUSE_ORDERED,
1079 : OMP_CLAUSE_COLLAPSE,
1080 : OMP_CLAUSE_UNTIED,
1081 : OMP_CLAUSE_FINAL,
1082 : OMP_CLAUSE_MERGEABLE,
1083 : OMP_CLAUSE_ALIGNED,
1084 : OMP_CLAUSE_DEPEND,
1085 : OMP_CLAUSE_INBRANCH,
1086 : OMP_CLAUSE_LINEAR,
1087 : OMP_CLAUSE_NOTINBRANCH,
1088 : OMP_CLAUSE_PROC_BIND,
1089 : OMP_CLAUSE_SAFELEN,
1090 : OMP_CLAUSE_SIMDLEN,
1091 : OMP_CLAUSE_UNIFORM,
1092 : OMP_CLAUSE_DEVICE,
1093 : OMP_CLAUSE_MAP,
1094 : OMP_CLAUSE_TO,
1095 : OMP_CLAUSE_FROM,
1096 : OMP_CLAUSE_NUM_TEAMS,
1097 : OMP_CLAUSE_THREAD_LIMIT,
1098 : OMP_CLAUSE_DIST_SCHEDULE,
1099 : OMP_CLAUSE_DEFAULTMAP,
1100 : OMP_CLAUSE_GRAINSIZE,
1101 : OMP_CLAUSE_HINT,
1102 : OMP_CLAUSE_IS_DEVICE_PTR,
1103 : OMP_CLAUSE_LINK,
1104 : OMP_CLAUSE_NOGROUP,
1105 : OMP_CLAUSE_NOTEMPORAL,
1106 : OMP_CLAUSE_NUM_TASKS,
1107 : OMP_CLAUSE_PRIORITY,
1108 : OMP_CLAUSE_SIMD,
1109 : OMP_CLAUSE_THREADS,
1110 : OMP_CLAUSE_USE_DEVICE_PTR,
1111 : OMP_CLAUSE_USE_DEVICE_ADDR, /* OpenMP 5.0. */
1112 : OMP_CLAUSE_DEVICE_TYPE, /* OpenMP 5.0. */
1113 : OMP_CLAUSE_ATOMIC, /* OpenMP 5.0. */
1114 : OMP_CLAUSE_CAPTURE, /* OpenMP 5.0. */
1115 : OMP_CLAUSE_MEMORDER, /* OpenMP 5.0. */
1116 : OMP_CLAUSE_DETACH, /* OpenMP 5.0. */
1117 : OMP_CLAUSE_AFFINITY, /* OpenMP 5.0. */
1118 : OMP_CLAUSE_ALLOCATE, /* OpenMP 5.0. */
1119 : OMP_CLAUSE_BIND, /* OpenMP 5.0. */
1120 : OMP_CLAUSE_FILTER, /* OpenMP 5.1. */
1121 : OMP_CLAUSE_AT, /* OpenMP 5.1. */
1122 : OMP_CLAUSE_MESSAGE, /* OpenMP 5.1. */
1123 : OMP_CLAUSE_SEVERITY, /* OpenMP 5.1. */
1124 : OMP_CLAUSE_COMPARE, /* OpenMP 5.1. */
1125 : OMP_CLAUSE_FAIL, /* OpenMP 5.1. */
1126 : OMP_CLAUSE_WEAK, /* OpenMP 5.1. */
1127 : OMP_CLAUSE_NOWAIT,
1128 : /* This must come last. */
1129 : OMP_MASK1_LAST
1130 : };
1131 :
1132 : /* More OpenMP clauses and OpenACC 2.0+ specific clauses. */
1133 : enum omp_mask2
1134 : {
1135 : OMP_CLAUSE_ASYNC,
1136 : OMP_CLAUSE_NUM_GANGS,
1137 : OMP_CLAUSE_NUM_WORKERS,
1138 : OMP_CLAUSE_VECTOR_LENGTH,
1139 : OMP_CLAUSE_COPY,
1140 : OMP_CLAUSE_COPYOUT,
1141 : OMP_CLAUSE_CREATE,
1142 : OMP_CLAUSE_NO_CREATE,
1143 : OMP_CLAUSE_PRESENT,
1144 : OMP_CLAUSE_DEVICEPTR,
1145 : OMP_CLAUSE_GANG,
1146 : OMP_CLAUSE_WORKER,
1147 : OMP_CLAUSE_VECTOR,
1148 : OMP_CLAUSE_SEQ,
1149 : OMP_CLAUSE_INDEPENDENT,
1150 : OMP_CLAUSE_USE_DEVICE,
1151 : OMP_CLAUSE_DEVICE_RESIDENT,
1152 : OMP_CLAUSE_SELF,
1153 : OMP_CLAUSE_HOST,
1154 : OMP_CLAUSE_WAIT,
1155 : OMP_CLAUSE_DELETE,
1156 : OMP_CLAUSE_AUTO,
1157 : OMP_CLAUSE_TILE,
1158 : OMP_CLAUSE_IF_PRESENT,
1159 : OMP_CLAUSE_FINALIZE,
1160 : OMP_CLAUSE_ATTACH,
1161 : OMP_CLAUSE_NOHOST,
1162 : OMP_CLAUSE_HAS_DEVICE_ADDR, /* OpenMP 5.1 */
1163 : OMP_CLAUSE_ENTER, /* OpenMP 5.2 */
1164 : OMP_CLAUSE_DOACROSS, /* OpenMP 5.2 */
1165 : OMP_CLAUSE_ASSUMPTIONS, /* OpenMP 5.1. */
1166 : OMP_CLAUSE_USES_ALLOCATORS, /* OpenMP 5.0 */
1167 : OMP_CLAUSE_INDIRECT, /* OpenMP 5.1 */
1168 : OMP_CLAUSE_FULL, /* OpenMP 5.1. */
1169 : OMP_CLAUSE_PARTIAL, /* OpenMP 5.1. */
1170 : OMP_CLAUSE_SIZES, /* OpenMP 5.1. */
1171 : OMP_CLAUSE_INIT, /* OpenMP 5.1. */
1172 : OMP_CLAUSE_DESTROY, /* OpenMP 5.1. */
1173 : OMP_CLAUSE_USE, /* OpenMP 5.1. */
1174 : OMP_CLAUSE_NOVARIANTS, /* OpenMP 5.1 */
1175 : OMP_CLAUSE_NOCONTEXT, /* OpenMP 5.1 */
1176 : OMP_CLAUSE_INTEROP, /* OpenMP 5.1 */
1177 : OMP_CLAUSE_LOCAL, /* OpenMP 6.0 */
1178 : OMP_CLAUSE_DYN_GROUPPRIVATE, /* OpenMP 6.1 */
1179 : /* This must come last. */
1180 : OMP_MASK2_LAST
1181 : };
1182 :
1183 : struct omp_inv_mask;
1184 :
1185 : /* Customized bitset for up to 128-bits.
1186 : The two enums above provide bit numbers to use, and which of the
1187 : two enums it is determines which of the two mask fields is used.
1188 : Supported operations are defining a mask, like:
1189 : #define XXX_CLAUSES \
1190 : (omp_mask (OMP_CLAUSE_XXX) | OMP_CLAUSE_YYY | OMP_CLAUSE_ZZZ)
1191 : oring such bitsets together or removing selected bits:
1192 : (XXX_CLAUSES | YYY_CLAUSES) & ~(omp_mask (OMP_CLAUSE_VVV))
1193 : and testing individual bits:
1194 : if (mask & OMP_CLAUSE_UUU) */
1195 :
1196 : struct omp_mask {
1197 : const uint64_t mask1;
1198 : const uint64_t mask2;
1199 : inline omp_mask ();
1200 : inline omp_mask (omp_mask1);
1201 : inline omp_mask (omp_mask2);
1202 : inline omp_mask (uint64_t, uint64_t);
1203 : inline omp_mask operator| (omp_mask1) const;
1204 : inline omp_mask operator| (omp_mask2) const;
1205 : inline omp_mask operator| (omp_mask) const;
1206 : inline omp_mask operator& (const omp_inv_mask &) const;
1207 : inline bool operator& (omp_mask1) const;
1208 : inline bool operator& (omp_mask2) const;
1209 : inline omp_inv_mask operator~ () const;
1210 : };
1211 :
1212 : struct omp_inv_mask : public omp_mask {
1213 : inline omp_inv_mask (const omp_mask &);
1214 : };
1215 :
1216 : omp_mask::omp_mask () : mask1 (0), mask2 (0)
1217 : {
1218 : }
1219 :
1220 31878 : omp_mask::omp_mask (omp_mask1 m) : mask1 (((uint64_t) 1) << m), mask2 (0)
1221 : {
1222 : }
1223 :
1224 2203 : omp_mask::omp_mask (omp_mask2 m) : mask1 (0), mask2 (((uint64_t) 1) << m)
1225 : {
1226 : }
1227 :
1228 32784 : omp_mask::omp_mask (uint64_t m1, uint64_t m2) : mask1 (m1), mask2 (m2)
1229 : {
1230 : }
1231 :
1232 : omp_mask
1233 31833 : omp_mask::operator| (omp_mask1 m) const
1234 : {
1235 31833 : return omp_mask (mask1 | (((uint64_t) 1) << m), mask2);
1236 : }
1237 :
1238 : omp_mask
1239 16572 : omp_mask::operator| (omp_mask2 m) const
1240 : {
1241 16572 : return omp_mask (mask1, mask2 | (((uint64_t) 1) << m));
1242 : }
1243 :
1244 : omp_mask
1245 4348 : omp_mask::operator| (omp_mask m) const
1246 : {
1247 4348 : return omp_mask (mask1 | m.mask1, mask2 | m.mask2);
1248 : }
1249 :
1250 : omp_mask
1251 2009 : omp_mask::operator& (const omp_inv_mask &m) const
1252 : {
1253 2009 : return omp_mask (mask1 & ~m.mask1, mask2 & ~m.mask2);
1254 : }
1255 :
1256 : bool
1257 124497 : omp_mask::operator& (omp_mask1 m) const
1258 : {
1259 124497 : return (mask1 & (((uint64_t) 1) << m)) != 0;
1260 : }
1261 :
1262 : bool
1263 88072 : omp_mask::operator& (omp_mask2 m) const
1264 : {
1265 88072 : return (mask2 & (((uint64_t) 1) << m)) != 0;
1266 : }
1267 :
1268 : omp_inv_mask
1269 2009 : omp_mask::operator~ () const
1270 : {
1271 2009 : return omp_inv_mask (*this);
1272 : }
1273 :
1274 2009 : omp_inv_mask::omp_inv_mask (const omp_mask &m) : omp_mask (m)
1275 : {
1276 : }
1277 :
1278 : /* Helper function for OpenACC and OpenMP clauses involving memory
1279 : mapping. */
1280 :
1281 : static bool
1282 5539 : gfc_match_omp_map_clause (gfc_omp_namelist **list, gfc_omp_map_op map_op,
1283 : bool allow_common, bool allow_derived)
1284 : {
1285 5539 : gfc_omp_namelist **head = NULL;
1286 5539 : if (gfc_match_omp_variable_list ("", list, allow_common, NULL, &head, true,
1287 : allow_derived)
1288 : == MATCH_YES)
1289 : {
1290 5530 : gfc_omp_namelist *n;
1291 13395 : for (n = *head; n; n = n->next)
1292 7865 : n->u.map.op = map_op;
1293 : return true;
1294 : }
1295 :
1296 : return false;
1297 : }
1298 :
1299 : static match
1300 1111 : gfc_match_iterator (gfc_namespace **ns, bool permit_var)
1301 : {
1302 1111 : locus old_loc = gfc_current_locus;
1303 :
1304 1111 : if (gfc_match ("iterator ( ") != MATCH_YES)
1305 : return MATCH_NO;
1306 :
1307 77 : gfc_typespec ts;
1308 77 : gfc_symbol *last = NULL;
1309 77 : gfc_expr *begin, *end, *step;
1310 77 : *ns = gfc_build_block_ns (gfc_current_ns);
1311 83 : char name[GFC_MAX_SYMBOL_LEN + 1];
1312 89 : while (true)
1313 : {
1314 83 : locus prev_loc = gfc_current_locus;
1315 83 : if (gfc_match_type_spec (&ts) == MATCH_YES
1316 83 : && gfc_match (" :: ") == MATCH_YES)
1317 : {
1318 5 : if (ts.type != BT_INTEGER)
1319 : {
1320 2 : gfc_error ("Expected INTEGER type at %L", &prev_loc);
1321 5 : return MATCH_ERROR;
1322 : }
1323 : permit_var = false;
1324 : }
1325 : else
1326 : {
1327 78 : ts.type = BT_INTEGER;
1328 78 : ts.kind = gfc_default_integer_kind;
1329 78 : gfc_current_locus = prev_loc;
1330 : }
1331 81 : prev_loc = gfc_current_locus;
1332 81 : if (gfc_match_name (name) != MATCH_YES)
1333 : {
1334 4 : gfc_error ("Expected identifier at %C");
1335 4 : goto failed;
1336 : }
1337 77 : if (gfc_find_symtree ((*ns)->sym_root, name))
1338 : {
1339 2 : gfc_error ("Same identifier %qs specified again at %C", name);
1340 2 : goto failed;
1341 : }
1342 :
1343 75 : gfc_symbol *sym = gfc_new_symbol (name, *ns);
1344 75 : if (last)
1345 4 : last->tlink = sym;
1346 : else
1347 71 : (*ns)->omp_affinity_iterators = sym;
1348 75 : last = sym;
1349 75 : sym->declared_at = prev_loc;
1350 75 : sym->ts = ts;
1351 75 : sym->attr.flavor = FL_VARIABLE;
1352 75 : sym->attr.artificial = 1;
1353 75 : sym->attr.referenced = 1;
1354 75 : sym->refs++;
1355 75 : gfc_symtree *st = gfc_new_symtree (&(*ns)->sym_root, name);
1356 75 : st->n.sym = sym;
1357 :
1358 75 : prev_loc = gfc_current_locus;
1359 75 : if (gfc_match (" = ") != MATCH_YES)
1360 3 : goto failed;
1361 72 : permit_var = false;
1362 72 : begin = end = step = NULL;
1363 72 : if (gfc_match ("%e : ", &begin) != MATCH_YES
1364 72 : || gfc_match ("%e ", &end) != MATCH_YES)
1365 : {
1366 3 : gfc_error ("Expected range-specification at %C");
1367 3 : gfc_free_expr (begin);
1368 3 : gfc_free_expr (end);
1369 3 : return MATCH_ERROR;
1370 : }
1371 69 : if (':' == gfc_peek_ascii_char ())
1372 : {
1373 23 : if (gfc_match (": %e ", &step) != MATCH_YES)
1374 : {
1375 5 : gfc_free_expr (begin);
1376 5 : gfc_free_expr (end);
1377 5 : gfc_free_expr (step);
1378 5 : goto failed;
1379 : }
1380 : }
1381 :
1382 64 : gfc_expr *e = gfc_get_expr ();
1383 64 : e->where = prev_loc;
1384 64 : e->expr_type = EXPR_ARRAY;
1385 64 : e->ts = ts;
1386 64 : e->rank = 1;
1387 64 : e->shape = gfc_get_shape (1);
1388 110 : mpz_init_set_ui (e->shape[0], step ? 3 : 2);
1389 64 : gfc_constructor_append_expr (&e->value.constructor, begin, &begin->where);
1390 64 : gfc_constructor_append_expr (&e->value.constructor, end, &end->where);
1391 64 : if (step)
1392 18 : gfc_constructor_append_expr (&e->value.constructor, step, &step->where);
1393 64 : sym->value = e;
1394 :
1395 64 : if (gfc_match (") ") == MATCH_YES)
1396 : break;
1397 6 : if (gfc_match (", ") != MATCH_YES)
1398 0 : goto failed;
1399 6 : }
1400 58 : return MATCH_YES;
1401 :
1402 14 : failed:
1403 14 : gfc_namespace *prev_ns = NULL;
1404 14 : for (gfc_namespace *it = gfc_current_ns->contained; it; it = it->sibling)
1405 : {
1406 0 : if (it == *ns)
1407 : {
1408 0 : if (prev_ns)
1409 0 : prev_ns->sibling = it->sibling;
1410 : else
1411 0 : gfc_current_ns->contained = it->sibling;
1412 0 : gfc_free_namespace (it);
1413 0 : break;
1414 : }
1415 0 : prev_ns = it;
1416 : }
1417 14 : *ns = NULL;
1418 14 : if (!permit_var)
1419 : return MATCH_ERROR;
1420 4 : gfc_current_locus = old_loc;
1421 4 : return MATCH_NO;
1422 : }
1423 :
1424 : /* Match target update's to/from( [present:] var-list). */
1425 :
1426 : static match
1427 1715 : gfc_match_motion_var_list (const char *str, gfc_omp_namelist **list,
1428 : gfc_omp_namelist ***headp)
1429 : {
1430 1715 : match m = gfc_match (str);
1431 1715 : if (m != MATCH_YES)
1432 : return m;
1433 :
1434 1715 : match m_present = gfc_match (" present : ");
1435 :
1436 1715 : m = gfc_match_omp_variable_list ("", list, false, NULL, headp, true, true);
1437 1715 : if (m != MATCH_YES)
1438 : return m;
1439 1715 : if (m_present == MATCH_YES)
1440 : {
1441 5 : gfc_omp_namelist *n;
1442 10 : for (n = **headp; n; n = n->next)
1443 5 : n->u.present_modifier = true;
1444 : }
1445 : return MATCH_YES;
1446 : }
1447 :
1448 : /* reduction ( reduction-modifier, reduction-operator : variable-list )
1449 : in_reduction ( reduction-operator : variable-list )
1450 : task_reduction ( reduction-operator : variable-list ) */
1451 :
1452 : static match
1453 4356 : gfc_match_omp_clause_reduction (char pc, gfc_omp_clauses *c, bool openacc,
1454 : bool allow_derived, bool openmp_target = false)
1455 : {
1456 4356 : if (pc == 'r' && gfc_match ("reduction ( ") != MATCH_YES)
1457 : return MATCH_NO;
1458 4356 : else if (pc == 'i' && gfc_match ("in_reduction ( ") != MATCH_YES)
1459 : return MATCH_NO;
1460 4244 : else if (pc == 't' && gfc_match ("task_reduction ( ") != MATCH_YES)
1461 : return MATCH_NO;
1462 :
1463 4244 : locus old_loc = gfc_current_locus;
1464 4244 : int list_idx = 0;
1465 :
1466 4244 : if (pc == 'r' && !openacc)
1467 : {
1468 2117 : if (gfc_match ("inscan") == MATCH_YES)
1469 : list_idx = OMP_LIST_REDUCTION_INSCAN;
1470 2047 : else if (gfc_match ("task") == MATCH_YES)
1471 : list_idx = OMP_LIST_REDUCTION_TASK;
1472 1943 : else if (gfc_match ("default") == MATCH_YES)
1473 : list_idx = OMP_LIST_REDUCTION;
1474 230 : if (list_idx != 0 && gfc_match (", ") != MATCH_YES)
1475 : {
1476 1 : gfc_error ("Comma expected at %C");
1477 1 : gfc_current_locus = old_loc;
1478 1 : return MATCH_NO;
1479 : }
1480 2116 : if (list_idx == 0)
1481 3831 : list_idx = OMP_LIST_REDUCTION;
1482 : }
1483 2127 : else if (pc == 'i')
1484 : list_idx = OMP_LIST_IN_REDUCTION;
1485 2009 : else if (pc == 't')
1486 : list_idx = OMP_LIST_TASK_REDUCTION;
1487 : else
1488 3831 : list_idx = OMP_LIST_REDUCTION;
1489 :
1490 4243 : gfc_omp_reduction_op rop = OMP_REDUCTION_NONE;
1491 4243 : char buffer[GFC_MAX_SYMBOL_LEN + 3];
1492 4243 : if (gfc_match_char ('+') == MATCH_YES)
1493 : rop = OMP_REDUCTION_PLUS;
1494 2223 : else if (gfc_match_char ('*') == MATCH_YES)
1495 : rop = OMP_REDUCTION_TIMES;
1496 1991 : else if (gfc_match_char ('-') == MATCH_YES)
1497 : {
1498 171 : if (!openacc)
1499 16 : gfc_warning (OPT_Wdeprecated_openmp,
1500 : "%<-%> operator at %C for reductions deprecated in "
1501 : "OpenMP 5.2");
1502 : rop = OMP_REDUCTION_MINUS;
1503 : }
1504 1820 : else if (gfc_match (".and.") == MATCH_YES)
1505 : rop = OMP_REDUCTION_AND;
1506 1714 : else if (gfc_match (".or.") == MATCH_YES)
1507 : rop = OMP_REDUCTION_OR;
1508 929 : else if (gfc_match (".eqv.") == MATCH_YES)
1509 : rop = OMP_REDUCTION_EQV;
1510 831 : else if (gfc_match (".neqv.") == MATCH_YES)
1511 : rop = OMP_REDUCTION_NEQV;
1512 736 : if (rop != OMP_REDUCTION_NONE)
1513 3507 : snprintf (buffer, sizeof buffer, "operator %s",
1514 : gfc_op2string ((gfc_intrinsic_op) rop));
1515 736 : else if (gfc_match_defined_op_name (buffer + 1, 1) == MATCH_YES)
1516 : {
1517 38 : buffer[0] = '.';
1518 38 : strcat (buffer, ".");
1519 : }
1520 698 : else if (gfc_match_name (buffer) == MATCH_YES)
1521 : {
1522 697 : gfc_symbol *sym;
1523 697 : const char *n = buffer;
1524 :
1525 697 : gfc_find_symbol (buffer, NULL, 1, &sym);
1526 697 : if (sym != NULL)
1527 : {
1528 216 : if (sym->attr.intrinsic)
1529 139 : n = sym->name;
1530 77 : else if ((sym->attr.flavor != FL_UNKNOWN
1531 75 : && sym->attr.flavor != FL_PROCEDURE)
1532 75 : || sym->attr.external
1533 64 : || sym->attr.generic
1534 64 : || sym->attr.entry
1535 64 : || sym->attr.result
1536 64 : || sym->attr.dummy
1537 64 : || sym->attr.subroutine
1538 63 : || sym->attr.pointer
1539 63 : || sym->attr.target
1540 63 : || sym->attr.cray_pointer
1541 63 : || sym->attr.cray_pointee
1542 63 : || (sym->attr.proc != PROC_UNKNOWN
1543 1 : && sym->attr.proc != PROC_INTRINSIC)
1544 62 : || sym->attr.if_source != IFSRC_UNKNOWN
1545 62 : || sym == sym->ns->proc_name)
1546 : {
1547 : sym = NULL;
1548 : n = NULL;
1549 : }
1550 : else
1551 62 : n = sym->name;
1552 : }
1553 201 : if (n == NULL)
1554 : rop = OMP_REDUCTION_NONE;
1555 682 : else if (strcmp (n, "max") == 0)
1556 : rop = OMP_REDUCTION_MAX;
1557 517 : else if (strcmp (n, "min") == 0)
1558 : rop = OMP_REDUCTION_MIN;
1559 376 : else if (strcmp (n, "iand") == 0)
1560 : rop = OMP_REDUCTION_IAND;
1561 321 : else if (strcmp (n, "ior") == 0)
1562 : rop = OMP_REDUCTION_IOR;
1563 255 : else if (strcmp (n, "ieor") == 0)
1564 : rop = OMP_REDUCTION_IEOR;
1565 : if (rop != OMP_REDUCTION_NONE
1566 477 : && sym != NULL
1567 200 : && ! sym->attr.intrinsic
1568 61 : && ! sym->attr.use_assoc
1569 61 : && ((sym->attr.flavor == FL_UNKNOWN
1570 2 : && !gfc_add_flavor (&sym->attr, FL_PROCEDURE,
1571 : sym->name, NULL))
1572 61 : || !gfc_add_intrinsic (&sym->attr, NULL)))
1573 : rop = OMP_REDUCTION_NONE;
1574 : }
1575 : else
1576 1 : buffer[0] = '\0';
1577 4243 : gfc_omp_udr *udr = (buffer[0] ? gfc_find_omp_udr (gfc_current_ns, buffer, NULL)
1578 : : NULL);
1579 4243 : gfc_omp_namelist **head = NULL;
1580 4243 : if (rop == OMP_REDUCTION_NONE && udr)
1581 250 : rop = OMP_REDUCTION_USER;
1582 :
1583 4243 : if (gfc_match_omp_variable_list (" :", &c->lists[list_idx], false, NULL,
1584 : &head, openacc, allow_derived) != MATCH_YES)
1585 : {
1586 9 : gfc_current_locus = old_loc;
1587 9 : return MATCH_NO;
1588 : }
1589 4234 : gfc_omp_namelist *n;
1590 4234 : if (rop == OMP_REDUCTION_NONE)
1591 : {
1592 6 : n = *head;
1593 6 : *head = NULL;
1594 6 : gfc_error_now ("!$OMP DECLARE REDUCTION %s not found at %L",
1595 : buffer, &old_loc);
1596 6 : gfc_free_omp_namelist (n, false, false, false, false);
1597 : }
1598 : else
1599 9108 : for (n = *head; n; n = n->next)
1600 : {
1601 4880 : n->u.reduction_op = rop;
1602 4880 : if (udr)
1603 : {
1604 473 : n->u2.udr = gfc_get_omp_namelist_udr ();
1605 473 : n->u2.udr->udr = udr;
1606 : }
1607 4880 : if (openmp_target && list_idx == OMP_LIST_IN_REDUCTION)
1608 : {
1609 40 : gfc_omp_namelist *p = gfc_get_omp_namelist (), **tl;
1610 40 : p->sym = n->sym;
1611 40 : p->where = n->where;
1612 40 : p->u.map.op = OMP_MAP_ALWAYS_TOFROM;
1613 :
1614 40 : tl = &c->lists[OMP_LIST_MAP];
1615 52 : while (*tl)
1616 12 : tl = &((*tl)->next);
1617 40 : *tl = p;
1618 40 : p->next = NULL;
1619 : }
1620 : }
1621 : return MATCH_YES;
1622 : }
1623 :
1624 : static match
1625 39 : gfc_omp_absent_contains_clause (gfc_omp_assumptions **assume, bool is_absent)
1626 : {
1627 39 : if (*assume == NULL)
1628 14 : *assume = gfc_get_omp_assumptions ();
1629 61 : do
1630 : {
1631 50 : gfc_statement st = ST_NONE;
1632 50 : gfc_gobble_whitespace ();
1633 50 : locus old_loc = gfc_current_locus;
1634 50 : char c = gfc_peek_ascii_char ();
1635 50 : enum gfc_omp_directive_kind kind
1636 : = GFC_OMP_DIR_DECLARATIVE; /* Silence warning. */
1637 1524 : for (size_t i = 0; i < ARRAY_SIZE (gfc_omp_directives); i++)
1638 : {
1639 1524 : if (gfc_omp_directives[i].name[0] > c)
1640 : break;
1641 1474 : if (gfc_omp_directives[i].name[0] != c)
1642 1135 : continue;
1643 339 : if (gfc_match (gfc_omp_directives[i].name) == MATCH_YES)
1644 : {
1645 50 : st = gfc_omp_directives[i].st;
1646 50 : kind = gfc_omp_directives[i].kind;
1647 : }
1648 : }
1649 50 : gfc_gobble_whitespace ();
1650 50 : c = gfc_peek_ascii_char ();
1651 50 : if (st == ST_NONE || (c != ',' && c != ')'))
1652 : {
1653 0 : if (st == ST_NONE)
1654 0 : gfc_error ("Unknown directive at %L", &old_loc);
1655 : else
1656 0 : gfc_error ("Invalid combined or composite directive at %L",
1657 : &old_loc);
1658 3 : return MATCH_ERROR;
1659 : }
1660 50 : if (kind == GFC_OMP_DIR_DECLARATIVE
1661 50 : || kind == GFC_OMP_DIR_INFORMATIONAL
1662 : || kind == GFC_OMP_DIR_META)
1663 : {
1664 3 : gfc_error ("Invalid %qs directive at %L in %s clause: declarative, "
1665 : "informational, and meta directives not permitted",
1666 : gfc_ascii_statement (st, true), &old_loc,
1667 : is_absent ? "ABSENT" : "CONTAINS");
1668 3 : return MATCH_ERROR;
1669 : }
1670 47 : if (is_absent)
1671 : {
1672 : /* Use exponential allocation; equivalent to pow2p(x). */
1673 33 : int i = (*assume)->n_absent;
1674 33 : int size = ((i == 0) ? 4
1675 10 : : pow2p_hwi (i) == 1 ? i*2 : 0);
1676 8 : if (size != 0)
1677 31 : (*assume)->absent = XRESIZEVEC (gfc_statement,
1678 : (*assume)->absent, size);
1679 33 : (*assume)->absent[(*assume)->n_absent++] = st;
1680 : }
1681 : else
1682 : {
1683 14 : int i = (*assume)->n_contains;
1684 14 : int size = ((i == 0) ? 4
1685 4 : : pow2p_hwi (i) == 1 ? i*2 : 0);
1686 4 : if (size != 0)
1687 14 : (*assume)->contains = XRESIZEVEC (gfc_statement,
1688 : (*assume)->contains, size);
1689 14 : (*assume)->contains[(*assume)->n_contains++] = st;
1690 : }
1691 47 : gfc_gobble_whitespace ();
1692 47 : if (gfc_match(",") == MATCH_YES)
1693 11 : continue;
1694 36 : if (gfc_match(")") == MATCH_YES)
1695 : break;
1696 0 : gfc_error ("Expected %<,%> or %<)%> at %C");
1697 0 : return MATCH_ERROR;
1698 : }
1699 : while (true);
1700 :
1701 36 : return MATCH_YES;
1702 : }
1703 :
1704 : /* Check 'check' argument for duplicated statements in absent and/or contains
1705 : clauses. If 'merge', merge them from check to 'merge'. */
1706 :
1707 : static match
1708 43 : omp_verify_merge_absent_contains (gfc_statement st, gfc_omp_assumptions *check,
1709 : gfc_omp_assumptions *merge, locus *loc)
1710 : {
1711 43 : if (check == NULL)
1712 : return MATCH_YES;
1713 43 : bitmap_head absent_head, contains_head;
1714 43 : bitmap_obstack_initialize (NULL);
1715 43 : bitmap_initialize (&absent_head, &bitmap_default_obstack);
1716 43 : bitmap_initialize (&contains_head, &bitmap_default_obstack);
1717 :
1718 43 : match m = MATCH_YES;
1719 76 : for (int i = 0; i < check->n_absent; i++)
1720 33 : if (!bitmap_set_bit (&absent_head, check->absent[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->absent[i], true),
1725 : "ABSENT", gfc_ascii_statement (st), loc);
1726 2 : m = MATCH_ERROR;
1727 : }
1728 57 : for (int i = 0; i < check->n_contains; i++)
1729 : {
1730 14 : if (!bitmap_set_bit (&contains_head, check->contains[i]))
1731 : {
1732 2 : gfc_error ("%qs directive mentioned multiple times in %s clause in %s "
1733 : "directive at %L",
1734 2 : gfc_ascii_statement (check->contains[i], true),
1735 : "CONTAINS", gfc_ascii_statement (st), loc);
1736 2 : m = MATCH_ERROR;
1737 : }
1738 14 : if (bitmap_bit_p (&absent_head, check->contains[i]))
1739 : {
1740 2 : gfc_error ("%qs directive mentioned both times in ABSENT and CONTAINS "
1741 : "clauses in %s directive at %L",
1742 2 : gfc_ascii_statement (check->absent[i], true),
1743 : gfc_ascii_statement (st), loc);
1744 2 : m = MATCH_ERROR;
1745 : }
1746 : }
1747 :
1748 43 : if (m == MATCH_ERROR)
1749 : return MATCH_ERROR;
1750 37 : if (merge == NULL)
1751 : return MATCH_YES;
1752 2 : if (merge->absent == NULL && check->absent)
1753 : {
1754 1 : merge->n_absent = check->n_absent;
1755 1 : merge->absent = check->absent;
1756 1 : check->absent = NULL;
1757 : }
1758 1 : else if (merge->absent && check->absent)
1759 : {
1760 0 : check->absent = XRESIZEVEC (gfc_statement, check->absent,
1761 : merge->n_absent + check->n_absent);
1762 0 : for (int i = 0; i < merge->n_absent; i++)
1763 0 : if (!bitmap_bit_p (&absent_head, merge->absent[i]))
1764 0 : check->absent[check->n_absent++] = merge->absent[i];
1765 0 : free (merge->absent);
1766 0 : merge->absent = check->absent;
1767 0 : merge->n_absent = check->n_absent;
1768 0 : check->absent = NULL;
1769 : }
1770 2 : if (merge->contains == NULL && check->contains)
1771 : {
1772 0 : merge->n_contains = check->n_contains;
1773 0 : merge->contains = check->contains;
1774 0 : check->contains = NULL;
1775 : }
1776 2 : else if (merge->contains && check->contains)
1777 : {
1778 0 : check->contains = XRESIZEVEC (gfc_statement, check->contains,
1779 : merge->n_contains + check->n_contains);
1780 0 : for (int i = 0; i < merge->n_contains; i++)
1781 0 : if (!bitmap_bit_p (&contains_head, merge->contains[i]))
1782 0 : check->contains[check->n_contains++] = merge->contains[i];
1783 0 : free (merge->contains);
1784 0 : merge->contains = check->contains;
1785 0 : merge->n_contains = check->n_contains;
1786 0 : check->contains = NULL;
1787 : }
1788 : return MATCH_YES;
1789 : }
1790 :
1791 : /* OpenMP 5.0
1792 : uses_allocators ( allocator-list )
1793 :
1794 : allocator:
1795 : predefined-allocator
1796 : variable ( traits-array )
1797 :
1798 : OpenMP 5.2 deprecated, 6.0 deleted: 'variable ( traits-array )'
1799 :
1800 : OpenMP 5.2:
1801 : uses_allocators ( [modifier-list :] allocator-list )
1802 :
1803 : OpenMP 6.0:
1804 : uses_allocators ( [modifier-list :] allocator-list [; ...])
1805 :
1806 : allocator:
1807 : variable or predefined-allocator
1808 : modifier:
1809 : traits ( traits-array )
1810 : memspace ( mem-space-handle ) */
1811 :
1812 : static match
1813 56 : gfc_match_omp_clause_uses_allocators (gfc_omp_clauses *c)
1814 : {
1815 60 : parse_next:
1816 60 : gfc_symbol *memspace_sym = NULL;
1817 60 : gfc_symbol *traits_sym = NULL;
1818 60 : gfc_omp_namelist *head = NULL;
1819 60 : gfc_omp_namelist *p, *tail, **list;
1820 60 : int ntraits, nmemspace;
1821 60 : bool has_modifiers;
1822 60 : locus old_loc, cur_loc;
1823 :
1824 60 : gfc_gobble_whitespace ();
1825 60 : old_loc = gfc_current_locus;
1826 60 : ntraits = nmemspace = 0;
1827 92 : do
1828 : {
1829 76 : cur_loc = gfc_current_locus;
1830 76 : if (gfc_match ("traits ( %S ) ", &traits_sym) == MATCH_YES)
1831 24 : ntraits++;
1832 52 : else if (gfc_match ("memspace ( %S ) ", &memspace_sym) == MATCH_YES)
1833 23 : nmemspace++;
1834 76 : if (ntraits > 1 || nmemspace > 1)
1835 : {
1836 2 : gfc_error ("Duplicate %s modifier at %L in USES_ALLOCATORS clause",
1837 : ntraits > 1 ? "TRAITS" : "MEMSPACE", &cur_loc);
1838 2 : return MATCH_ERROR;
1839 : }
1840 74 : if (gfc_match (", ") == MATCH_YES)
1841 16 : continue;
1842 58 : if (gfc_match (": ") != MATCH_YES)
1843 : {
1844 : /* Assume no modifier. */
1845 31 : memspace_sym = traits_sym = NULL;
1846 31 : gfc_current_locus = old_loc;
1847 31 : break;
1848 : }
1849 : break;
1850 : } while (true);
1851 :
1852 85 : has_modifiers = traits_sym != NULL || memspace_sym != NULL;
1853 150 : do
1854 : {
1855 104 : p = gfc_get_omp_namelist ();
1856 104 : p->where = gfc_current_locus;
1857 104 : if (head == NULL)
1858 : head = tail = p;
1859 : else
1860 : {
1861 46 : tail->next = p;
1862 46 : tail = tail->next;
1863 : }
1864 104 : if (gfc_match ("%S ", &p->sym) != MATCH_YES)
1865 0 : goto error;
1866 104 : if (!has_modifiers)
1867 : {
1868 72 : if (gfc_match ("( %S ) ", &p->u2.traits_sym) == MATCH_YES)
1869 17 : gfc_warning (OPT_Wdeprecated_openmp,
1870 : "The specification of arguments to "
1871 : "%<uses_allocators%> at %L where each item is of "
1872 : "the form %<allocator(traits)%> is deprecated since "
1873 : "OpenMP 5.2; instead use %<uses_allocators(traits(%s"
1874 17 : "): %s)%>", &p->where, p->u2.traits_sym->name,
1875 17 : p->sym->name);
1876 : }
1877 32 : else if (gfc_peek_ascii_char () == '(')
1878 : {
1879 0 : gfc_error ("Unexpected %<(%> at %C");
1880 0 : goto error;
1881 : }
1882 : else
1883 : {
1884 32 : p->u.memspace_sym = memspace_sym;
1885 32 : p->u2.traits_sym = traits_sym;
1886 : }
1887 104 : gfc_gobble_whitespace ();
1888 104 : const char c = gfc_peek_ascii_char ();
1889 104 : if (c == ';' || c == ')')
1890 : break;
1891 48 : if (c != ',')
1892 : {
1893 2 : gfc_error ("Expected %<,%>, %<)%> or %<;%> at %C");
1894 2 : goto error;
1895 : }
1896 46 : gfc_match_char (',');
1897 46 : gfc_gobble_whitespace ();
1898 46 : } while (true);
1899 :
1900 56 : list = &c->lists[OMP_LIST_USES_ALLOCATORS];
1901 74 : while (*list)
1902 18 : list = &(*list)->next;
1903 56 : *list = head;
1904 :
1905 56 : if (gfc_match_char (';') == MATCH_YES)
1906 4 : goto parse_next;
1907 :
1908 52 : gfc_match_char (')');
1909 52 : return MATCH_YES;
1910 :
1911 2 : error:
1912 2 : gfc_free_omp_namelist (head, false, false, true, false);
1913 2 : return MATCH_ERROR;
1914 : }
1915 :
1916 :
1917 : /* Match the 'prefer_type' modifier of the interop 'init' clause:
1918 : with either OpenMP 5.1's
1919 : prefer_type ( <const-int-expr|string literal> [, ...]
1920 : or
1921 : prefer_type ( '{' <fr(...) | attr (...)>, ...] '}' [, '{' ... '}' ] )
1922 : where 'fr' takes a constant expression or a string literal
1923 : and 'attr takes a list of string literals, starting with 'ompx_')
1924 :
1925 : For the foreign runtime identifiers, string values are converted to
1926 : their integer value; unknown string or integer values are set to
1927 : GOMP_INTEROP_IFR_KNOWN.
1928 :
1929 : Data format:
1930 : For the foreign runtime identifiers, string values are converted to
1931 : their integer value; unknown string or integer values are set to 0.
1932 :
1933 : Each item (a) GOMP_INTEROP_IFR_SEPARATOR
1934 : (b) for any 'fr', its integer value.
1935 : Note: Spec only permits 1 'fr' entry (6.0; changed after TR13)
1936 : (c) GOMP_INTEROP_IFR_SEPARATOR
1937 : (d) list of \0-terminated non-empty strings for 'attr'
1938 : (e) '\0'
1939 : Tailing '\0'. */
1940 :
1941 : static match
1942 82 : gfc_match_omp_prefer_type (char **type_str, int *type_str_len)
1943 : {
1944 82 : gfc_expr *e;
1945 82 : std::string type_string, attr_string;
1946 : /* New syntax. */
1947 82 : if (gfc_peek_ascii_char () == '{')
1948 115 : do
1949 : {
1950 85 : attr_string.clear ();
1951 85 : type_string += (char) GOMP_INTEROP_IFR_SEPARATOR;
1952 85 : if (gfc_match ("{ ") != MATCH_YES)
1953 : {
1954 1 : gfc_error ("Expected %<{%> at %C");
1955 1 : return MATCH_ERROR;
1956 : }
1957 : bool fr_found = false;
1958 148 : do
1959 : {
1960 116 : if (gfc_match ("fr ( ") == MATCH_YES)
1961 : {
1962 62 : if (fr_found)
1963 : {
1964 1 : gfc_error ("Duplicated %<fr%> preference-selector-name "
1965 : "at %C");
1966 1 : return MATCH_ERROR;
1967 : }
1968 61 : fr_found = true;
1969 61 : do
1970 : {
1971 61 : bool found_literal = false;
1972 61 : match m = MATCH_YES;
1973 61 : if (gfc_match_literal_constant (&e, false) == MATCH_YES)
1974 : found_literal = true;
1975 : else
1976 12 : m = gfc_match_expr (&e);
1977 12 : if (m != MATCH_YES
1978 61 : || !gfc_resolve_expr (e)
1979 61 : || e->rank != 0
1980 60 : || e->expr_type != EXPR_CONSTANT
1981 59 : || (e->ts.type != BT_INTEGER
1982 43 : && (!found_literal || e->ts.type != BT_CHARACTER))
1983 58 : || (e->ts.type == BT_INTEGER
1984 16 : && !mpz_fits_sint_p (e->value.integer))
1985 70 : || (e->ts.type == BT_CHARACTER
1986 42 : && (e->ts.kind != gfc_default_character_kind
1987 41 : || e->value.character.length == 0)))
1988 : {
1989 5 : gfc_error ("Expected constant scalar integer expression"
1990 : " or non-empty default-kind character "
1991 5 : "literal at %L", &e->where);
1992 5 : gfc_free_expr (e);
1993 5 : return MATCH_ERROR;
1994 : }
1995 56 : gfc_gobble_whitespace ();
1996 56 : int val;
1997 56 : if (e->ts.type == BT_INTEGER)
1998 : {
1999 16 : val = mpz_get_si (e->value.integer);
2000 16 : if (val < 1 || val > GOMP_INTEROP_IFR_LAST)
2001 : {
2002 0 : gfc_warning_now (OPT_Wopenmp,
2003 : "Unknown foreign runtime "
2004 : "identifier %qd at %L",
2005 : val, &e->where);
2006 0 : val = GOMP_INTEROP_IFR_UNKNOWN;
2007 : }
2008 : }
2009 : else
2010 : {
2011 40 : char *str = XALLOCAVEC (char,
2012 : e->value.character.length+1);
2013 229 : for (int i = 0; i < e->value.character.length + 1; i++)
2014 189 : str[i] = e->value.character.string[i];
2015 40 : if (memchr (str, '\0', e->value.character.length) != 0)
2016 : {
2017 0 : gfc_error ("Unexpected null character in character "
2018 : "literal at %L", &e->where);
2019 0 : return MATCH_ERROR;
2020 : }
2021 40 : val = omp_get_fr_id_from_name (str);
2022 40 : if (val == GOMP_INTEROP_IFR_UNKNOWN)
2023 2 : gfc_warning_now (OPT_Wopenmp,
2024 : "Unknown foreign runtime identifier "
2025 2 : "%qs at %L", str, &e->where);
2026 : }
2027 :
2028 56 : type_string += (char) val;
2029 56 : if (gfc_match (") ") == MATCH_YES)
2030 : break;
2031 4 : gfc_error ("Expected %<)%> at %C");
2032 4 : return MATCH_ERROR;
2033 : }
2034 : while (true);
2035 : }
2036 54 : else if (gfc_match ("attr ( ") == MATCH_YES)
2037 : {
2038 60 : do
2039 : {
2040 57 : if (gfc_match_literal_constant (&e, false) != MATCH_YES
2041 56 : || !gfc_resolve_expr (e)
2042 56 : || e->expr_type != EXPR_CONSTANT
2043 56 : || e->rank != 0
2044 56 : || e->ts.type != BT_CHARACTER
2045 113 : || e->ts.kind != gfc_default_character_kind)
2046 : {
2047 1 : gfc_error ("Expected default-kind character literal "
2048 1 : "at %L", &e->where);
2049 1 : gfc_free_expr (e);
2050 1 : return MATCH_ERROR;
2051 : }
2052 56 : gfc_gobble_whitespace ();
2053 56 : char *str = XALLOCAVEC (char, e->value.character.length+1);
2054 564 : for (int i = 0; i < e->value.character.length + 1; i++)
2055 508 : str[i] = e->value.character.string[i];
2056 56 : if (!startswith (str, "ompx_"))
2057 : {
2058 1 : gfc_error ("Character literal at %L must start with "
2059 : "%<ompx_%>", &e->where);
2060 1 : gfc_free_expr (e);
2061 1 : return MATCH_ERROR;
2062 : }
2063 55 : if (memchr (str, '\0', e->value.character.length) != 0
2064 55 : || memchr (str, ',', e->value.character.length) != 0)
2065 : {
2066 1 : gfc_error ("Unexpected null or %<,%> character in "
2067 : "character literal at %L", &e->where);
2068 1 : return MATCH_ERROR;
2069 : }
2070 54 : attr_string += str;
2071 54 : attr_string += '\0';
2072 54 : if (gfc_match (", ") == MATCH_YES)
2073 3 : continue;
2074 51 : if (gfc_match (") ") == MATCH_YES)
2075 : break;
2076 0 : gfc_error ("Expected %<,%> or %<)%> at %C");
2077 0 : return MATCH_ERROR;
2078 3 : }
2079 : while (true);
2080 : }
2081 : else
2082 : {
2083 0 : gfc_error ("Expected %<fr(%> or %<attr(%> at %C");
2084 0 : return MATCH_ERROR;
2085 : }
2086 103 : if (gfc_match (", ") == MATCH_YES)
2087 32 : continue;
2088 71 : if (gfc_match ("} ") == MATCH_YES)
2089 : break;
2090 2 : gfc_error ("Expected %<,%> or %<}%> at %C");
2091 2 : return MATCH_ERROR;
2092 32 : }
2093 : while (true);
2094 69 : type_string += (char) GOMP_INTEROP_IFR_SEPARATOR;
2095 69 : type_string += attr_string;
2096 69 : type_string += '\0';
2097 69 : if (gfc_match (", ") == MATCH_YES)
2098 30 : continue;
2099 39 : if (gfc_match (") ") == MATCH_YES)
2100 : break;
2101 1 : gfc_error ("Expected %<,%> or %<)%> at %C");
2102 1 : return MATCH_ERROR;
2103 30 : }
2104 : while (true);
2105 : else
2106 75 : do
2107 : {
2108 51 : type_string += (char) GOMP_INTEROP_IFR_SEPARATOR;
2109 51 : bool found_literal = false;
2110 51 : match m = MATCH_YES;
2111 51 : if (gfc_match_literal_constant (&e, false) == MATCH_YES)
2112 : found_literal = true;
2113 : else
2114 19 : m = gfc_match_expr (&e);
2115 19 : if (m != MATCH_YES
2116 51 : || !gfc_resolve_expr (e)
2117 51 : || e->rank != 0
2118 50 : || e->expr_type != EXPR_CONSTANT
2119 49 : || (e->ts.type != BT_INTEGER
2120 28 : && (!found_literal || e->ts.type != BT_CHARACTER))
2121 48 : || (e->ts.type == BT_INTEGER
2122 21 : && !mpz_fits_sint_p (e->value.integer))
2123 67 : || (e->ts.type == BT_CHARACTER
2124 27 : && (e->ts.kind != gfc_default_character_kind
2125 27 : || e->value.character.length == 0)))
2126 : {
2127 3 : gfc_error ("Expected constant scalar integer expression or "
2128 3 : "non-empty default-kind character literal at %L", &e->where);
2129 3 : gfc_free_expr (e);
2130 3 : return MATCH_ERROR;
2131 : }
2132 48 : gfc_gobble_whitespace ();
2133 48 : int val;
2134 48 : if (e->ts.type == BT_INTEGER)
2135 : {
2136 21 : val = mpz_get_si (e->value.integer);
2137 21 : if (val < 1 || val > GOMP_INTEROP_IFR_LAST)
2138 : {
2139 3 : gfc_warning_now (OPT_Wopenmp,
2140 : "Unknown foreign runtime identifier %qd at %L",
2141 : val, &e->where);
2142 3 : val = 0;
2143 : }
2144 : }
2145 : else
2146 : {
2147 27 : char *str = XALLOCAVEC (char, e->value.character.length+1);
2148 169 : for (int i = 0; i < e->value.character.length + 1; i++)
2149 142 : str[i] = e->value.character.string[i];
2150 27 : if (memchr (str, '\0', e->value.character.length) != 0)
2151 : {
2152 0 : gfc_error ("Unexpected null character in character "
2153 : "literal at %L", &e->where);
2154 0 : return MATCH_ERROR;
2155 : }
2156 27 : val = omp_get_fr_id_from_name (str);
2157 27 : if (val == GOMP_INTEROP_IFR_UNKNOWN)
2158 5 : gfc_warning_now (OPT_Wopenmp,
2159 : "Unknown foreign runtime identifier %qs at %L",
2160 5 : str, &e->where);
2161 : }
2162 48 : type_string += (char) val;
2163 48 : type_string += (char) GOMP_INTEROP_IFR_SEPARATOR;
2164 48 : type_string += '\0';
2165 48 : gfc_free_expr (e);
2166 48 : if (gfc_match (", ") == MATCH_YES)
2167 24 : continue;
2168 24 : if (gfc_match (") ") == MATCH_YES)
2169 : break;
2170 2 : gfc_error ("Expected %<,%> or %<)%> at %C");
2171 2 : return MATCH_ERROR;
2172 24 : }
2173 : while (true);
2174 60 : type_string += '\0';
2175 60 : *type_str_len = type_string.length();
2176 60 : *type_str = XNEWVEC (char, type_string.length ());
2177 60 : memcpy (*type_str, type_string.data (), type_string.length ());
2178 60 : return MATCH_YES;
2179 82 : }
2180 :
2181 :
2182 : /* Match OpenMP 5.1's 'init'-clause modifiers, used by the 'init' clause of
2183 : the 'interop' directive and the 'append_args' directive of 'declare variant'.
2184 : [prefer_type(...)][,][<target|targetsync>, ...])
2185 :
2186 : If is_init_clause, the modifier parsing ends with a ':'.
2187 : If not is_init_clause (i.e. append_args), the parsing ends with ')'. */
2188 :
2189 : static match
2190 164 : gfc_parser_omp_clause_init_modifiers (bool &target, bool &targetsync,
2191 : char **type_str, int &type_str_len,
2192 : bool is_init_clause)
2193 : {
2194 164 : target = false;
2195 164 : targetsync = false;
2196 164 : *type_str = NULL;
2197 164 : type_str_len = 0;
2198 286 : match m;
2199 :
2200 286 : do
2201 : {
2202 286 : if (gfc_match ("prefer_type ( ") == MATCH_YES)
2203 : {
2204 83 : if (*type_str)
2205 : {
2206 1 : gfc_error ("Duplicate %<prefer_type%> modifier at %C");
2207 1 : return MATCH_ERROR;
2208 : }
2209 82 : m = gfc_match_omp_prefer_type (type_str, &type_str_len);
2210 82 : if (m != MATCH_YES)
2211 : return m;
2212 60 : if (gfc_match (", ") == MATCH_YES)
2213 14 : continue;
2214 46 : if (is_init_clause)
2215 : {
2216 24 : if (gfc_match (": ") == MATCH_YES)
2217 : break;
2218 0 : gfc_error ("Expected %<,%> or %<:%> at %C");
2219 : }
2220 : else
2221 : {
2222 22 : if (gfc_match (") ") == MATCH_YES)
2223 : break;
2224 0 : gfc_error ("Expected %<,%> or %<)%> at %C");
2225 : }
2226 0 : return MATCH_ERROR;
2227 : }
2228 :
2229 203 : if (gfc_match ("prefer_type ") == MATCH_YES)
2230 : {
2231 2 : gfc_error ("Expected %<(%> after %<prefer_type%> at %C");
2232 2 : return MATCH_ERROR;
2233 : }
2234 :
2235 201 : if (gfc_match ("targetsync ") == MATCH_YES)
2236 : {
2237 57 : if (targetsync)
2238 : {
2239 3 : gfc_error ("Duplicate %<targetsync%> at %C");
2240 3 : return MATCH_ERROR;
2241 : }
2242 54 : targetsync = true;
2243 54 : if (gfc_match (", ") == MATCH_YES)
2244 13 : continue;
2245 41 : if (!is_init_clause)
2246 : {
2247 23 : if (gfc_match (") ") == MATCH_YES)
2248 : break;
2249 0 : gfc_error ("Expected %<,%> or %<)%> at %C");
2250 0 : return MATCH_ERROR;
2251 : }
2252 18 : if (gfc_match (": ") == MATCH_YES)
2253 : break;
2254 1 : gfc_error ("Expected %<,%> or %<:%> at %C");
2255 1 : return MATCH_ERROR;
2256 : }
2257 144 : if (gfc_match ("target ") == MATCH_YES)
2258 : {
2259 135 : if (target)
2260 : {
2261 3 : gfc_error ("Duplicate %<target%> at %C");
2262 3 : return MATCH_ERROR;
2263 : }
2264 132 : target = true;
2265 132 : if (gfc_match (", ") == MATCH_YES)
2266 95 : continue;
2267 37 : if (!is_init_clause)
2268 : {
2269 11 : if (gfc_match (") ") == MATCH_YES)
2270 : break;
2271 0 : gfc_error ("Expected %<,%> or %<)%> at %C");
2272 0 : return MATCH_ERROR;
2273 : }
2274 26 : if (gfc_match (": ") == MATCH_YES)
2275 : break;
2276 1 : gfc_error ("Expected %<,%> or %<:%> at %C");
2277 1 : return MATCH_ERROR;
2278 : }
2279 9 : gfc_error ("Expected %<prefer_type%>, %<target%>, or %<targetsync%> "
2280 : "at %C");
2281 9 : return MATCH_ERROR;
2282 : }
2283 : while (true);
2284 :
2285 122 : if (!target && !targetsync)
2286 : {
2287 4 : gfc_error ("Missing required %<target%> and/or %<targetsync%> "
2288 : "modifier at %C");
2289 4 : return MATCH_ERROR;
2290 : }
2291 : return MATCH_YES;
2292 : }
2293 :
2294 : /* Match OpenMP 5.1's 'init' clause for 'interop' objects:
2295 : init([prefer_type(...)][,][<target|targetsync>, ...] :] interop-obj-list) */
2296 :
2297 : static match
2298 108 : gfc_match_omp_init (gfc_omp_namelist **list)
2299 : {
2300 108 : bool target, targetsync;
2301 108 : char *type_str = NULL;
2302 108 : int type_str_len;
2303 108 : if (gfc_parser_omp_clause_init_modifiers (target, targetsync, &type_str,
2304 : type_str_len, true) == MATCH_ERROR)
2305 : return MATCH_ERROR;
2306 :
2307 64 : gfc_omp_namelist **head = NULL;
2308 64 : if (gfc_match_omp_variable_list ("", list, false, NULL, &head) != MATCH_YES)
2309 : return MATCH_ERROR;
2310 147 : for (gfc_omp_namelist *n = *head; n; n = n->next)
2311 : {
2312 84 : n->u.init.target = target;
2313 84 : n->u.init.targetsync = targetsync;
2314 84 : n->u.init.len = type_str_len;
2315 84 : n->u2.init_interop = type_str;
2316 : }
2317 : return MATCH_YES;
2318 : }
2319 :
2320 :
2321 : /* Match with duplicate check. Matches 'name'. If expr != NULL, it
2322 : then matches '(expr)', otherwise, if open_parens is true,
2323 : it matches a ' ( ' after 'name'.
2324 : dupl_message requires '%qs %L' - and is used by
2325 : gfc_match_dupl_memorder and gfc_match_dupl_atomic. */
2326 :
2327 : static match
2328 22344 : gfc_match_dupl_check (bool not_dupl, const char *name, bool open_parens = false,
2329 : gfc_expr **expr = NULL, const char *dupl_msg = NULL)
2330 : {
2331 22344 : match m;
2332 22344 : char c;
2333 22344 : locus old_loc = gfc_current_locus;
2334 22344 : if ((m = gfc_match (name)) != MATCH_YES)
2335 : return m;
2336 : /* Ensure that no partial string is matched. */
2337 17391 : if (gfc_current_form == FORM_FREE
2338 16893 : && gfc_match_eos () != MATCH_YES
2339 30148 : && ((c = gfc_peek_ascii_char ()) == '_' || ISALNUM (c)))
2340 : {
2341 8 : gfc_current_locus = old_loc;
2342 8 : return MATCH_NO;
2343 : }
2344 17383 : if (!not_dupl)
2345 : {
2346 44 : if (dupl_msg)
2347 2 : gfc_error (dupl_msg, name, &old_loc);
2348 : else
2349 42 : gfc_error ("Duplicated %qs clause at %L", name, &old_loc);
2350 44 : return MATCH_ERROR;
2351 : }
2352 17339 : if (open_parens || expr)
2353 : {
2354 9450 : if (gfc_match (" ( ") != MATCH_YES)
2355 : {
2356 22 : gfc_error ("Expected %<(%> after %qs at %C", name);
2357 22 : return MATCH_ERROR;
2358 : }
2359 9428 : if (expr)
2360 : {
2361 4406 : if (gfc_match ("%e )", expr) != MATCH_YES)
2362 : {
2363 9 : gfc_error ("Invalid expression after %<%s(%> at %C", name);
2364 9 : return MATCH_ERROR;
2365 : }
2366 : }
2367 : }
2368 : return MATCH_YES;
2369 : }
2370 :
2371 : static match
2372 211 : gfc_match_dupl_memorder (bool not_dupl, const char *name)
2373 : {
2374 0 : return gfc_match_dupl_check (not_dupl, name, false, NULL,
2375 : "Duplicated memory-order clause: unexpected %s "
2376 0 : "clause at %L");
2377 : }
2378 :
2379 : static match
2380 1175 : gfc_match_dupl_atomic (bool not_dupl, const char *name)
2381 : {
2382 0 : return gfc_match_dupl_check (not_dupl, name, false, NULL,
2383 : "Duplicated atomic clause: unexpected %s "
2384 0 : "clause at %L");
2385 : }
2386 :
2387 : /* Match OpenMP and OpenACC directive clauses. MASK is a bitmask of
2388 : clauses that are allowed for a particular directive. */
2389 :
2390 : static match
2391 34081 : gfc_match_omp_clauses (gfc_omp_clauses **cp, const omp_mask mask,
2392 : bool first = true, bool needs_space = true,
2393 : bool openacc = false, bool openmp_target = false)
2394 : {
2395 34081 : bool error = false;
2396 34081 : gfc_omp_clauses *c = gfc_get_omp_clauses ();
2397 34081 : locus old_loc;
2398 : /* Determine whether we're dealing with an OpenACC directive that permits
2399 : derived type member accesses. This in particular disallows
2400 : "!$acc declare" from using such accesses, because it's not clear if/how
2401 : that should work. */
2402 34081 : bool allow_derived = (openacc
2403 34081 : && ((mask & OMP_CLAUSE_ATTACH)
2404 5927 : || (mask & OMP_CLAUSE_DETACH)));
2405 :
2406 34081 : gcc_checking_assert (OMP_MASK1_LAST <= 64 && OMP_MASK2_LAST <= 64);
2407 34081 : *cp = NULL;
2408 124821 : while (1)
2409 : {
2410 79451 : match m = MATCH_NO;
2411 59130 : if ((first || (m = gfc_match_char (',')) != MATCH_YES)
2412 138225 : && (needs_space && gfc_match_space () != MATCH_YES))
2413 : break;
2414 74904 : needs_space = false;
2415 74904 : first = false;
2416 74904 : gfc_gobble_whitespace ();
2417 74904 : bool end_colon;
2418 74904 : gfc_omp_namelist **head;
2419 74904 : old_loc = gfc_current_locus;
2420 74904 : char pc = gfc_peek_ascii_char ();
2421 74904 : if (pc == '\n' && m == MATCH_YES)
2422 : {
2423 1 : gfc_error ("Clause expected at %C after trailing comma");
2424 1 : goto error;
2425 : }
2426 74903 : switch (pc)
2427 : {
2428 1310 : case 'a':
2429 1310 : end_colon = false;
2430 1310 : head = NULL;
2431 1334 : if ((mask & OMP_CLAUSE_ASSUMPTIONS)
2432 1310 : && gfc_match ("absent ( ") == MATCH_YES)
2433 : {
2434 27 : if (gfc_omp_absent_contains_clause (&c->assume, true)
2435 : != MATCH_YES)
2436 3 : goto error;
2437 24 : continue;
2438 : }
2439 1283 : if ((mask & OMP_CLAUSE_ALIGNED)
2440 1283 : && gfc_match_omp_variable_list ("aligned (",
2441 : &c->lists[OMP_LIST_ALIGNED],
2442 : false, &end_colon,
2443 : &head) == MATCH_YES)
2444 : {
2445 112 : gfc_expr *alignment = NULL;
2446 112 : gfc_omp_namelist *n;
2447 :
2448 112 : if (end_colon && gfc_match (" %e )", &alignment) != MATCH_YES)
2449 : {
2450 0 : gfc_free_omp_namelist (*head, false, false, false, false);
2451 0 : gfc_current_locus = old_loc;
2452 0 : *head = NULL;
2453 0 : break;
2454 : }
2455 268 : for (n = *head; n; n = n->next)
2456 156 : if (n->next && alignment)
2457 42 : n->expr = gfc_copy_expr (alignment);
2458 : else
2459 114 : n->expr = alignment;
2460 112 : continue;
2461 112 : }
2462 1181 : if ((mask & OMP_CLAUSE_MEMORDER)
2463 1188 : && (m = gfc_match_dupl_memorder ((c->memorder
2464 17 : == OMP_MEMORDER_UNSET),
2465 : "acq_rel")) != MATCH_NO)
2466 : {
2467 10 : if (m == MATCH_ERROR)
2468 0 : goto error;
2469 10 : c->memorder = OMP_MEMORDER_ACQ_REL;
2470 10 : continue;
2471 : }
2472 1168 : if ((mask & OMP_CLAUSE_MEMORDER)
2473 1168 : && (m = gfc_match_dupl_memorder ((c->memorder
2474 7 : == OMP_MEMORDER_UNSET),
2475 : "acquire")) != MATCH_NO)
2476 : {
2477 7 : if (m == MATCH_ERROR)
2478 0 : goto error;
2479 7 : c->memorder = OMP_MEMORDER_ACQUIRE;
2480 7 : continue;
2481 : }
2482 1154 : if ((mask & OMP_CLAUSE_AFFINITY)
2483 1154 : && gfc_match ("affinity ( ") == MATCH_YES)
2484 : {
2485 41 : gfc_namespace *ns_iter = NULL, *ns_curr = gfc_current_ns;
2486 41 : m = gfc_match_iterator (&ns_iter, true);
2487 41 : if (m == MATCH_ERROR)
2488 : break;
2489 31 : if (m == MATCH_YES && gfc_match (" : ") != MATCH_YES)
2490 : {
2491 1 : gfc_error ("Expected %<:%> at %C");
2492 1 : break;
2493 : }
2494 30 : if (ns_iter)
2495 18 : gfc_current_ns = ns_iter;
2496 30 : head = NULL;
2497 30 : m = gfc_match_omp_variable_list ("", &c->lists[OMP_LIST_AFFINITY],
2498 : false, NULL, &head, true);
2499 30 : gfc_current_ns = ns_curr;
2500 30 : if (m == MATCH_ERROR)
2501 : break;
2502 27 : if (ns_iter)
2503 : {
2504 45 : for (gfc_omp_namelist *n = *head; n; n = n->next)
2505 : {
2506 27 : n->u2.ns = ns_iter;
2507 27 : ns_iter->refs++;
2508 : }
2509 : }
2510 27 : continue;
2511 27 : }
2512 1113 : if ((mask & OMP_CLAUSE_ALLOCATE)
2513 1113 : && gfc_match ("allocate ( ") == MATCH_YES)
2514 : {
2515 279 : gfc_expr *allocator = NULL;
2516 279 : gfc_expr *align = NULL;
2517 279 : old_loc = gfc_current_locus;
2518 279 : if ((m = gfc_match ("allocator ( %e )", &allocator)) == MATCH_YES)
2519 50 : gfc_match (" , align ( %e )", &align);
2520 229 : else if ((m = gfc_match ("align ( %e )", &align)) == MATCH_YES)
2521 29 : gfc_match (" , allocator ( %e )", &allocator);
2522 :
2523 279 : if (m == MATCH_YES)
2524 : {
2525 79 : if (gfc_match (" : ") != MATCH_YES)
2526 : {
2527 5 : gfc_error ("Expected %<:%> at %C");
2528 8 : goto error;
2529 : }
2530 : }
2531 : else
2532 : {
2533 200 : m = gfc_match_expr (&allocator);
2534 200 : if (m == MATCH_YES && gfc_match (" : ") != MATCH_YES)
2535 : {
2536 : /* If no ":" then there is no allocator, we backtrack
2537 : and read the variable list. */
2538 101 : gfc_free_expr (allocator);
2539 101 : allocator = NULL;
2540 101 : gfc_current_locus = old_loc;
2541 : }
2542 : }
2543 274 : gfc_omp_namelist **head = NULL;
2544 274 : m = gfc_match_omp_variable_list ("", &c->lists[OMP_LIST_ALLOCATE],
2545 : true, NULL, &head);
2546 :
2547 274 : if (m != MATCH_YES)
2548 : {
2549 3 : gfc_free_expr (allocator);
2550 3 : gfc_free_expr (align);
2551 3 : gfc_error ("Expected variable list at %C");
2552 3 : goto error;
2553 : }
2554 :
2555 725 : for (gfc_omp_namelist *n = *head; n; n = n->next)
2556 : {
2557 454 : n->u2.allocator = allocator;
2558 454 : n->u.align = (align) ? gfc_copy_expr (align) : NULL;
2559 : }
2560 271 : gfc_free_expr (align);
2561 271 : continue;
2562 271 : }
2563 894 : if ((mask & OMP_CLAUSE_AT)
2564 834 : && (m = gfc_match_dupl_check (c->at == OMP_AT_UNSET, "at", true))
2565 : != MATCH_NO)
2566 : {
2567 66 : if (m == MATCH_ERROR)
2568 2 : goto error;
2569 64 : if (gfc_match ("compilation )") == MATCH_YES)
2570 15 : c->at = OMP_AT_COMPILATION;
2571 49 : else if (gfc_match ("execution )") == MATCH_YES)
2572 45 : c->at = OMP_AT_EXECUTION;
2573 : else
2574 : {
2575 4 : gfc_error ("Expected COMPILATION or EXECUTION in AT clause "
2576 : "at %C");
2577 4 : goto error;
2578 : }
2579 60 : continue;
2580 : }
2581 1411 : if ((mask & OMP_CLAUSE_ASYNC)
2582 768 : && (m = gfc_match_dupl_check (!c->async, "async")) != MATCH_NO)
2583 : {
2584 643 : if (m == MATCH_ERROR)
2585 0 : goto error;
2586 643 : c->async = true;
2587 643 : m = gfc_match (" ( %e )", &c->async_expr);
2588 643 : if (m == MATCH_ERROR)
2589 : {
2590 0 : gfc_current_locus = old_loc;
2591 0 : break;
2592 : }
2593 643 : else if (m == MATCH_NO)
2594 : {
2595 133 : c->async_expr
2596 133 : = gfc_get_constant_expr (BT_INTEGER,
2597 : gfc_default_integer_kind,
2598 : &gfc_current_locus);
2599 133 : mpz_set_si (c->async_expr->value.integer, GOMP_ASYNC_NOVAL);
2600 : }
2601 643 : continue;
2602 : }
2603 188 : if ((mask & OMP_CLAUSE_AUTO)
2604 125 : && (m = gfc_match_dupl_check (!c->par_auto, "auto"))
2605 : != MATCH_NO)
2606 : {
2607 63 : if (m == MATCH_ERROR)
2608 0 : goto error;
2609 63 : c->par_auto = true;
2610 63 : continue;
2611 : }
2612 121 : if ((mask & OMP_CLAUSE_ATTACH)
2613 60 : && gfc_match ("attach ( ") == MATCH_YES
2614 121 : && gfc_match_omp_map_clause (&c->lists[OMP_LIST_MAP],
2615 : OMP_MAP_ATTACH, false,
2616 : allow_derived))
2617 59 : continue;
2618 : break;
2619 36 : case 'b':
2620 70 : if ((mask & OMP_CLAUSE_BIND)
2621 36 : && (m = gfc_match_dupl_check (c->bind == OMP_BIND_UNSET, "bind",
2622 : true)) != MATCH_NO)
2623 : {
2624 36 : if (m == MATCH_ERROR)
2625 1 : goto error;
2626 35 : if (gfc_match ("teams )") == MATCH_YES)
2627 11 : c->bind = OMP_BIND_TEAMS;
2628 24 : else if (gfc_match ("parallel )") == MATCH_YES)
2629 15 : c->bind = OMP_BIND_PARALLEL;
2630 9 : else if (gfc_match ("thread )") == MATCH_YES)
2631 8 : c->bind = OMP_BIND_THREAD;
2632 : else
2633 : {
2634 1 : gfc_error ("Expected TEAMS, PARALLEL or THREAD as binding in "
2635 : "BIND at %C");
2636 1 : break;
2637 : }
2638 34 : continue;
2639 : }
2640 : break;
2641 7105 : case 'c':
2642 7378 : if ((mask & OMP_CLAUSE_CAPTURE)
2643 7105 : && (m = gfc_match_dupl_check (!c->capture, "capture"))
2644 : != MATCH_NO)
2645 : {
2646 274 : if (m == MATCH_ERROR)
2647 1 : goto error;
2648 273 : c->capture = true;
2649 273 : continue;
2650 : }
2651 6831 : if (mask & OMP_CLAUSE_COLLAPSE)
2652 : {
2653 1995 : gfc_expr *cexpr = NULL;
2654 1995 : if ((m = gfc_match_dupl_check (!c->collapse, "collapse", true,
2655 : &cexpr)) != MATCH_NO)
2656 : {
2657 1505 : int collapse;
2658 1505 : if (m == MATCH_ERROR)
2659 0 : goto error;
2660 1505 : if (gfc_extract_int (cexpr, &collapse, -1))
2661 4 : collapse = 1;
2662 1501 : else if (collapse <= 0)
2663 : {
2664 8 : gfc_error_now ("COLLAPSE clause argument not constant "
2665 : "positive integer at %C");
2666 8 : collapse = 1;
2667 : }
2668 1505 : gfc_free_expr (cexpr);
2669 1505 : c->collapse = collapse;
2670 1505 : continue;
2671 1505 : }
2672 : }
2673 5492 : if ((mask & OMP_CLAUSE_COMPARE)
2674 5326 : && (m = gfc_match_dupl_check (!c->compare, "compare"))
2675 : != MATCH_NO)
2676 : {
2677 167 : if (m == MATCH_ERROR)
2678 1 : goto error;
2679 166 : c->compare = true;
2680 166 : continue;
2681 : }
2682 5171 : if ((mask & OMP_CLAUSE_ASSUMPTIONS)
2683 5159 : && gfc_match ("contains ( ") == MATCH_YES)
2684 : {
2685 12 : if (gfc_omp_absent_contains_clause (&c->assume, false)
2686 : != MATCH_YES)
2687 0 : goto error;
2688 12 : continue;
2689 : }
2690 7263 : if ((mask & OMP_CLAUSE_COPY)
2691 3720 : && gfc_match ("copy ( ") == MATCH_YES
2692 7264 : && gfc_match_omp_map_clause (&c->lists[OMP_LIST_MAP],
2693 : OMP_MAP_TOFROM, true,
2694 : allow_derived))
2695 2116 : continue;
2696 3031 : if (mask & OMP_CLAUSE_COPYIN)
2697 : {
2698 2625 : if (openacc)
2699 : {
2700 2526 : if (gfc_match ("copyin ( ") == MATCH_YES)
2701 : {
2702 1456 : bool readonly = gfc_match ("readonly : ") == MATCH_YES;
2703 1456 : head = NULL;
2704 1456 : if (gfc_match_omp_variable_list ("",
2705 : &c->lists[OMP_LIST_MAP],
2706 : true, NULL, &head, true,
2707 : allow_derived)
2708 : == MATCH_YES)
2709 : {
2710 1450 : gfc_omp_namelist *n;
2711 3343 : for (n = *head; n; n = n->next)
2712 : {
2713 1893 : n->u.map.op = OMP_MAP_TO;
2714 1893 : n->u.map.readonly = readonly;
2715 : }
2716 1450 : continue;
2717 1450 : }
2718 : }
2719 : }
2720 99 : else if (gfc_match_omp_variable_list ("copyin (",
2721 : &c->lists[OMP_LIST_COPYIN],
2722 : true) == MATCH_YES)
2723 97 : continue;
2724 : }
2725 2554 : if ((mask & OMP_CLAUSE_COPYOUT)
2726 1215 : && gfc_match ("copyout ( ") == MATCH_YES
2727 2554 : && gfc_match_omp_map_clause (&c->lists[OMP_LIST_MAP],
2728 : OMP_MAP_FROM, true, allow_derived))
2729 1070 : continue;
2730 498 : if ((mask & OMP_CLAUSE_COPYPRIVATE)
2731 414 : && gfc_match_omp_variable_list ("copyprivate (",
2732 : &c->lists[OMP_LIST_COPYPRIVATE],
2733 : true) == MATCH_YES)
2734 84 : continue;
2735 651 : if ((mask & OMP_CLAUSE_CREATE)
2736 328 : && gfc_match ("create ( ") == MATCH_YES
2737 651 : && gfc_match_omp_map_clause (&c->lists[OMP_LIST_MAP],
2738 : OMP_MAP_ALLOC, true, allow_derived))
2739 321 : continue;
2740 : break;
2741 3722 : case 'd':
2742 3722 : if ((mask & OMP_CLAUSE_DEFAULTMAP)
2743 3722 : && gfc_match ("defaultmap ( ") == MATCH_YES)
2744 : {
2745 180 : enum gfc_omp_defaultmap behavior;
2746 180 : gfc_omp_defaultmap_category category
2747 : = OMP_DEFAULTMAP_CAT_UNCATEGORIZED;
2748 180 : if (gfc_match ("alloc ") == MATCH_YES)
2749 : behavior = OMP_DEFAULTMAP_ALLOC;
2750 174 : else if (gfc_match ("tofrom ") == MATCH_YES)
2751 : behavior = OMP_DEFAULTMAP_TOFROM;
2752 142 : else if (gfc_match ("to ") == MATCH_YES)
2753 : behavior = OMP_DEFAULTMAP_TO;
2754 132 : else if (gfc_match ("from ") == MATCH_YES)
2755 : behavior = OMP_DEFAULTMAP_FROM;
2756 129 : else if (gfc_match ("firstprivate ") == MATCH_YES)
2757 : behavior = OMP_DEFAULTMAP_FIRSTPRIVATE;
2758 94 : else if (gfc_match ("present ") == MATCH_YES)
2759 : behavior = OMP_DEFAULTMAP_PRESENT;
2760 90 : else if (gfc_match ("none ") == MATCH_YES)
2761 : behavior = OMP_DEFAULTMAP_NONE;
2762 10 : else if (gfc_match ("default ") == MATCH_YES)
2763 : behavior = OMP_DEFAULTMAP_DEFAULT;
2764 : else
2765 : {
2766 1 : gfc_error ("Expected ALLOC, TO, FROM, TOFROM, FIRSTPRIVATE, "
2767 : "PRESENT, NONE or DEFAULT at %C");
2768 1 : break;
2769 : }
2770 179 : if (')' == gfc_peek_ascii_char ())
2771 : ;
2772 102 : else if (gfc_match (": ") != MATCH_YES)
2773 : break;
2774 : else
2775 : {
2776 102 : if (gfc_match ("scalar ") == MATCH_YES)
2777 : category = OMP_DEFAULTMAP_CAT_SCALAR;
2778 67 : else if (gfc_match ("aggregate ") == MATCH_YES)
2779 : category = OMP_DEFAULTMAP_CAT_AGGREGATE;
2780 43 : else if (gfc_match ("allocatable ") == MATCH_YES)
2781 : category = OMP_DEFAULTMAP_CAT_ALLOCATABLE;
2782 31 : else if (gfc_match ("pointer ") == MATCH_YES)
2783 : category = OMP_DEFAULTMAP_CAT_POINTER;
2784 14 : else if (gfc_match ("all ") == MATCH_YES)
2785 : category = OMP_DEFAULTMAP_CAT_ALL;
2786 : else
2787 : {
2788 1 : gfc_error ("Expected SCALAR, AGGREGATE, ALLOCATABLE, "
2789 : "POINTER or ALL at %C");
2790 1 : break;
2791 : }
2792 : }
2793 1193 : for (int i = 0; i < OMP_DEFAULTMAP_CAT_NUM; ++i)
2794 : {
2795 1028 : if (i != category
2796 1028 : && category != OMP_DEFAULTMAP_CAT_UNCATEGORIZED
2797 486 : && category != OMP_DEFAULTMAP_CAT_ALL
2798 486 : && i != OMP_DEFAULTMAP_CAT_UNCATEGORIZED
2799 341 : && i != OMP_DEFAULTMAP_CAT_ALL)
2800 254 : continue;
2801 774 : if (c->defaultmap[i] != OMP_DEFAULTMAP_UNSET)
2802 : {
2803 13 : const char *pcategory = NULL;
2804 13 : switch (i)
2805 : {
2806 : case OMP_DEFAULTMAP_CAT_UNCATEGORIZED: break;
2807 : case OMP_DEFAULTMAP_CAT_ALL: pcategory = "ALL"; break;
2808 1 : case OMP_DEFAULTMAP_CAT_SCALAR: pcategory = "SCALAR"; break;
2809 2 : case OMP_DEFAULTMAP_CAT_AGGREGATE:
2810 2 : pcategory = "AGGREGATE";
2811 2 : break;
2812 1 : case OMP_DEFAULTMAP_CAT_ALLOCATABLE:
2813 1 : pcategory = "ALLOCATABLE";
2814 1 : break;
2815 2 : case OMP_DEFAULTMAP_CAT_POINTER:
2816 2 : pcategory = "POINTER";
2817 2 : break;
2818 : default: gcc_unreachable ();
2819 : }
2820 6 : if (i == OMP_DEFAULTMAP_CAT_UNCATEGORIZED)
2821 4 : gfc_error ("DEFAULTMAP at %C but prior DEFAULTMAP with "
2822 : "unspecified category");
2823 : else
2824 9 : gfc_error ("DEFAULTMAP at %C but prior DEFAULTMAP for "
2825 : "category %s", pcategory);
2826 13 : goto error;
2827 : }
2828 : }
2829 165 : c->defaultmap[category] = behavior;
2830 165 : if (gfc_match (")") != MATCH_YES)
2831 : break;
2832 165 : continue;
2833 165 : }
2834 4497 : if ((mask & OMP_CLAUSE_DEFAULT)
2835 3542 : && (m = gfc_match_dupl_check (c->default_sharing
2836 : == OMP_DEFAULT_UNKNOWN, "default",
2837 : true)) != MATCH_NO)
2838 : {
2839 1000 : if (m == MATCH_ERROR)
2840 6 : goto error;
2841 994 : if (gfc_match ("none") == MATCH_YES)
2842 584 : c->default_sharing = OMP_DEFAULT_NONE;
2843 410 : else if (openacc)
2844 : {
2845 225 : if (gfc_match ("present") == MATCH_YES)
2846 195 : c->default_sharing = OMP_DEFAULT_PRESENT;
2847 : }
2848 : else
2849 : {
2850 185 : if (gfc_match ("firstprivate") == MATCH_YES)
2851 8 : c->default_sharing = OMP_DEFAULT_FIRSTPRIVATE;
2852 177 : else if (gfc_match ("private") == MATCH_YES)
2853 24 : c->default_sharing = OMP_DEFAULT_PRIVATE;
2854 153 : else if (gfc_match ("shared") == MATCH_YES)
2855 153 : c->default_sharing = OMP_DEFAULT_SHARED;
2856 : }
2857 994 : if (c->default_sharing == OMP_DEFAULT_UNKNOWN)
2858 : {
2859 30 : if (openacc)
2860 30 : gfc_error ("Expected NONE or PRESENT in DEFAULT clause "
2861 : "at %C");
2862 : else
2863 0 : gfc_error ("Expected NONE, FIRSTPRIVATE, PRIVATE or SHARED "
2864 : "in DEFAULT clause at %C");
2865 30 : goto error;
2866 : }
2867 964 : if (gfc_match (" )") != MATCH_YES)
2868 9 : goto error;
2869 955 : continue;
2870 : }
2871 2850 : if ((mask & OMP_CLAUSE_DELETE)
2872 343 : && gfc_match ("delete ( ") == MATCH_YES
2873 2850 : && gfc_match_omp_map_clause (&c->lists[OMP_LIST_MAP],
2874 : OMP_MAP_RELEASE, true,
2875 : allow_derived))
2876 308 : continue;
2877 : /* DOACROSS: match 'doacross' and 'depend' with sink/source.
2878 : DEPEND: match 'depend' but not sink/source. */
2879 2234 : m = MATCH_NO;
2880 2234 : if (((mask & OMP_CLAUSE_DOACROSS)
2881 383 : && gfc_match ("doacross ( ") == MATCH_YES)
2882 2590 : || (((mask & OMP_CLAUSE_DEPEND) || (mask & OMP_CLAUSE_DOACROSS))
2883 1595 : && (m = gfc_match ("depend ( ")) == MATCH_YES))
2884 : {
2885 1097 : bool has_omp_all_memory;
2886 1097 : bool is_depend = m == MATCH_YES;
2887 1097 : gfc_namespace *ns_iter = NULL, *ns_curr = gfc_current_ns;
2888 1097 : match m_it = MATCH_NO;
2889 1097 : if (is_depend)
2890 1070 : m_it = gfc_match_iterator (&ns_iter, false);
2891 1070 : if (m_it == MATCH_ERROR)
2892 : break;
2893 1092 : if (m_it == MATCH_YES && gfc_match (" , ") != MATCH_YES)
2894 : break;
2895 1092 : m = MATCH_YES;
2896 1092 : gfc_omp_depend_doacross_op depend_op = OMP_DEPEND_OUT;
2897 1092 : if (gfc_match ("inoutset") == MATCH_YES)
2898 : depend_op = OMP_DEPEND_INOUTSET;
2899 1080 : else if (gfc_match ("inout") == MATCH_YES)
2900 : depend_op = OMP_DEPEND_INOUT;
2901 988 : else if (gfc_match ("in") == MATCH_YES)
2902 : depend_op = OMP_DEPEND_IN;
2903 702 : else if (gfc_match ("out") == MATCH_YES)
2904 : depend_op = OMP_DEPEND_OUT;
2905 442 : else if (gfc_match ("mutexinoutset") == MATCH_YES)
2906 : depend_op = OMP_DEPEND_MUTEXINOUTSET;
2907 424 : else if (gfc_match ("depobj") == MATCH_YES)
2908 : depend_op = OMP_DEPEND_DEPOBJ;
2909 387 : else if (gfc_match ("source") == MATCH_YES)
2910 : {
2911 143 : if (m_it == MATCH_YES)
2912 : {
2913 1 : gfc_error ("ITERATOR may not be combined with SOURCE "
2914 : "at %C");
2915 17 : goto error;
2916 : }
2917 142 : if (!(mask & OMP_CLAUSE_DOACROSS))
2918 : {
2919 1 : gfc_error ("SOURCE at %C not permitted as dependence-type"
2920 : " for this directive");
2921 1 : goto error;
2922 : }
2923 141 : if (c->doacross_source)
2924 : {
2925 0 : gfc_error ("Duplicated clause with SOURCE dependence-type"
2926 : " at %C");
2927 0 : goto error;
2928 : }
2929 141 : gfc_gobble_whitespace ();
2930 141 : m = gfc_match (": ");
2931 141 : if (m != MATCH_YES && !is_depend)
2932 : {
2933 1 : gfc_error ("Expected %<:%> at %C");
2934 1 : goto error;
2935 : }
2936 140 : if (gfc_match (")") != MATCH_YES
2937 146 : && !(m == MATCH_YES
2938 6 : && gfc_match ("omp_cur_iteration )") == MATCH_YES))
2939 : {
2940 2 : gfc_error ("Expected %<)%> or %<omp_cur_iteration)%> "
2941 : "at %C");
2942 2 : goto error;
2943 : }
2944 138 : if (is_depend)
2945 130 : gfc_warning (OPT_Wdeprecated_openmp,
2946 : "%<source%> modifier with %<depend%> clause "
2947 : "at %L deprecated since OpenMP 5.2, use with "
2948 : "%<doacross%>", &old_loc);
2949 138 : c->doacross_source = true;
2950 138 : c->depend_source = is_depend;
2951 1075 : continue;
2952 : }
2953 244 : else if (gfc_match ("sink ") == MATCH_YES)
2954 : {
2955 244 : if (!(mask & OMP_CLAUSE_DOACROSS))
2956 : {
2957 2 : gfc_error ("SINK at %C not permitted as dependence-type "
2958 : "for this directive");
2959 2 : goto error;
2960 : }
2961 242 : if (gfc_match (": ") != MATCH_YES)
2962 : {
2963 1 : gfc_error ("Expected %<:%> at %C");
2964 1 : goto error;
2965 : }
2966 241 : if (m_it == MATCH_YES)
2967 : {
2968 0 : gfc_error ("ITERATOR may not be combined with SINK "
2969 : "at %C");
2970 0 : goto error;
2971 : }
2972 241 : if (is_depend)
2973 226 : gfc_warning (OPT_Wdeprecated_openmp,
2974 : "%<sink%> modifier with %<depend%> clause at "
2975 : "%L deprecated since OpenMP 5.2, use with "
2976 : "%<doacross%>", &old_loc);
2977 241 : m = gfc_match_omp_doacross_sink (&c->lists[OMP_LIST_DEPEND],
2978 : is_depend);
2979 241 : if (m == MATCH_YES)
2980 238 : continue;
2981 3 : goto error;
2982 : }
2983 : else
2984 : m = MATCH_NO;
2985 705 : if (!(mask & OMP_CLAUSE_DEPEND))
2986 : {
2987 0 : gfc_error ("Expected dependence-type SINK or SOURCE at %C");
2988 0 : goto error;
2989 : }
2990 705 : head = NULL;
2991 705 : if (ns_iter)
2992 37 : gfc_current_ns = ns_iter;
2993 705 : if (m == MATCH_YES)
2994 705 : m = gfc_match_omp_variable_list (" : ",
2995 : &c->lists[OMP_LIST_DEPEND],
2996 : false, NULL, &head, true,
2997 : false, &has_omp_all_memory);
2998 705 : if (m != MATCH_YES)
2999 2 : goto error;
3000 703 : gfc_current_ns = ns_curr;
3001 703 : if (has_omp_all_memory && depend_op != OMP_DEPEND_INOUT
3002 21 : && depend_op != OMP_DEPEND_OUT)
3003 : {
3004 4 : gfc_error ("%<omp_all_memory%> used with DEPEND kind "
3005 : "other than OUT or INOUT at %C");
3006 4 : goto error;
3007 : }
3008 699 : gfc_omp_namelist *n;
3009 1429 : for (n = *head; n; n = n->next)
3010 : {
3011 730 : n->u.depend_doacross_op = depend_op;
3012 730 : n->u2.ns = ns_iter;
3013 730 : if (ns_iter)
3014 36 : ns_iter->refs++;
3015 : }
3016 699 : continue;
3017 699 : }
3018 1158 : if ((mask & OMP_CLAUSE_DESTROY)
3019 1137 : && gfc_match_omp_variable_list ("destroy (",
3020 : &c->lists[OMP_LIST_DESTROY],
3021 : true) == MATCH_YES)
3022 21 : continue;
3023 1242 : if ((mask & OMP_CLAUSE_DETACH)
3024 162 : && !openacc
3025 127 : && !c->detach
3026 1242 : && gfc_match_omp_detach (&c->detach) == MATCH_YES)
3027 126 : continue;
3028 1025 : if ((mask & OMP_CLAUSE_DETACH)
3029 36 : && openacc
3030 35 : && gfc_match ("detach ( ") == MATCH_YES
3031 1025 : && gfc_match_omp_map_clause (&c->lists[OMP_LIST_MAP],
3032 : OMP_MAP_DETACH, false,
3033 : allow_derived))
3034 35 : continue;
3035 991 : if ((mask & OMP_CLAUSE_DEVICEPTR)
3036 87 : && gfc_match ("deviceptr ( ") == MATCH_YES
3037 993 : && gfc_match_omp_map_clause (&c->lists[OMP_LIST_MAP],
3038 : OMP_MAP_FORCE_DEVICEPTR, false,
3039 : allow_derived))
3040 36 : continue;
3041 1010 : if ((mask & OMP_CLAUSE_DEVICE_TYPE)
3042 919 : && gfc_match_dupl_check (c->device_type == OMP_DEVICE_TYPE_UNSET,
3043 : "device_type", true) == MATCH_YES)
3044 : {
3045 92 : if (gfc_match ("host") == MATCH_YES)
3046 32 : c->device_type = OMP_DEVICE_TYPE_HOST;
3047 60 : else if (gfc_match ("nohost") == MATCH_YES)
3048 21 : c->device_type = OMP_DEVICE_TYPE_NOHOST;
3049 39 : else if (gfc_match ("any") == MATCH_YES)
3050 38 : c->device_type = OMP_DEVICE_TYPE_ANY;
3051 : else
3052 : {
3053 1 : gfc_error ("Expected HOST, NOHOST or ANY at %C");
3054 1 : break;
3055 : }
3056 91 : if (gfc_match (" )") != MATCH_YES)
3057 : break;
3058 91 : continue;
3059 : }
3060 875 : if ((mask & OMP_CLAUSE_DEVICE_RESIDENT)
3061 876 : && gfc_match_omp_variable_list
3062 49 : ("device_resident (",
3063 : &c->lists[OMP_LIST_DEVICE_RESIDENT], true) == MATCH_YES)
3064 48 : continue;
3065 1091 : if ((mask & OMP_CLAUSE_DEVICE)
3066 703 : && openacc
3067 314 : && gfc_match ("device ( ") == MATCH_YES
3068 1092 : && gfc_match_omp_map_clause (&c->lists[OMP_LIST_MAP],
3069 : OMP_MAP_FORCE_TO, true,
3070 : /* allow_derived = */ true))
3071 312 : continue;
3072 467 : if ((mask & OMP_CLAUSE_DEVICE)
3073 391 : && !openacc
3074 856 : && ((m = gfc_match_dupl_check (!c->device, "device", true))
3075 : != MATCH_NO))
3076 : {
3077 349 : if (m == MATCH_ERROR)
3078 0 : goto error;
3079 349 : c->ancestor = false;
3080 349 : if (gfc_match ("device_num : ") == MATCH_YES)
3081 : {
3082 18 : if (gfc_match ("%e )", &c->device) != MATCH_YES)
3083 : {
3084 1 : gfc_error ("Expected integer expression at %C");
3085 1 : break;
3086 : }
3087 : }
3088 331 : else if (gfc_match ("ancestor : ") == MATCH_YES)
3089 : {
3090 45 : bool has_requires = false;
3091 45 : c->ancestor = true;
3092 82 : for (gfc_namespace *ns = gfc_current_ns; ns; ns = ns->parent)
3093 80 : if (ns->omp_requires & OMP_REQ_REVERSE_OFFLOAD)
3094 : {
3095 : has_requires = true;
3096 : break;
3097 : }
3098 45 : if (!has_requires)
3099 : {
3100 2 : gfc_error ("%<ancestor%> device modifier not "
3101 : "preceded by %<requires%> directive "
3102 : "with %<reverse_offload%> clause at %C");
3103 5 : break;
3104 : }
3105 43 : locus old_loc2 = gfc_current_locus;
3106 43 : if (gfc_match ("%e )", &c->device) == MATCH_YES)
3107 : {
3108 43 : int device = 0;
3109 43 : if (!gfc_extract_int (c->device, &device) && device != 1)
3110 : {
3111 1 : gfc_current_locus = old_loc2;
3112 1 : gfc_error ("the %<device%> clause expression must "
3113 : "evaluate to %<1%> at %C");
3114 1 : break;
3115 : }
3116 : }
3117 : else
3118 : {
3119 0 : gfc_error ("Expected integer expression at %C");
3120 0 : break;
3121 : }
3122 : }
3123 286 : else if (gfc_match ("%e )", &c->device) != MATCH_YES)
3124 : {
3125 13 : gfc_error ("Expected integer expression or a single device-"
3126 : "modifier %<device_num%> or %<ancestor%> at %C");
3127 13 : break;
3128 : }
3129 332 : continue;
3130 332 : }
3131 118 : if ((mask & OMP_CLAUSE_DIST_SCHEDULE)
3132 97 : && c->dist_sched_kind == OMP_SCHED_NONE
3133 215 : && gfc_match ("dist_schedule ( static") == MATCH_YES)
3134 : {
3135 97 : m = MATCH_NO;
3136 97 : c->dist_sched_kind = OMP_SCHED_STATIC;
3137 97 : m = gfc_match (" , %e )", &c->dist_chunk_size);
3138 97 : if (m != MATCH_YES)
3139 14 : m = gfc_match_char (')');
3140 14 : if (m != MATCH_YES)
3141 : {
3142 0 : c->dist_sched_kind = OMP_SCHED_NONE;
3143 0 : gfc_current_locus = old_loc;
3144 : }
3145 : else
3146 97 : continue;
3147 : }
3148 32 : if ((mask & OMP_CLAUSE_DYN_GROUPPRIVATE)
3149 21 : && gfc_match_dupl_check (!c->dyn_groupprivate,
3150 : "dyn_groupprivate", true) == MATCH_YES)
3151 : {
3152 12 : if (gfc_match ("fallback ( abort ) : ") == MATCH_YES)
3153 1 : c->fallback = OMP_FALLBACK_ABORT;
3154 11 : else if (gfc_match ("fallback ( default_mem ) : ") == MATCH_YES)
3155 1 : c->fallback = OMP_FALLBACK_DEFAULT_MEM;
3156 10 : else if (gfc_match ("fallback ( null ) : ") == MATCH_YES)
3157 1 : c->fallback = OMP_FALLBACK_NULL;
3158 12 : if (gfc_match_expr (&c->dyn_groupprivate) != MATCH_YES)
3159 0 : return MATCH_ERROR;
3160 12 : if (gfc_match (" )") != MATCH_YES)
3161 1 : goto error;
3162 11 : continue;
3163 : }
3164 : break;
3165 90 : case 'e':
3166 90 : if ((mask & OMP_CLAUSE_ENTER))
3167 : {
3168 90 : m = gfc_match_omp_to_link ("enter (", &c->lists[OMP_LIST_ENTER]);
3169 90 : if (m == MATCH_ERROR)
3170 0 : goto error;
3171 90 : if (m == MATCH_YES)
3172 90 : continue;
3173 : }
3174 : break;
3175 2263 : case 'f':
3176 2312 : if ((mask & OMP_CLAUSE_FAIL)
3177 2263 : && (m = gfc_match_dupl_check (c->fail == OMP_MEMORDER_UNSET,
3178 : "fail", true)) != MATCH_NO)
3179 : {
3180 58 : if (m == MATCH_ERROR)
3181 3 : goto error;
3182 55 : if (gfc_match ("seq_cst") == MATCH_YES)
3183 6 : c->fail = OMP_MEMORDER_SEQ_CST;
3184 49 : else if (gfc_match ("acquire") == MATCH_YES)
3185 14 : c->fail = OMP_MEMORDER_ACQUIRE;
3186 35 : else if (gfc_match ("relaxed") == MATCH_YES)
3187 30 : c->fail = OMP_MEMORDER_RELAXED;
3188 : else
3189 : {
3190 5 : gfc_error ("Expected SEQ_CST, ACQUIRE or RELAXED at %C");
3191 5 : break;
3192 : }
3193 50 : if (gfc_match (" )") != MATCH_YES)
3194 1 : goto error;
3195 49 : continue;
3196 : }
3197 2248 : if ((mask & OMP_CLAUSE_FILTER)
3198 2205 : && (m = gfc_match_dupl_check (!c->filter, "filter", true,
3199 : &c->filter)) != MATCH_NO)
3200 : {
3201 44 : if (m == MATCH_ERROR)
3202 1 : goto error;
3203 43 : continue;
3204 : }
3205 2225 : if ((mask & OMP_CLAUSE_FINAL)
3206 2161 : && (m = gfc_match_dupl_check (!c->final_expr, "final", true,
3207 : &c->final_expr)) != MATCH_NO)
3208 : {
3209 64 : if (m == MATCH_ERROR)
3210 0 : goto error;
3211 64 : continue;
3212 : }
3213 2123 : if ((mask & OMP_CLAUSE_FINALIZE)
3214 2097 : && (m = gfc_match_dupl_check (!c->finalize, "finalize"))
3215 : != MATCH_NO)
3216 : {
3217 26 : if (m == MATCH_ERROR)
3218 0 : goto error;
3219 26 : c->finalize = true;
3220 26 : continue;
3221 : }
3222 3066 : if ((mask & OMP_CLAUSE_FIRSTPRIVATE)
3223 2071 : && gfc_match_omp_variable_list ("firstprivate (",
3224 : &c->lists[OMP_LIST_FIRSTPRIVATE],
3225 : true) == MATCH_YES)
3226 995 : continue;
3227 2075 : if ((mask & OMP_CLAUSE_FROM)
3228 1076 : && gfc_match_motion_var_list ("from (", &c->lists[OMP_LIST_FROM],
3229 : &head) == MATCH_YES)
3230 999 : continue;
3231 142 : if ((mask & OMP_CLAUSE_FULL)
3232 77 : && (m = gfc_match_dupl_check (!c->full, "full")) != MATCH_NO)
3233 : {
3234 65 : if (m == MATCH_ERROR)
3235 0 : goto error;
3236 65 : c->full = true;
3237 65 : continue;
3238 : }
3239 : break;
3240 1230 : case 'g':
3241 2421 : if ((mask & OMP_CLAUSE_GANG)
3242 1230 : && (m = gfc_match_dupl_check (!c->gang, "gang")) != MATCH_NO)
3243 : {
3244 1196 : if (m == MATCH_ERROR)
3245 0 : goto error;
3246 1196 : c->gang = true;
3247 1196 : m = match_oacc_clause_gwv (c, GOMP_DIM_GANG);
3248 1196 : if (m == MATCH_ERROR)
3249 : {
3250 5 : gfc_current_locus = old_loc;
3251 5 : break;
3252 : }
3253 1191 : continue;
3254 : }
3255 68 : if ((mask & OMP_CLAUSE_GRAINSIZE)
3256 34 : && (m = gfc_match_dupl_check (!c->grainsize, "grainsize", true))
3257 : != MATCH_NO)
3258 : {
3259 34 : if (m == MATCH_ERROR)
3260 0 : goto error;
3261 34 : if (gfc_match ("strict : ") == MATCH_YES)
3262 1 : c->grainsize_strict = true;
3263 34 : if (gfc_match (" %e )", &c->grainsize) != MATCH_YES)
3264 0 : goto error;
3265 34 : continue;
3266 : }
3267 : break;
3268 465 : case 'h':
3269 513 : if ((mask & OMP_CLAUSE_HAS_DEVICE_ADDR)
3270 513 : && gfc_match_omp_variable_list
3271 48 : ("has_device_addr (", &c->lists[OMP_LIST_HAS_DEVICE_ADDR],
3272 : false, NULL, NULL, true) == MATCH_YES)
3273 48 : continue;
3274 460 : if ((mask & OMP_CLAUSE_HINT)
3275 417 : && (m = gfc_match_dupl_check (!c->hint, "hint", true, &c->hint))
3276 : != MATCH_NO)
3277 : {
3278 43 : if (m == MATCH_ERROR)
3279 0 : goto error;
3280 43 : continue;
3281 : }
3282 374 : if ((mask & OMP_CLAUSE_ASSUMPTIONS)
3283 374 : && gfc_match ("holds ( ") == MATCH_YES)
3284 : {
3285 19 : gfc_expr *e;
3286 19 : if (gfc_match ("%e )", &e) != MATCH_YES)
3287 0 : goto error;
3288 19 : if (c->assume == NULL)
3289 12 : c->assume = gfc_get_omp_assumptions ();
3290 19 : gfc_expr_list *el = XCNEW (gfc_expr_list);
3291 19 : el->expr = e;
3292 19 : el->next = c->assume->holds;
3293 19 : c->assume->holds = el;
3294 19 : continue;
3295 19 : }
3296 709 : if ((mask & OMP_CLAUSE_HOST)
3297 355 : && gfc_match ("host ( ") == MATCH_YES
3298 710 : && gfc_match_omp_map_clause (&c->lists[OMP_LIST_MAP],
3299 : OMP_MAP_FORCE_FROM, true,
3300 : /* allow_derived = */ true))
3301 354 : continue;
3302 : break;
3303 2119 : case 'i':
3304 2142 : if ((mask & OMP_CLAUSE_IF_PRESENT)
3305 2119 : && (m = gfc_match_dupl_check (!c->if_present, "if_present"))
3306 : != MATCH_NO)
3307 : {
3308 23 : if (m == MATCH_ERROR)
3309 0 : goto error;
3310 23 : c->if_present = true;
3311 23 : continue;
3312 : }
3313 2096 : if ((mask & OMP_CLAUSE_IF)
3314 2096 : && (m = gfc_match_dupl_check (!c->if_expr, "if", true))
3315 : != MATCH_NO)
3316 : {
3317 1347 : if (m == MATCH_ERROR)
3318 12 : goto error;
3319 1335 : if (!openacc)
3320 : {
3321 : /* This should match the enum gfc_omp_if_kind order. */
3322 : static const char *ifs[OMP_IF_LAST] = {
3323 : "cancel : %e )",
3324 : "parallel : %e )",
3325 : "simd : %e )",
3326 : "task : %e )",
3327 : "taskloop : %e )",
3328 : "target : %e )",
3329 : "target data : %e )",
3330 : "target update : %e )",
3331 : "target enter data : %e )",
3332 : "target exit data : %e )" };
3333 : int i;
3334 4841 : for (i = 0; i < OMP_IF_LAST; i++)
3335 4443 : if (c->if_exprs[i] == NULL
3336 4443 : && gfc_match (ifs[i], &c->if_exprs[i]) == MATCH_YES)
3337 : break;
3338 536 : if (i < OMP_IF_LAST)
3339 138 : continue;
3340 : }
3341 1197 : if (gfc_match (" %e )", &c->if_expr) == MATCH_YES)
3342 1192 : continue;
3343 5 : goto error;
3344 : }
3345 866 : if ((mask & OMP_CLAUSE_IN_REDUCTION)
3346 749 : && gfc_match_omp_clause_reduction (pc, c, openacc, allow_derived,
3347 : openmp_target) == MATCH_YES)
3348 117 : continue;
3349 657 : if ((mask & OMP_CLAUSE_INBRANCH)
3350 632 : && (m = gfc_match_dupl_check (!c->inbranch && !c->notinbranch,
3351 : "inbranch")) != MATCH_NO)
3352 : {
3353 25 : if (m == MATCH_ERROR)
3354 0 : goto error;
3355 25 : c->inbranch = true;
3356 25 : continue;
3357 : }
3358 849 : if ((mask & OMP_CLAUSE_INDEPENDENT)
3359 607 : && (m = gfc_match_dupl_check (!c->independent, "independent"))
3360 : != MATCH_NO)
3361 : {
3362 242 : if (m == MATCH_ERROR)
3363 0 : goto error;
3364 242 : c->independent = true;
3365 242 : continue;
3366 : }
3367 365 : if ((mask & OMP_CLAUSE_INDIRECT)
3368 365 : && (m = gfc_match_dupl_check (!c->indirect, "indirect"))
3369 : != MATCH_NO)
3370 : {
3371 61 : if (m == MATCH_ERROR)
3372 5 : goto error;
3373 60 : gfc_expr *indirect_expr = NULL;
3374 60 : m = gfc_match (" ( %e )", &indirect_expr);
3375 60 : if (m == MATCH_YES)
3376 : {
3377 13 : if (!gfc_resolve_expr (indirect_expr)
3378 13 : || indirect_expr->ts.type != BT_LOGICAL
3379 23 : || indirect_expr->expr_type != EXPR_CONSTANT)
3380 : {
3381 4 : gfc_error ("INDIRECT clause at %C requires a constant "
3382 : "logical expression");
3383 4 : gfc_free_expr (indirect_expr);
3384 4 : goto error;
3385 : }
3386 9 : c->indirect = indirect_expr->value.logical;
3387 9 : gfc_free_expr (indirect_expr);
3388 : }
3389 : else
3390 47 : c->indirect = 1;
3391 56 : continue;
3392 56 : }
3393 304 : if ((mask & OMP_CLAUSE_INIT)
3394 304 : && gfc_match ("init ( ") == MATCH_YES)
3395 : {
3396 108 : m = gfc_match_omp_init (&c->lists[OMP_LIST_INIT]);
3397 108 : if (m == MATCH_YES)
3398 63 : continue;
3399 45 : goto error;
3400 : }
3401 196 : if ((mask & OMP_CLAUSE_INTEROP)
3402 196 : && (m = gfc_match_dupl_check (!c->lists[OMP_LIST_INTEROP],
3403 : "interop", true)) != MATCH_NO)
3404 : {
3405 : /* Note: the interop objects are saved in reverse order to match
3406 : the order in C/C++. */
3407 125 : if (m == MATCH_YES
3408 63 : && (gfc_match_omp_variable_list ("",
3409 : &c->lists[OMP_LIST_INTEROP],
3410 : false, NULL, NULL, false,
3411 : false, NULL, false, true)
3412 : == MATCH_YES))
3413 62 : continue;
3414 1 : goto error;
3415 : }
3416 253 : if ((mask & OMP_CLAUSE_IS_DEVICE_PTR)
3417 253 : && gfc_match_omp_variable_list
3418 120 : ("is_device_ptr (",
3419 : &c->lists[OMP_LIST_IS_DEVICE_PTR], false) == MATCH_YES)
3420 120 : continue;
3421 : break;
3422 2333 : case 'l':
3423 2333 : if ((mask & OMP_CLAUSE_LASTPRIVATE)
3424 2333 : && gfc_match ("lastprivate ( ") == MATCH_YES)
3425 : {
3426 1431 : bool conditional = gfc_match ("conditional : ") == MATCH_YES;
3427 1431 : head = NULL;
3428 1431 : if (gfc_match_omp_variable_list ("",
3429 : &c->lists[OMP_LIST_LASTPRIVATE],
3430 : false, NULL, &head) == MATCH_YES)
3431 : {
3432 1431 : gfc_omp_namelist *n;
3433 3737 : for (n = *head; n; n = n->next)
3434 2306 : n->u.lastprivate_conditional = conditional;
3435 1431 : continue;
3436 1431 : }
3437 0 : gfc_current_locus = old_loc;
3438 0 : break;
3439 : }
3440 902 : end_colon = false;
3441 902 : head = NULL;
3442 902 : if ((mask & OMP_CLAUSE_LINEAR)
3443 902 : && gfc_match ("linear (") == MATCH_YES)
3444 : {
3445 835 : bool old_linear_modifier = false;
3446 835 : gfc_omp_linear_op linear_op = OMP_LINEAR_DEFAULT;
3447 835 : gfc_expr *step = NULL;
3448 835 : locus saved_loc = gfc_current_locus;
3449 :
3450 835 : if (gfc_match_omp_variable_list (" ref (",
3451 : &c->lists[OMP_LIST_LINEAR],
3452 : false, NULL, &head)
3453 : == MATCH_YES)
3454 : {
3455 : linear_op = OMP_LINEAR_REF;
3456 : old_linear_modifier = true;
3457 : }
3458 807 : else if (gfc_match_omp_variable_list (" val (",
3459 : &c->lists[OMP_LIST_LINEAR],
3460 : false, NULL, &head)
3461 : == MATCH_YES)
3462 : {
3463 : linear_op = OMP_LINEAR_VAL;
3464 : old_linear_modifier = true;
3465 : }
3466 796 : else if (gfc_match_omp_variable_list (" uval (",
3467 : &c->lists[OMP_LIST_LINEAR],
3468 : false, NULL, &head)
3469 : == MATCH_YES)
3470 : {
3471 : linear_op = OMP_LINEAR_UVAL;
3472 : old_linear_modifier = true;
3473 : }
3474 787 : else if (gfc_match_omp_variable_list ("",
3475 : &c->lists[OMP_LIST_LINEAR],
3476 : false, &end_colon, &head)
3477 : == MATCH_YES)
3478 : linear_op = OMP_LINEAR_DEFAULT;
3479 : else
3480 : {
3481 2 : gfc_current_locus = old_loc;
3482 2 : break;
3483 : }
3484 : if (linear_op != OMP_LINEAR_DEFAULT)
3485 : {
3486 48 : if (gfc_match (" :") == MATCH_YES)
3487 31 : end_colon = true;
3488 17 : else if (gfc_match (" )") != MATCH_YES)
3489 : {
3490 0 : gfc_free_omp_namelist (*head, false, false, false, false);
3491 0 : gfc_current_locus = old_loc;
3492 0 : *head = NULL;
3493 0 : break;
3494 : }
3495 : }
3496 833 : gfc_gobble_whitespace ();
3497 833 : if (old_linear_modifier && end_colon)
3498 : {
3499 31 : if (gfc_match (" %e )", &step) != MATCH_YES)
3500 : {
3501 1 : gfc_free_omp_namelist (*head, false, false, false, false);
3502 1 : gfc_current_locus = old_loc;
3503 1 : *head = NULL;
3504 5 : goto error;
3505 : }
3506 : }
3507 832 : if (old_linear_modifier)
3508 : {
3509 47 : char var_names[512]{};
3510 47 : int count, offset = 0;
3511 106 : for (gfc_omp_namelist *n = *head; n; n = n->next)
3512 : {
3513 59 : if (!n->next)
3514 47 : count = snprintf (var_names + offset,
3515 47 : sizeof (var_names) - offset,
3516 47 : "%s", n->sym->name);
3517 : else
3518 12 : count = snprintf (var_names + offset,
3519 12 : sizeof (var_names) - offset,
3520 12 : "%s, ", n->sym->name);
3521 59 : if (count < 0 || count >= ((int)sizeof (var_names))
3522 59 : - offset)
3523 : {
3524 0 : snprintf (var_names, 512, "%s, ..., ",
3525 0 : (*head)->sym->name);
3526 0 : while (n->next)
3527 : n = n->next;
3528 0 : offset = strlen (var_names);
3529 0 : snprintf (var_names + offset,
3530 0 : sizeof (var_names) - offset,
3531 0 : "%s", n->sym->name);
3532 0 : break;
3533 : }
3534 59 : offset += count;
3535 : }
3536 47 : char *var_names_for_warn = var_names;
3537 47 : const char *op_name;
3538 47 : switch (linear_op)
3539 : {
3540 : case OMP_LINEAR_REF: op_name = "ref"; break;
3541 10 : case OMP_LINEAR_VAL: op_name = "val"; break;
3542 9 : case OMP_LINEAR_UVAL: op_name = "uval"; break;
3543 0 : default: gcc_unreachable ();
3544 : }
3545 47 : gfc_warning (OPT_Wdeprecated_openmp,
3546 : "Specification of the list items as "
3547 : "arguments to the modifiers at %L is "
3548 : "deprecated; since OpenMP 5.2, use "
3549 : "%<linear(%s : %s%s)%>", &saved_loc,
3550 : var_names_for_warn, op_name,
3551 47 : step == nullptr ? "" : ", step(...)");
3552 : }
3553 785 : else if (end_colon)
3554 : {
3555 713 : bool has_error = false;
3556 : bool has_modifiers = false;
3557 : bool has_step = false;
3558 713 : bool duplicate_step = false;
3559 713 : bool duplicate_mod = false;
3560 713 : while (true)
3561 : {
3562 713 : old_loc = gfc_current_locus;
3563 713 : bool close_paren = gfc_match ("val )") == MATCH_YES;
3564 713 : if (close_paren || gfc_match ("val , ") == MATCH_YES)
3565 : {
3566 17 : if (linear_op != OMP_LINEAR_DEFAULT)
3567 : {
3568 : duplicate_mod = true;
3569 : break;
3570 : }
3571 16 : linear_op = OMP_LINEAR_VAL;
3572 16 : has_modifiers = true;
3573 16 : if (close_paren)
3574 : break;
3575 10 : continue;
3576 : }
3577 696 : close_paren = gfc_match ("uval )") == MATCH_YES;
3578 696 : if (close_paren || gfc_match ("uval , ") == MATCH_YES)
3579 : {
3580 7 : if (linear_op != OMP_LINEAR_DEFAULT)
3581 : {
3582 : duplicate_mod = true;
3583 : break;
3584 : }
3585 7 : linear_op = OMP_LINEAR_UVAL;
3586 7 : has_modifiers = true;
3587 7 : if (close_paren)
3588 : break;
3589 2 : continue;
3590 : }
3591 689 : close_paren = gfc_match ("ref )") == MATCH_YES;
3592 689 : if (close_paren || gfc_match ("ref , ") == MATCH_YES)
3593 : {
3594 16 : if (linear_op != OMP_LINEAR_DEFAULT)
3595 : {
3596 : duplicate_mod = true;
3597 : break;
3598 : }
3599 15 : linear_op = OMP_LINEAR_REF;
3600 15 : has_modifiers = true;
3601 15 : if (close_paren)
3602 : break;
3603 7 : continue;
3604 : }
3605 673 : close_paren = (gfc_match ("step ( %e ) )", &step)
3606 : == MATCH_YES);
3607 684 : if (close_paren
3608 673 : || gfc_match ("step ( %e ) , ", &step) == MATCH_YES)
3609 : {
3610 38 : if (has_step)
3611 : {
3612 : duplicate_step = true;
3613 : break;
3614 : }
3615 37 : has_modifiers = has_step = true;
3616 37 : if (close_paren)
3617 : break;
3618 11 : continue;
3619 : }
3620 635 : if (!has_modifiers
3621 635 : && gfc_match ("%e )", &step) == MATCH_YES)
3622 : {
3623 635 : if ((step->expr_type == EXPR_FUNCTION
3624 634 : || step->expr_type == EXPR_VARIABLE)
3625 31 : && strcmp (step->symtree->name, "step") == 0)
3626 : {
3627 1 : gfc_current_locus = old_loc;
3628 1 : gfc_match ("step (");
3629 1 : has_error = true;
3630 : }
3631 : break;
3632 : }
3633 : has_error = true;
3634 : break;
3635 : }
3636 49 : if (duplicate_mod || duplicate_step)
3637 : {
3638 3 : gfc_error ("Multiple %qs modifiers specified at %C",
3639 : duplicate_mod ? "linear" : "step");
3640 3 : has_error = true;
3641 : }
3642 683 : if (has_error)
3643 : {
3644 4 : gfc_free_omp_namelist (*head, false, false, false, false);
3645 4 : *head = NULL;
3646 4 : goto error;
3647 : }
3648 : }
3649 828 : if (step == NULL)
3650 : {
3651 129 : step = gfc_get_constant_expr (BT_INTEGER,
3652 : gfc_default_integer_kind,
3653 : &old_loc);
3654 129 : mpz_set_si (step->value.integer, 1);
3655 : }
3656 828 : (*head)->expr = step;
3657 828 : if (linear_op != OMP_LINEAR_DEFAULT || old_linear_modifier)
3658 176 : for (gfc_omp_namelist *n = *head; n; n = n->next)
3659 : {
3660 94 : n->u.linear.op = linear_op;
3661 94 : n->u.linear.old_modifier = old_linear_modifier;
3662 : }
3663 828 : continue;
3664 828 : }
3665 71 : if ((mask & OMP_CLAUSE_LINK)
3666 67 : && openacc
3667 75 : && (gfc_match_oacc_clause_link ("link (",
3668 : &c->lists[OMP_LIST_LINK])
3669 : == MATCH_YES))
3670 4 : continue;
3671 110 : else if ((mask & OMP_CLAUSE_LINK)
3672 63 : && !openacc
3673 122 : && (gfc_match_omp_to_link ("link (",
3674 : &c->lists[OMP_LIST_LINK])
3675 : == MATCH_YES))
3676 47 : continue;
3677 28 : if ((mask & OMP_CLAUSE_LOCAL)
3678 16 : && (gfc_match_omp_to_link ("local (", &c->lists[OMP_LIST_LOCAL])
3679 : == MATCH_YES))
3680 12 : continue;
3681 : break;
3682 5208 : case 'm':
3683 5208 : if ((mask & OMP_CLAUSE_MAP)
3684 5208 : && gfc_match ("map ( ") == MATCH_YES)
3685 : {
3686 5116 : locus old_loc2 = gfc_current_locus;
3687 5116 : int always_modifier = 0;
3688 5116 : int close_modifier = 0;
3689 5116 : int present_modifier = 0;
3690 5116 : locus second_always_locus = old_loc2;
3691 5116 : locus second_close_locus = old_loc2;
3692 5116 : locus second_present_locus = old_loc2;
3693 :
3694 5640 : for (;;)
3695 : {
3696 5378 : locus current_locus = gfc_current_locus;
3697 5378 : if (gfc_match ("always ") == MATCH_YES)
3698 : {
3699 141 : if (always_modifier++ == 1)
3700 5 : second_always_locus = current_locus;
3701 : }
3702 5237 : else if (gfc_match ("close ") == MATCH_YES)
3703 : {
3704 66 : if (close_modifier++ == 1)
3705 5 : second_close_locus = current_locus;
3706 : }
3707 5171 : else if (gfc_match ("present ") == MATCH_YES)
3708 : {
3709 55 : if (present_modifier++ == 1)
3710 4 : second_present_locus = current_locus;
3711 : }
3712 : else
3713 : break;
3714 262 : if (gfc_match (", ") != MATCH_YES)
3715 62 : gfc_warning (OPT_Wdeprecated_openmp,
3716 : "The specification of modifiers without "
3717 : "comma separators for the %<map%> clause "
3718 : "at %C has been deprecated since "
3719 : "OpenMP 5.2");
3720 262 : }
3721 :
3722 5116 : gfc_omp_map_op map_op = OMP_MAP_TOFROM;
3723 5116 : int always_present_modifier
3724 5116 : = always_modifier && present_modifier;
3725 :
3726 5116 : if (gfc_match ("alloc : ") == MATCH_YES)
3727 601 : map_op = (present_modifier ? OMP_MAP_PRESENT_ALLOC
3728 : : OMP_MAP_ALLOC);
3729 4515 : else if (gfc_match ("tofrom : ") == MATCH_YES)
3730 840 : map_op = (always_present_modifier ? OMP_MAP_ALWAYS_PRESENT_TOFROM
3731 836 : : present_modifier ? OMP_MAP_PRESENT_TOFROM
3732 832 : : always_modifier ? OMP_MAP_ALWAYS_TOFROM
3733 : : OMP_MAP_TOFROM);
3734 3675 : else if (gfc_match ("to : ") == MATCH_YES)
3735 1623 : map_op = (always_present_modifier ? OMP_MAP_ALWAYS_PRESENT_TO
3736 1617 : : present_modifier ? OMP_MAP_PRESENT_TO
3737 1606 : : always_modifier ? OMP_MAP_ALWAYS_TO
3738 : : OMP_MAP_TO);
3739 2052 : else if (gfc_match ("from : ") == MATCH_YES)
3740 1528 : map_op = (always_present_modifier ? OMP_MAP_ALWAYS_PRESENT_FROM
3741 1524 : : present_modifier ? OMP_MAP_PRESENT_FROM
3742 1520 : : always_modifier ? OMP_MAP_ALWAYS_FROM
3743 : : OMP_MAP_FROM);
3744 524 : else if (gfc_match ("release : ") == MATCH_YES)
3745 : map_op = OMP_MAP_RELEASE;
3746 507 : else if (gfc_match ("delete : ") == MATCH_YES)
3747 : map_op = OMP_MAP_DELETE;
3748 : else
3749 : {
3750 460 : gfc_current_locus = old_loc2;
3751 460 : always_modifier = 0;
3752 460 : close_modifier = 0;
3753 : }
3754 :
3755 1264 : if (always_modifier > 1)
3756 : {
3757 5 : gfc_error ("too many %<always%> modifiers at %L",
3758 : &second_always_locus);
3759 21 : break;
3760 : }
3761 5111 : if (close_modifier > 1)
3762 : {
3763 4 : gfc_error ("too many %<close%> modifiers at %L",
3764 : &second_close_locus);
3765 4 : break;
3766 : }
3767 5107 : if (present_modifier > 1)
3768 : {
3769 4 : gfc_error ("too many %<present%> modifiers at %L",
3770 : &second_present_locus);
3771 4 : break;
3772 : }
3773 :
3774 5103 : head = NULL;
3775 5103 : if (gfc_match_omp_variable_list ("", &c->lists[OMP_LIST_MAP],
3776 : false, NULL, &head,
3777 : true, true) == MATCH_YES)
3778 : {
3779 5100 : gfc_omp_namelist *n;
3780 11759 : for (n = *head; n; n = n->next)
3781 6659 : n->u.map.op = map_op;
3782 5100 : continue;
3783 5100 : }
3784 3 : gfc_current_locus = old_loc;
3785 3 : break;
3786 : }
3787 126 : if ((mask & OMP_CLAUSE_MERGEABLE)
3788 92 : && (m = gfc_match_dupl_check (!c->mergeable, "mergeable"))
3789 : != MATCH_NO)
3790 : {
3791 34 : if (m == MATCH_ERROR)
3792 0 : goto error;
3793 34 : c->mergeable = true;
3794 34 : continue;
3795 : }
3796 111 : if ((mask & OMP_CLAUSE_MESSAGE)
3797 58 : && (m = gfc_match_dupl_check (!c->message, "message", true,
3798 : &c->message)) != MATCH_NO)
3799 : {
3800 58 : if (m == MATCH_ERROR)
3801 5 : goto error;
3802 53 : continue;
3803 : }
3804 : break;
3805 2898 : case 'n':
3806 2950 : if ((mask & OMP_CLAUSE_NO_CREATE)
3807 1343 : && gfc_match ("no_create ( ") == MATCH_YES
3808 2950 : && gfc_match_omp_map_clause (&c->lists[OMP_LIST_MAP],
3809 : OMP_MAP_IF_PRESENT, true,
3810 : allow_derived))
3811 52 : continue;
3812 2847 : if ((mask & OMP_CLAUSE_ASSUMPTIONS)
3813 2872 : && (m = gfc_match_dupl_check (!c->assume
3814 26 : || !c->assume->no_openmp_constructs,
3815 : "no_openmp_constructs")) != MATCH_NO)
3816 : {
3817 2 : if (m == MATCH_ERROR)
3818 1 : goto error;
3819 1 : if (c->assume == NULL)
3820 0 : c->assume = gfc_get_omp_assumptions ();
3821 1 : c->assume->no_openmp_constructs = true;
3822 1 : continue;
3823 : }
3824 2857 : if ((mask & OMP_CLAUSE_ASSUMPTIONS)
3825 2868 : && (m = gfc_match_dupl_check (!c->assume
3826 24 : || !c->assume->no_openmp_routines,
3827 : "no_openmp_routines")) != MATCH_NO)
3828 : {
3829 13 : if (m == MATCH_ERROR)
3830 0 : goto error;
3831 13 : if (c->assume == NULL)
3832 12 : c->assume = gfc_get_omp_assumptions ();
3833 13 : c->assume->no_openmp_routines = true;
3834 13 : continue;
3835 : }
3836 2835 : if ((mask & OMP_CLAUSE_ASSUMPTIONS)
3837 2841 : && (m = gfc_match_dupl_check (!c->assume || !c->assume->no_openmp,
3838 : "no_openmp")) != MATCH_NO)
3839 : {
3840 4 : if (m == MATCH_ERROR)
3841 0 : goto error;
3842 4 : if (c->assume == NULL)
3843 4 : c->assume = gfc_get_omp_assumptions ();
3844 4 : c->assume->no_openmp = true;
3845 4 : continue;
3846 : }
3847 2833 : if ((mask & OMP_CLAUSE_ASSUMPTIONS)
3848 2834 : && (m = gfc_match_dupl_check (!c->assume
3849 7 : || !c->assume->no_parallelism,
3850 : "no_parallelism")) != MATCH_NO)
3851 : {
3852 6 : if (m == MATCH_ERROR)
3853 0 : goto error;
3854 6 : if (c->assume == NULL)
3855 6 : c->assume = gfc_get_omp_assumptions ();
3856 6 : c->assume->no_parallelism = true;
3857 6 : continue;
3858 : }
3859 :
3860 2831 : if ((mask & OMP_CLAUSE_NOVARIANTS)
3861 2821 : && (m = gfc_match_dupl_check (!c->novariants, "novariants", true,
3862 : &c->novariants))
3863 : != MATCH_NO)
3864 : {
3865 12 : if (m == MATCH_ERROR)
3866 2 : goto error;
3867 10 : continue;
3868 : }
3869 2822 : if ((mask & OMP_CLAUSE_NOCONTEXT)
3870 2809 : && (m = gfc_match_dupl_check (!c->nocontext, "nocontext", true,
3871 : &c->nocontext))
3872 : != MATCH_NO)
3873 : {
3874 15 : if (m == MATCH_ERROR)
3875 2 : goto error;
3876 13 : continue;
3877 : }
3878 2808 : if ((mask & OMP_CLAUSE_NOGROUP)
3879 2794 : && (m = gfc_match_dupl_check (!c->nogroup, "nogroup"))
3880 : != MATCH_NO)
3881 : {
3882 14 : if (m == MATCH_ERROR)
3883 0 : goto error;
3884 14 : c->nogroup = true;
3885 14 : continue;
3886 : }
3887 2930 : if ((mask & OMP_CLAUSE_NOHOST)
3888 2780 : && (m = gfc_match_dupl_check (!c->nohost, "nohost")) != MATCH_NO)
3889 : {
3890 151 : if (m == MATCH_ERROR)
3891 1 : goto error;
3892 150 : c->nohost = true;
3893 150 : continue;
3894 : }
3895 2671 : if ((mask & OMP_CLAUSE_NOTEMPORAL)
3896 2629 : && gfc_match_omp_variable_list ("nontemporal (",
3897 : &c->lists[OMP_LIST_NONTEMPORAL],
3898 : true) == MATCH_YES)
3899 42 : continue;
3900 2611 : if ((mask & OMP_CLAUSE_NOTINBRANCH)
3901 2588 : && (m = gfc_match_dupl_check (!c->notinbranch && !c->inbranch,
3902 : "notinbranch")) != MATCH_NO)
3903 : {
3904 25 : if (m == MATCH_ERROR)
3905 1 : goto error;
3906 24 : c->notinbranch = true;
3907 24 : continue;
3908 : }
3909 2691 : if ((mask & OMP_CLAUSE_NOWAIT)
3910 2562 : && (m = gfc_match_dupl_check (!c->nowait, "nowait")) != MATCH_NO)
3911 : {
3912 132 : if (m == MATCH_ERROR)
3913 3 : goto error;
3914 129 : c->nowait = true;
3915 129 : continue;
3916 : }
3917 3112 : if ((mask & OMP_CLAUSE_NUM_GANGS)
3918 2430 : && (m = gfc_match_dupl_check (!c->num_gangs_expr, "num_gangs",
3919 : true)) != MATCH_NO)
3920 : {
3921 686 : if (m == MATCH_ERROR)
3922 2 : goto error;
3923 684 : if (gfc_match (" %e )", &c->num_gangs_expr) != MATCH_YES)
3924 2 : goto error;
3925 682 : continue;
3926 : }
3927 1770 : if ((mask & OMP_CLAUSE_NUM_TASKS)
3928 1744 : && (m = gfc_match_dupl_check (!c->num_tasks, "num_tasks", true))
3929 : != MATCH_NO)
3930 : {
3931 26 : if (m == MATCH_ERROR)
3932 0 : goto error;
3933 26 : if (gfc_match ("strict : ") == MATCH_YES)
3934 1 : c->num_tasks_strict = true;
3935 26 : if (gfc_match (" %e )", &c->num_tasks) != MATCH_YES)
3936 0 : goto error;
3937 26 : continue;
3938 : }
3939 1845 : if ((mask & OMP_CLAUSE_NUM_TEAMS)
3940 1718 : && (m = gfc_match_dupl_check (!c->num_teams_upper, "num_teams",
3941 : true)) != MATCH_NO)
3942 : {
3943 127 : if (m == MATCH_ERROR)
3944 0 : goto error;
3945 127 : if (gfc_match ("%e ", &c->num_teams_upper) != MATCH_YES)
3946 0 : goto error;
3947 127 : if (gfc_peek_ascii_char () == ':')
3948 : {
3949 21 : c->num_teams_lower = c->num_teams_upper;
3950 21 : c->num_teams_upper = NULL;
3951 21 : if (gfc_match (": %e ", &c->num_teams_upper) != MATCH_YES)
3952 0 : goto error;
3953 : }
3954 127 : if (gfc_match (") ") != MATCH_YES)
3955 0 : goto error;
3956 127 : continue;
3957 : }
3958 2541 : if ((mask & OMP_CLAUSE_NUM_THREADS)
3959 1591 : && (m = gfc_match_dupl_check (!c->num_threads, "num_threads", true,
3960 : &c->num_threads)) != MATCH_NO)
3961 : {
3962 950 : if (m == MATCH_ERROR)
3963 0 : goto error;
3964 950 : continue;
3965 : }
3966 1240 : if ((mask & OMP_CLAUSE_NUM_WORKERS)
3967 641 : && (m = gfc_match_dupl_check (!c->num_workers_expr, "num_workers",
3968 : true, &c->num_workers_expr))
3969 : != MATCH_NO)
3970 : {
3971 603 : if (m == MATCH_ERROR)
3972 4 : goto error;
3973 599 : continue;
3974 : }
3975 : break;
3976 591 : case 'o':
3977 591 : if ((mask & OMP_CLAUSE_ORDERED)
3978 591 : && (m = gfc_match_dupl_check (!c->ordered, "ordered"))
3979 : != MATCH_NO)
3980 : {
3981 343 : if (m == MATCH_ERROR)
3982 0 : goto error;
3983 343 : gfc_expr *cexpr = NULL;
3984 343 : m = gfc_match (" ( %e )", &cexpr);
3985 :
3986 343 : c->ordered = true;
3987 343 : if (m == MATCH_YES)
3988 : {
3989 144 : int ordered = 0;
3990 144 : if (gfc_extract_int (cexpr, &ordered, -1))
3991 0 : ordered = 0;
3992 144 : else if (ordered <= 0)
3993 : {
3994 0 : gfc_error_now ("ORDERED clause argument not"
3995 : " constant positive integer at %C");
3996 0 : ordered = 0;
3997 : }
3998 144 : c->orderedc = ordered;
3999 144 : gfc_free_expr (cexpr);
4000 144 : continue;
4001 144 : }
4002 :
4003 199 : continue;
4004 199 : }
4005 482 : if ((mask & OMP_CLAUSE_ORDER)
4006 248 : && (m = gfc_match_dupl_check (!c->order_concurrent, "order", true))
4007 : != MATCH_NO)
4008 : {
4009 247 : if (m == MATCH_ERROR)
4010 10 : goto error;
4011 237 : if (gfc_match (" reproducible : concurrent )") == MATCH_YES)
4012 55 : c->order_reproducible = true;
4013 182 : else if (gfc_match (" concurrent )") == MATCH_YES)
4014 : ;
4015 50 : else if (gfc_match (" unconstrained : concurrent )") == MATCH_YES)
4016 47 : c->order_unconstrained = true;
4017 : else
4018 : {
4019 3 : gfc_error ("Expected ORDER(CONCURRENT) at %C "
4020 : "with optional %<reproducible%> or "
4021 : "%<unconstrained%> modifier");
4022 3 : goto error;
4023 : }
4024 234 : c->order_concurrent = true;
4025 234 : continue;
4026 : }
4027 : break;
4028 3093 : case 'p':
4029 3093 : if (mask & OMP_CLAUSE_PARTIAL)
4030 : {
4031 276 : if ((m = gfc_match_dupl_check (!c->partial, "partial"))
4032 : != MATCH_NO)
4033 : {
4034 276 : int expr;
4035 276 : if (m == MATCH_ERROR)
4036 0 : goto error;
4037 :
4038 276 : c->partial = -1;
4039 :
4040 276 : gfc_expr *cexpr = NULL;
4041 276 : m = gfc_match (" ( %e )", &cexpr);
4042 276 : if (m == MATCH_NO)
4043 : ;
4044 251 : else if (m == MATCH_YES
4045 251 : && !gfc_extract_int (cexpr, &expr, -1)
4046 502 : && expr > 0)
4047 247 : c->partial = expr;
4048 : else
4049 4 : gfc_error_now ("PARTIAL clause argument not constant "
4050 : "positive integer at %C");
4051 276 : gfc_free_expr (cexpr);
4052 276 : continue;
4053 276 : }
4054 : }
4055 2886 : if ((mask & OMP_CLAUSE_COPY)
4056 877 : && gfc_match ("pcopy ( ") == MATCH_YES
4057 2887 : && gfc_match_omp_map_clause (&c->lists[OMP_LIST_MAP],
4058 : OMP_MAP_TOFROM, true, allow_derived))
4059 69 : continue;
4060 2822 : if ((mask & OMP_CLAUSE_COPYIN)
4061 1904 : && gfc_match ("pcopyin ( ") == MATCH_YES
4062 2822 : && gfc_match_omp_map_clause (&c->lists[OMP_LIST_MAP],
4063 : OMP_MAP_TO, true, allow_derived))
4064 74 : continue;
4065 2747 : if ((mask & OMP_CLAUSE_COPYOUT)
4066 735 : && gfc_match ("pcopyout ( ") == MATCH_YES
4067 2747 : && gfc_match_omp_map_clause (&c->lists[OMP_LIST_MAP],
4068 : OMP_MAP_FROM, true, allow_derived))
4069 73 : continue;
4070 2616 : if ((mask & OMP_CLAUSE_CREATE)
4071 672 : && gfc_match ("pcreate ( ") == MATCH_YES
4072 2616 : && gfc_match_omp_map_clause (&c->lists[OMP_LIST_MAP],
4073 : OMP_MAP_ALLOC, true, allow_derived))
4074 15 : continue;
4075 3002 : if ((mask & OMP_CLAUSE_PRESENT)
4076 647 : && gfc_match ("present ( ") == MATCH_YES
4077 3004 : && gfc_match_omp_map_clause (&c->lists[OMP_LIST_MAP],
4078 : OMP_MAP_FORCE_PRESENT, false,
4079 : allow_derived))
4080 416 : continue;
4081 2193 : if ((mask & OMP_CLAUSE_COPY)
4082 231 : && gfc_match ("present_or_copy ( ") == MATCH_YES
4083 2193 : && gfc_match_omp_map_clause (&c->lists[OMP_LIST_MAP],
4084 : OMP_MAP_TOFROM, true,
4085 : allow_derived))
4086 23 : continue;
4087 2187 : if ((mask & OMP_CLAUSE_COPYIN)
4088 1303 : && gfc_match ("present_or_copyin ( ") == MATCH_YES
4089 2187 : && gfc_match_omp_map_clause (&c->lists[OMP_LIST_MAP],
4090 : OMP_MAP_TO, true, allow_derived))
4091 40 : continue;
4092 2142 : if ((mask & OMP_CLAUSE_COPYOUT)
4093 173 : && gfc_match ("present_or_copyout ( ") == MATCH_YES
4094 2142 : && gfc_match_omp_map_clause (&c->lists[OMP_LIST_MAP],
4095 : OMP_MAP_FROM, true, allow_derived))
4096 35 : continue;
4097 2100 : if ((mask & OMP_CLAUSE_CREATE)
4098 143 : && gfc_match ("present_or_create ( ") == MATCH_YES
4099 2100 : && gfc_match_omp_map_clause (&c->lists[OMP_LIST_MAP],
4100 : OMP_MAP_ALLOC, true, allow_derived))
4101 28 : continue;
4102 2078 : if ((mask & OMP_CLAUSE_PRIORITY)
4103 2044 : && (m = gfc_match_dupl_check (!c->priority, "priority", true,
4104 : &c->priority)) != MATCH_NO)
4105 : {
4106 34 : if (m == MATCH_ERROR)
4107 0 : goto error;
4108 34 : continue;
4109 : }
4110 3943 : if ((mask & OMP_CLAUSE_PRIVATE)
4111 2010 : && gfc_match_omp_variable_list ("private (",
4112 : &c->lists[OMP_LIST_PRIVATE],
4113 : true) == MATCH_YES)
4114 1933 : continue;
4115 141 : if ((mask & OMP_CLAUSE_PROC_BIND)
4116 141 : && (m = gfc_match_dupl_check ((c->proc_bind
4117 64 : == OMP_PROC_BIND_UNKNOWN),
4118 : "proc_bind", true)) != MATCH_NO)
4119 : {
4120 64 : if (m == MATCH_ERROR)
4121 0 : goto error;
4122 64 : if (gfc_match ("primary )") == MATCH_YES)
4123 1 : c->proc_bind = OMP_PROC_BIND_PRIMARY;
4124 63 : else if (gfc_match ("master )") == MATCH_YES)
4125 : {
4126 9 : gfc_warning (OPT_Wdeprecated_openmp,
4127 : "%<master%> affinity policy at %C deprecated "
4128 : "since OpenMP 5.1, use %<primary%>");
4129 9 : c->proc_bind = OMP_PROC_BIND_MASTER;
4130 : }
4131 54 : else if (gfc_match ("spread )") == MATCH_YES)
4132 53 : c->proc_bind = OMP_PROC_BIND_SPREAD;
4133 1 : else if (gfc_match ("close )") == MATCH_YES)
4134 1 : c->proc_bind = OMP_PROC_BIND_CLOSE;
4135 : else
4136 0 : goto error;
4137 64 : continue;
4138 : }
4139 : break;
4140 4579 : case 'r':
4141 5069 : if ((mask & OMP_CLAUSE_ATOMIC)
4142 4579 : && (m = gfc_match_dupl_atomic ((c->atomic_op
4143 : == GFC_OMP_ATOMIC_UNSET),
4144 : "read")) != MATCH_NO)
4145 : {
4146 490 : if (m == MATCH_ERROR)
4147 0 : goto error;
4148 490 : c->atomic_op = GFC_OMP_ATOMIC_READ;
4149 490 : continue;
4150 : }
4151 8141 : if ((mask & OMP_CLAUSE_REDUCTION)
4152 4089 : && gfc_match_omp_clause_reduction (pc, c, openacc,
4153 : allow_derived) == MATCH_YES)
4154 4052 : continue;
4155 47 : if ((mask & OMP_CLAUSE_MEMORDER)
4156 65 : && (m = gfc_match_dupl_memorder ((c->memorder
4157 28 : == OMP_MEMORDER_UNSET),
4158 : "relaxed")) != MATCH_NO)
4159 : {
4160 10 : if (m == MATCH_ERROR)
4161 0 : goto error;
4162 10 : c->memorder = OMP_MEMORDER_RELAXED;
4163 10 : continue;
4164 : }
4165 44 : if ((mask & OMP_CLAUSE_MEMORDER)
4166 45 : && (m = gfc_match_dupl_memorder ((c->memorder
4167 18 : == OMP_MEMORDER_UNSET),
4168 : "release")) != MATCH_NO)
4169 : {
4170 18 : if (m == MATCH_ERROR)
4171 1 : goto error;
4172 17 : c->memorder = OMP_MEMORDER_RELEASE;
4173 17 : continue;
4174 : }
4175 : break;
4176 3024 : case 's':
4177 3117 : if ((mask & OMP_CLAUSE_SAFELEN)
4178 3024 : && (m = gfc_match_dupl_check (!c->safelen_expr, "safelen",
4179 : true, &c->safelen_expr))
4180 : != MATCH_NO)
4181 : {
4182 93 : if (m == MATCH_ERROR)
4183 0 : goto error;
4184 93 : continue;
4185 : }
4186 2931 : if ((mask & OMP_CLAUSE_SCHEDULE)
4187 2931 : && (m = gfc_match_dupl_check (c->sched_kind == OMP_SCHED_NONE,
4188 : "schedule", true)) != MATCH_NO)
4189 : {
4190 809 : if (m == MATCH_ERROR)
4191 0 : goto error;
4192 809 : int nmodifiers = 0;
4193 809 : locus old_loc2 = gfc_current_locus;
4194 827 : do
4195 : {
4196 818 : if (gfc_match ("simd") == MATCH_YES)
4197 : {
4198 18 : c->sched_simd = true;
4199 18 : nmodifiers++;
4200 : }
4201 800 : else if (gfc_match ("monotonic") == MATCH_YES)
4202 : {
4203 30 : c->sched_monotonic = true;
4204 30 : nmodifiers++;
4205 : }
4206 770 : else if (gfc_match ("nonmonotonic") == MATCH_YES)
4207 : {
4208 35 : c->sched_nonmonotonic = true;
4209 35 : nmodifiers++;
4210 : }
4211 : else
4212 : {
4213 735 : if (nmodifiers)
4214 0 : gfc_current_locus = old_loc2;
4215 : break;
4216 : }
4217 92 : if (nmodifiers == 1
4218 83 : && gfc_match (" , ") == MATCH_YES)
4219 9 : continue;
4220 74 : else if (gfc_match (" : ") == MATCH_YES)
4221 : break;
4222 0 : gfc_current_locus = old_loc2;
4223 0 : break;
4224 : }
4225 : while (1);
4226 809 : if (gfc_match ("static") == MATCH_YES)
4227 425 : c->sched_kind = OMP_SCHED_STATIC;
4228 384 : else if (gfc_match ("dynamic") == MATCH_YES)
4229 164 : c->sched_kind = OMP_SCHED_DYNAMIC;
4230 220 : else if (gfc_match ("guided") == MATCH_YES)
4231 127 : c->sched_kind = OMP_SCHED_GUIDED;
4232 93 : else if (gfc_match ("runtime") == MATCH_YES)
4233 85 : c->sched_kind = OMP_SCHED_RUNTIME;
4234 8 : else if (gfc_match ("auto") == MATCH_YES)
4235 8 : c->sched_kind = OMP_SCHED_AUTO;
4236 809 : if (c->sched_kind != OMP_SCHED_NONE)
4237 : {
4238 809 : m = MATCH_NO;
4239 809 : if (c->sched_kind != OMP_SCHED_RUNTIME
4240 809 : && c->sched_kind != OMP_SCHED_AUTO)
4241 716 : m = gfc_match (" , %e )", &c->chunk_size);
4242 716 : if (m != MATCH_YES)
4243 299 : m = gfc_match_char (')');
4244 299 : if (m != MATCH_YES)
4245 0 : c->sched_kind = OMP_SCHED_NONE;
4246 : }
4247 809 : if (c->sched_kind != OMP_SCHED_NONE)
4248 809 : continue;
4249 : else
4250 0 : gfc_current_locus = old_loc;
4251 : }
4252 2305 : if ((mask & OMP_CLAUSE_SELF)
4253 335 : && !(mask & OMP_CLAUSE_HOST) /* OpenACC compute construct */
4254 2362 : && (m = gfc_match_dupl_check (!c->self_expr, "self"))
4255 : != MATCH_NO)
4256 : {
4257 186 : if (m == MATCH_ERROR)
4258 3 : goto error;
4259 183 : m = gfc_match (" ( %e )", &c->self_expr);
4260 183 : if (m == MATCH_ERROR)
4261 : {
4262 0 : gfc_current_locus = old_loc;
4263 0 : break;
4264 : }
4265 183 : else if (m == MATCH_NO)
4266 9 : c->self_expr = gfc_get_logical_expr (gfc_default_logical_kind,
4267 : NULL, true);
4268 183 : continue;
4269 : }
4270 2030 : if ((mask & OMP_CLAUSE_SELF)
4271 149 : && (mask & OMP_CLAUSE_HOST) /* OpenACC 'update' directive */
4272 95 : && gfc_match ("self ( ") == MATCH_YES
4273 2031 : && gfc_match_omp_map_clause (&c->lists[OMP_LIST_MAP],
4274 : OMP_MAP_FORCE_FROM, true,
4275 : /* allow_derived = */ true))
4276 94 : continue;
4277 2190 : if ((mask & OMP_CLAUSE_SEQ)
4278 1842 : && (m = gfc_match_dupl_check (!c->seq, "seq")) != MATCH_NO)
4279 : {
4280 348 : if (m == MATCH_ERROR)
4281 0 : goto error;
4282 348 : c->seq = true;
4283 348 : continue;
4284 : }
4285 1635 : if ((mask & OMP_CLAUSE_MEMORDER)
4286 1635 : && (m = gfc_match_dupl_memorder ((c->memorder
4287 141 : == OMP_MEMORDER_UNSET),
4288 : "seq_cst")) != MATCH_NO)
4289 : {
4290 141 : if (m == MATCH_ERROR)
4291 0 : goto error;
4292 141 : c->memorder = OMP_MEMORDER_SEQ_CST;
4293 141 : continue;
4294 : }
4295 2316 : if ((mask & OMP_CLAUSE_SHARED)
4296 1353 : && gfc_match_omp_variable_list ("shared (",
4297 : &c->lists[OMP_LIST_SHARED],
4298 : true) == MATCH_YES)
4299 963 : continue;
4300 508 : if ((mask & OMP_CLAUSE_SIMDLEN)
4301 390 : && (m = gfc_match_dupl_check (!c->simdlen_expr, "simdlen", true,
4302 : &c->simdlen_expr)) != MATCH_NO)
4303 : {
4304 118 : if (m == MATCH_ERROR)
4305 0 : goto error;
4306 118 : continue;
4307 : }
4308 294 : if ((mask & OMP_CLAUSE_SIMD)
4309 272 : && (m = gfc_match_dupl_check (!c->simd, "simd")) != MATCH_NO)
4310 : {
4311 22 : if (m == MATCH_ERROR)
4312 0 : goto error;
4313 22 : c->simd = true;
4314 22 : continue;
4315 : }
4316 289 : if ((mask & OMP_CLAUSE_SEVERITY)
4317 250 : && (m = gfc_match_dupl_check (!c->severity, "severity", true))
4318 : != MATCH_NO)
4319 : {
4320 45 : if (m == MATCH_ERROR)
4321 2 : goto error;
4322 43 : if (gfc_match ("fatal )") == MATCH_YES)
4323 10 : c->severity = OMP_SEVERITY_FATAL;
4324 33 : else if (gfc_match ("warning )") == MATCH_YES)
4325 29 : c->severity = OMP_SEVERITY_WARNING;
4326 : else
4327 : {
4328 4 : gfc_error ("Expected FATAL or WARNING in SEVERITY clause "
4329 : "at %C");
4330 4 : goto error;
4331 : }
4332 39 : continue;
4333 : }
4334 205 : if ((mask & OMP_CLAUSE_SIZES)
4335 205 : && ((m = gfc_match_dupl_check (!c->sizes_list, "sizes"))
4336 : != MATCH_NO))
4337 : {
4338 203 : if (m == MATCH_ERROR)
4339 0 : goto error;
4340 203 : m = match_omp_oacc_expr_list (" (", &c->sizes_list, false, true);
4341 203 : if (m == MATCH_ERROR)
4342 7 : goto error;
4343 196 : if (m == MATCH_YES)
4344 195 : continue;
4345 1 : gfc_error ("Expected %<(%> after %qs at %C", "sizes");
4346 1 : goto error;
4347 : }
4348 : break;
4349 1203 : case 't':
4350 1268 : if ((mask & OMP_CLAUSE_TASK_REDUCTION)
4351 1203 : && gfc_match_omp_clause_reduction (pc, c, openacc,
4352 : allow_derived) == MATCH_YES)
4353 65 : continue;
4354 1210 : if ((mask & OMP_CLAUSE_THREAD_LIMIT)
4355 1138 : && (m = gfc_match_dupl_check (!c->thread_limit, "thread_limit",
4356 : true, &c->thread_limit))
4357 : != MATCH_NO)
4358 : {
4359 72 : if (m == MATCH_ERROR)
4360 0 : goto error;
4361 72 : continue;
4362 : }
4363 1079 : if ((mask & OMP_CLAUSE_THREADS)
4364 1066 : && (m = gfc_match_dupl_check (!c->threads, "threads"))
4365 : != MATCH_NO)
4366 : {
4367 13 : if (m == MATCH_ERROR)
4368 0 : goto error;
4369 13 : c->threads = true;
4370 13 : continue;
4371 : }
4372 1250 : if ((mask & OMP_CLAUSE_TILE)
4373 221 : && !c->tile_list
4374 1274 : && match_omp_oacc_expr_list ("tile (", &c->tile_list,
4375 : true, false) == MATCH_YES)
4376 197 : continue;
4377 856 : if ((mask & OMP_CLAUSE_TO) && (mask & OMP_CLAUSE_LINK))
4378 : {
4379 : /* Declare target: 'to' is an alias for 'enter';
4380 : 'to' is deprecated since 5.2. */
4381 116 : m = gfc_match_omp_to_link ("to (", &c->lists[OMP_LIST_TO]);
4382 116 : if (m == MATCH_ERROR)
4383 0 : goto error;
4384 116 : if (m == MATCH_YES)
4385 : {
4386 116 : gfc_warning (OPT_Wdeprecated_openmp,
4387 : "%<to%> clause with %<declare target%> at %L "
4388 : "deprecated since OpenMP 5.2, use %<enter%>",
4389 : &old_loc);
4390 116 : continue;
4391 : }
4392 : }
4393 1456 : else if ((mask & OMP_CLAUSE_TO)
4394 740 : && gfc_match_motion_var_list ("to (", &c->lists[OMP_LIST_TO],
4395 : &head) == MATCH_YES)
4396 716 : continue;
4397 : break;
4398 1516 : case 'u':
4399 1574 : if ((mask & OMP_CLAUSE_UNIFORM)
4400 1516 : && gfc_match_omp_variable_list ("uniform (",
4401 : &c->lists[OMP_LIST_UNIFORM],
4402 : false) == MATCH_YES)
4403 58 : continue;
4404 1599 : if ((mask & OMP_CLAUSE_UNTIED)
4405 1458 : && (m = gfc_match_dupl_check (!c->untied, "untied")) != MATCH_NO)
4406 : {
4407 141 : if (m == MATCH_ERROR)
4408 0 : goto error;
4409 141 : c->untied = true;
4410 141 : continue;
4411 : }
4412 1561 : if ((mask & OMP_CLAUSE_ATOMIC)
4413 1317 : && (m = gfc_match_dupl_atomic ((c->atomic_op
4414 : == GFC_OMP_ATOMIC_UNSET),
4415 : "update")) != MATCH_NO)
4416 : {
4417 245 : if (m == MATCH_ERROR)
4418 1 : goto error;
4419 244 : c->atomic_op = GFC_OMP_ATOMIC_UPDATE;
4420 244 : continue;
4421 : }
4422 1094 : if ((mask & OMP_CLAUSE_USE)
4423 1072 : && gfc_match_omp_variable_list ("use (",
4424 : &c->lists[OMP_LIST_USE],
4425 : true) == MATCH_YES)
4426 22 : continue;
4427 1110 : if ((mask & OMP_CLAUSE_USE_DEVICE)
4428 1050 : && gfc_match_omp_variable_list ("use_device (",
4429 : &c->lists[OMP_LIST_USE_DEVICE],
4430 : true) == MATCH_YES)
4431 60 : continue;
4432 1153 : if ((mask & OMP_CLAUSE_USE_DEVICE_PTR)
4433 1918 : && gfc_match_omp_variable_list
4434 928 : ("use_device_ptr (",
4435 : &c->lists[OMP_LIST_USE_DEVICE_PTR], false) == MATCH_YES)
4436 163 : continue;
4437 1592 : if ((mask & OMP_CLAUSE_USE_DEVICE_ADDR)
4438 1592 : && gfc_match_omp_variable_list
4439 765 : ("use_device_addr (", &c->lists[OMP_LIST_USE_DEVICE_ADDR],
4440 : false, NULL, NULL, true) == MATCH_YES)
4441 765 : continue;
4442 114 : if ((mask & OMP_CLAUSE_USES_ALLOCATORS)
4443 62 : && (gfc_match ("uses_allocators ( ") == MATCH_YES))
4444 : {
4445 56 : if (gfc_match_omp_clause_uses_allocators (c) != MATCH_YES)
4446 4 : goto error;
4447 52 : continue;
4448 : }
4449 : break;
4450 1570 : case 'v':
4451 : /* VECTOR_LENGTH must be matched before VECTOR, because the latter
4452 : doesn't unconditionally match '('. */
4453 2139 : if ((mask & OMP_CLAUSE_VECTOR_LENGTH)
4454 1570 : && (m = gfc_match_dupl_check (!c->vector_length_expr,
4455 : "vector_length", true,
4456 : &c->vector_length_expr))
4457 : != MATCH_NO)
4458 : {
4459 573 : if (m == MATCH_ERROR)
4460 4 : goto error;
4461 569 : continue;
4462 : }
4463 1989 : if ((mask & OMP_CLAUSE_VECTOR)
4464 997 : && (m = gfc_match_dupl_check (!c->vector, "vector")) != MATCH_NO)
4465 : {
4466 995 : if (m == MATCH_ERROR)
4467 0 : goto error;
4468 995 : c->vector = true;
4469 995 : m = match_oacc_clause_gwv (c, GOMP_DIM_VECTOR);
4470 995 : if (m == MATCH_ERROR)
4471 3 : goto error;
4472 992 : continue;
4473 : }
4474 : break;
4475 1482 : case 'w':
4476 1482 : if ((mask & OMP_CLAUSE_WAIT)
4477 1482 : && gfc_match ("wait") == MATCH_YES)
4478 : {
4479 192 : m = match_omp_oacc_expr_list (" (", &c->wait_list, false, false);
4480 192 : if (m == MATCH_ERROR)
4481 9 : goto error;
4482 183 : else if (m == MATCH_NO)
4483 : {
4484 47 : gfc_expr *expr
4485 47 : = gfc_get_constant_expr (BT_INTEGER,
4486 : gfc_default_integer_kind,
4487 : &gfc_current_locus);
4488 47 : mpz_set_si (expr->value.integer, GOMP_ASYNC_NOVAL);
4489 47 : gfc_expr_list **expr_list = &c->wait_list;
4490 56 : while (*expr_list)
4491 9 : expr_list = &(*expr_list)->next;
4492 47 : *expr_list = gfc_get_expr_list ();
4493 47 : (*expr_list)->expr = expr;
4494 47 : needs_space = true;
4495 : }
4496 183 : continue;
4497 183 : }
4498 1303 : if ((mask & OMP_CLAUSE_WEAK)
4499 1290 : && (m = gfc_match_dupl_check (!c->weak, "weak"))
4500 : != MATCH_NO)
4501 : {
4502 14 : if (m == MATCH_ERROR)
4503 1 : goto error;
4504 13 : c->weak = true;
4505 13 : continue;
4506 : }
4507 2137 : if ((mask & OMP_CLAUSE_WORKER)
4508 1276 : && (m = gfc_match_dupl_check (!c->worker, "worker")) != MATCH_NO)
4509 : {
4510 864 : if (m == MATCH_ERROR)
4511 0 : goto error;
4512 864 : c->worker = true;
4513 864 : m = match_oacc_clause_gwv (c, GOMP_DIM_WORKER);
4514 864 : if (m == MATCH_ERROR)
4515 3 : goto error;
4516 861 : continue;
4517 : }
4518 824 : if ((mask & OMP_CLAUSE_ATOMIC)
4519 412 : && (m = gfc_match_dupl_atomic ((c->atomic_op
4520 : == GFC_OMP_ATOMIC_UNSET),
4521 : "write")) != MATCH_NO)
4522 : {
4523 412 : if (m == MATCH_ERROR)
4524 0 : goto error;
4525 412 : c->atomic_op = GFC_OMP_ATOMIC_WRITE;
4526 412 : continue;
4527 : }
4528 : break;
4529 : }
4530 : break;
4531 45370 : }
4532 :
4533 34081 : end:
4534 33827 : if (error || gfc_match_omp_eos () != MATCH_YES)
4535 : {
4536 521 : if (!gfc_error_flag_test ())
4537 137 : gfc_error ("Failed to match clause at %C");
4538 521 : gfc_free_omp_clauses (c);
4539 521 : return MATCH_ERROR;
4540 : }
4541 :
4542 33560 : *cp = c;
4543 33560 : return MATCH_YES;
4544 :
4545 254 : error:
4546 254 : error = true;
4547 254 : goto end;
4548 : }
4549 :
4550 :
4551 : #define OACC_PARALLEL_CLAUSES \
4552 : (omp_mask (OMP_CLAUSE_IF) | OMP_CLAUSE_ASYNC | OMP_CLAUSE_NUM_GANGS \
4553 : | OMP_CLAUSE_NUM_WORKERS | OMP_CLAUSE_VECTOR_LENGTH | OMP_CLAUSE_REDUCTION \
4554 : | OMP_CLAUSE_COPY | OMP_CLAUSE_COPYIN | OMP_CLAUSE_COPYOUT \
4555 : | OMP_CLAUSE_CREATE | OMP_CLAUSE_NO_CREATE | OMP_CLAUSE_PRESENT \
4556 : | OMP_CLAUSE_DEVICEPTR | OMP_CLAUSE_PRIVATE | OMP_CLAUSE_FIRSTPRIVATE \
4557 : | OMP_CLAUSE_DEFAULT | OMP_CLAUSE_WAIT | OMP_CLAUSE_ATTACH \
4558 : | OMP_CLAUSE_SELF)
4559 : #define OACC_KERNELS_CLAUSES \
4560 : (omp_mask (OMP_CLAUSE_IF) | OMP_CLAUSE_ASYNC | OMP_CLAUSE_NUM_GANGS \
4561 : | OMP_CLAUSE_NUM_WORKERS | OMP_CLAUSE_VECTOR_LENGTH | OMP_CLAUSE_DEVICEPTR \
4562 : | OMP_CLAUSE_COPY | OMP_CLAUSE_COPYIN | OMP_CLAUSE_COPYOUT \
4563 : | OMP_CLAUSE_CREATE | OMP_CLAUSE_NO_CREATE | OMP_CLAUSE_PRESENT \
4564 : | OMP_CLAUSE_DEFAULT | OMP_CLAUSE_WAIT | OMP_CLAUSE_ATTACH \
4565 : | OMP_CLAUSE_SELF)
4566 : #define OACC_SERIAL_CLAUSES \
4567 : (omp_mask (OMP_CLAUSE_IF) | OMP_CLAUSE_ASYNC | OMP_CLAUSE_REDUCTION \
4568 : | OMP_CLAUSE_COPY | OMP_CLAUSE_COPYIN | OMP_CLAUSE_COPYOUT \
4569 : | OMP_CLAUSE_CREATE | OMP_CLAUSE_NO_CREATE | OMP_CLAUSE_PRESENT \
4570 : | OMP_CLAUSE_DEVICEPTR | OMP_CLAUSE_PRIVATE | OMP_CLAUSE_FIRSTPRIVATE \
4571 : | OMP_CLAUSE_DEFAULT | OMP_CLAUSE_WAIT | OMP_CLAUSE_ATTACH \
4572 : | OMP_CLAUSE_SELF)
4573 : #define OACC_DATA_CLAUSES \
4574 : (omp_mask (OMP_CLAUSE_IF) | OMP_CLAUSE_DEVICEPTR | OMP_CLAUSE_COPY \
4575 : | OMP_CLAUSE_COPYIN | OMP_CLAUSE_COPYOUT | OMP_CLAUSE_CREATE \
4576 : | OMP_CLAUSE_NO_CREATE | OMP_CLAUSE_PRESENT | OMP_CLAUSE_ATTACH \
4577 : | OMP_CLAUSE_DEFAULT)
4578 : #define OACC_LOOP_CLAUSES \
4579 : (omp_mask (OMP_CLAUSE_COLLAPSE) | OMP_CLAUSE_GANG | OMP_CLAUSE_WORKER \
4580 : | OMP_CLAUSE_VECTOR | OMP_CLAUSE_SEQ | OMP_CLAUSE_INDEPENDENT \
4581 : | OMP_CLAUSE_PRIVATE | OMP_CLAUSE_REDUCTION | OMP_CLAUSE_AUTO \
4582 : | OMP_CLAUSE_TILE)
4583 : #define OACC_PARALLEL_LOOP_CLAUSES \
4584 : (OACC_LOOP_CLAUSES | OACC_PARALLEL_CLAUSES)
4585 : #define OACC_KERNELS_LOOP_CLAUSES \
4586 : (OACC_LOOP_CLAUSES | OACC_KERNELS_CLAUSES)
4587 : #define OACC_SERIAL_LOOP_CLAUSES \
4588 : (OACC_LOOP_CLAUSES | OACC_SERIAL_CLAUSES)
4589 : #define OACC_HOST_DATA_CLAUSES \
4590 : (omp_mask (OMP_CLAUSE_USE_DEVICE) \
4591 : | OMP_CLAUSE_IF \
4592 : | OMP_CLAUSE_IF_PRESENT)
4593 : #define OACC_DECLARE_CLAUSES \
4594 : (omp_mask (OMP_CLAUSE_COPY) | OMP_CLAUSE_COPYIN | OMP_CLAUSE_COPYOUT \
4595 : | OMP_CLAUSE_CREATE | OMP_CLAUSE_DEVICEPTR | OMP_CLAUSE_DEVICE_RESIDENT \
4596 : | OMP_CLAUSE_PRESENT \
4597 : | OMP_CLAUSE_LINK)
4598 : #define OACC_UPDATE_CLAUSES \
4599 : (omp_mask (OMP_CLAUSE_IF) | OMP_CLAUSE_ASYNC | OMP_CLAUSE_HOST \
4600 : | OMP_CLAUSE_DEVICE | OMP_CLAUSE_WAIT | OMP_CLAUSE_IF_PRESENT \
4601 : | OMP_CLAUSE_SELF)
4602 : #define OACC_ENTER_DATA_CLAUSES \
4603 : (omp_mask (OMP_CLAUSE_IF) | OMP_CLAUSE_ASYNC | OMP_CLAUSE_WAIT \
4604 : | OMP_CLAUSE_COPYIN | OMP_CLAUSE_CREATE | OMP_CLAUSE_ATTACH)
4605 : #define OACC_EXIT_DATA_CLAUSES \
4606 : (omp_mask (OMP_CLAUSE_IF) | OMP_CLAUSE_ASYNC | OMP_CLAUSE_WAIT \
4607 : | OMP_CLAUSE_COPYOUT | OMP_CLAUSE_DELETE | OMP_CLAUSE_FINALIZE \
4608 : | OMP_CLAUSE_DETACH)
4609 : #define OACC_WAIT_CLAUSES \
4610 : omp_mask (OMP_CLAUSE_ASYNC) | OMP_CLAUSE_IF
4611 : #define OACC_ROUTINE_CLAUSES \
4612 : (omp_mask (OMP_CLAUSE_GANG) | OMP_CLAUSE_WORKER | OMP_CLAUSE_VECTOR \
4613 : | OMP_CLAUSE_SEQ \
4614 : | OMP_CLAUSE_NOHOST)
4615 :
4616 :
4617 : static match
4618 11796 : match_acc (gfc_exec_op op, const omp_mask mask)
4619 : {
4620 11796 : gfc_omp_clauses *c;
4621 11796 : if (gfc_match_omp_clauses (&c, mask, false, false, true) != MATCH_YES)
4622 : return MATCH_ERROR;
4623 11591 : new_st.op = op;
4624 11591 : new_st.ext.omp_clauses = c;
4625 11591 : return MATCH_YES;
4626 : }
4627 :
4628 : match
4629 1378 : gfc_match_oacc_parallel_loop (void)
4630 : {
4631 1378 : return match_acc (EXEC_OACC_PARALLEL_LOOP, OACC_PARALLEL_LOOP_CLAUSES);
4632 : }
4633 :
4634 :
4635 : match
4636 2974 : gfc_match_oacc_parallel (void)
4637 : {
4638 2974 : return match_acc (EXEC_OACC_PARALLEL, OACC_PARALLEL_CLAUSES);
4639 : }
4640 :
4641 :
4642 : match
4643 129 : gfc_match_oacc_kernels_loop (void)
4644 : {
4645 129 : return match_acc (EXEC_OACC_KERNELS_LOOP, OACC_KERNELS_LOOP_CLAUSES);
4646 : }
4647 :
4648 :
4649 : match
4650 904 : gfc_match_oacc_kernels (void)
4651 : {
4652 904 : return match_acc (EXEC_OACC_KERNELS, OACC_KERNELS_CLAUSES);
4653 : }
4654 :
4655 :
4656 : match
4657 230 : gfc_match_oacc_serial_loop (void)
4658 : {
4659 230 : return match_acc (EXEC_OACC_SERIAL_LOOP, OACC_SERIAL_LOOP_CLAUSES);
4660 : }
4661 :
4662 :
4663 : match
4664 359 : gfc_match_oacc_serial (void)
4665 : {
4666 359 : return match_acc (EXEC_OACC_SERIAL, OACC_SERIAL_CLAUSES);
4667 : }
4668 :
4669 :
4670 : match
4671 689 : gfc_match_oacc_data (void)
4672 : {
4673 689 : return match_acc (EXEC_OACC_DATA, OACC_DATA_CLAUSES);
4674 : }
4675 :
4676 :
4677 : match
4678 65 : gfc_match_oacc_host_data (void)
4679 : {
4680 65 : return match_acc (EXEC_OACC_HOST_DATA, OACC_HOST_DATA_CLAUSES);
4681 : }
4682 :
4683 :
4684 : match
4685 3583 : gfc_match_oacc_loop (void)
4686 : {
4687 3583 : return match_acc (EXEC_OACC_LOOP, OACC_LOOP_CLAUSES);
4688 : }
4689 :
4690 :
4691 : match
4692 176 : gfc_match_oacc_declare (void)
4693 : {
4694 176 : gfc_omp_clauses *c;
4695 176 : gfc_omp_namelist *n;
4696 176 : gfc_namespace *ns = gfc_current_ns;
4697 176 : gfc_oacc_declare *new_oc;
4698 176 : bool module_var = false;
4699 176 : locus where = gfc_current_locus;
4700 :
4701 176 : if (gfc_match_omp_clauses (&c, OACC_DECLARE_CLAUSES, false, false, true)
4702 : != MATCH_YES)
4703 : return MATCH_ERROR;
4704 :
4705 260 : for (n = c->lists[OMP_LIST_DEVICE_RESIDENT]; n != NULL; n = n->next)
4706 90 : n->sym->attr.oacc_declare_device_resident = 1;
4707 :
4708 190 : for (n = c->lists[OMP_LIST_LINK]; n != NULL; n = n->next)
4709 20 : n->sym->attr.oacc_declare_link = 1;
4710 :
4711 312 : for (n = c->lists[OMP_LIST_MAP]; n != NULL; n = n->next)
4712 : {
4713 152 : gfc_symbol *s = n->sym;
4714 :
4715 152 : if (gfc_current_ns->proc_name
4716 152 : && gfc_current_ns->proc_name->attr.flavor == FL_MODULE)
4717 : {
4718 48 : if (n->u.map.op != OMP_MAP_ALLOC && n->u.map.op != OMP_MAP_TO)
4719 : {
4720 6 : gfc_error ("Invalid clause in module with !$ACC DECLARE at %L",
4721 : &where);
4722 6 : return MATCH_ERROR;
4723 : }
4724 :
4725 : module_var = true;
4726 : }
4727 :
4728 146 : if (s->attr.use_assoc)
4729 : {
4730 0 : gfc_error ("Variable is USE-associated with !$ACC DECLARE at %L",
4731 : &where);
4732 0 : return MATCH_ERROR;
4733 : }
4734 :
4735 146 : if ((s->result == s && s->ns->contained != gfc_current_ns)
4736 146 : || ((s->attr.flavor == FL_UNKNOWN || s->attr.flavor == FL_VARIABLE)
4737 131 : && s->ns != gfc_current_ns))
4738 : {
4739 2 : gfc_error ("Variable %qs shall be declared in the same scoping unit "
4740 : "as !$ACC DECLARE at %L", s->name, &where);
4741 2 : return MATCH_ERROR;
4742 : }
4743 :
4744 144 : if ((s->attr.dimension || s->attr.codimension)
4745 76 : && s->attr.dummy && s->as->type != AS_EXPLICIT)
4746 : {
4747 2 : gfc_error ("Assumed-size dummy array with !$ACC DECLARE at %L",
4748 : &where);
4749 2 : return MATCH_ERROR;
4750 : }
4751 :
4752 142 : switch (n->u.map.op)
4753 : {
4754 49 : case OMP_MAP_FORCE_ALLOC:
4755 49 : case OMP_MAP_ALLOC:
4756 49 : s->attr.oacc_declare_create = 1;
4757 49 : break;
4758 :
4759 59 : case OMP_MAP_FORCE_TO:
4760 59 : case OMP_MAP_TO:
4761 59 : s->attr.oacc_declare_copyin = 1;
4762 59 : break;
4763 :
4764 1 : case OMP_MAP_FORCE_DEVICEPTR:
4765 1 : s->attr.oacc_declare_deviceptr = 1;
4766 1 : break;
4767 :
4768 : default:
4769 : break;
4770 : }
4771 : }
4772 :
4773 160 : new_oc = gfc_get_oacc_declare ();
4774 160 : new_oc->next = ns->oacc_declare;
4775 160 : new_oc->module_var = module_var;
4776 160 : new_oc->clauses = c;
4777 160 : new_oc->loc = gfc_current_locus;
4778 160 : ns->oacc_declare = new_oc;
4779 :
4780 160 : return MATCH_YES;
4781 : }
4782 :
4783 :
4784 : match
4785 760 : gfc_match_oacc_update (void)
4786 : {
4787 760 : gfc_omp_clauses *c;
4788 760 : locus here = gfc_current_locus;
4789 :
4790 760 : if (gfc_match_omp_clauses (&c, OACC_UPDATE_CLAUSES, false, false, true)
4791 : != MATCH_YES)
4792 : return MATCH_ERROR;
4793 :
4794 756 : if (!c->lists[OMP_LIST_MAP])
4795 : {
4796 1 : gfc_error ("%<acc update%> must contain at least one "
4797 : "%<device%> or %<host%> or %<self%> clause at %L", &here);
4798 1 : return MATCH_ERROR;
4799 : }
4800 :
4801 755 : new_st.op = EXEC_OACC_UPDATE;
4802 755 : new_st.ext.omp_clauses = c;
4803 755 : return MATCH_YES;
4804 : }
4805 :
4806 :
4807 : match
4808 875 : gfc_match_oacc_enter_data (void)
4809 : {
4810 875 : return match_acc (EXEC_OACC_ENTER_DATA, OACC_ENTER_DATA_CLAUSES);
4811 : }
4812 :
4813 :
4814 : match
4815 610 : gfc_match_oacc_exit_data (void)
4816 : {
4817 610 : return match_acc (EXEC_OACC_EXIT_DATA, OACC_EXIT_DATA_CLAUSES);
4818 : }
4819 :
4820 :
4821 : match
4822 203 : gfc_match_oacc_wait (void)
4823 : {
4824 203 : gfc_omp_clauses *c = gfc_get_omp_clauses ();
4825 203 : gfc_expr_list *wait_list = NULL, *el;
4826 203 : bool space = true;
4827 203 : match m;
4828 :
4829 203 : m = match_omp_oacc_expr_list (" (", &wait_list, true, false);
4830 203 : if (m == MATCH_ERROR)
4831 : return m;
4832 197 : else if (m == MATCH_YES)
4833 126 : space = false;
4834 :
4835 197 : if (gfc_match_omp_clauses (&c, OACC_WAIT_CLAUSES, space, space, true)
4836 : == MATCH_ERROR)
4837 : return MATCH_ERROR;
4838 :
4839 184 : if (wait_list)
4840 261 : for (el = wait_list; el; el = el->next)
4841 : {
4842 140 : if (el->expr == NULL)
4843 : {
4844 2 : gfc_error ("Invalid argument to !$ACC WAIT at %C");
4845 2 : return MATCH_ERROR;
4846 : }
4847 :
4848 138 : if (!gfc_resolve_expr (el->expr)
4849 138 : || el->expr->ts.type != BT_INTEGER || el->expr->rank != 0)
4850 : {
4851 3 : gfc_error ("WAIT clause at %L requires a scalar INTEGER expression",
4852 3 : &el->expr->where);
4853 :
4854 3 : return MATCH_ERROR;
4855 : }
4856 : }
4857 179 : c->wait_list = wait_list;
4858 179 : new_st.op = EXEC_OACC_WAIT;
4859 179 : new_st.ext.omp_clauses = c;
4860 179 : return MATCH_YES;
4861 : }
4862 :
4863 :
4864 : match
4865 97 : gfc_match_oacc_cache (void)
4866 : {
4867 97 : bool readonly = false;
4868 97 : gfc_omp_clauses *c = gfc_get_omp_clauses ();
4869 : /* The OpenACC cache directive explicitly only allows "array elements or
4870 : subarrays", which we're currently not checking here. Either check this
4871 : after the call of gfc_match_omp_variable_list, or add something like a
4872 : only_sections variant next to its allow_sections parameter. */
4873 97 : match m = gfc_match (" ( ");
4874 97 : if (m != MATCH_YES)
4875 : {
4876 0 : gfc_free_omp_clauses(c);
4877 0 : return m;
4878 : }
4879 :
4880 97 : if (gfc_match ("readonly : ") == MATCH_YES)
4881 8 : readonly = true;
4882 :
4883 97 : gfc_omp_namelist **head = NULL;
4884 97 : m = gfc_match_omp_variable_list ("", &c->lists[OMP_LIST_CACHE], true,
4885 : NULL, &head, true);
4886 97 : if (m != MATCH_YES)
4887 : {
4888 2 : gfc_free_omp_clauses(c);
4889 2 : return m;
4890 : }
4891 :
4892 95 : if (readonly)
4893 24 : for (gfc_omp_namelist *n = *head; n; n = n->next)
4894 16 : n->u.map.readonly = true;
4895 :
4896 95 : if (gfc_current_state() != COMP_DO
4897 56 : && gfc_current_state() != COMP_DO_CONCURRENT)
4898 : {
4899 2 : gfc_error ("ACC CACHE directive must be inside of loop %C");
4900 2 : gfc_free_omp_clauses(c);
4901 2 : return MATCH_ERROR;
4902 : }
4903 :
4904 93 : new_st.op = EXEC_OACC_CACHE;
4905 93 : new_st.ext.omp_clauses = c;
4906 93 : return MATCH_YES;
4907 : }
4908 :
4909 : /* Determine the OpenACC 'routine' directive's level of parallelism. */
4910 :
4911 : static oacc_routine_lop
4912 734 : gfc_oacc_routine_lop (gfc_omp_clauses *clauses)
4913 : {
4914 734 : oacc_routine_lop ret = OACC_ROUTINE_LOP_SEQ;
4915 :
4916 734 : if (clauses)
4917 : {
4918 584 : unsigned n_lop_clauses = 0;
4919 :
4920 584 : if (clauses->gang)
4921 : {
4922 164 : ++n_lop_clauses;
4923 164 : ret = OACC_ROUTINE_LOP_GANG;
4924 : }
4925 584 : if (clauses->worker)
4926 : {
4927 114 : ++n_lop_clauses;
4928 114 : ret = OACC_ROUTINE_LOP_WORKER;
4929 : }
4930 584 : if (clauses->vector)
4931 : {
4932 116 : ++n_lop_clauses;
4933 116 : ret = OACC_ROUTINE_LOP_VECTOR;
4934 : }
4935 584 : if (clauses->seq)
4936 : {
4937 206 : ++n_lop_clauses;
4938 206 : ret = OACC_ROUTINE_LOP_SEQ;
4939 : }
4940 :
4941 584 : if (n_lop_clauses > 1)
4942 47 : ret = OACC_ROUTINE_LOP_ERROR;
4943 : }
4944 :
4945 734 : return ret;
4946 : }
4947 :
4948 : match
4949 698 : gfc_match_oacc_routine (void)
4950 : {
4951 698 : locus old_loc;
4952 698 : match m;
4953 698 : gfc_intrinsic_sym *isym = NULL;
4954 698 : gfc_symbol *sym = NULL;
4955 698 : gfc_omp_clauses *c = NULL;
4956 698 : gfc_oacc_routine_name *n = NULL;
4957 698 : oacc_routine_lop lop = OACC_ROUTINE_LOP_NONE;
4958 698 : bool nohost;
4959 :
4960 698 : old_loc = gfc_current_locus;
4961 :
4962 698 : m = gfc_match (" (");
4963 :
4964 698 : if (gfc_current_ns->proc_name
4965 696 : && gfc_current_ns->proc_name->attr.if_source == IFSRC_IFBODY
4966 90 : && m == MATCH_YES)
4967 : {
4968 3 : gfc_error ("Only the !$ACC ROUTINE form without "
4969 : "list is allowed in interface block at %C");
4970 3 : goto cleanup;
4971 : }
4972 :
4973 608 : if (m == MATCH_YES)
4974 : {
4975 295 : char buffer[GFC_MAX_SYMBOL_LEN + 1];
4976 :
4977 295 : m = gfc_match_name (buffer);
4978 295 : if (m == MATCH_YES)
4979 : {
4980 294 : gfc_symtree *st = NULL;
4981 :
4982 : /* First look for an intrinsic symbol. */
4983 294 : isym = gfc_find_function (buffer);
4984 294 : if (!isym)
4985 294 : isym = gfc_find_subroutine (buffer);
4986 : /* If no intrinsic symbol found, search the current namespace. */
4987 294 : if (!isym)
4988 276 : st = gfc_find_symtree (gfc_current_ns->sym_root, buffer);
4989 276 : if (st)
4990 : {
4991 270 : sym = st->n.sym;
4992 : /* If the name in a 'routine' directive refers to the containing
4993 : subroutine or function, then make sure that we'll later handle
4994 : this accordingly. */
4995 270 : if (gfc_current_ns->proc_name != NULL
4996 270 : && strcmp (sym->name, gfc_current_ns->proc_name->name) == 0)
4997 294 : sym = NULL;
4998 : }
4999 :
5000 294 : if (isym == NULL && st == NULL)
5001 : {
5002 6 : gfc_error ("Invalid NAME %qs in !$ACC ROUTINE ( NAME ) at %C",
5003 : buffer);
5004 6 : gfc_current_locus = old_loc;
5005 9 : return MATCH_ERROR;
5006 : }
5007 : }
5008 : else
5009 : {
5010 1 : gfc_error ("Syntax error in !$ACC ROUTINE ( NAME ) at %C");
5011 1 : gfc_current_locus = old_loc;
5012 1 : return MATCH_ERROR;
5013 : }
5014 :
5015 288 : if (gfc_match_char (')') != MATCH_YES)
5016 : {
5017 2 : gfc_error ("Syntax error in !$ACC ROUTINE ( NAME ) at %C, expecting"
5018 : " %<)%> after NAME");
5019 2 : gfc_current_locus = old_loc;
5020 2 : return MATCH_ERROR;
5021 : }
5022 : }
5023 :
5024 686 : if (gfc_match_omp_eos () != MATCH_YES
5025 686 : && (gfc_match_omp_clauses (&c, OACC_ROUTINE_CLAUSES, false, false, true)
5026 : != MATCH_YES))
5027 : return MATCH_ERROR;
5028 :
5029 683 : lop = gfc_oacc_routine_lop (c);
5030 683 : if (lop == OACC_ROUTINE_LOP_ERROR)
5031 : {
5032 47 : gfc_error ("Multiple loop axes specified for routine at %C");
5033 47 : goto cleanup;
5034 : }
5035 636 : nohost = c ? c->nohost : false;
5036 :
5037 636 : if (isym != NULL)
5038 : {
5039 : /* Diagnose any OpenACC 'routine' directive that doesn't match the
5040 : (implicit) one with a 'seq' clause. */
5041 16 : if (c && (c->gang || c->worker || c->vector))
5042 : {
5043 10 : gfc_error ("Intrinsic symbol specified in !$ACC ROUTINE ( NAME )"
5044 : " at %C marked with incompatible GANG, WORKER, or VECTOR"
5045 : " clause");
5046 10 : goto cleanup;
5047 : }
5048 : /* ..., and no 'nohost' clause. */
5049 6 : if (nohost)
5050 : {
5051 2 : gfc_error ("Intrinsic symbol specified in !$ACC ROUTINE ( NAME )"
5052 : " at %C marked with incompatible NOHOST clause");
5053 2 : goto cleanup;
5054 : }
5055 : }
5056 620 : else if (sym != NULL)
5057 : {
5058 151 : bool add = true;
5059 :
5060 : /* For a repeated OpenACC 'routine' directive, diagnose if it doesn't
5061 : match the first one. */
5062 151 : for (gfc_oacc_routine_name *n_p = gfc_current_ns->oacc_routine_names;
5063 346 : n_p;
5064 195 : n_p = n_p->next)
5065 235 : if (n_p->sym == sym)
5066 : {
5067 51 : add = false;
5068 51 : bool nohost_p = n_p->clauses ? n_p->clauses->nohost : false;
5069 51 : if (lop != gfc_oacc_routine_lop (n_p->clauses)
5070 51 : || nohost != nohost_p)
5071 : {
5072 40 : gfc_error ("!$ACC ROUTINE already applied at %C");
5073 40 : goto cleanup;
5074 : }
5075 : }
5076 :
5077 111 : if (add)
5078 : {
5079 100 : sym->attr.oacc_routine_lop = lop;
5080 100 : sym->attr.oacc_routine_nohost = nohost;
5081 :
5082 100 : n = gfc_get_oacc_routine_name ();
5083 100 : n->sym = sym;
5084 100 : n->clauses = c;
5085 100 : n->next = gfc_current_ns->oacc_routine_names;
5086 100 : n->loc = old_loc;
5087 100 : gfc_current_ns->oacc_routine_names = n;
5088 : }
5089 : }
5090 469 : else if (gfc_current_ns->proc_name)
5091 : {
5092 : /* For a repeated OpenACC 'routine' directive, diagnose if it doesn't
5093 : match the first one. */
5094 468 : oacc_routine_lop lop_p = gfc_current_ns->proc_name->attr.oacc_routine_lop;
5095 468 : bool nohost_p = gfc_current_ns->proc_name->attr.oacc_routine_nohost;
5096 468 : if (lop_p != OACC_ROUTINE_LOP_NONE
5097 86 : && (lop != lop_p
5098 86 : || nohost != nohost_p))
5099 : {
5100 56 : gfc_error ("!$ACC ROUTINE already applied at %C");
5101 56 : goto cleanup;
5102 : }
5103 :
5104 412 : if (!gfc_add_omp_declare_target (&gfc_current_ns->proc_name->attr,
5105 : gfc_current_ns->proc_name->name,
5106 : &old_loc))
5107 1 : goto cleanup;
5108 411 : gfc_current_ns->proc_name->attr.oacc_routine_lop = lop;
5109 411 : gfc_current_ns->proc_name->attr.oacc_routine_nohost = nohost;
5110 : }
5111 : else
5112 : /* Something has gone wrong, possibly a syntax error. */
5113 1 : goto cleanup;
5114 :
5115 526 : if (gfc_pure (NULL) && c && (c->gang || c->worker || c->vector))
5116 : {
5117 6 : gfc_error ("!$ACC ROUTINE with GANG, WORKER, or VECTOR clause is not "
5118 : "permitted in PURE procedure at %C");
5119 6 : goto cleanup;
5120 : }
5121 :
5122 :
5123 520 : if (n)
5124 100 : n->clauses = c;
5125 420 : else if (gfc_current_ns->oacc_routine)
5126 0 : gfc_current_ns->oacc_routine_clauses = c;
5127 :
5128 520 : new_st.op = EXEC_OACC_ROUTINE;
5129 520 : new_st.ext.omp_clauses = c;
5130 520 : return MATCH_YES;
5131 :
5132 166 : cleanup:
5133 166 : gfc_current_locus = old_loc;
5134 166 : return MATCH_ERROR;
5135 : }
5136 :
5137 :
5138 : #define OMP_PARALLEL_CLAUSES \
5139 : (omp_mask (OMP_CLAUSE_PRIVATE) | OMP_CLAUSE_FIRSTPRIVATE \
5140 : | OMP_CLAUSE_SHARED | OMP_CLAUSE_COPYIN | OMP_CLAUSE_REDUCTION \
5141 : | OMP_CLAUSE_IF | OMP_CLAUSE_NUM_THREADS | OMP_CLAUSE_DEFAULT \
5142 : | OMP_CLAUSE_PROC_BIND | OMP_CLAUSE_ALLOCATE)
5143 : #define OMP_DECLARE_SIMD_CLAUSES \
5144 : (omp_mask (OMP_CLAUSE_SIMDLEN) | OMP_CLAUSE_LINEAR \
5145 : | OMP_CLAUSE_UNIFORM | OMP_CLAUSE_ALIGNED | OMP_CLAUSE_INBRANCH \
5146 : | OMP_CLAUSE_NOTINBRANCH)
5147 : #define OMP_DO_CLAUSES \
5148 : (omp_mask (OMP_CLAUSE_PRIVATE) | OMP_CLAUSE_FIRSTPRIVATE \
5149 : | OMP_CLAUSE_LASTPRIVATE | OMP_CLAUSE_REDUCTION \
5150 : | OMP_CLAUSE_SCHEDULE | OMP_CLAUSE_ORDERED | OMP_CLAUSE_COLLAPSE \
5151 : | OMP_CLAUSE_LINEAR | OMP_CLAUSE_ORDER | OMP_CLAUSE_ALLOCATE \
5152 : | OMP_CLAUSE_NOWAIT)
5153 : #define OMP_LOOP_CLAUSES \
5154 : (omp_mask (OMP_CLAUSE_BIND) | OMP_CLAUSE_COLLAPSE | OMP_CLAUSE_ORDER \
5155 : | OMP_CLAUSE_PRIVATE | OMP_CLAUSE_LASTPRIVATE | OMP_CLAUSE_REDUCTION)
5156 :
5157 : #define OMP_SCOPE_CLAUSES \
5158 : (omp_mask (OMP_CLAUSE_PRIVATE) |OMP_CLAUSE_FIRSTPRIVATE \
5159 : | OMP_CLAUSE_REDUCTION | OMP_CLAUSE_ALLOCATE | OMP_CLAUSE_NOWAIT)
5160 : #define OMP_SECTIONS_CLAUSES \
5161 : (omp_mask (OMP_CLAUSE_PRIVATE) | OMP_CLAUSE_FIRSTPRIVATE \
5162 : | OMP_CLAUSE_LASTPRIVATE | OMP_CLAUSE_REDUCTION \
5163 : | OMP_CLAUSE_ALLOCATE | OMP_CLAUSE_NOWAIT)
5164 : #define OMP_SIMD_CLAUSES \
5165 : (omp_mask (OMP_CLAUSE_PRIVATE) | OMP_CLAUSE_LASTPRIVATE \
5166 : | OMP_CLAUSE_REDUCTION | OMP_CLAUSE_COLLAPSE | OMP_CLAUSE_SAFELEN \
5167 : | OMP_CLAUSE_LINEAR | OMP_CLAUSE_ALIGNED | OMP_CLAUSE_SIMDLEN \
5168 : | OMP_CLAUSE_IF | OMP_CLAUSE_ORDER | OMP_CLAUSE_NOTEMPORAL)
5169 : #define OMP_TASK_CLAUSES \
5170 : (omp_mask (OMP_CLAUSE_PRIVATE) | OMP_CLAUSE_FIRSTPRIVATE \
5171 : | OMP_CLAUSE_SHARED | OMP_CLAUSE_IF | OMP_CLAUSE_DEFAULT \
5172 : | OMP_CLAUSE_UNTIED | OMP_CLAUSE_FINAL | OMP_CLAUSE_MERGEABLE \
5173 : | OMP_CLAUSE_DEPEND | OMP_CLAUSE_PRIORITY | OMP_CLAUSE_IN_REDUCTION \
5174 : | OMP_CLAUSE_DETACH | OMP_CLAUSE_AFFINITY | OMP_CLAUSE_ALLOCATE)
5175 : #define OMP_TASKLOOP_CLAUSES \
5176 : (omp_mask (OMP_CLAUSE_PRIVATE) | OMP_CLAUSE_FIRSTPRIVATE \
5177 : | OMP_CLAUSE_LASTPRIVATE | OMP_CLAUSE_SHARED | OMP_CLAUSE_IF \
5178 : | OMP_CLAUSE_DEFAULT | OMP_CLAUSE_UNTIED | OMP_CLAUSE_FINAL \
5179 : | OMP_CLAUSE_MERGEABLE | OMP_CLAUSE_PRIORITY | OMP_CLAUSE_GRAINSIZE \
5180 : | OMP_CLAUSE_NUM_TASKS | OMP_CLAUSE_COLLAPSE | OMP_CLAUSE_NOGROUP \
5181 : | OMP_CLAUSE_REDUCTION | OMP_CLAUSE_IN_REDUCTION | OMP_CLAUSE_ALLOCATE)
5182 : #define OMP_TASKGROUP_CLAUSES \
5183 : (omp_mask (OMP_CLAUSE_TASK_REDUCTION) | OMP_CLAUSE_ALLOCATE)
5184 : #define OMP_TARGET_CLAUSES \
5185 : (omp_mask (OMP_CLAUSE_DEVICE) | OMP_CLAUSE_MAP | OMP_CLAUSE_IF \
5186 : | OMP_CLAUSE_DEPEND | OMP_CLAUSE_NOWAIT | OMP_CLAUSE_PRIVATE \
5187 : | OMP_CLAUSE_FIRSTPRIVATE | OMP_CLAUSE_DEFAULTMAP \
5188 : | OMP_CLAUSE_IS_DEVICE_PTR | OMP_CLAUSE_IN_REDUCTION \
5189 : | OMP_CLAUSE_THREAD_LIMIT | OMP_CLAUSE_ALLOCATE \
5190 : | OMP_CLAUSE_HAS_DEVICE_ADDR | OMP_CLAUSE_USES_ALLOCATORS \
5191 : | OMP_CLAUSE_DYN_GROUPPRIVATE | OMP_CLAUSE_DEVICE_TYPE)
5192 : #define OMP_TARGET_DATA_CLAUSES \
5193 : (omp_mask (OMP_CLAUSE_DEVICE) | OMP_CLAUSE_MAP | OMP_CLAUSE_IF \
5194 : | OMP_CLAUSE_USE_DEVICE_PTR | OMP_CLAUSE_USE_DEVICE_ADDR)
5195 : #define OMP_TARGET_ENTER_DATA_CLAUSES \
5196 : (omp_mask (OMP_CLAUSE_DEVICE) | OMP_CLAUSE_MAP | OMP_CLAUSE_IF \
5197 : | OMP_CLAUSE_DEPEND | OMP_CLAUSE_NOWAIT)
5198 : #define OMP_TARGET_EXIT_DATA_CLAUSES \
5199 : (omp_mask (OMP_CLAUSE_DEVICE) | OMP_CLAUSE_MAP | OMP_CLAUSE_IF \
5200 : | OMP_CLAUSE_DEPEND | OMP_CLAUSE_NOWAIT)
5201 : #define OMP_TARGET_UPDATE_CLAUSES \
5202 : (omp_mask (OMP_CLAUSE_DEVICE) | OMP_CLAUSE_IF | OMP_CLAUSE_TO \
5203 : | OMP_CLAUSE_FROM | OMP_CLAUSE_DEPEND | OMP_CLAUSE_NOWAIT)
5204 : #define OMP_TEAMS_CLAUSES \
5205 : (omp_mask (OMP_CLAUSE_NUM_TEAMS) | OMP_CLAUSE_THREAD_LIMIT \
5206 : | OMP_CLAUSE_DEFAULT | OMP_CLAUSE_PRIVATE | OMP_CLAUSE_FIRSTPRIVATE \
5207 : | OMP_CLAUSE_SHARED | OMP_CLAUSE_REDUCTION | OMP_CLAUSE_ALLOCATE)
5208 : #define OMP_DISTRIBUTE_CLAUSES \
5209 : (omp_mask (OMP_CLAUSE_PRIVATE) | OMP_CLAUSE_FIRSTPRIVATE \
5210 : | OMP_CLAUSE_LASTPRIVATE | OMP_CLAUSE_COLLAPSE | OMP_CLAUSE_DIST_SCHEDULE \
5211 : | OMP_CLAUSE_ORDER | OMP_CLAUSE_ALLOCATE)
5212 : #define OMP_SINGLE_CLAUSES \
5213 : (omp_mask (OMP_CLAUSE_PRIVATE) | OMP_CLAUSE_FIRSTPRIVATE \
5214 : | OMP_CLAUSE_ALLOCATE | OMP_CLAUSE_NOWAIT | OMP_CLAUSE_COPYPRIVATE)
5215 : #define OMP_ORDERED_CLAUSES \
5216 : (omp_mask (OMP_CLAUSE_THREADS) | OMP_CLAUSE_SIMD)
5217 : #define OMP_DECLARE_TARGET_CLAUSES \
5218 : (omp_mask (OMP_CLAUSE_ENTER) | OMP_CLAUSE_LINK | OMP_CLAUSE_DEVICE_TYPE \
5219 : | OMP_CLAUSE_TO | OMP_CLAUSE_INDIRECT | OMP_CLAUSE_LOCAL)
5220 : #define OMP_ATOMIC_CLAUSES \
5221 : (omp_mask (OMP_CLAUSE_ATOMIC) | OMP_CLAUSE_CAPTURE | OMP_CLAUSE_HINT \
5222 : | OMP_CLAUSE_MEMORDER | OMP_CLAUSE_COMPARE | OMP_CLAUSE_FAIL \
5223 : | OMP_CLAUSE_WEAK)
5224 : #define OMP_MASKED_CLAUSES \
5225 : (omp_mask (OMP_CLAUSE_FILTER))
5226 : #define OMP_ERROR_CLAUSES \
5227 : (omp_mask (OMP_CLAUSE_AT) | OMP_CLAUSE_MESSAGE | OMP_CLAUSE_SEVERITY)
5228 : #define OMP_WORKSHARE_CLAUSES \
5229 : omp_mask (OMP_CLAUSE_NOWAIT)
5230 : #define OMP_UNROLL_CLAUSES \
5231 : (omp_mask (OMP_CLAUSE_FULL) | OMP_CLAUSE_PARTIAL)
5232 : #define OMP_TILE_CLAUSES \
5233 : (omp_mask (OMP_CLAUSE_SIZES))
5234 : #define OMP_ALLOCATORS_CLAUSES \
5235 : omp_mask (OMP_CLAUSE_ALLOCATE)
5236 : #define OMP_INTEROP_CLAUSES \
5237 : (omp_mask (OMP_CLAUSE_DEPEND) | OMP_CLAUSE_NOWAIT | OMP_CLAUSE_DEVICE \
5238 : | OMP_CLAUSE_INIT | OMP_CLAUSE_DESTROY | OMP_CLAUSE_USE)
5239 : #define OMP_DISPATCH_CLAUSES \
5240 : (omp_mask (OMP_CLAUSE_DEVICE) | OMP_CLAUSE_DEPEND | OMP_CLAUSE_NOVARIANTS \
5241 : | OMP_CLAUSE_NOCONTEXT | OMP_CLAUSE_IS_DEVICE_PTR | OMP_CLAUSE_NOWAIT \
5242 : | OMP_CLAUSE_HAS_DEVICE_ADDR | OMP_CLAUSE_INTEROP)
5243 :
5244 :
5245 : static match
5246 16767 : match_omp (gfc_exec_op op, const omp_mask mask)
5247 : {
5248 16767 : gfc_omp_clauses *c;
5249 16767 : if (gfc_match_omp_clauses (&c, mask, true, true, false,
5250 : op == EXEC_OMP_TARGET) != MATCH_YES)
5251 : return MATCH_ERROR;
5252 16519 : new_st.op = op;
5253 16519 : new_st.ext.omp_clauses = c;
5254 16519 : return MATCH_YES;
5255 : }
5256 :
5257 : /* Handles both declarative and (deprecated) executable ALLOCATE directive;
5258 : accepts optional list (for executable) and common blocks.
5259 : If no variables have been provided, the single omp namelist has sym == NULL.
5260 :
5261 : Note that the executable ALLOCATE directive permits structure elements only
5262 : in OpenMP 5.0 and 5.1 but not longer in 5.2. See also the comment on the
5263 : 'omp allocators' directive below. The accidental change was reverted for
5264 : OpenMP TR12, permitting them again. See also gfc_match_omp_allocators.
5265 :
5266 : Hence, structure elements are rejected for now, also to make resolving
5267 : OMP_LIST_ALLOCATE simpler (check for duplicates, same symbol in
5268 : Fortran allocate stmt). TODO: Permit structure elements. */
5269 :
5270 : match
5271 274 : gfc_match_omp_allocate (void)
5272 : {
5273 274 : match m;
5274 274 : bool first = true;
5275 274 : gfc_omp_namelist *vars = NULL;
5276 274 : gfc_expr *align = NULL;
5277 274 : gfc_expr *allocator = NULL;
5278 274 : locus loc = gfc_current_locus;
5279 :
5280 274 : m = gfc_match_omp_variable_list (" (", &vars, true, NULL, NULL, true, true,
5281 : NULL, true);
5282 :
5283 274 : if (m == MATCH_ERROR)
5284 : return m;
5285 :
5286 502 : while (true)
5287 : {
5288 502 : gfc_gobble_whitespace ();
5289 502 : if (gfc_match_omp_eos () == MATCH_YES)
5290 : break;
5291 234 : if (!first)
5292 28 : gfc_match (", ");
5293 234 : first = false;
5294 234 : if ((m = gfc_match_dupl_check (!align, "align", true, &align))
5295 : != MATCH_NO)
5296 : {
5297 62 : if (m == MATCH_ERROR)
5298 1 : goto error;
5299 61 : continue;
5300 : }
5301 172 : if ((m = gfc_match_dupl_check (!allocator, "allocator",
5302 : true, &allocator)) != MATCH_NO)
5303 : {
5304 171 : if (m == MATCH_ERROR)
5305 1 : goto error;
5306 170 : continue;
5307 : }
5308 1 : gfc_error ("Expected ALIGN or ALLOCATOR clause at %C");
5309 1 : return MATCH_ERROR;
5310 : }
5311 541 : for (gfc_omp_namelist *n = vars; n; n = n->next)
5312 276 : if (n->expr)
5313 : {
5314 3 : if ((n->expr->ref && n->expr->ref->type == REF_COMPONENT)
5315 3 : || (n->expr->ref->next && n->expr->ref->type == REF_COMPONENT))
5316 1 : gfc_error ("Sorry, structure-element list item at %L in ALLOCATE "
5317 : "directive is not yet supported", &n->expr->where);
5318 : else
5319 2 : gfc_error ("Unexpected expression as list item at %L in ALLOCATE "
5320 : "directive", &n->expr->where);
5321 :
5322 3 : gfc_free_omp_namelist (vars, false, true, false, false);
5323 3 : goto error;
5324 : }
5325 :
5326 265 : new_st.op = EXEC_OMP_ALLOCATE;
5327 265 : new_st.ext.omp_clauses = gfc_get_omp_clauses ();
5328 265 : if (vars == NULL)
5329 : {
5330 27 : vars = gfc_get_omp_namelist ();
5331 27 : vars->where = loc;
5332 27 : vars->u.align = align;
5333 27 : vars->u2.allocator = allocator;
5334 27 : new_st.ext.omp_clauses->lists[OMP_LIST_ALLOCATE] = vars;
5335 : }
5336 : else
5337 : {
5338 238 : new_st.ext.omp_clauses->lists[OMP_LIST_ALLOCATE] = vars;
5339 511 : for (; vars; vars = vars->next)
5340 : {
5341 273 : vars->u.align = (align) ? gfc_copy_expr (align) : NULL;
5342 273 : vars->u2.allocator = allocator;
5343 : }
5344 238 : gfc_free_expr (align);
5345 : }
5346 : return MATCH_YES;
5347 :
5348 5 : error:
5349 5 : gfc_free_expr (align);
5350 5 : gfc_free_expr (allocator);
5351 5 : return MATCH_ERROR;
5352 : }
5353 :
5354 : /* In line with OpenMP 5.2 derived-type components are rejected.
5355 : See also comment before gfc_match_omp_allocate. */
5356 :
5357 : match
5358 26 : gfc_match_omp_allocators (void)
5359 : {
5360 26 : return match_omp (EXEC_OMP_ALLOCATORS, OMP_ALLOCATORS_CLAUSES);
5361 : }
5362 :
5363 :
5364 : match
5365 22 : gfc_match_omp_assume (void)
5366 : {
5367 22 : gfc_omp_clauses *c;
5368 22 : locus loc = gfc_current_locus;
5369 22 : if ((gfc_match_omp_clauses (&c, omp_mask (OMP_CLAUSE_ASSUMPTIONS))
5370 : != MATCH_YES)
5371 22 : || (omp_verify_merge_absent_contains (ST_OMP_ASSUME, c->assume, NULL,
5372 : &loc) != MATCH_YES))
5373 6 : return MATCH_ERROR;
5374 16 : new_st.op = EXEC_OMP_ASSUME;
5375 16 : new_st.ext.omp_clauses = c;
5376 16 : return MATCH_YES;
5377 : }
5378 :
5379 :
5380 : match
5381 28 : gfc_match_omp_assumes (void)
5382 : {
5383 28 : gfc_omp_clauses *c;
5384 28 : locus loc = gfc_current_locus;
5385 28 : if (!gfc_current_ns->proc_name
5386 27 : || (gfc_current_ns->proc_name->attr.flavor != FL_MODULE
5387 23 : && !gfc_current_ns->proc_name->attr.subroutine
5388 10 : && !gfc_current_ns->proc_name->attr.function))
5389 : {
5390 2 : gfc_error ("!$OMP ASSUMES at %C must be in the specification part of a "
5391 : "subprogram or module");
5392 2 : return MATCH_ERROR;
5393 : }
5394 26 : if ((gfc_match_omp_clauses (&c, omp_mask (OMP_CLAUSE_ASSUMPTIONS))
5395 : != MATCH_YES)
5396 50 : || (omp_verify_merge_absent_contains (ST_OMP_ASSUMES, c->assume,
5397 24 : gfc_current_ns->omp_assumes, &loc)
5398 : != MATCH_YES))
5399 5 : return MATCH_ERROR;
5400 21 : if (gfc_current_ns->omp_assumes == NULL)
5401 : {
5402 19 : gfc_current_ns->omp_assumes = c->assume;
5403 19 : c->assume = NULL;
5404 : }
5405 2 : else if (gfc_current_ns->omp_assumes && c->assume)
5406 : {
5407 2 : gfc_current_ns->omp_assumes->no_openmp |= c->assume->no_openmp;
5408 2 : gfc_current_ns->omp_assumes->no_openmp_routines
5409 2 : |= c->assume->no_openmp_routines;
5410 2 : gfc_current_ns->omp_assumes->no_openmp_constructs
5411 2 : |= c->assume->no_openmp_constructs;
5412 2 : gfc_current_ns->omp_assumes->no_parallelism |= c->assume->no_parallelism;
5413 2 : if (gfc_current_ns->omp_assumes->holds && c->assume->holds)
5414 : {
5415 : gfc_expr_list *el = gfc_current_ns->omp_assumes->holds;
5416 1 : for ( ; el->next ; el = el->next)
5417 : ;
5418 1 : el->next = c->assume->holds;
5419 1 : }
5420 1 : else if (c->assume->holds)
5421 0 : gfc_current_ns->omp_assumes->holds = c->assume->holds;
5422 2 : c->assume->holds = NULL;
5423 : }
5424 21 : gfc_free_omp_clauses (c);
5425 21 : return MATCH_YES;
5426 : }
5427 :
5428 :
5429 : match
5430 162 : gfc_match_omp_critical (void)
5431 : {
5432 162 : char n[GFC_MAX_SYMBOL_LEN+1];
5433 162 : gfc_omp_clauses *c = NULL;
5434 :
5435 162 : if (gfc_match (" ( %n )", n) != MATCH_YES)
5436 115 : n[0] = '\0';
5437 :
5438 162 : if (gfc_match_omp_clauses (&c, omp_mask (OMP_CLAUSE_HINT),
5439 162 : /* first = */ n[0] == '\0') != MATCH_YES)
5440 : return MATCH_ERROR;
5441 :
5442 160 : new_st.op = EXEC_OMP_CRITICAL;
5443 160 : new_st.ext.omp_clauses = c;
5444 160 : if (n[0])
5445 47 : c->critical_name = xstrdup (n);
5446 : return MATCH_YES;
5447 : }
5448 :
5449 :
5450 : match
5451 160 : gfc_match_omp_end_critical (void)
5452 : {
5453 160 : char n[GFC_MAX_SYMBOL_LEN+1];
5454 :
5455 160 : if (gfc_match (" ( %n )", n) != MATCH_YES)
5456 113 : n[0] = '\0';
5457 160 : if (gfc_match_omp_eos () != MATCH_YES)
5458 : {
5459 1 : gfc_error ("Unexpected junk after $OMP CRITICAL statement at %C");
5460 1 : return MATCH_ERROR;
5461 : }
5462 :
5463 159 : new_st.op = EXEC_OMP_END_CRITICAL;
5464 159 : new_st.ext.omp_name = n[0] ? xstrdup (n) : NULL;
5465 159 : return MATCH_YES;
5466 : }
5467 :
5468 : /* depobj(depobj) depend(dep-type:loc)|destroy|update(dep-type)
5469 : dep-type = in/out/inout/mutexinoutset/depobj/source/sink
5470 : depend: !source, !sink
5471 : update: !source, !sink, !depobj
5472 : locator = exactly one list item .*/
5473 : match
5474 125 : gfc_match_omp_depobj (void)
5475 : {
5476 125 : gfc_omp_clauses *c = NULL;
5477 125 : gfc_expr *depobj;
5478 :
5479 125 : if (gfc_match (" ( %v ) ", &depobj) != MATCH_YES)
5480 : {
5481 2 : gfc_error ("Expected %<( depobj )%> at %C");
5482 2 : return MATCH_ERROR;
5483 : }
5484 123 : if (gfc_match ("update ( ") == MATCH_YES)
5485 : {
5486 12 : c = gfc_get_omp_clauses ();
5487 12 : if (gfc_match ("inoutset )") == MATCH_YES)
5488 2 : c->depobj_update = OMP_DEPEND_INOUTSET;
5489 10 : else if (gfc_match ("inout )") == MATCH_YES)
5490 1 : c->depobj_update = OMP_DEPEND_INOUT;
5491 9 : else if (gfc_match ("in )") == MATCH_YES)
5492 2 : c->depobj_update = OMP_DEPEND_IN;
5493 7 : else if (gfc_match ("out )") == MATCH_YES)
5494 2 : c->depobj_update = OMP_DEPEND_OUT;
5495 5 : else if (gfc_match ("mutexinoutset )") == MATCH_YES)
5496 2 : c->depobj_update = OMP_DEPEND_MUTEXINOUTSET;
5497 : else
5498 : {
5499 3 : gfc_error ("Expected IN, OUT, INOUT, INOUTSET or MUTEXINOUTSET "
5500 : "followed by %<)%> at %C");
5501 3 : goto error;
5502 : }
5503 : }
5504 111 : else if (gfc_match ("destroy ") == MATCH_YES)
5505 : {
5506 16 : gfc_expr *destroyobj = NULL;
5507 16 : c = gfc_get_omp_clauses ();
5508 16 : c->destroy = true;
5509 :
5510 16 : if (gfc_match (" ( %v ) ", &destroyobj) == MATCH_YES)
5511 : {
5512 3 : if (destroyobj->symtree != depobj->symtree)
5513 2 : gfc_warning (OPT_Wopenmp, "The same depend object should be used as"
5514 : " DEPOBJ argument at %L and as DESTROY argument at %L",
5515 : &depobj->where, &destroyobj->where);
5516 3 : gfc_free_expr (destroyobj);
5517 : }
5518 : }
5519 95 : else if (gfc_match_omp_clauses (&c, omp_mask (OMP_CLAUSE_DEPEND), true, false)
5520 : != MATCH_YES)
5521 2 : goto error;
5522 :
5523 118 : if (c->depobj_update == OMP_DEPEND_UNSET && !c->destroy)
5524 : {
5525 93 : if (!c->doacross_source && !c->lists[OMP_LIST_DEPEND])
5526 : {
5527 1 : gfc_error ("Expected DEPEND, UPDATE, or DESTROY clause at %C");
5528 1 : goto error;
5529 : }
5530 92 : if (c->lists[OMP_LIST_DEPEND]->u.depend_doacross_op == OMP_DEPEND_DEPOBJ)
5531 : {
5532 1 : gfc_error ("DEPEND clause at %L of OMP DEPOBJ construct shall not "
5533 : "have dependence-type DEPOBJ",
5534 : c->lists[OMP_LIST_DEPEND]
5535 : ? &c->lists[OMP_LIST_DEPEND]->where : &gfc_current_locus);
5536 1 : goto error;
5537 : }
5538 91 : if (c->lists[OMP_LIST_DEPEND]->next)
5539 : {
5540 1 : gfc_error ("DEPEND clause at %L of OMP DEPOBJ construct shall have "
5541 : "only a single locator",
5542 : &c->lists[OMP_LIST_DEPEND]->next->where);
5543 1 : goto error;
5544 : }
5545 : }
5546 :
5547 115 : c->depobj = depobj;
5548 115 : new_st.op = EXEC_OMP_DEPOBJ;
5549 115 : new_st.ext.omp_clauses = c;
5550 115 : return MATCH_YES;
5551 :
5552 8 : error:
5553 8 : gfc_free_expr (depobj);
5554 8 : gfc_free_omp_clauses (c);
5555 8 : return MATCH_ERROR;
5556 : }
5557 :
5558 : match
5559 160 : gfc_match_omp_dispatch (void)
5560 : {
5561 160 : return match_omp (EXEC_OMP_DISPATCH, OMP_DISPATCH_CLAUSES);
5562 : }
5563 :
5564 : match
5565 57 : gfc_match_omp_distribute (void)
5566 : {
5567 57 : return match_omp (EXEC_OMP_DISTRIBUTE, OMP_DISTRIBUTE_CLAUSES);
5568 : }
5569 :
5570 :
5571 : match
5572 44 : gfc_match_omp_distribute_parallel_do (void)
5573 : {
5574 44 : return match_omp (EXEC_OMP_DISTRIBUTE_PARALLEL_DO,
5575 44 : (OMP_DISTRIBUTE_CLAUSES | OMP_PARALLEL_CLAUSES
5576 44 : | OMP_DO_CLAUSES)
5577 44 : & ~(omp_mask (OMP_CLAUSE_ORDERED)
5578 44 : | OMP_CLAUSE_LINEAR | OMP_CLAUSE_NOWAIT));
5579 : }
5580 :
5581 :
5582 : match
5583 34 : gfc_match_omp_distribute_parallel_do_simd (void)
5584 : {
5585 34 : return match_omp (EXEC_OMP_DISTRIBUTE_PARALLEL_DO_SIMD,
5586 34 : (OMP_DISTRIBUTE_CLAUSES | OMP_PARALLEL_CLAUSES
5587 34 : | OMP_DO_CLAUSES | OMP_SIMD_CLAUSES)
5588 34 : & ~(omp_mask (OMP_CLAUSE_ORDERED) | OMP_CLAUSE_NOWAIT));
5589 : }
5590 :
5591 :
5592 : match
5593 52 : gfc_match_omp_distribute_simd (void)
5594 : {
5595 52 : return match_omp (EXEC_OMP_DISTRIBUTE_SIMD,
5596 52 : OMP_DISTRIBUTE_CLAUSES | OMP_SIMD_CLAUSES);
5597 : }
5598 :
5599 :
5600 : match
5601 1252 : gfc_match_omp_do (void)
5602 : {
5603 1252 : return match_omp (EXEC_OMP_DO, OMP_DO_CLAUSES);
5604 : }
5605 :
5606 :
5607 : match
5608 137 : gfc_match_omp_do_simd (void)
5609 : {
5610 137 : return match_omp (EXEC_OMP_DO_SIMD, OMP_DO_CLAUSES | OMP_SIMD_CLAUSES);
5611 : }
5612 :
5613 :
5614 : match
5615 70 : gfc_match_omp_loop (void)
5616 : {
5617 70 : return match_omp (EXEC_OMP_LOOP, OMP_LOOP_CLAUSES);
5618 : }
5619 :
5620 :
5621 : match
5622 35 : gfc_match_omp_teams_loop (void)
5623 : {
5624 35 : return match_omp (EXEC_OMP_TEAMS_LOOP, OMP_TEAMS_CLAUSES | OMP_LOOP_CLAUSES);
5625 : }
5626 :
5627 :
5628 : match
5629 18 : gfc_match_omp_target_teams_loop (void)
5630 : {
5631 18 : return match_omp (EXEC_OMP_TARGET_TEAMS_LOOP,
5632 18 : OMP_TARGET_CLAUSES | OMP_TEAMS_CLAUSES | OMP_LOOP_CLAUSES);
5633 : }
5634 :
5635 :
5636 : match
5637 31 : gfc_match_omp_parallel_loop (void)
5638 : {
5639 31 : return match_omp (EXEC_OMP_PARALLEL_LOOP,
5640 31 : OMP_PARALLEL_CLAUSES | OMP_LOOP_CLAUSES);
5641 : }
5642 :
5643 :
5644 : match
5645 16 : gfc_match_omp_target_parallel_loop (void)
5646 : {
5647 16 : return match_omp (EXEC_OMP_TARGET_PARALLEL_LOOP,
5648 16 : (OMP_TARGET_CLAUSES | OMP_PARALLEL_CLAUSES
5649 16 : | OMP_LOOP_CLAUSES));
5650 : }
5651 :
5652 :
5653 : match
5654 101 : gfc_match_omp_error (void)
5655 : {
5656 101 : locus loc = gfc_current_locus;
5657 101 : match m = match_omp (EXEC_OMP_ERROR, OMP_ERROR_CLAUSES);
5658 101 : if (m != MATCH_YES)
5659 : return m;
5660 :
5661 82 : gfc_omp_clauses *c = new_st.ext.omp_clauses;
5662 82 : if (c->severity == OMP_SEVERITY_UNSET)
5663 45 : c->severity = OMP_SEVERITY_FATAL;
5664 82 : if (new_st.ext.omp_clauses->at == OMP_AT_EXECUTION)
5665 : return MATCH_YES;
5666 37 : if (c->message
5667 37 : && (!gfc_resolve_expr (c->message)
5668 16 : || c->message->ts.type != BT_CHARACTER
5669 14 : || c->message->ts.kind != gfc_default_character_kind
5670 13 : || c->message->rank != 0))
5671 : {
5672 4 : gfc_error ("MESSAGE clause at %L requires a scalar default-kind "
5673 : "CHARACTER expression",
5674 4 : &new_st.ext.omp_clauses->message->where);
5675 4 : return MATCH_ERROR;
5676 : }
5677 33 : if (c->message && !gfc_is_constant_expr (c->message))
5678 : {
5679 2 : gfc_error ("Constant character expression required in MESSAGE clause "
5680 2 : "at %L", &new_st.ext.omp_clauses->message->where);
5681 2 : return MATCH_ERROR;
5682 : }
5683 31 : if (c->message)
5684 : {
5685 10 : const char *msg = G_("$OMP ERROR encountered at %L: %s");
5686 10 : gcc_assert (c->message->expr_type == EXPR_CONSTANT);
5687 10 : gfc_charlen_t slen = c->message->value.character.length;
5688 10 : int i = gfc_validate_kind (BT_CHARACTER, gfc_default_character_kind,
5689 : false);
5690 10 : size_t size = slen * gfc_character_kinds[i].bit_size / 8;
5691 10 : unsigned char *s = XCNEWVAR (unsigned char, size + 1);
5692 10 : gfc_encode_character (gfc_default_character_kind, slen,
5693 10 : c->message->value.character.string,
5694 : (unsigned char *) s, size);
5695 10 : s[size] = '\0';
5696 10 : if (c->severity == OMP_SEVERITY_WARNING)
5697 6 : gfc_warning_now (0, msg, &loc, s);
5698 : else
5699 4 : gfc_error_now (msg, &loc, s);
5700 10 : free (s);
5701 : }
5702 : else
5703 : {
5704 21 : const char *msg = G_("$OMP ERROR encountered at %L");
5705 21 : if (c->severity == OMP_SEVERITY_WARNING)
5706 7 : gfc_warning_now (0, msg, &loc);
5707 : else
5708 14 : gfc_error_now (msg, &loc);
5709 : }
5710 : return MATCH_YES;
5711 : }
5712 :
5713 : match
5714 86 : gfc_match_omp_flush (void)
5715 : {
5716 86 : gfc_omp_namelist *list = NULL;
5717 86 : gfc_omp_clauses *c = NULL;
5718 86 : gfc_gobble_whitespace ();
5719 86 : enum gfc_omp_memorder mo = OMP_MEMORDER_UNSET;
5720 86 : if (gfc_match_omp_eos () == MATCH_NO && gfc_peek_ascii_char () != '(')
5721 : {
5722 14 : if (gfc_match ("seq_cst") == MATCH_YES)
5723 : mo = OMP_MEMORDER_SEQ_CST;
5724 11 : else if (gfc_match ("acq_rel") == MATCH_YES)
5725 : mo = OMP_MEMORDER_ACQ_REL;
5726 8 : else if (gfc_match ("release") == MATCH_YES)
5727 : mo = OMP_MEMORDER_RELEASE;
5728 5 : else if (gfc_match ("acquire") == MATCH_YES)
5729 : mo = OMP_MEMORDER_ACQUIRE;
5730 : else
5731 : {
5732 2 : gfc_error ("Expected SEQ_CST, AQC_REL, RELEASE, or ACQUIRE at %C");
5733 2 : return MATCH_ERROR;
5734 : }
5735 12 : c = gfc_get_omp_clauses ();
5736 12 : c->memorder = mo;
5737 : }
5738 84 : gfc_match_omp_variable_list (" (", &list, true);
5739 84 : if (list && mo != OMP_MEMORDER_UNSET)
5740 : {
5741 4 : gfc_error ("List specified together with memory order clause in FLUSH "
5742 : "directive at %C");
5743 4 : gfc_free_omp_namelist (list, false, false, false, false);
5744 4 : gfc_free_omp_clauses (c);
5745 4 : return MATCH_ERROR;
5746 : }
5747 80 : if (gfc_match_omp_eos () != MATCH_YES)
5748 : {
5749 0 : gfc_error ("Unexpected junk after $OMP FLUSH statement at %C");
5750 0 : gfc_free_omp_namelist (list, false, false, false, false);
5751 0 : gfc_free_omp_clauses (c);
5752 0 : return MATCH_ERROR;
5753 : }
5754 80 : new_st.op = EXEC_OMP_FLUSH;
5755 80 : new_st.ext.omp_namelist = list;
5756 80 : new_st.ext.omp_clauses = c;
5757 80 : return MATCH_YES;
5758 : }
5759 :
5760 :
5761 : match
5762 188 : gfc_match_omp_declare_simd (void)
5763 : {
5764 188 : locus where = gfc_current_locus;
5765 188 : gfc_symbol *proc_name;
5766 188 : gfc_omp_clauses *c;
5767 188 : gfc_omp_declare_simd *ods;
5768 188 : bool needs_space = false;
5769 :
5770 188 : switch (gfc_match (" ( "))
5771 : {
5772 144 : case MATCH_YES:
5773 144 : if (gfc_match_symbol (&proc_name, /* host assoc = */ true) != MATCH_YES
5774 144 : || gfc_match (" ) ") != MATCH_YES)
5775 0 : return MATCH_ERROR;
5776 : break;
5777 44 : case MATCH_NO: proc_name = NULL; needs_space = true; break;
5778 : case MATCH_ERROR: return MATCH_ERROR;
5779 : }
5780 :
5781 188 : if (gfc_match_omp_clauses (&c, OMP_DECLARE_SIMD_CLAUSES, true,
5782 : needs_space) != MATCH_YES)
5783 : return MATCH_ERROR;
5784 :
5785 183 : if (gfc_current_ns->is_block_data)
5786 : {
5787 1 : gfc_free_omp_clauses (c);
5788 1 : return MATCH_YES;
5789 : }
5790 :
5791 182 : ods = gfc_get_omp_declare_simd ();
5792 182 : ods->where = where;
5793 182 : ods->proc_name = proc_name;
5794 182 : ods->clauses = c;
5795 182 : ods->next = gfc_current_ns->omp_declare_simd;
5796 182 : gfc_current_ns->omp_declare_simd = ods;
5797 182 : return MATCH_YES;
5798 : }
5799 :
5800 :
5801 : static bool
5802 877 : match_udr_expr (gfc_symtree *omp_sym1, gfc_symtree *omp_sym2)
5803 : {
5804 877 : match m;
5805 877 : locus old_loc = gfc_current_locus;
5806 877 : char sname[GFC_MAX_SYMBOL_LEN + 1];
5807 877 : gfc_symbol *sym;
5808 877 : gfc_namespace *ns = gfc_current_ns;
5809 877 : gfc_expr *lvalue = NULL, *rvalue = NULL;
5810 877 : gfc_symtree *st;
5811 877 : gfc_actual_arglist *arglist;
5812 :
5813 877 : m = gfc_match (" %v =", &lvalue);
5814 877 : if (m != MATCH_YES)
5815 200 : gfc_current_locus = old_loc;
5816 : else
5817 : {
5818 677 : m = gfc_match (" %e )", &rvalue);
5819 677 : if (m == MATCH_YES)
5820 : {
5821 675 : ns->code = gfc_get_code (EXEC_ASSIGN);
5822 675 : ns->code->expr1 = lvalue;
5823 675 : ns->code->expr2 = rvalue;
5824 675 : ns->code->loc = old_loc;
5825 675 : return true;
5826 : }
5827 :
5828 2 : gfc_current_locus = old_loc;
5829 2 : gfc_free_expr (lvalue);
5830 : }
5831 :
5832 202 : m = gfc_match (" %n", sname);
5833 202 : if (m != MATCH_YES)
5834 : return false;
5835 :
5836 202 : if (strcmp (sname, omp_sym1->name) == 0
5837 200 : || strcmp (sname, omp_sym2->name) == 0)
5838 : return false;
5839 :
5840 200 : gfc_current_ns = ns->parent;
5841 200 : if (gfc_get_ha_sym_tree (sname, &st))
5842 : return false;
5843 :
5844 200 : sym = st->n.sym;
5845 200 : if (sym->attr.flavor != FL_PROCEDURE
5846 72 : && sym->attr.flavor != FL_UNKNOWN)
5847 : return false;
5848 :
5849 199 : if (!sym->attr.generic
5850 189 : && !sym->attr.subroutine
5851 71 : && !sym->attr.function)
5852 : {
5853 71 : if (!(sym->attr.external && !sym->attr.referenced))
5854 : {
5855 : /* ...create a symbol in this scope... */
5856 71 : if (sym->ns != gfc_current_ns
5857 71 : && gfc_get_sym_tree (sname, NULL, &st, false) == 1)
5858 : return false;
5859 :
5860 71 : if (sym != st->n.sym)
5861 71 : sym = st->n.sym;
5862 : }
5863 :
5864 : /* ...and then to try to make the symbol into a subroutine. */
5865 71 : if (!gfc_add_subroutine (&sym->attr, sym->name, NULL))
5866 : return false;
5867 : }
5868 :
5869 199 : gfc_set_sym_referenced (sym);
5870 199 : gfc_gobble_whitespace ();
5871 199 : if (gfc_peek_ascii_char () != '(')
5872 : return false;
5873 :
5874 195 : gfc_current_ns = ns;
5875 195 : m = gfc_match_actual_arglist (1, &arglist);
5876 195 : if (m != MATCH_YES)
5877 : return false;
5878 :
5879 195 : if (gfc_match_char (')') != MATCH_YES)
5880 : return false;
5881 :
5882 195 : ns->code = gfc_get_code (EXEC_CALL);
5883 195 : ns->code->symtree = st;
5884 195 : ns->code->ext.actual = arglist;
5885 195 : ns->code->loc = old_loc;
5886 195 : return true;
5887 : }
5888 :
5889 : static bool
5890 1156 : gfc_omp_udr_predef (gfc_omp_reduction_op rop, const char *name,
5891 : gfc_typespec *ts, const char **n)
5892 : {
5893 1156 : if (!gfc_numeric_ts (ts) && ts->type != BT_LOGICAL)
5894 : return false;
5895 :
5896 648 : switch (rop)
5897 : {
5898 21 : case OMP_REDUCTION_PLUS:
5899 21 : case OMP_REDUCTION_MINUS:
5900 21 : case OMP_REDUCTION_TIMES:
5901 21 : return ts->type != BT_LOGICAL;
5902 8 : case OMP_REDUCTION_AND:
5903 8 : case OMP_REDUCTION_OR:
5904 8 : case OMP_REDUCTION_EQV:
5905 8 : case OMP_REDUCTION_NEQV:
5906 8 : return ts->type == BT_LOGICAL;
5907 618 : case OMP_REDUCTION_USER:
5908 618 : if (name[0] != '.' && (ts->type == BT_INTEGER || ts->type == BT_REAL))
5909 : {
5910 546 : gfc_symbol *sym;
5911 :
5912 546 : gfc_find_symbol (name, NULL, 1, &sym);
5913 546 : if (sym != NULL)
5914 : {
5915 93 : if (sym->attr.intrinsic)
5916 0 : *n = sym->name;
5917 93 : else if ((sym->attr.flavor != FL_UNKNOWN
5918 81 : && sym->attr.flavor != FL_PROCEDURE)
5919 69 : || sym->attr.external
5920 54 : || sym->attr.generic
5921 54 : || sym->attr.entry
5922 54 : || sym->attr.result
5923 54 : || sym->attr.dummy
5924 54 : || sym->attr.subroutine
5925 50 : || sym->attr.pointer
5926 50 : || sym->attr.target
5927 50 : || sym->attr.cray_pointer
5928 50 : || sym->attr.cray_pointee
5929 50 : || (sym->attr.proc != PROC_UNKNOWN
5930 0 : && sym->attr.proc != PROC_INTRINSIC)
5931 50 : || sym->attr.if_source != IFSRC_UNKNOWN
5932 50 : || sym == sym->ns->proc_name)
5933 43 : *n = NULL;
5934 : else
5935 50 : *n = sym->name;
5936 : }
5937 : else
5938 453 : *n = name;
5939 546 : if (*n
5940 503 : && (strcmp (*n, "max") == 0 || strcmp (*n, "min") == 0))
5941 54 : return true;
5942 510 : else if (*n
5943 467 : && ts->type == BT_INTEGER
5944 383 : && (strcmp (*n, "iand") == 0
5945 377 : || strcmp (*n, "ior") == 0
5946 371 : || strcmp (*n, "ieor") == 0))
5947 : return true;
5948 : }
5949 : break;
5950 : default:
5951 : break;
5952 : }
5953 : return false;
5954 : }
5955 :
5956 : gfc_omp_udr *
5957 639 : gfc_omp_udr_find (gfc_symtree *st, gfc_typespec *ts)
5958 : {
5959 639 : gfc_omp_udr *omp_udr;
5960 :
5961 639 : if (st == NULL)
5962 : return NULL;
5963 :
5964 250 : for (omp_udr = st->n.omp_udr; omp_udr; omp_udr = omp_udr->next)
5965 154 : if (omp_udr->ts.type == ts->type
5966 89 : || ((omp_udr->ts.type == BT_DERIVED || omp_udr->ts.type == BT_CLASS)
5967 0 : && (ts->type == BT_DERIVED || ts->type == BT_CLASS)))
5968 : {
5969 65 : if (omp_udr->ts.type == BT_DERIVED || omp_udr->ts.type == BT_CLASS)
5970 : {
5971 12 : if (strcmp (omp_udr->ts.u.derived->name, ts->u.derived->name) == 0)
5972 : return omp_udr;
5973 : }
5974 53 : else if (omp_udr->ts.kind == ts->kind)
5975 : {
5976 19 : if (omp_udr->ts.type == BT_CHARACTER)
5977 : {
5978 17 : if (omp_udr->ts.u.cl->length == NULL
5979 15 : || ts->u.cl->length == NULL)
5980 : return omp_udr;
5981 15 : if (omp_udr->ts.u.cl->length->expr_type != EXPR_CONSTANT)
5982 : return omp_udr;
5983 15 : if (ts->u.cl->length->expr_type != EXPR_CONSTANT)
5984 : return omp_udr;
5985 15 : if (omp_udr->ts.u.cl->length->ts.type != BT_INTEGER)
5986 : return omp_udr;
5987 15 : if (ts->u.cl->length->ts.type != BT_INTEGER)
5988 : return omp_udr;
5989 15 : if (gfc_compare_expr (omp_udr->ts.u.cl->length,
5990 : ts->u.cl->length, INTRINSIC_EQ) != 0)
5991 15 : continue;
5992 : }
5993 2 : return omp_udr;
5994 : }
5995 : }
5996 : return NULL;
5997 : }
5998 :
5999 : match
6000 532 : gfc_match_omp_declare_reduction (void)
6001 : {
6002 532 : match m;
6003 532 : gfc_intrinsic_op op;
6004 532 : char name[GFC_MAX_SYMBOL_LEN + 3];
6005 532 : auto_vec<gfc_typespec, 5> tss;
6006 532 : gfc_typespec ts;
6007 532 : unsigned int i;
6008 532 : gfc_symtree *st;
6009 532 : locus where = gfc_current_locus;
6010 532 : locus end_loc = gfc_current_locus;
6011 532 : bool end_loc_set = false;
6012 532 : gfc_omp_reduction_op rop = OMP_REDUCTION_NONE;
6013 :
6014 532 : if (gfc_match_char ('(') != MATCH_YES)
6015 : return MATCH_ERROR;
6016 :
6017 530 : m = gfc_match (" %o : ", &op);
6018 530 : if (m == MATCH_ERROR)
6019 : return MATCH_ERROR;
6020 530 : if (m == MATCH_YES)
6021 : {
6022 117 : snprintf (name, sizeof name, "operator %s", gfc_op2string (op));
6023 117 : rop = (gfc_omp_reduction_op) op;
6024 : }
6025 : else
6026 : {
6027 413 : m = gfc_match_defined_op_name (name + 1, 1);
6028 413 : if (m == MATCH_ERROR)
6029 : return MATCH_ERROR;
6030 413 : if (m == MATCH_YES)
6031 : {
6032 41 : name[0] = '.';
6033 41 : strcat (name, ".");
6034 41 : if (gfc_match (" : ") != MATCH_YES)
6035 : return MATCH_ERROR;
6036 : }
6037 : else
6038 : {
6039 372 : if (gfc_match (" %n : ", name) != MATCH_YES)
6040 : return MATCH_ERROR;
6041 : }
6042 : rop = OMP_REDUCTION_USER;
6043 : }
6044 :
6045 529 : m = gfc_match_type_spec (&ts);
6046 529 : if (m != MATCH_YES)
6047 : return MATCH_ERROR;
6048 : /* Treat len=: the same as len=*. */
6049 528 : if (ts.type == BT_CHARACTER)
6050 61 : ts.deferred = false;
6051 528 : tss.safe_push (ts);
6052 :
6053 1093 : while (gfc_match_char (',') == MATCH_YES)
6054 : {
6055 37 : m = gfc_match_type_spec (&ts);
6056 37 : if (m != MATCH_YES)
6057 : return MATCH_ERROR;
6058 37 : tss.safe_push (ts);
6059 : }
6060 528 : if (gfc_match_char (':') != MATCH_YES)
6061 : return MATCH_ERROR;
6062 :
6063 527 : st = gfc_find_symtree (gfc_current_ns->omp_udr_root, name);
6064 1084 : for (i = 0; i < tss.length (); i++)
6065 : {
6066 564 : gfc_symtree *omp_out, *omp_in;
6067 564 : gfc_symtree *omp_priv = NULL, *omp_orig = NULL;
6068 564 : gfc_namespace *combiner_ns, *initializer_ns = NULL;
6069 564 : gfc_omp_udr *prev_udr, *omp_udr;
6070 564 : const char *predef_name = NULL;
6071 :
6072 564 : omp_udr = gfc_get_omp_udr ();
6073 564 : omp_udr->name = gfc_get_string ("%s", name);
6074 564 : omp_udr->rop = rop;
6075 564 : omp_udr->ts = tss[i];
6076 564 : omp_udr->where = where;
6077 :
6078 564 : gfc_current_ns = combiner_ns = gfc_get_namespace (gfc_current_ns, 1);
6079 564 : combiner_ns->proc_name = combiner_ns->parent->proc_name;
6080 :
6081 564 : gfc_get_sym_tree ("omp_out", combiner_ns, &omp_out, false);
6082 564 : gfc_get_sym_tree ("omp_in", combiner_ns, &omp_in, false);
6083 564 : combiner_ns->omp_udr_ns = 1;
6084 564 : omp_out->n.sym->ts = tss[i];
6085 564 : omp_in->n.sym->ts = tss[i];
6086 564 : omp_out->n.sym->attr.omp_udr_artificial_var = 1;
6087 564 : omp_in->n.sym->attr.omp_udr_artificial_var = 1;
6088 564 : omp_out->n.sym->attr.flavor = FL_VARIABLE;
6089 564 : omp_in->n.sym->attr.flavor = FL_VARIABLE;
6090 564 : gfc_commit_symbols ();
6091 564 : omp_udr->combiner_ns = combiner_ns;
6092 564 : omp_udr->omp_out = omp_out->n.sym;
6093 564 : omp_udr->omp_in = omp_in->n.sym;
6094 :
6095 564 : locus old_loc = gfc_current_locus;
6096 :
6097 564 : if (!match_udr_expr (omp_out, omp_in))
6098 : {
6099 4 : syntax:
6100 7 : gfc_current_locus = old_loc;
6101 7 : gfc_current_ns = combiner_ns->parent;
6102 7 : gfc_undo_symbols ();
6103 7 : gfc_free_omp_udr (omp_udr);
6104 7 : return MATCH_ERROR;
6105 : }
6106 :
6107 560 : if (gfc_match (" initializer ( ") == MATCH_YES)
6108 : {
6109 313 : gfc_current_ns = combiner_ns->parent;
6110 313 : initializer_ns = gfc_get_namespace (gfc_current_ns, 1);
6111 313 : gfc_current_ns = initializer_ns;
6112 313 : initializer_ns->proc_name = initializer_ns->parent->proc_name;
6113 :
6114 313 : gfc_get_sym_tree ("omp_priv", initializer_ns, &omp_priv, false);
6115 313 : gfc_get_sym_tree ("omp_orig", initializer_ns, &omp_orig, false);
6116 313 : initializer_ns->omp_udr_ns = 1;
6117 313 : omp_priv->n.sym->ts = tss[i];
6118 313 : omp_orig->n.sym->ts = tss[i];
6119 313 : omp_priv->n.sym->attr.omp_udr_artificial_var = 1;
6120 313 : omp_orig->n.sym->attr.omp_udr_artificial_var = 1;
6121 313 : omp_priv->n.sym->attr.flavor = FL_VARIABLE;
6122 313 : omp_orig->n.sym->attr.flavor = FL_VARIABLE;
6123 313 : gfc_commit_symbols ();
6124 313 : omp_udr->initializer_ns = initializer_ns;
6125 313 : omp_udr->omp_priv = omp_priv->n.sym;
6126 313 : omp_udr->omp_orig = omp_orig->n.sym;
6127 :
6128 313 : if (!match_udr_expr (omp_priv, omp_orig))
6129 3 : goto syntax;
6130 : }
6131 :
6132 557 : gfc_current_ns = combiner_ns->parent;
6133 557 : if (!end_loc_set)
6134 : {
6135 520 : end_loc_set = true;
6136 520 : end_loc = gfc_current_locus;
6137 : }
6138 557 : gfc_current_locus = old_loc;
6139 :
6140 557 : prev_udr = gfc_omp_udr_find (st, &tss[i]);
6141 557 : if (gfc_omp_udr_predef (rop, name, &tss[i], &predef_name)
6142 : /* Don't error on !$omp declare reduction (min : integer : ...)
6143 : just yet, there could be integer :: min afterwards,
6144 : making it valid. When the UDR is resolved, we'll get
6145 : to it again. */
6146 557 : && (rop != OMP_REDUCTION_USER || name[0] == '.'))
6147 : {
6148 29 : if (predef_name)
6149 0 : gfc_error_now ("Redefinition of predefined %s "
6150 : "!$OMP DECLARE REDUCTION at %L",
6151 : predef_name, &where);
6152 : else
6153 29 : gfc_error_now ("Redefinition of predefined "
6154 : "!$OMP DECLARE REDUCTION at %L", &where);
6155 : }
6156 528 : else if (prev_udr)
6157 : {
6158 6 : gfc_error_now ("Redefinition of !$OMP DECLARE REDUCTION at %L",
6159 : &where);
6160 6 : gfc_error_now ("Previous !$OMP DECLARE REDUCTION at %L",
6161 : &prev_udr->where);
6162 : }
6163 522 : else if (st)
6164 : {
6165 96 : omp_udr->next = st->n.omp_udr;
6166 96 : st->n.omp_udr = omp_udr;
6167 : }
6168 : else
6169 : {
6170 426 : st = gfc_new_symtree (&gfc_current_ns->omp_udr_root, name);
6171 426 : st->n.omp_udr = omp_udr;
6172 : }
6173 : }
6174 :
6175 520 : if (end_loc_set)
6176 : {
6177 520 : gfc_current_locus = end_loc;
6178 520 : if (gfc_match_omp_eos () != MATCH_YES)
6179 : {
6180 1 : gfc_error ("Unexpected junk after !$OMP DECLARE REDUCTION at %C");
6181 1 : gfc_current_locus = where;
6182 1 : return MATCH_ERROR;
6183 : }
6184 :
6185 : return MATCH_YES;
6186 : }
6187 0 : gfc_clear_error ();
6188 0 : return MATCH_ERROR;
6189 532 : }
6190 :
6191 :
6192 : match
6193 469 : gfc_match_omp_declare_target (void)
6194 : {
6195 469 : locus old_loc;
6196 469 : match m;
6197 469 : gfc_omp_clauses *c = NULL;
6198 469 : int list;
6199 469 : gfc_omp_namelist *n;
6200 469 : gfc_symbol *s;
6201 :
6202 469 : old_loc = gfc_current_locus;
6203 :
6204 469 : if (gfc_current_ns->proc_name
6205 469 : && gfc_match_omp_eos () == MATCH_YES)
6206 : {
6207 138 : if (!gfc_add_omp_declare_target (&gfc_current_ns->proc_name->attr,
6208 138 : gfc_current_ns->proc_name->name,
6209 : &old_loc))
6210 0 : goto cleanup;
6211 : return MATCH_YES;
6212 : }
6213 :
6214 331 : if (gfc_current_ns->proc_name
6215 331 : && gfc_current_ns->proc_name->attr.if_source == IFSRC_IFBODY)
6216 : {
6217 2 : gfc_error ("Only the !$OMP DECLARE TARGET form without "
6218 : "clauses is allowed in interface block at %C");
6219 2 : goto cleanup;
6220 : }
6221 :
6222 329 : m = gfc_match (" (");
6223 329 : if (m == MATCH_YES)
6224 : {
6225 83 : c = gfc_get_omp_clauses ();
6226 83 : gfc_current_locus = old_loc;
6227 83 : m = gfc_match_omp_to_link (" (", &c->lists[OMP_LIST_ENTER]);
6228 83 : if (m != MATCH_YES)
6229 0 : goto syntax;
6230 83 : if (gfc_match_omp_eos () != MATCH_YES)
6231 : {
6232 0 : gfc_error ("Unexpected junk after !$OMP DECLARE TARGET at %C");
6233 0 : goto cleanup;
6234 : }
6235 : }
6236 246 : else if (gfc_match_omp_clauses (&c, OMP_DECLARE_TARGET_CLAUSES) != MATCH_YES)
6237 : return MATCH_ERROR;
6238 :
6239 323 : gfc_buffer_error (false);
6240 :
6241 323 : static const int to_enter_link_lists[]
6242 : = { OMP_LIST_TO, OMP_LIST_ENTER, OMP_LIST_LINK, OMP_LIST_LOCAL };
6243 1615 : for (size_t listn = 0; listn < ARRAY_SIZE (to_enter_link_lists)
6244 1615 : && (list = to_enter_link_lists[listn], true); ++listn)
6245 1832 : for (n = c->lists[list]; n; n = n->next)
6246 540 : if (n->sym)
6247 499 : n->sym->mark = 0;
6248 41 : else if (n->u.common->head)
6249 41 : n->u.common->head->mark = 0;
6250 :
6251 323 : if (c->device_type == OMP_DEVICE_TYPE_UNSET)
6252 255 : c->device_type = OMP_DEVICE_TYPE_ANY;
6253 1292 : for (size_t listn = 0; listn < ARRAY_SIZE (to_enter_link_lists)
6254 1615 : && (list = to_enter_link_lists[listn], true); ++listn)
6255 1832 : for (n = c->lists[list]; n; n = n->next)
6256 540 : if (n->sym)
6257 : {
6258 499 : if (n->sym->attr.in_common)
6259 1 : gfc_error_now ("OMP DECLARE TARGET variable at %L is an "
6260 : "element of a COMMON block", &n->where);
6261 498 : else if (n->sym->attr.omp_groupprivate && list != OMP_LIST_LOCAL)
6262 12 : gfc_error_now ("List item %qs at %L not appear in the %qs clause "
6263 : "as it was previously specified in a GROUPPRIVATE "
6264 : "directive", n->sym->name, &n->where,
6265 : list == OMP_LIST_LINK
6266 5 : ? "link" : list == OMP_LIST_TO ? "to" : "enter");
6267 491 : else if (n->sym->mark)
6268 9 : gfc_error_now ("Variable at %L mentioned multiple times in "
6269 : "clauses of the same OMP DECLARE TARGET directive",
6270 : &n->where);
6271 482 : else if ((n->sym->attr.omp_declare_target_link
6272 477 : || n->sym->attr.omp_declare_target_local)
6273 : && list != OMP_LIST_LINK
6274 7 : && list != OMP_LIST_LOCAL)
6275 1 : gfc_error_now ("OMP DECLARE TARGET variable at %L previously "
6276 : "mentioned in %s clause and later in %s clause",
6277 : &n->where,
6278 : n->sym->attr.omp_declare_target_link ? "LINK"
6279 : : "LOCAL",
6280 : list == OMP_LIST_TO ? "TO" : "ENTER");
6281 481 : else if (n->sym->attr.omp_declare_target
6282 14 : && (list == OMP_LIST_LINK || list == OMP_LIST_LOCAL))
6283 1 : gfc_error_now ("OMP DECLARE TARGET variable at %L previously "
6284 : "mentioned in TO or ENTER clause and later in "
6285 : "%s clause", &n->where,
6286 : list == OMP_LIST_LINK ? "LINK" : "LOCAL");
6287 : else
6288 : {
6289 480 : if (list == OMP_LIST_TO || list == OMP_LIST_ENTER)
6290 441 : gfc_add_omp_declare_target (&n->sym->attr, n->sym->name,
6291 : &n->sym->declared_at);
6292 480 : if (list == OMP_LIST_LINK)
6293 30 : gfc_add_omp_declare_target_link (&n->sym->attr, n->sym->name,
6294 30 : &n->sym->declared_at);
6295 480 : if (list == OMP_LIST_LOCAL)
6296 9 : gfc_add_omp_declare_target_local (&n->sym->attr, n->sym->name,
6297 9 : &n->sym->declared_at);
6298 : }
6299 499 : if (n->sym->attr.omp_device_type != OMP_DEVICE_TYPE_UNSET
6300 36 : && n->sym->attr.omp_device_type != c->device_type)
6301 : {
6302 12 : const char *dt = "any";
6303 12 : if (n->sym->attr.omp_device_type == OMP_DEVICE_TYPE_NOHOST)
6304 : dt = "nohost";
6305 8 : else if (n->sym->attr.omp_device_type == OMP_DEVICE_TYPE_HOST)
6306 4 : dt = "host";
6307 12 : if (n->sym->attr.omp_groupprivate)
6308 1 : gfc_error_now ("List item %qs at %L set in previous OMP "
6309 : "GROUPPRIVATE directive to the different "
6310 : "DEVICE_TYPE %qs", n->sym->name, &n->where, dt);
6311 : else
6312 11 : gfc_error_now ("List item %qs at %L set in previous OMP "
6313 : "DECLARE TARGET directive to the different "
6314 : "DEVICE_TYPE %qs", n->sym->name, &n->where, dt);
6315 : }
6316 499 : n->sym->attr.omp_device_type = c->device_type;
6317 499 : if (c->indirect && c->device_type != OMP_DEVICE_TYPE_ANY)
6318 : {
6319 1 : gfc_error_now ("DEVICE_TYPE must be ANY when used with INDIRECT "
6320 : "at %L", &n->where);
6321 1 : c->indirect = 0;
6322 : }
6323 499 : n->sym->attr.omp_declare_target_indirect = c->indirect;
6324 499 : if (list == OMP_LIST_LINK && c->device_type == OMP_DEVICE_TYPE_NOHOST)
6325 3 : gfc_error_now ("List item %qs at %L set with NOHOST specified may "
6326 : "not appear in a LINK clause", n->sym->name,
6327 : &n->where);
6328 499 : n->sym->mark = 1;
6329 : }
6330 : else /* common block */
6331 : {
6332 41 : if (n->u.common->omp_groupprivate && list != OMP_LIST_LOCAL)
6333 7 : gfc_error_now ("Common block %</%s/%> at %L not appear in the %qs "
6334 : "clause as it was previously specified in a "
6335 : "GROUPPRIVATE directive",
6336 7 : n->u.common->name, &n->where,
6337 : list == OMP_LIST_LINK
6338 5 : ? "link" : list == OMP_LIST_TO ? "to" : "enter");
6339 34 : else if (n->u.common->head && n->u.common->head->mark)
6340 4 : gfc_error_now ("Common block %</%s/%> at %L mentioned multiple "
6341 : "times in clauses of the same OMP DECLARE TARGET "
6342 4 : "directive", n->u.common->name, &n->where);
6343 30 : else if ((n->u.common->omp_declare_target_link
6344 26 : || n->u.common->omp_declare_target_local)
6345 : && list != OMP_LIST_LINK
6346 6 : && list != OMP_LIST_LOCAL)
6347 2 : gfc_error_now ("Common block %</%s/%> at %L previously mentioned "
6348 : "in %s clause and later in %s clause",
6349 1 : n->u.common->name, &n->where,
6350 : n->u.common->omp_declare_target_link ? "LINK"
6351 : : "LOCAL",
6352 : list == OMP_LIST_TO ? "TO" : "ENTER");
6353 29 : else if (n->u.common->omp_declare_target
6354 4 : && (list == OMP_LIST_LINK || list == OMP_LIST_LOCAL))
6355 1 : gfc_error_now ("Common block %</%s/%> at %L previously mentioned "
6356 : "in TO or ENTER clause and later in %s clause",
6357 1 : n->u.common->name, &n->where,
6358 : list == OMP_LIST_LINK ? "LINK" : "LOCAL");
6359 41 : if (n->u.common->omp_device_type != OMP_DEVICE_TYPE_UNSET
6360 21 : && n->u.common->omp_device_type != c->device_type)
6361 : {
6362 1 : const char *dt = "any";
6363 1 : if (n->u.common->omp_device_type == OMP_DEVICE_TYPE_NOHOST)
6364 : dt = "nohost";
6365 0 : else if (n->u.common->omp_device_type == OMP_DEVICE_TYPE_HOST)
6366 0 : dt = "host";
6367 1 : if (n->u.common->omp_groupprivate)
6368 1 : gfc_error_now ("Common block %</%s/%> at %L set in previous OMP "
6369 : "GROUPPRIVATE directive to the different "
6370 1 : "DEVICE_TYPE %qs", n->u.common->name, &n->where,
6371 : dt);
6372 : else
6373 0 : gfc_error_now ("Common block %</%s/%> at %L set in previous OMP "
6374 : "DECLARE TARGET directive to the different "
6375 0 : "DEVICE_TYPE %qs", n->u.common->name, &n->where,
6376 : dt);
6377 : }
6378 41 : n->u.common->omp_device_type = c->device_type;
6379 :
6380 41 : if (c->indirect && c->device_type != OMP_DEVICE_TYPE_ANY)
6381 : {
6382 0 : gfc_error_now ("DEVICE_TYPE must be ANY when used with INDIRECT "
6383 : "at %L", &n->where);
6384 0 : c->indirect = 0;
6385 : }
6386 41 : if (list == OMP_LIST_LINK && c->device_type == OMP_DEVICE_TYPE_NOHOST)
6387 1 : gfc_error_now ("Common block %</%s/%> at %L set with NOHOST "
6388 : "specified may not appear in a LINK clause",
6389 1 : n->u.common->name, &n->where);
6390 :
6391 41 : if (list == OMP_LIST_TO || list == OMP_LIST_ENTER)
6392 21 : n->u.common->omp_declare_target = 1;
6393 41 : if (list == OMP_LIST_LINK)
6394 15 : n->u.common->omp_declare_target_link = 1;
6395 41 : if (list == OMP_LIST_LOCAL)
6396 5 : n->u.common->omp_declare_target_local = 1;
6397 :
6398 110 : for (s = n->u.common->head; s; s = s->common_next)
6399 : {
6400 69 : s->mark = 1;
6401 69 : if (list == OMP_LIST_TO || list == OMP_LIST_ENTER)
6402 33 : gfc_add_omp_declare_target (&s->attr, s->name, &n->where);
6403 69 : if (list == OMP_LIST_LINK)
6404 31 : gfc_add_omp_declare_target_link (&s->attr, s->name, &n->where);
6405 69 : if (list == OMP_LIST_LOCAL)
6406 5 : gfc_add_omp_declare_target_local (&s->attr, s->name, &n->where);
6407 69 : s->attr.omp_device_type = c->device_type;
6408 69 : s->attr.omp_declare_target_indirect = c->indirect;
6409 : }
6410 : }
6411 323 : if ((c->device_type || c->indirect)
6412 323 : && !c->lists[OMP_LIST_ENTER]
6413 151 : && !c->lists[OMP_LIST_TO]
6414 47 : && !c->lists[OMP_LIST_LINK]
6415 10 : && !c->lists[OMP_LIST_LOCAL])
6416 2 : gfc_warning_now (OPT_Wopenmp,
6417 : "OMP DECLARE TARGET directive at %L with only "
6418 : "DEVICE_TYPE or INDIRECT clauses is ignored",
6419 : &old_loc);
6420 :
6421 323 : gfc_buffer_error (true);
6422 :
6423 323 : if (c)
6424 323 : gfc_free_omp_clauses (c);
6425 323 : return MATCH_YES;
6426 :
6427 0 : syntax:
6428 0 : gfc_error ("Syntax error in !$OMP DECLARE TARGET list at %C");
6429 :
6430 2 : cleanup:
6431 2 : gfc_current_locus = old_loc;
6432 2 : if (c)
6433 0 : gfc_free_omp_clauses (c);
6434 : return MATCH_ERROR;
6435 : }
6436 :
6437 : /* Skip over and ignore trait-property-extensions.
6438 :
6439 : trait-property-extension :
6440 : trait-property-name
6441 : identifier (trait-property-extension[, trait-property-extension[, ...]])
6442 : constant integer expression
6443 : */
6444 :
6445 : static match gfc_ignore_trait_property_extension_list (void);
6446 :
6447 : static match
6448 7 : gfc_ignore_trait_property_extension (void)
6449 : {
6450 7 : char buf[GFC_MAX_SYMBOL_LEN + 1];
6451 7 : gfc_expr *expr;
6452 :
6453 : /* Identifier form of trait-property name, possibly followed by
6454 : a list of (recursive) trait-property-extensions. */
6455 7 : if (gfc_match_name (buf) == MATCH_YES)
6456 : {
6457 0 : if (gfc_match (" (") == MATCH_YES)
6458 0 : return gfc_ignore_trait_property_extension_list ();
6459 : return MATCH_YES;
6460 : }
6461 :
6462 : /* Literal constant. */
6463 7 : if (gfc_match_literal_constant (&expr, 0) == MATCH_YES)
6464 : return MATCH_YES;
6465 :
6466 : /* FIXME: constant integer expressions. */
6467 0 : gfc_error ("Expected trait-property-extension at %C");
6468 0 : return MATCH_ERROR;
6469 : }
6470 :
6471 : static match
6472 5 : gfc_ignore_trait_property_extension_list (void)
6473 : {
6474 9 : while (1)
6475 : {
6476 7 : if (gfc_ignore_trait_property_extension () != MATCH_YES)
6477 : return MATCH_ERROR;
6478 7 : if (gfc_match (" ,") == MATCH_YES)
6479 2 : continue;
6480 5 : if (gfc_match (" )") == MATCH_YES)
6481 : return MATCH_YES;
6482 0 : gfc_error ("expected %<)%> at %C");
6483 0 : return MATCH_ERROR;
6484 : }
6485 : }
6486 :
6487 :
6488 : match
6489 110 : gfc_match_omp_interop (void)
6490 : {
6491 110 : return match_omp (EXEC_OMP_INTEROP, OMP_INTEROP_CLAUSES);
6492 : }
6493 :
6494 :
6495 : /* OpenMP 5.0:
6496 :
6497 : trait-selector:
6498 : trait-selector-name[([trait-score:]trait-property[,trait-property[,...]])]
6499 :
6500 : trait-score:
6501 : score(score-expression) */
6502 :
6503 : static match
6504 637 : gfc_match_omp_context_selector (gfc_omp_set_selector *oss)
6505 : {
6506 775 : do
6507 : {
6508 775 : char selector[GFC_MAX_SYMBOL_LEN + 1];
6509 :
6510 775 : if (gfc_match_name (selector) != MATCH_YES)
6511 : {
6512 2 : gfc_error ("expected trait selector name at %C");
6513 39 : return MATCH_ERROR;
6514 : }
6515 :
6516 773 : gfc_omp_selector *os = gfc_get_omp_selector ();
6517 773 : if (oss->code == OMP_TRAIT_SET_CONSTRUCT
6518 335 : && !strcmp (selector, "do"))
6519 48 : os->code = OMP_TRAIT_CONSTRUCT_FOR;
6520 725 : else if (oss->code == OMP_TRAIT_SET_CONSTRUCT
6521 287 : && !strcmp (selector, "for"))
6522 1 : os->code = OMP_TRAIT_INVALID;
6523 : else
6524 724 : os->code = omp_lookup_ts_code (oss->code, selector);
6525 773 : os->next = oss->trait_selectors;
6526 773 : oss->trait_selectors = os;
6527 :
6528 773 : if (os->code == OMP_TRAIT_INVALID)
6529 : {
6530 18 : gfc_warning (OPT_Wopenmp,
6531 : "unknown selector %qs for context selector set %qs "
6532 : "at %C",
6533 18 : selector, omp_tss_map[oss->code]);
6534 18 : if (gfc_match (" (") == MATCH_YES
6535 18 : && gfc_ignore_trait_property_extension_list () != MATCH_YES)
6536 : return MATCH_ERROR;
6537 18 : if (gfc_match (" ,") == MATCH_YES)
6538 1 : continue;
6539 598 : break;
6540 : }
6541 :
6542 755 : enum omp_tp_type property_kind = omp_ts_map[os->code].tp_type;
6543 755 : bool allow_score = omp_ts_map[os->code].allow_score;
6544 :
6545 755 : if (gfc_match (" (") == MATCH_YES)
6546 : {
6547 431 : if (property_kind == OMP_TRAIT_PROPERTY_NONE)
6548 : {
6549 6 : gfc_error ("selector %qs does not accept any properties at %C",
6550 : selector);
6551 6 : return MATCH_ERROR;
6552 : }
6553 :
6554 425 : if (gfc_match (" score") == MATCH_YES)
6555 : {
6556 63 : if (!allow_score)
6557 : {
6558 10 : gfc_error ("%<score%> cannot be specified in traits "
6559 : "in the %qs trait-selector-set at %C",
6560 10 : omp_tss_map[oss->code]);
6561 10 : return MATCH_ERROR;
6562 : }
6563 53 : if (gfc_match (" (") != MATCH_YES)
6564 : {
6565 0 : gfc_error ("expected %<(%> at %C");
6566 0 : return MATCH_ERROR;
6567 : }
6568 53 : if (gfc_match_expr (&os->score) != MATCH_YES)
6569 : return MATCH_ERROR;
6570 :
6571 52 : if (gfc_match (" )") != MATCH_YES)
6572 : {
6573 0 : gfc_error ("expected %<)%> at %C");
6574 0 : return MATCH_ERROR;
6575 : }
6576 :
6577 52 : if (gfc_match (" :") != MATCH_YES)
6578 : {
6579 0 : gfc_error ("expected : at %C");
6580 0 : return MATCH_ERROR;
6581 : }
6582 : }
6583 :
6584 414 : gfc_omp_trait_property *otp = gfc_get_omp_trait_property ();
6585 414 : otp->property_kind = property_kind;
6586 414 : otp->next = os->properties;
6587 414 : os->properties = otp;
6588 :
6589 414 : switch (property_kind)
6590 : {
6591 25 : case OMP_TRAIT_PROPERTY_ID:
6592 25 : {
6593 25 : char buf[GFC_MAX_SYMBOL_LEN + 1];
6594 25 : if (gfc_match_name (buf) == MATCH_YES)
6595 : {
6596 24 : otp->name = XNEWVEC (char, strlen (buf) + 1);
6597 24 : strcpy (otp->name, buf);
6598 : }
6599 : else
6600 : {
6601 1 : gfc_error ("expected identifier at %C");
6602 1 : free (otp);
6603 1 : os->properties = nullptr;
6604 1 : return MATCH_ERROR;
6605 : }
6606 : }
6607 24 : break;
6608 290 : case OMP_TRAIT_PROPERTY_NAME_LIST:
6609 343 : do
6610 : {
6611 290 : char buf[GFC_MAX_SYMBOL_LEN + 1];
6612 290 : if (gfc_match_name (buf) == MATCH_YES)
6613 : {
6614 170 : otp->name = XNEWVEC (char, strlen (buf) + 1);
6615 170 : strcpy (otp->name, buf);
6616 170 : otp->is_name = true;
6617 : }
6618 120 : else if (gfc_match_literal_constant (&otp->expr, 0)
6619 : != MATCH_YES
6620 120 : || otp->expr->ts.type != BT_CHARACTER)
6621 : {
6622 5 : gfc_error ("expected identifier or string literal "
6623 : "at %C");
6624 5 : free (otp);
6625 5 : os->properties = nullptr;
6626 5 : return MATCH_ERROR;
6627 : }
6628 :
6629 285 : if (gfc_match (" ,") == MATCH_YES)
6630 : {
6631 53 : otp = gfc_get_omp_trait_property ();
6632 53 : otp->property_kind = property_kind;
6633 53 : otp->next = os->properties;
6634 53 : os->properties = otp;
6635 : }
6636 : else
6637 : break;
6638 53 : }
6639 : while (1);
6640 232 : break;
6641 137 : case OMP_TRAIT_PROPERTY_DEV_NUM_EXPR:
6642 137 : case OMP_TRAIT_PROPERTY_BOOL_EXPR:
6643 137 : if (gfc_match_expr (&otp->expr) != MATCH_YES)
6644 : {
6645 3 : gfc_error ("expected expression at %C");
6646 3 : free (otp);
6647 3 : os->properties = nullptr;
6648 3 : return MATCH_ERROR;
6649 : }
6650 : break;
6651 15 : case OMP_TRAIT_PROPERTY_CLAUSE_LIST:
6652 15 : {
6653 15 : if (os->code == OMP_TRAIT_CONSTRUCT_SIMD)
6654 : {
6655 15 : gfc_matching_omp_context_selector = true;
6656 15 : if (gfc_match_omp_clauses (&otp->clauses,
6657 15 : OMP_DECLARE_SIMD_CLAUSES,
6658 : true, false, false)
6659 : != MATCH_YES)
6660 : {
6661 1 : gfc_matching_omp_context_selector = false;
6662 1 : gfc_error ("expected simd clause at %C");
6663 1 : return MATCH_ERROR;
6664 : }
6665 14 : gfc_matching_omp_context_selector = false;
6666 : }
6667 0 : else if (os->code == OMP_TRAIT_IMPLEMENTATION_REQUIRES)
6668 : {
6669 : /* FIXME: The "requires" selector was added in OpenMP 5.1.
6670 : Currently only the now-deprecated syntax
6671 : from OpenMP 5.0 is supported.
6672 : TODO: When implementing, update modules.cc as well. */
6673 0 : sorry_at (gfc_get_location (&gfc_current_locus),
6674 : "%<requires%> selector is not supported yet");
6675 0 : return MATCH_ERROR;
6676 : }
6677 : else
6678 0 : gcc_unreachable ();
6679 14 : break;
6680 : }
6681 0 : default:
6682 0 : gcc_unreachable ();
6683 : }
6684 :
6685 404 : if (gfc_match (" )") != MATCH_YES)
6686 : {
6687 2 : gfc_error ("expected %<)%> at %C");
6688 2 : return MATCH_ERROR;
6689 : }
6690 : }
6691 324 : else if (property_kind != OMP_TRAIT_PROPERTY_NONE
6692 324 : && property_kind != OMP_TRAIT_PROPERTY_CLAUSE_LIST
6693 8 : && property_kind != OMP_TRAIT_PROPERTY_EXTENSION)
6694 : {
6695 8 : if (gfc_match (" (") != MATCH_YES)
6696 : {
6697 8 : gfc_error ("expected %<(%> at %C");
6698 8 : return MATCH_ERROR;
6699 : }
6700 : }
6701 :
6702 718 : if (gfc_match (" ,") != MATCH_YES)
6703 : break;
6704 : }
6705 : while (1);
6706 :
6707 598 : return MATCH_YES;
6708 : }
6709 :
6710 : /* OpenMP 5.0:
6711 :
6712 : trait-set-selector[,trait-set-selector[,...]]
6713 :
6714 : trait-set-selector:
6715 : trait-set-selector-name = { trait-selector[, trait-selector[, ...]] }
6716 :
6717 : trait-set-selector-name:
6718 : constructor
6719 : device
6720 : implementation
6721 : user */
6722 :
6723 : static match
6724 577 : gfc_match_omp_context_selector_specification (gfc_omp_set_selector **oss_head)
6725 : {
6726 713 : do
6727 : {
6728 645 : match m;
6729 645 : char buf[GFC_MAX_SYMBOL_LEN + 1];
6730 645 : enum omp_tss_code set = OMP_TRAIT_SET_INVALID;
6731 :
6732 645 : m = gfc_match_name (buf);
6733 645 : if (m == MATCH_YES)
6734 643 : set = omp_lookup_tss_code (buf);
6735 :
6736 643 : if (set == OMP_TRAIT_SET_INVALID)
6737 : {
6738 5 : gfc_error ("expected context selector set name at %C");
6739 47 : return MATCH_ERROR;
6740 : }
6741 :
6742 640 : m = gfc_match (" =");
6743 640 : if (m != MATCH_YES)
6744 : {
6745 1 : gfc_error ("expected %<=%> at %C");
6746 1 : return MATCH_ERROR;
6747 : }
6748 :
6749 639 : m = gfc_match (" {");
6750 639 : if (m != MATCH_YES)
6751 : {
6752 2 : gfc_error ("expected %<{%> at %C");
6753 2 : return MATCH_ERROR;
6754 : }
6755 :
6756 637 : gfc_omp_set_selector *oss = gfc_get_omp_set_selector ();
6757 637 : oss->next = *oss_head;
6758 637 : oss->code = set;
6759 637 : *oss_head = oss;
6760 :
6761 637 : if (gfc_match_omp_context_selector (oss) != MATCH_YES)
6762 : return MATCH_ERROR;
6763 :
6764 598 : m = gfc_match (" }");
6765 598 : if (m != MATCH_YES)
6766 : {
6767 0 : gfc_error ("expected %<}%> at %C");
6768 0 : return MATCH_ERROR;
6769 : }
6770 :
6771 598 : m = gfc_match (" ,");
6772 598 : if (m != MATCH_YES)
6773 : break;
6774 68 : }
6775 : while (1);
6776 :
6777 530 : return MATCH_YES;
6778 : }
6779 :
6780 :
6781 : match
6782 418 : gfc_match_omp_declare_variant (void)
6783 : {
6784 418 : char buf[GFC_MAX_SYMBOL_LEN + 1];
6785 :
6786 418 : if (gfc_match (" (") != MATCH_YES)
6787 : {
6788 2 : gfc_error ("expected %<(%> at %C");
6789 2 : return MATCH_ERROR;
6790 : }
6791 :
6792 416 : gfc_symtree *base_proc_st, *variant_proc_st;
6793 416 : if (gfc_match_name (buf) != MATCH_YES)
6794 : {
6795 2 : gfc_error ("expected name at %C");
6796 2 : return MATCH_ERROR;
6797 : }
6798 :
6799 414 : if (gfc_get_ha_sym_tree (buf, &base_proc_st))
6800 : return MATCH_ERROR;
6801 :
6802 414 : if (gfc_match (" :") == MATCH_YES)
6803 : {
6804 15 : if (gfc_match_name (buf) != MATCH_YES)
6805 : {
6806 0 : gfc_error ("expected variant name at %C");
6807 0 : return MATCH_ERROR;
6808 : }
6809 :
6810 15 : if (gfc_get_ha_sym_tree (buf, &variant_proc_st))
6811 : return MATCH_ERROR;
6812 : }
6813 : else
6814 : {
6815 : /* Base procedure not specified. */
6816 399 : variant_proc_st = base_proc_st;
6817 399 : base_proc_st = NULL;
6818 : }
6819 :
6820 414 : gfc_omp_declare_variant *odv;
6821 414 : odv = gfc_get_omp_declare_variant ();
6822 414 : odv->where = gfc_current_locus;
6823 414 : odv->variant_proc_symtree = variant_proc_st;
6824 414 : odv->adjust_args_list = NULL;
6825 414 : odv->base_proc_symtree = base_proc_st;
6826 414 : odv->next = NULL;
6827 414 : odv->error_p = false;
6828 :
6829 : /* Add the new declare variant to the end of the list. */
6830 414 : gfc_omp_declare_variant **prev_next = &gfc_current_ns->omp_declare_variant;
6831 554 : while (*prev_next)
6832 140 : prev_next = &((*prev_next)->next);
6833 414 : *prev_next = odv;
6834 :
6835 414 : if (gfc_match (" )") != MATCH_YES)
6836 : {
6837 0 : gfc_error ("expected %<)%> at %C");
6838 0 : return MATCH_ERROR;
6839 : }
6840 :
6841 414 : bool has_match = false, has_adjust_args = false, has_append_args = false;
6842 414 : bool error_p = false;
6843 414 : locus adjust_args_loc;
6844 414 : locus append_args_loc;
6845 :
6846 414 : gfc_gobble_whitespace ();
6847 414 : gfc_match_char (',');
6848 632 : for (;;)
6849 : {
6850 523 : gfc_gobble_whitespace ();
6851 :
6852 523 : enum clause
6853 : {
6854 : clause_match,
6855 : clause_adjust_args,
6856 : clause_append_args
6857 : } ccode;
6858 :
6859 523 : if (gfc_match ("match") == MATCH_YES)
6860 : ccode = clause_match;
6861 119 : else if (gfc_match ("adjust_args") == MATCH_YES)
6862 : {
6863 517 : ccode = clause_adjust_args;
6864 : adjust_args_loc = gfc_current_locus;
6865 : }
6866 38 : else if (gfc_match ("append_args") == MATCH_YES)
6867 : {
6868 517 : ccode = clause_append_args;
6869 : append_args_loc = gfc_current_locus;
6870 : }
6871 : else
6872 : {
6873 : error_p = true;
6874 : break;
6875 : }
6876 :
6877 517 : if (gfc_match (" ( ") != MATCH_YES)
6878 : {
6879 1 : gfc_error ("expected %<(%> at %C");
6880 1 : return MATCH_ERROR;
6881 : }
6882 :
6883 516 : if (ccode == clause_match)
6884 : {
6885 403 : if (has_match)
6886 : {
6887 1 : gfc_error ("%qs clause at %L specified more than once",
6888 : "match", &gfc_current_locus);
6889 1 : return MATCH_ERROR;
6890 : }
6891 402 : has_match = true;
6892 402 : if (gfc_match_omp_context_selector_specification (&odv->set_selectors)
6893 : != MATCH_YES)
6894 : return MATCH_ERROR;
6895 362 : if (gfc_match (" )") != MATCH_YES)
6896 : {
6897 0 : gfc_error ("expected %<)%> at %C");
6898 0 : return MATCH_ERROR;
6899 : }
6900 : }
6901 113 : else if (ccode == clause_adjust_args)
6902 : {
6903 81 : has_adjust_args = true;
6904 81 : bool need_device_ptr_p = false;
6905 81 : bool need_device_addr_p = false;
6906 81 : if (gfc_match ("nothing ") == MATCH_YES)
6907 : ;
6908 58 : else if (gfc_match ("need_device_ptr ") == MATCH_YES)
6909 : need_device_ptr_p = true;
6910 9 : else if (gfc_match ("need_device_addr ") == MATCH_YES)
6911 : need_device_addr_p = true;
6912 : else
6913 : {
6914 2 : gfc_error ("expected %<nothing%>, %<need_device_ptr%> or "
6915 : "%<need_device_addr%> at %C");
6916 2 : return MATCH_ERROR;
6917 : }
6918 79 : if (gfc_match (": ") != MATCH_YES)
6919 : {
6920 1 : gfc_error ("expected %<:%> at %C");
6921 1 : return MATCH_ERROR;
6922 : }
6923 : gfc_omp_namelist *tail = NULL;
6924 : bool need_range = false, have_range = false;
6925 125 : while (true)
6926 : {
6927 125 : gfc_omp_namelist *p = gfc_get_omp_namelist ();
6928 125 : p->where = gfc_current_locus;
6929 125 : p->u.adj_args.need_ptr = need_device_ptr_p;
6930 125 : p->u.adj_args.need_addr = need_device_addr_p;
6931 125 : if (tail)
6932 : {
6933 47 : tail->next = p;
6934 47 : tail = tail->next;
6935 : }
6936 : else
6937 : {
6938 78 : gfc_omp_namelist **q = &odv->adjust_args_list;
6939 78 : if (*q)
6940 : {
6941 50 : for (; (*q)->next; q = &(*q)->next)
6942 : ;
6943 28 : (*q)->next = p;
6944 : }
6945 : else
6946 50 : *q = p;
6947 : tail = p;
6948 : }
6949 125 : if (gfc_match (": ") == MATCH_YES)
6950 : {
6951 2 : if (have_range)
6952 : {
6953 0 : gfc_error ("unexpected %<:%> at %C");
6954 2 : return MATCH_ERROR;
6955 : }
6956 2 : p->u.adj_args.range_start = have_range = true;
6957 2 : need_range = false;
6958 49 : continue;
6959 : }
6960 123 : if (have_range && gfc_match (", ") == MATCH_YES)
6961 : {
6962 1 : have_range = false;
6963 1 : continue;
6964 : }
6965 122 : if (have_range && gfc_match (") ") == MATCH_YES)
6966 : break;
6967 121 : locus saved_loc = gfc_current_locus;
6968 :
6969 : /* Without ranges, only arg names or integer literals permitted;
6970 : handle literals here as gfc_match_expr simplifies the expr. */
6971 121 : if (gfc_match_literal_constant (&p->expr, true) == MATCH_YES)
6972 : {
6973 17 : gfc_gobble_whitespace ();
6974 17 : char c = gfc_peek_ascii_char ();
6975 17 : if (c != ')' && c != ',' && c != ':')
6976 : {
6977 1 : gfc_free_expr (p->expr);
6978 1 : p->expr = NULL;
6979 1 : gfc_current_locus = saved_loc;
6980 : }
6981 : }
6982 121 : if (!p->expr && gfc_match ("omp_num_args") == MATCH_YES)
6983 : {
6984 6 : if (!have_range)
6985 3 : p->u.adj_args.range_start = need_range = true;
6986 : else
6987 : need_range = false;
6988 :
6989 6 : locus saved_loc2 = gfc_current_locus;
6990 6 : gfc_gobble_whitespace ();
6991 6 : char c = gfc_peek_ascii_char ();
6992 6 : if (c == '+' || c == '-')
6993 : {
6994 5 : if (gfc_match ("+ %e", &p->expr) == MATCH_YES)
6995 1 : p->u.adj_args.omp_num_args_plus = true;
6996 4 : else if (gfc_match ("- %e", &p->expr) == MATCH_YES)
6997 4 : p->u.adj_args.omp_num_args_minus = true;
6998 0 : else if (!gfc_error_check ())
6999 : {
7000 0 : gfc_error ("expected constant integer expression "
7001 : "at %C");
7002 0 : p->u.adj_args.error_p = true;
7003 0 : return MATCH_ERROR;
7004 : }
7005 5 : p->where = gfc_get_location_range (&saved_loc, 1,
7006 : &saved_loc, 1,
7007 : &gfc_current_locus);
7008 : }
7009 : else
7010 : {
7011 1 : p->where = gfc_get_location_range (&saved_loc, 1,
7012 : &saved_loc, 1,
7013 : &saved_loc2);
7014 1 : p->u.adj_args.omp_num_args_plus = true;
7015 : }
7016 : }
7017 115 : else if (!p->expr)
7018 : {
7019 99 : match m = gfc_match_expr (&p->expr);
7020 99 : if (m != MATCH_YES)
7021 : {
7022 1 : gfc_error ("expected dummy parameter name, "
7023 : "%<omp_num_args%> or constant positive integer"
7024 : " at %C");
7025 1 : p->u.adj_args.error_p = true;
7026 1 : return MATCH_ERROR;
7027 : }
7028 98 : if (p->expr->expr_type == EXPR_CONSTANT && !have_range)
7029 98 : need_range = true; /* Constant expr but not literal. */
7030 98 : p->where = p->expr->where;
7031 : }
7032 : else
7033 16 : p->where = p->expr->where;
7034 120 : gfc_gobble_whitespace ();
7035 120 : match m = gfc_match (": ");
7036 120 : if (need_range && m != MATCH_YES)
7037 : {
7038 1 : gfc_error ("expected %<:%> at %C");
7039 1 : return MATCH_ERROR;
7040 : }
7041 119 : if (m == MATCH_YES)
7042 : {
7043 6 : p->u.adj_args.range_start = have_range = true;
7044 6 : need_range = false;
7045 6 : continue;
7046 : }
7047 113 : need_range = have_range = false;
7048 113 : if (gfc_match (", ") == MATCH_YES)
7049 38 : continue;
7050 75 : if (gfc_match (") ") == MATCH_YES)
7051 : break;
7052 : }
7053 : }
7054 32 : else if (ccode == clause_append_args)
7055 : {
7056 32 : if (has_append_args)
7057 : {
7058 1 : gfc_error ("%qs clause at %L specified more than once",
7059 : "append_args", &gfc_current_locus);
7060 1 : return MATCH_ERROR;
7061 : }
7062 56 : has_append_args = true;
7063 : gfc_omp_namelist *append_args_last = NULL;
7064 81 : do
7065 : {
7066 56 : gfc_gobble_whitespace ();
7067 56 : if (gfc_match ("interop ") != MATCH_YES)
7068 : {
7069 0 : gfc_error ("expected %<interop%> at %C");
7070 3 : return MATCH_ERROR;
7071 : }
7072 56 : if (gfc_match ("( ") != MATCH_YES)
7073 : {
7074 0 : gfc_error ("expected %<(%> at %C");
7075 0 : return MATCH_ERROR;
7076 : }
7077 :
7078 56 : bool target, targetsync;
7079 56 : char *type_str = NULL;
7080 56 : int type_str_len;
7081 56 : locus loc = gfc_current_locus;
7082 56 : if (gfc_parser_omp_clause_init_modifiers (target, targetsync,
7083 : &type_str, type_str_len,
7084 : false) == MATCH_ERROR)
7085 : return MATCH_ERROR;
7086 :
7087 54 : gfc_omp_namelist *n = gfc_get_omp_namelist();
7088 54 : n->where = loc;
7089 54 : n->u.init.target = target;
7090 54 : n->u.init.targetsync = targetsync;
7091 54 : n->u.init.len = type_str_len;
7092 54 : n->u2.init_interop = type_str;
7093 54 : if (odv->append_args_list)
7094 : {
7095 25 : append_args_last->next = n;
7096 25 : append_args_last = n;
7097 : }
7098 : else
7099 29 : append_args_last = odv->append_args_list = n;
7100 :
7101 54 : gfc_gobble_whitespace ();
7102 54 : if (gfc_match_char (',') == MATCH_YES)
7103 25 : continue;
7104 29 : if (gfc_match_char (')') == MATCH_YES)
7105 : break;
7106 1 : gfc_error ("Expected %<,%> or %<)%> at %C");
7107 1 : return MATCH_ERROR;
7108 : }
7109 : while (true);
7110 : }
7111 466 : gfc_gobble_whitespace ();
7112 466 : if (gfc_match_omp_eos () == MATCH_YES)
7113 : break;
7114 109 : gfc_match_char (',');
7115 109 : }
7116 :
7117 363 : if (error_p || (!has_match && !has_adjust_args && !has_append_args))
7118 : {
7119 6 : gfc_error ("expected %<match%>, %<adjust_args%> or %<append_args%> at %C");
7120 6 : return MATCH_ERROR;
7121 : }
7122 :
7123 357 : if (!has_match)
7124 : {
7125 3 : gfc_error ("expected %<match%> clause at %C");
7126 3 : return MATCH_ERROR;
7127 : }
7128 :
7129 : return MATCH_YES;
7130 : }
7131 :
7132 :
7133 : static match
7134 160 : match_omp_metadirective (bool begin_p)
7135 : {
7136 160 : locus old_loc = gfc_current_locus;
7137 160 : gfc_omp_variant *variants_head;
7138 160 : gfc_omp_variant **next_variant = &variants_head;
7139 160 : bool default_seen = false;
7140 :
7141 : /* Parse the context selectors. */
7142 656 : for (;;)
7143 : {
7144 408 : bool default_p = false;
7145 408 : gfc_omp_set_selector *selectors = NULL;
7146 :
7147 408 : gfc_gobble_whitespace ();
7148 408 : if (gfc_match_eos () == MATCH_YES)
7149 : break;
7150 266 : gfc_match_char (',');
7151 266 : gfc_gobble_whitespace ();
7152 :
7153 266 : locus variant_locus = gfc_current_locus;
7154 :
7155 266 : if (gfc_match ("default ( ") == MATCH_YES)
7156 : {
7157 82 : default_p = true;
7158 82 : gfc_warning (OPT_Wdeprecated_openmp,
7159 : "%<default%> clause with metadirective at %L "
7160 : "deprecated since OpenMP 5.2", &variant_locus);
7161 : }
7162 184 : else if (gfc_match ("otherwise ( ") == MATCH_YES)
7163 : default_p = true;
7164 177 : else if (gfc_match ("when ( ") != MATCH_YES)
7165 : {
7166 1 : gfc_error ("expected %<when%>, %<otherwise%>, or %<default%> at %C");
7167 1 : gfc_current_locus = old_loc;
7168 18 : return MATCH_ERROR;
7169 : }
7170 89 : if (default_p && default_seen)
7171 : {
7172 3 : gfc_error ("too many %<otherwise%> or %<default%> clauses "
7173 : "in %<metadirective%> at %C");
7174 3 : gfc_current_locus = old_loc;
7175 3 : return MATCH_ERROR;
7176 : }
7177 262 : else if (default_seen)
7178 : {
7179 1 : gfc_error ("%<otherwise%> or %<default%> clause "
7180 : "must appear last in %<metadirective%> at %C");
7181 1 : gfc_current_locus = old_loc;
7182 1 : return MATCH_ERROR;
7183 : }
7184 :
7185 261 : if (!default_p)
7186 : {
7187 175 : if (gfc_match_omp_context_selector_specification (&selectors)
7188 : != MATCH_YES)
7189 : return MATCH_ERROR;
7190 :
7191 168 : if (gfc_match (" : ") != MATCH_YES)
7192 : {
7193 1 : gfc_error ("expected %<:%> at %C");
7194 1 : gfc_current_locus = old_loc;
7195 1 : return MATCH_ERROR;
7196 : }
7197 :
7198 167 : gfc_commit_symbols ();
7199 : }
7200 :
7201 253 : gfc_matching_omp_context_selector = true;
7202 253 : gfc_statement directive = match_omp_directive ();
7203 253 : gfc_matching_omp_context_selector = false;
7204 :
7205 253 : if (is_omp_declarative_stmt (directive))
7206 0 : sorry_at (gfc_get_location (&gfc_current_locus),
7207 : "declarative directive variants are not supported");
7208 :
7209 253 : if (gfc_error_flag_test ())
7210 : {
7211 2 : gfc_current_locus = old_loc;
7212 2 : return MATCH_ERROR;
7213 : }
7214 :
7215 251 : if (gfc_match (" )") != MATCH_YES)
7216 : {
7217 0 : gfc_error ("Expected %<)%> at %C");
7218 0 : gfc_current_locus = old_loc;
7219 0 : return MATCH_ERROR;
7220 : }
7221 :
7222 251 : gfc_commit_symbols ();
7223 :
7224 251 : if (begin_p
7225 251 : && directive != ST_NONE
7226 251 : && gfc_omp_end_stmt (directive) == ST_NONE)
7227 : {
7228 3 : gfc_error ("variant directive used in OMP BEGIN METADIRECTIVE "
7229 : "at %C must have a corresponding end directive");
7230 3 : gfc_current_locus = old_loc;
7231 3 : return MATCH_ERROR;
7232 : }
7233 :
7234 248 : if (default_p)
7235 : default_seen = true;
7236 :
7237 248 : gfc_omp_variant *omv = gfc_get_omp_variant ();
7238 248 : omv->selectors = selectors;
7239 248 : omv->stmt = directive;
7240 248 : omv->where = variant_locus;
7241 :
7242 248 : if (directive == ST_NONE)
7243 : {
7244 : /* The directive was a 'nothing' directive. */
7245 15 : omv->code = gfc_get_code (EXEC_CONTINUE);
7246 15 : omv->code->ext.omp_clauses = NULL;
7247 : }
7248 : else
7249 : {
7250 233 : omv->code = gfc_get_code (new_st.op);
7251 233 : omv->code->ext.omp_clauses = new_st.ext.omp_clauses;
7252 : /* Prevent the OpenMP clauses from being freed via NEW_ST. */
7253 233 : new_st.ext.omp_clauses = NULL;
7254 : }
7255 :
7256 248 : *next_variant = omv;
7257 248 : next_variant = &omv->next;
7258 248 : }
7259 :
7260 142 : if (gfc_match_omp_eos () != MATCH_YES)
7261 : {
7262 0 : gfc_error ("Unexpected junk after OMP METADIRECTIVE at %C");
7263 0 : gfc_current_locus = old_loc;
7264 0 : return MATCH_ERROR;
7265 : }
7266 :
7267 : /* Add a 'default (nothing)' clause if no default is explicitly given. */
7268 142 : if (!default_seen)
7269 : {
7270 65 : gfc_omp_variant *omv = gfc_get_omp_variant ();
7271 65 : omv->stmt = ST_NONE;
7272 65 : omv->code = gfc_get_code (EXEC_CONTINUE);
7273 65 : omv->code->ext.omp_clauses = NULL;
7274 65 : omv->where = old_loc;
7275 65 : omv->selectors = NULL;
7276 :
7277 65 : *next_variant = omv;
7278 65 : next_variant = &omv->next;
7279 : }
7280 :
7281 142 : new_st.op = EXEC_OMP_METADIRECTIVE;
7282 142 : new_st.ext.omp_variants = variants_head;
7283 :
7284 142 : return MATCH_YES;
7285 : }
7286 :
7287 : match
7288 43 : gfc_match_omp_begin_metadirective (void)
7289 : {
7290 43 : return match_omp_metadirective (true);
7291 : }
7292 :
7293 : match
7294 117 : gfc_match_omp_metadirective (void)
7295 : {
7296 117 : return match_omp_metadirective (false);
7297 : }
7298 :
7299 : /* Match 'omp threadprivate' or 'omp groupprivate'. */
7300 : static match
7301 259 : gfc_match_omp_thread_group_private (bool is_groupprivate)
7302 : {
7303 259 : locus old_loc;
7304 259 : char n[GFC_MAX_SYMBOL_LEN+1];
7305 259 : gfc_symbol *sym;
7306 259 : match m;
7307 259 : gfc_symtree *st;
7308 259 : struct sym_loc_t { gfc_symbol *sym; gfc_common_head *com; locus loc; };
7309 259 : auto_vec<sym_loc_t> syms;
7310 :
7311 259 : old_loc = gfc_current_locus;
7312 :
7313 259 : m = gfc_match (" ( ");
7314 259 : if (m != MATCH_YES)
7315 : return m;
7316 :
7317 369 : for (;;)
7318 : {
7319 314 : locus sym_loc = gfc_current_locus;
7320 314 : m = gfc_match_symbol (&sym, 0);
7321 314 : switch (m)
7322 : {
7323 209 : case MATCH_YES:
7324 209 : if (sym->attr.in_common)
7325 0 : gfc_error_now ("%qs variable at %L is an element of a COMMON block",
7326 : is_groupprivate ? "groupprivate" : "threadprivate",
7327 : &sym_loc);
7328 209 : else if (!is_groupprivate
7329 209 : && !gfc_add_threadprivate (&sym->attr, sym->name, &sym_loc))
7330 16 : goto cleanup;
7331 207 : else if (is_groupprivate)
7332 : {
7333 30 : if (!gfc_add_omp_groupprivate (&sym->attr, sym->name, &sym_loc))
7334 4 : goto cleanup;
7335 26 : syms.safe_push ({sym, nullptr, sym_loc});
7336 : }
7337 203 : goto next_item;
7338 : case MATCH_NO:
7339 : break;
7340 0 : case MATCH_ERROR:
7341 0 : goto cleanup;
7342 : }
7343 :
7344 105 : m = gfc_match (" / %n /", n);
7345 105 : if (m == MATCH_ERROR)
7346 0 : goto cleanup;
7347 105 : if (m == MATCH_NO || n[0] == '\0')
7348 0 : goto syntax;
7349 :
7350 105 : st = gfc_find_symtree (gfc_current_ns->common_root, n);
7351 105 : if (st == NULL)
7352 : {
7353 2 : gfc_error ("COMMON block /%s/ not found at %L", n, &sym_loc);
7354 2 : goto cleanup;
7355 : }
7356 103 : syms.safe_push ({nullptr, st->n.common, sym_loc});
7357 103 : if (is_groupprivate)
7358 30 : st->n.common->omp_groupprivate = 1;
7359 : else
7360 73 : st->n.common->threadprivate = 1;
7361 236 : for (sym = st->n.common->head; sym; sym = sym->common_next)
7362 141 : if (!is_groupprivate
7363 141 : && !gfc_add_threadprivate (&sym->attr, sym->name, &sym_loc))
7364 3 : goto cleanup;
7365 138 : else if (is_groupprivate
7366 138 : && !gfc_add_omp_groupprivate (&sym->attr, sym->name, &sym_loc))
7367 5 : goto cleanup;
7368 :
7369 95 : next_item:
7370 298 : if (gfc_match_char (')') == MATCH_YES)
7371 : break;
7372 55 : if (gfc_match_char (',') != MATCH_YES)
7373 0 : goto syntax;
7374 55 : }
7375 :
7376 243 : if (is_groupprivate)
7377 : {
7378 39 : gfc_omp_clauses *c;
7379 39 : m = gfc_match_omp_clauses (&c, omp_mask (OMP_CLAUSE_DEVICE_TYPE));
7380 39 : if (m == MATCH_ERROR)
7381 0 : return MATCH_ERROR;
7382 :
7383 39 : if (c->device_type == OMP_DEVICE_TYPE_UNSET)
7384 19 : c->device_type = OMP_DEVICE_TYPE_ANY;
7385 :
7386 86 : for (size_t i = 0; i < syms.length (); i++)
7387 47 : if (syms[i].sym)
7388 : {
7389 24 : sym_loc_t &n = syms[i];
7390 24 : if (n.sym->attr.in_common)
7391 0 : gfc_error_now ("Variable %qs at %L is an element of a COMMON "
7392 : "block", n.sym->name, &n.loc);
7393 24 : else if (n.sym->attr.omp_declare_target
7394 23 : || n.sym->attr.omp_declare_target_link)
7395 2 : gfc_error_now ("List item %qs at %L implies OMP DECLARE TARGET "
7396 : "with the LOCAL clause, but it has been specified"
7397 : " with a different clause before",
7398 : n.sym->name, &n.loc);
7399 24 : if (n.sym->attr.omp_device_type != OMP_DEVICE_TYPE_UNSET
7400 5 : && n.sym->attr.omp_device_type != c->device_type)
7401 : {
7402 2 : const char *dt = "any";
7403 2 : if (n.sym->attr.omp_device_type == OMP_DEVICE_TYPE_HOST)
7404 : dt = "host";
7405 0 : else if (n.sym->attr.omp_device_type == OMP_DEVICE_TYPE_NOHOST)
7406 0 : dt = "nohost";
7407 2 : gfc_error_now ("List item %qs at %L set in previous OMP DECLARE "
7408 : "TARGET directive to the different DEVICE_TYPE %qs",
7409 : n.sym->name, &n.loc, dt);
7410 : }
7411 24 : gfc_add_omp_declare_target_local (&n.sym->attr, n.sym->name,
7412 : &n.loc);
7413 24 : n.sym->attr.omp_device_type = c->device_type;
7414 : }
7415 : else /* Common block. */
7416 : {
7417 23 : sym_loc_t &n = syms[i];
7418 23 : if (n.com->omp_declare_target
7419 22 : || n.com->omp_declare_target_link)
7420 2 : gfc_error_now ("List item %</%s/%> at %L implies OMP DECLARE "
7421 : "TARGET with the LOCAL clause, but it has been "
7422 : "specified with a different clause before",
7423 2 : n.com->name, &n.loc);
7424 23 : if (n.com->omp_device_type != OMP_DEVICE_TYPE_UNSET
7425 5 : && n.com->omp_device_type != c->device_type)
7426 : {
7427 2 : const char *dt = "any";
7428 2 : if (n.com->omp_device_type == OMP_DEVICE_TYPE_HOST)
7429 : dt = "host";
7430 0 : else if (n.com->omp_device_type == OMP_DEVICE_TYPE_NOHOST)
7431 0 : dt = "nohost";
7432 2 : gfc_error_now ("List item %qs at %L set in previous OMP DECLARE"
7433 : " TARGET directive to the different DEVICE_TYPE "
7434 2 : "%qs", n.com->name, &n.loc, dt);
7435 : }
7436 23 : n.com->omp_declare_target_local = 1;
7437 23 : n.com->omp_device_type = c->device_type;
7438 46 : for (gfc_symbol *s = n.com->head; s; s = s->common_next)
7439 : {
7440 23 : gfc_add_omp_declare_target_local (&s->attr, s->name, &n.loc);
7441 23 : s->attr.omp_device_type = c->device_type;
7442 : }
7443 : }
7444 39 : free (c);
7445 : }
7446 :
7447 243 : if (gfc_match_omp_eos () != MATCH_YES)
7448 : {
7449 0 : gfc_error ("Unexpected junk after OMP %s at %C",
7450 : is_groupprivate ? "GROUPPRIVATE" : "THREADPRIVATE");
7451 0 : goto cleanup;
7452 : }
7453 :
7454 : return MATCH_YES;
7455 :
7456 0 : syntax:
7457 0 : gfc_error ("Syntax error in !$OMP %s list at %C",
7458 : is_groupprivate ? "GROUPPRIVATE" : "THREADPRIVATE");
7459 :
7460 16 : cleanup:
7461 16 : gfc_current_locus = old_loc;
7462 16 : return MATCH_ERROR;
7463 259 : }
7464 :
7465 :
7466 : match
7467 48 : gfc_match_omp_groupprivate (void)
7468 : {
7469 48 : return gfc_match_omp_thread_group_private (true);
7470 : }
7471 :
7472 :
7473 : match
7474 211 : gfc_match_omp_threadprivate (void)
7475 : {
7476 211 : return gfc_match_omp_thread_group_private (false);
7477 : }
7478 :
7479 :
7480 : match
7481 2139 : gfc_match_omp_parallel (void)
7482 : {
7483 2139 : return match_omp (EXEC_OMP_PARALLEL, OMP_PARALLEL_CLAUSES);
7484 : }
7485 :
7486 :
7487 : match
7488 1191 : gfc_match_omp_parallel_do (void)
7489 : {
7490 1191 : return match_omp (EXEC_OMP_PARALLEL_DO,
7491 1191 : (OMP_PARALLEL_CLAUSES | OMP_DO_CLAUSES)
7492 1191 : & ~(omp_mask (OMP_CLAUSE_NOWAIT)));
7493 : }
7494 :
7495 :
7496 : match
7497 298 : gfc_match_omp_parallel_do_simd (void)
7498 : {
7499 298 : return match_omp (EXEC_OMP_PARALLEL_DO_SIMD,
7500 298 : (OMP_PARALLEL_CLAUSES | OMP_DO_CLAUSES | OMP_SIMD_CLAUSES)
7501 298 : & ~(omp_mask (OMP_CLAUSE_NOWAIT)));
7502 : }
7503 :
7504 :
7505 : match
7506 14 : gfc_match_omp_parallel_masked (void)
7507 : {
7508 14 : return match_omp (EXEC_OMP_PARALLEL_MASKED,
7509 14 : OMP_PARALLEL_CLAUSES | OMP_MASKED_CLAUSES);
7510 : }
7511 :
7512 : match
7513 10 : gfc_match_omp_parallel_masked_taskloop (void)
7514 : {
7515 10 : return match_omp (EXEC_OMP_PARALLEL_MASKED_TASKLOOP,
7516 10 : (OMP_PARALLEL_CLAUSES | OMP_MASKED_CLAUSES
7517 10 : | OMP_TASKLOOP_CLAUSES)
7518 10 : & ~(omp_mask (OMP_CLAUSE_IN_REDUCTION)));
7519 : }
7520 :
7521 : match
7522 13 : gfc_match_omp_parallel_masked_taskloop_simd (void)
7523 : {
7524 13 : return match_omp (EXEC_OMP_PARALLEL_MASKED_TASKLOOP_SIMD,
7525 13 : (OMP_PARALLEL_CLAUSES | OMP_MASKED_CLAUSES
7526 13 : | OMP_TASKLOOP_CLAUSES | OMP_SIMD_CLAUSES)
7527 13 : & ~(omp_mask (OMP_CLAUSE_IN_REDUCTION)));
7528 : }
7529 :
7530 : match
7531 14 : gfc_match_omp_parallel_master (void)
7532 : {
7533 14 : gfc_warning (OPT_Wdeprecated_openmp,
7534 : "%<master%> construct at %C deprecated since OpenMP 5.1, use "
7535 : "%<masked%>");
7536 14 : return match_omp (EXEC_OMP_PARALLEL_MASTER, OMP_PARALLEL_CLAUSES);
7537 : }
7538 :
7539 : match
7540 15 : gfc_match_omp_parallel_master_taskloop (void)
7541 : {
7542 15 : gfc_warning (OPT_Wdeprecated_openmp,
7543 : "%<master%> construct at %C deprecated since OpenMP 5.1, "
7544 : "use %<masked%>");
7545 15 : return match_omp (EXEC_OMP_PARALLEL_MASTER_TASKLOOP,
7546 15 : (OMP_PARALLEL_CLAUSES | OMP_TASKLOOP_CLAUSES)
7547 15 : & ~(omp_mask (OMP_CLAUSE_IN_REDUCTION)));
7548 : }
7549 :
7550 : match
7551 21 : gfc_match_omp_parallel_master_taskloop_simd (void)
7552 : {
7553 21 : gfc_warning (OPT_Wdeprecated_openmp,
7554 : "%<master%> construct at %C deprecated since OpenMP 5.1, "
7555 : "use %<masked%>");
7556 21 : return match_omp (EXEC_OMP_PARALLEL_MASTER_TASKLOOP_SIMD,
7557 21 : (OMP_PARALLEL_CLAUSES | OMP_TASKLOOP_CLAUSES
7558 21 : | OMP_SIMD_CLAUSES)
7559 21 : & ~(omp_mask (OMP_CLAUSE_IN_REDUCTION)));
7560 : }
7561 :
7562 : match
7563 59 : gfc_match_omp_parallel_sections (void)
7564 : {
7565 59 : return match_omp (EXEC_OMP_PARALLEL_SECTIONS,
7566 59 : (OMP_PARALLEL_CLAUSES | OMP_SECTIONS_CLAUSES)
7567 59 : & ~(omp_mask (OMP_CLAUSE_NOWAIT)));
7568 : }
7569 :
7570 :
7571 : match
7572 56 : gfc_match_omp_parallel_workshare (void)
7573 : {
7574 56 : return match_omp (EXEC_OMP_PARALLEL_WORKSHARE, OMP_PARALLEL_CLAUSES);
7575 : }
7576 :
7577 : void
7578 48643 : gfc_check_omp_requires (gfc_namespace *ns, int ref_omp_requires)
7579 : {
7580 48643 : const char *msg = G_("Program unit at %L has OpenMP device "
7581 : "constructs/routines but does not set !$OMP REQUIRES %s "
7582 : "but other program units do");
7583 48643 : if (ns->omp_target_seen
7584 1205 : && (ns->omp_requires & OMP_REQ_TARGET_MASK)
7585 1205 : != (ref_omp_requires & OMP_REQ_TARGET_MASK))
7586 : {
7587 6 : gcc_assert (ns->proc_name);
7588 6 : if ((ref_omp_requires & OMP_REQ_REVERSE_OFFLOAD)
7589 5 : && !(ns->omp_requires & OMP_REQ_REVERSE_OFFLOAD))
7590 4 : gfc_error (msg, &ns->proc_name->declared_at, "REVERSE_OFFLOAD");
7591 6 : if ((ref_omp_requires & OMP_REQ_UNIFIED_ADDRESS)
7592 1 : && !(ns->omp_requires & OMP_REQ_UNIFIED_ADDRESS))
7593 1 : gfc_error (msg, &ns->proc_name->declared_at, "UNIFIED_ADDRESS");
7594 6 : if ((ref_omp_requires & OMP_REQ_UNIFIED_SHARED_MEMORY)
7595 4 : && !(ns->omp_requires & OMP_REQ_UNIFIED_SHARED_MEMORY))
7596 2 : gfc_error (msg, &ns->proc_name->declared_at, "UNIFIED_SHARED_MEMORY");
7597 6 : if ((ref_omp_requires & OMP_REQ_SELF_MAPS)
7598 1 : && !(ns->omp_requires & OMP_REQ_UNIFIED_SHARED_MEMORY))
7599 1 : gfc_error (msg, &ns->proc_name->declared_at, "SELF_MAPS");
7600 : }
7601 48643 : }
7602 :
7603 : bool
7604 120 : gfc_omp_requires_add_clause (gfc_omp_requires_kind clause,
7605 : const char *clause_name, locus *loc,
7606 : const char *module_name)
7607 : {
7608 120 : gfc_namespace *prog_unit = gfc_current_ns;
7609 144 : while (prog_unit->parent)
7610 : {
7611 25 : if (gfc_state_stack->previous
7612 25 : && gfc_state_stack->previous->state == COMP_INTERFACE)
7613 : break;
7614 : prog_unit = prog_unit->parent;
7615 : }
7616 :
7617 : /* Requires added after use. */
7618 120 : if (prog_unit->omp_target_seen
7619 24 : && (clause & OMP_REQ_TARGET_MASK)
7620 24 : && !(prog_unit->omp_requires & clause))
7621 : {
7622 0 : if (module_name)
7623 0 : gfc_error ("!$OMP REQUIRES clause %qs specified via module %qs use "
7624 : "at %L comes after using a device construct/routine",
7625 : clause_name, module_name, loc);
7626 : else
7627 0 : gfc_error ("!$OMP REQUIRES clause %qs specified at %L comes after "
7628 : "using a device construct/routine", clause_name, loc);
7629 0 : return false;
7630 : }
7631 :
7632 : /* Overriding atomic_default_mem_order clause value. */
7633 120 : if ((clause & OMP_REQ_ATOMIC_MEM_ORDER_MASK)
7634 34 : && (prog_unit->omp_requires & OMP_REQ_ATOMIC_MEM_ORDER_MASK)
7635 6 : && (prog_unit->omp_requires & OMP_REQ_ATOMIC_MEM_ORDER_MASK)
7636 6 : != (int) clause)
7637 : {
7638 3 : const char *other;
7639 3 : switch (prog_unit->omp_requires & OMP_REQ_ATOMIC_MEM_ORDER_MASK)
7640 : {
7641 : case OMP_REQ_ATOMIC_MEM_ORDER_SEQ_CST: other = "seq_cst"; break;
7642 0 : case OMP_REQ_ATOMIC_MEM_ORDER_ACQ_REL: other = "acq_rel"; break;
7643 1 : case OMP_REQ_ATOMIC_MEM_ORDER_ACQUIRE: other = "acquire"; break;
7644 1 : case OMP_REQ_ATOMIC_MEM_ORDER_RELAXED: other = "relaxed"; break;
7645 0 : case OMP_REQ_ATOMIC_MEM_ORDER_RELEASE: other = "release"; break;
7646 0 : default: gcc_unreachable ();
7647 : }
7648 :
7649 3 : if (module_name)
7650 0 : gfc_error ("!$OMP REQUIRES clause %<atomic_default_mem_order(%s)%> "
7651 : "specified via module %qs use at %L overrides a previous "
7652 : "%<atomic_default_mem_order(%s)%> (which might be through "
7653 : "using a module)", clause_name, module_name, loc, other);
7654 : else
7655 3 : gfc_error ("!$OMP REQUIRES clause %<atomic_default_mem_order(%s)%> "
7656 : "specified at %L overrides a previous "
7657 : "%<atomic_default_mem_order(%s)%> (which might be through "
7658 : "using a module)", clause_name, loc, other);
7659 3 : return false;
7660 : }
7661 :
7662 : /* Requires via module not at program-unit level and not repeating clause. */
7663 117 : if (prog_unit != gfc_current_ns && !(prog_unit->omp_requires & clause))
7664 : {
7665 0 : if (clause & OMP_REQ_ATOMIC_MEM_ORDER_MASK)
7666 0 : gfc_error ("!$OMP REQUIRES clause %<atomic_default_mem_order(%s)%> "
7667 : "specified via module %qs use at %L but same clause is "
7668 : "not specified for the program unit", clause_name,
7669 : module_name, loc);
7670 : else
7671 0 : gfc_error ("!$OMP REQUIRES clause %qs specified via module %qs use at "
7672 : "%L but same clause is not specified for the program unit",
7673 : clause_name, module_name, loc);
7674 0 : return false;
7675 : }
7676 :
7677 117 : if (!gfc_state_stack->previous
7678 109 : || gfc_state_stack->previous->state != COMP_INTERFACE)
7679 116 : prog_unit->omp_requires |= clause;
7680 : return true;
7681 : }
7682 :
7683 : match
7684 92 : gfc_match_omp_requires (void)
7685 : {
7686 92 : static const char *clauses[] = {"reverse_offload",
7687 : "unified_address",
7688 : "unified_shared_memory",
7689 : "self_maps",
7690 : "dynamic_allocators",
7691 : "atomic_default"};
7692 92 : const char *clause = NULL;
7693 92 : int requires_clauses = 0;
7694 92 : bool first = true;
7695 92 : locus old_loc;
7696 :
7697 92 : if (gfc_current_ns->parent
7698 7 : && (!gfc_state_stack->previous
7699 7 : || gfc_state_stack->previous->state != COMP_INTERFACE))
7700 : {
7701 6 : gfc_error ("!$OMP REQUIRES at %C must appear in the specification part "
7702 : "of a program unit");
7703 6 : return MATCH_ERROR;
7704 : }
7705 :
7706 258 : while (true)
7707 : {
7708 172 : old_loc = gfc_current_locus;
7709 172 : gfc_omp_requires_kind requires_clause;
7710 86 : if ((first || gfc_match_char (',') != MATCH_YES)
7711 172 : && (first && gfc_match_space () != MATCH_YES))
7712 0 : goto error;
7713 172 : first = false;
7714 172 : gfc_gobble_whitespace ();
7715 172 : old_loc = gfc_current_locus;
7716 :
7717 172 : if (gfc_match_omp_eos () != MATCH_NO)
7718 : break;
7719 97 : if (gfc_match (clauses[0]) == MATCH_YES)
7720 : {
7721 34 : clause = clauses[0];
7722 34 : requires_clause = OMP_REQ_REVERSE_OFFLOAD;
7723 34 : if (requires_clauses & OMP_REQ_REVERSE_OFFLOAD)
7724 1 : goto duplicate_clause;
7725 : }
7726 63 : else if (gfc_match (clauses[1]) == MATCH_YES)
7727 : {
7728 9 : clause = clauses[1];
7729 9 : requires_clause = OMP_REQ_UNIFIED_ADDRESS;
7730 9 : if (requires_clauses & OMP_REQ_UNIFIED_ADDRESS)
7731 1 : goto duplicate_clause;
7732 : }
7733 54 : else if (gfc_match (clauses[2]) == MATCH_YES)
7734 : {
7735 14 : clause = clauses[2];
7736 14 : requires_clause = OMP_REQ_UNIFIED_SHARED_MEMORY;
7737 14 : if (requires_clauses & OMP_REQ_UNIFIED_SHARED_MEMORY)
7738 1 : goto duplicate_clause;
7739 : }
7740 40 : else if (gfc_match (clauses[3]) == MATCH_YES)
7741 : {
7742 1 : clause = clauses[3];
7743 1 : requires_clause = OMP_REQ_SELF_MAPS;
7744 1 : if (requires_clauses & OMP_REQ_SELF_MAPS)
7745 0 : goto duplicate_clause;
7746 : }
7747 39 : else if (gfc_match (clauses[4]) == MATCH_YES)
7748 : {
7749 7 : clause = clauses[4];
7750 7 : requires_clause = OMP_REQ_DYNAMIC_ALLOCATORS;
7751 7 : if (requires_clauses & OMP_REQ_DYNAMIC_ALLOCATORS)
7752 1 : goto duplicate_clause;
7753 : }
7754 32 : else if (gfc_match ("atomic_default_mem_order (") == MATCH_YES)
7755 : {
7756 31 : clause = clauses[5];
7757 31 : if (requires_clauses & OMP_REQ_ATOMIC_MEM_ORDER_MASK)
7758 1 : goto duplicate_clause;
7759 30 : if (gfc_match (" seq_cst )") == MATCH_YES)
7760 : {
7761 : clause = "seq_cst";
7762 : requires_clause = OMP_REQ_ATOMIC_MEM_ORDER_SEQ_CST;
7763 : }
7764 18 : else if (gfc_match (" acq_rel )") == MATCH_YES)
7765 : {
7766 : clause = "acq_rel";
7767 : requires_clause = OMP_REQ_ATOMIC_MEM_ORDER_ACQ_REL;
7768 : }
7769 12 : else if (gfc_match (" acquire )") == MATCH_YES)
7770 : {
7771 : clause = "acquire";
7772 : requires_clause = OMP_REQ_ATOMIC_MEM_ORDER_ACQUIRE;
7773 : }
7774 9 : else if (gfc_match (" relaxed )") == MATCH_YES)
7775 : {
7776 : clause = "relaxed";
7777 : requires_clause = OMP_REQ_ATOMIC_MEM_ORDER_RELAXED;
7778 : }
7779 5 : else if (gfc_match (" release )") == MATCH_YES)
7780 : {
7781 : clause = "release";
7782 : requires_clause = OMP_REQ_ATOMIC_MEM_ORDER_RELEASE;
7783 : }
7784 : else
7785 : {
7786 2 : gfc_error ("Expected ACQ_REL, ACQUIRE, RELAXED, RELEASE or "
7787 : "SEQ_CST for ATOMIC_DEFAULT_MEM_ORDER clause at %C");
7788 2 : goto error;
7789 : }
7790 : }
7791 : else
7792 1 : goto error;
7793 :
7794 89 : if (!gfc_omp_requires_add_clause (requires_clause, clause, &old_loc, NULL))
7795 3 : goto error;
7796 86 : requires_clauses |= requires_clause;
7797 86 : }
7798 :
7799 75 : if (requires_clauses == 0)
7800 : {
7801 1 : if (!gfc_error_flag_test ())
7802 1 : gfc_error ("Clause expected at %C");
7803 1 : goto error;
7804 : }
7805 : return MATCH_YES;
7806 :
7807 5 : duplicate_clause:
7808 5 : gfc_error ("%qs clause at %L specified more than once", clause, &old_loc);
7809 12 : error:
7810 12 : if (!gfc_error_flag_test ())
7811 1 : gfc_error ("Expected UNIFIED_ADDRESS, UNIFIED_SHARED_MEMORY, SELF_MAPS, "
7812 : "DYNAMIC_ALLOCATORS, REVERSE_OFFLOAD, or "
7813 : "ATOMIC_DEFAULT_MEM_ORDER clause at %L", &old_loc);
7814 : return MATCH_ERROR;
7815 : }
7816 :
7817 :
7818 : match
7819 51 : gfc_match_omp_scan (void)
7820 : {
7821 51 : bool incl;
7822 51 : gfc_omp_clauses *c = gfc_get_omp_clauses ();
7823 51 : gfc_gobble_whitespace ();
7824 51 : if ((incl = (gfc_match ("inclusive") == MATCH_YES))
7825 51 : || gfc_match ("exclusive") == MATCH_YES)
7826 : {
7827 70 : if (gfc_match_omp_variable_list (" (", &c->lists[incl ? OMP_LIST_SCAN_IN
7828 : : OMP_LIST_SCAN_EX],
7829 : false) != MATCH_YES)
7830 : {
7831 0 : gfc_free_omp_clauses (c);
7832 0 : return MATCH_ERROR;
7833 : }
7834 : }
7835 : else
7836 : {
7837 1 : gfc_error ("Expected INCLUSIVE or EXCLUSIVE clause at %C");
7838 1 : gfc_free_omp_clauses (c);
7839 1 : return MATCH_ERROR;
7840 : }
7841 50 : if (gfc_match_omp_eos () != MATCH_YES)
7842 : {
7843 1 : gfc_error ("Unexpected junk after !$OMP SCAN at %C");
7844 1 : gfc_free_omp_clauses (c);
7845 1 : return MATCH_ERROR;
7846 : }
7847 :
7848 49 : new_st.op = EXEC_OMP_SCAN;
7849 49 : new_st.ext.omp_clauses = c;
7850 49 : return MATCH_YES;
7851 : }
7852 :
7853 :
7854 : match
7855 58 : gfc_match_omp_scope (void)
7856 : {
7857 58 : return match_omp (EXEC_OMP_SCOPE, OMP_SCOPE_CLAUSES);
7858 : }
7859 :
7860 :
7861 : match
7862 82 : gfc_match_omp_sections (void)
7863 : {
7864 82 : return match_omp (EXEC_OMP_SECTIONS, OMP_SECTIONS_CLAUSES);
7865 : }
7866 :
7867 :
7868 : match
7869 782 : gfc_match_omp_simd (void)
7870 : {
7871 782 : return match_omp (EXEC_OMP_SIMD, OMP_SIMD_CLAUSES);
7872 : }
7873 :
7874 :
7875 : match
7876 570 : gfc_match_omp_single (void)
7877 : {
7878 570 : return match_omp (EXEC_OMP_SINGLE, OMP_SINGLE_CLAUSES);
7879 : }
7880 :
7881 :
7882 : match
7883 1970 : gfc_match_omp_target (void)
7884 : {
7885 1970 : return match_omp (EXEC_OMP_TARGET, OMP_TARGET_CLAUSES);
7886 : }
7887 :
7888 :
7889 : match
7890 1398 : gfc_match_omp_target_data (void)
7891 : {
7892 1398 : return match_omp (EXEC_OMP_TARGET_DATA, OMP_TARGET_DATA_CLAUSES);
7893 : }
7894 :
7895 :
7896 : match
7897 408 : gfc_match_omp_target_enter_data (void)
7898 : {
7899 408 : return match_omp (EXEC_OMP_TARGET_ENTER_DATA, OMP_TARGET_ENTER_DATA_CLAUSES);
7900 : }
7901 :
7902 :
7903 : match
7904 322 : gfc_match_omp_target_exit_data (void)
7905 : {
7906 322 : return match_omp (EXEC_OMP_TARGET_EXIT_DATA, OMP_TARGET_EXIT_DATA_CLAUSES);
7907 : }
7908 :
7909 :
7910 : match
7911 24 : gfc_match_omp_target_parallel (void)
7912 : {
7913 24 : return match_omp (EXEC_OMP_TARGET_PARALLEL,
7914 24 : (OMP_TARGET_CLAUSES | OMP_PARALLEL_CLAUSES)
7915 24 : & ~(omp_mask (OMP_CLAUSE_COPYIN)));
7916 : }
7917 :
7918 :
7919 : match
7920 81 : gfc_match_omp_target_parallel_do (void)
7921 : {
7922 81 : return match_omp (EXEC_OMP_TARGET_PARALLEL_DO,
7923 81 : (OMP_TARGET_CLAUSES | OMP_PARALLEL_CLAUSES
7924 81 : | OMP_DO_CLAUSES) & ~(omp_mask (OMP_CLAUSE_COPYIN)));
7925 : }
7926 :
7927 :
7928 : match
7929 19 : gfc_match_omp_target_parallel_do_simd (void)
7930 : {
7931 19 : return match_omp (EXEC_OMP_TARGET_PARALLEL_DO_SIMD,
7932 19 : (OMP_TARGET_CLAUSES | OMP_PARALLEL_CLAUSES | OMP_DO_CLAUSES
7933 19 : | OMP_SIMD_CLAUSES) & ~(omp_mask (OMP_CLAUSE_COPYIN)));
7934 : }
7935 :
7936 :
7937 : match
7938 34 : gfc_match_omp_target_simd (void)
7939 : {
7940 34 : return match_omp (EXEC_OMP_TARGET_SIMD,
7941 34 : OMP_TARGET_CLAUSES | OMP_SIMD_CLAUSES);
7942 : }
7943 :
7944 :
7945 : match
7946 72 : gfc_match_omp_target_teams (void)
7947 : {
7948 72 : return match_omp (EXEC_OMP_TARGET_TEAMS,
7949 72 : OMP_TARGET_CLAUSES | OMP_TEAMS_CLAUSES);
7950 : }
7951 :
7952 :
7953 : match
7954 19 : gfc_match_omp_target_teams_distribute (void)
7955 : {
7956 19 : return match_omp (EXEC_OMP_TARGET_TEAMS_DISTRIBUTE,
7957 19 : OMP_TARGET_CLAUSES | OMP_TEAMS_CLAUSES
7958 19 : | OMP_DISTRIBUTE_CLAUSES);
7959 : }
7960 :
7961 :
7962 : match
7963 64 : gfc_match_omp_target_teams_distribute_parallel_do (void)
7964 : {
7965 64 : return match_omp (EXEC_OMP_TARGET_TEAMS_DISTRIBUTE_PARALLEL_DO,
7966 64 : (OMP_TARGET_CLAUSES | OMP_TEAMS_CLAUSES
7967 64 : | OMP_DISTRIBUTE_CLAUSES | OMP_PARALLEL_CLAUSES
7968 64 : | OMP_DO_CLAUSES)
7969 64 : & ~(omp_mask (OMP_CLAUSE_ORDERED))
7970 64 : & ~(omp_mask (OMP_CLAUSE_LINEAR)));
7971 : }
7972 :
7973 :
7974 : match
7975 35 : gfc_match_omp_target_teams_distribute_parallel_do_simd (void)
7976 : {
7977 35 : return match_omp (EXEC_OMP_TARGET_TEAMS_DISTRIBUTE_PARALLEL_DO_SIMD,
7978 35 : (OMP_TARGET_CLAUSES | OMP_TEAMS_CLAUSES
7979 35 : | OMP_DISTRIBUTE_CLAUSES | OMP_PARALLEL_CLAUSES
7980 35 : | OMP_DO_CLAUSES | OMP_SIMD_CLAUSES)
7981 35 : & ~(omp_mask (OMP_CLAUSE_ORDERED)));
7982 : }
7983 :
7984 :
7985 : match
7986 21 : gfc_match_omp_target_teams_distribute_simd (void)
7987 : {
7988 21 : return match_omp (EXEC_OMP_TARGET_TEAMS_DISTRIBUTE_SIMD,
7989 21 : OMP_TARGET_CLAUSES | OMP_TEAMS_CLAUSES
7990 21 : | OMP_DISTRIBUTE_CLAUSES | OMP_SIMD_CLAUSES);
7991 : }
7992 :
7993 :
7994 : match
7995 1704 : gfc_match_omp_target_update (void)
7996 : {
7997 1704 : return match_omp (EXEC_OMP_TARGET_UPDATE, OMP_TARGET_UPDATE_CLAUSES);
7998 : }
7999 :
8000 :
8001 : match
8002 1180 : gfc_match_omp_task (void)
8003 : {
8004 1180 : return match_omp (EXEC_OMP_TASK, OMP_TASK_CLAUSES);
8005 : }
8006 :
8007 :
8008 : match
8009 72 : gfc_match_omp_taskloop (void)
8010 : {
8011 72 : return match_omp (EXEC_OMP_TASKLOOP, OMP_TASKLOOP_CLAUSES);
8012 : }
8013 :
8014 :
8015 : match
8016 40 : gfc_match_omp_taskloop_simd (void)
8017 : {
8018 40 : return match_omp (EXEC_OMP_TASKLOOP_SIMD,
8019 40 : OMP_TASKLOOP_CLAUSES | OMP_SIMD_CLAUSES);
8020 : }
8021 :
8022 :
8023 : match
8024 146 : gfc_match_omp_taskwait (void)
8025 : {
8026 146 : if (gfc_match_omp_eos () == MATCH_YES)
8027 : {
8028 133 : new_st.op = EXEC_OMP_TASKWAIT;
8029 133 : new_st.ext.omp_clauses = NULL;
8030 133 : return MATCH_YES;
8031 : }
8032 13 : return match_omp (EXEC_OMP_TASKWAIT,
8033 13 : omp_mask (OMP_CLAUSE_DEPEND) | OMP_CLAUSE_NOWAIT);
8034 : }
8035 :
8036 :
8037 : match
8038 10 : gfc_match_omp_taskyield (void)
8039 : {
8040 10 : if (gfc_match_omp_eos () != MATCH_YES)
8041 : {
8042 0 : gfc_error ("Unexpected junk after TASKYIELD clause at %C");
8043 0 : return MATCH_ERROR;
8044 : }
8045 10 : new_st.op = EXEC_OMP_TASKYIELD;
8046 10 : new_st.ext.omp_clauses = NULL;
8047 10 : return MATCH_YES;
8048 : }
8049 :
8050 :
8051 : match
8052 150 : gfc_match_omp_teams (void)
8053 : {
8054 150 : return match_omp (EXEC_OMP_TEAMS, OMP_TEAMS_CLAUSES);
8055 : }
8056 :
8057 :
8058 : match
8059 22 : gfc_match_omp_teams_distribute (void)
8060 : {
8061 22 : return match_omp (EXEC_OMP_TEAMS_DISTRIBUTE,
8062 22 : OMP_TEAMS_CLAUSES | OMP_DISTRIBUTE_CLAUSES);
8063 : }
8064 :
8065 :
8066 : match
8067 39 : gfc_match_omp_teams_distribute_parallel_do (void)
8068 : {
8069 39 : return match_omp (EXEC_OMP_TEAMS_DISTRIBUTE_PARALLEL_DO,
8070 39 : (OMP_TEAMS_CLAUSES | OMP_DISTRIBUTE_CLAUSES
8071 39 : | OMP_PARALLEL_CLAUSES | OMP_DO_CLAUSES)
8072 39 : & ~(omp_mask (OMP_CLAUSE_ORDERED)
8073 39 : | OMP_CLAUSE_LINEAR | OMP_CLAUSE_NOWAIT));
8074 : }
8075 :
8076 :
8077 : match
8078 62 : gfc_match_omp_teams_distribute_parallel_do_simd (void)
8079 : {
8080 62 : return match_omp (EXEC_OMP_TEAMS_DISTRIBUTE_PARALLEL_DO_SIMD,
8081 62 : (OMP_TEAMS_CLAUSES | OMP_DISTRIBUTE_CLAUSES
8082 62 : | OMP_PARALLEL_CLAUSES | OMP_DO_CLAUSES
8083 62 : | OMP_SIMD_CLAUSES)
8084 62 : & ~(omp_mask (OMP_CLAUSE_ORDERED) | OMP_CLAUSE_NOWAIT));
8085 : }
8086 :
8087 :
8088 : match
8089 44 : gfc_match_omp_teams_distribute_simd (void)
8090 : {
8091 44 : return match_omp (EXEC_OMP_TEAMS_DISTRIBUTE_SIMD,
8092 44 : OMP_TEAMS_CLAUSES | OMP_DISTRIBUTE_CLAUSES
8093 44 : | OMP_SIMD_CLAUSES);
8094 : }
8095 :
8096 : match
8097 203 : gfc_match_omp_tile (void)
8098 : {
8099 203 : return match_omp (EXEC_OMP_TILE, OMP_TILE_CLAUSES);
8100 : }
8101 :
8102 : match
8103 415 : gfc_match_omp_unroll (void)
8104 : {
8105 415 : return match_omp (EXEC_OMP_UNROLL, OMP_UNROLL_CLAUSES);
8106 : }
8107 :
8108 : match
8109 39 : gfc_match_omp_workshare (void)
8110 : {
8111 39 : return match_omp (EXEC_OMP_WORKSHARE, OMP_WORKSHARE_CLAUSES);
8112 : }
8113 :
8114 :
8115 : match
8116 49 : gfc_match_omp_masked (void)
8117 : {
8118 49 : return match_omp (EXEC_OMP_MASKED, OMP_MASKED_CLAUSES);
8119 : }
8120 :
8121 : match
8122 10 : gfc_match_omp_masked_taskloop (void)
8123 : {
8124 10 : return match_omp (EXEC_OMP_MASKED_TASKLOOP,
8125 10 : OMP_MASKED_CLAUSES | OMP_TASKLOOP_CLAUSES);
8126 : }
8127 :
8128 : match
8129 16 : gfc_match_omp_masked_taskloop_simd (void)
8130 : {
8131 16 : return match_omp (EXEC_OMP_MASKED_TASKLOOP_SIMD,
8132 16 : (OMP_MASKED_CLAUSES | OMP_TASKLOOP_CLAUSES
8133 16 : | OMP_SIMD_CLAUSES));
8134 : }
8135 :
8136 : match
8137 111 : gfc_match_omp_master (void)
8138 : {
8139 111 : gfc_warning (OPT_Wdeprecated_openmp,
8140 : "%<master%> construct at %C deprecated since OpenMP 5.1, "
8141 : "use %<masked%>");
8142 111 : if (gfc_match_omp_eos () != MATCH_YES)
8143 : {
8144 1 : gfc_error ("Unexpected junk after $OMP MASTER statement at %C");
8145 1 : return MATCH_ERROR;
8146 : }
8147 110 : new_st.op = EXEC_OMP_MASTER;
8148 110 : new_st.ext.omp_clauses = NULL;
8149 110 : return MATCH_YES;
8150 : }
8151 :
8152 : match
8153 16 : gfc_match_omp_master_taskloop (void)
8154 : {
8155 16 : gfc_warning (OPT_Wdeprecated_openmp,
8156 : "%<master%> construct at %C deprecated since OpenMP 5.1, "
8157 : "use %<masked%>");
8158 16 : return match_omp (EXEC_OMP_MASTER_TASKLOOP, OMP_TASKLOOP_CLAUSES);
8159 : }
8160 :
8161 : match
8162 21 : gfc_match_omp_master_taskloop_simd (void)
8163 : {
8164 21 : gfc_warning (OPT_Wdeprecated_openmp,
8165 : "%<master%> construct at %C deprecated since OpenMP 5.1, use "
8166 : "%<masked%>");
8167 21 : return match_omp (EXEC_OMP_MASTER_TASKLOOP_SIMD,
8168 21 : OMP_TASKLOOP_CLAUSES | OMP_SIMD_CLAUSES);
8169 : }
8170 :
8171 : match
8172 235 : gfc_match_omp_ordered (void)
8173 : {
8174 235 : return match_omp (EXEC_OMP_ORDERED, OMP_ORDERED_CLAUSES);
8175 : }
8176 :
8177 : match
8178 24 : gfc_match_omp_nothing (void)
8179 : {
8180 24 : if (gfc_match_omp_eos () != MATCH_YES)
8181 : {
8182 1 : gfc_error ("Unexpected junk after $OMP NOTHING statement at %C");
8183 1 : return MATCH_ERROR;
8184 : }
8185 : /* Will use ST_NONE; therefore, no EXEC_OMP_ is needed. */
8186 : return MATCH_YES;
8187 : }
8188 :
8189 : match
8190 317 : gfc_match_omp_ordered_depend (void)
8191 : {
8192 317 : return match_omp (EXEC_OMP_ORDERED, omp_mask (OMP_CLAUSE_DOACROSS));
8193 : }
8194 :
8195 :
8196 : /* omp atomic [clause-list]
8197 : - atomic-clause: read | write | update
8198 : - capture
8199 : - memory-order-clause: seq_cst | acq_rel | release | acquire | relaxed
8200 : - hint(hint-expr)
8201 : - OpenMP 5.1: compare | fail (seq_cst | acquire | relaxed ) | weak
8202 : */
8203 :
8204 : match
8205 2171 : gfc_match_omp_atomic (void)
8206 : {
8207 2171 : gfc_omp_clauses *c;
8208 2171 : locus loc = gfc_current_locus;
8209 :
8210 2171 : if (gfc_match_omp_clauses (&c, OMP_ATOMIC_CLAUSES, true, true) != MATCH_YES)
8211 : return MATCH_ERROR;
8212 :
8213 2153 : if (c->atomic_op == GFC_OMP_ATOMIC_UNSET)
8214 1011 : c->atomic_op = GFC_OMP_ATOMIC_UPDATE;
8215 :
8216 2153 : if (c->capture && c->atomic_op != GFC_OMP_ATOMIC_UPDATE)
8217 3 : gfc_error ("!$OMP ATOMIC at %L with %s clause is incompatible with "
8218 : "READ or WRITE", &loc, "CAPTURE");
8219 2153 : if (c->compare && c->atomic_op != GFC_OMP_ATOMIC_UPDATE)
8220 3 : gfc_error ("!$OMP ATOMIC at %L with %s clause is incompatible with "
8221 : "READ or WRITE", &loc, "COMPARE");
8222 2153 : if (c->fail != OMP_MEMORDER_UNSET && c->atomic_op != GFC_OMP_ATOMIC_UPDATE)
8223 2 : gfc_error ("!$OMP ATOMIC at %L with %s clause is incompatible with "
8224 : "READ or WRITE", &loc, "FAIL");
8225 2153 : if (c->weak && !c->compare)
8226 : {
8227 5 : gfc_error ("!$OMP ATOMIC at %L with %s clause requires %s clause", &loc,
8228 : "WEAK", "COMPARE");
8229 5 : c->weak = false;
8230 : }
8231 :
8232 2153 : if (c->memorder == OMP_MEMORDER_UNSET)
8233 : {
8234 1969 : gfc_namespace *prog_unit = gfc_current_ns;
8235 2525 : while (prog_unit->parent)
8236 : prog_unit = prog_unit->parent;
8237 1969 : switch (prog_unit->omp_requires & OMP_REQ_ATOMIC_MEM_ORDER_MASK)
8238 : {
8239 1936 : case 0:
8240 1936 : case OMP_REQ_ATOMIC_MEM_ORDER_RELAXED:
8241 1936 : c->memorder = OMP_MEMORDER_RELAXED;
8242 1936 : break;
8243 7 : case OMP_REQ_ATOMIC_MEM_ORDER_SEQ_CST:
8244 7 : c->memorder = OMP_MEMORDER_SEQ_CST;
8245 7 : break;
8246 16 : case OMP_REQ_ATOMIC_MEM_ORDER_ACQ_REL:
8247 16 : if (c->capture)
8248 5 : c->memorder = OMP_MEMORDER_ACQ_REL;
8249 11 : else if (c->atomic_op == GFC_OMP_ATOMIC_READ)
8250 3 : c->memorder = OMP_MEMORDER_ACQUIRE;
8251 : else
8252 8 : c->memorder = OMP_MEMORDER_RELEASE;
8253 : break;
8254 5 : case OMP_REQ_ATOMIC_MEM_ORDER_ACQUIRE:
8255 5 : if (c->atomic_op == GFC_OMP_ATOMIC_WRITE)
8256 : {
8257 1 : gfc_error ("!$OMP ATOMIC WRITE at %L incompatible with "
8258 : "ACQUIRES clause implicitly provided by a "
8259 : "REQUIRES directive", &loc);
8260 1 : c->memorder = OMP_MEMORDER_SEQ_CST;
8261 : }
8262 : else
8263 4 : c->memorder = OMP_MEMORDER_ACQUIRE;
8264 : break;
8265 5 : case OMP_REQ_ATOMIC_MEM_ORDER_RELEASE:
8266 5 : if (c->atomic_op == GFC_OMP_ATOMIC_READ)
8267 : {
8268 1 : gfc_error ("!$OMP ATOMIC READ at %L incompatible with "
8269 : "RELEASE clause implicitly provided by a "
8270 : "REQUIRES directive", &loc);
8271 1 : c->memorder = OMP_MEMORDER_SEQ_CST;
8272 : }
8273 : else
8274 4 : c->memorder = OMP_MEMORDER_RELEASE;
8275 : break;
8276 0 : default:
8277 0 : gcc_unreachable ();
8278 : }
8279 : }
8280 : else
8281 184 : switch (c->atomic_op)
8282 : {
8283 29 : case GFC_OMP_ATOMIC_READ:
8284 29 : if (c->memorder == OMP_MEMORDER_RELEASE)
8285 : {
8286 1 : gfc_error ("!$OMP ATOMIC READ at %L incompatible with "
8287 : "RELEASE clause", &loc);
8288 1 : c->memorder = OMP_MEMORDER_SEQ_CST;
8289 : }
8290 28 : else if (c->memorder == OMP_MEMORDER_ACQ_REL)
8291 1 : c->memorder = OMP_MEMORDER_ACQUIRE;
8292 : break;
8293 35 : case GFC_OMP_ATOMIC_WRITE:
8294 35 : if (c->memorder == OMP_MEMORDER_ACQUIRE)
8295 : {
8296 1 : gfc_error ("!$OMP ATOMIC WRITE at %L incompatible with "
8297 : "ACQUIRE clause", &loc);
8298 1 : c->memorder = OMP_MEMORDER_SEQ_CST;
8299 : }
8300 34 : else if (c->memorder == OMP_MEMORDER_ACQ_REL)
8301 1 : c->memorder = OMP_MEMORDER_RELEASE;
8302 : break;
8303 : default:
8304 : break;
8305 : }
8306 2153 : gfc_error_check ();
8307 2153 : new_st.ext.omp_clauses = c;
8308 2153 : new_st.op = EXEC_OMP_ATOMIC;
8309 2153 : return MATCH_YES;
8310 : }
8311 :
8312 :
8313 : /* acc atomic [ read | write | update | capture] */
8314 :
8315 : match
8316 552 : gfc_match_oacc_atomic (void)
8317 : {
8318 552 : gfc_omp_clauses *c = gfc_get_omp_clauses ();
8319 552 : c->atomic_op = GFC_OMP_ATOMIC_UPDATE;
8320 552 : c->memorder = OMP_MEMORDER_RELAXED;
8321 552 : gfc_gobble_whitespace ();
8322 552 : if (gfc_match ("update") == MATCH_YES)
8323 : ;
8324 373 : else if (gfc_match ("read") == MATCH_YES)
8325 17 : c->atomic_op = GFC_OMP_ATOMIC_READ;
8326 356 : else if (gfc_match ("write") == MATCH_YES)
8327 13 : c->atomic_op = GFC_OMP_ATOMIC_WRITE;
8328 343 : else if (gfc_match ("capture") == MATCH_YES)
8329 319 : c->capture = true;
8330 552 : gfc_gobble_whitespace ();
8331 552 : if (gfc_match_omp_eos () != MATCH_YES)
8332 : {
8333 9 : gfc_error ("Unexpected junk after !$ACC ATOMIC statement at %C");
8334 9 : gfc_free_omp_clauses (c);
8335 9 : return MATCH_ERROR;
8336 : }
8337 543 : new_st.ext.omp_clauses = c;
8338 543 : new_st.op = EXEC_OACC_ATOMIC;
8339 543 : return MATCH_YES;
8340 : }
8341 :
8342 :
8343 : match
8344 614 : gfc_match_omp_barrier (void)
8345 : {
8346 614 : if (gfc_match_omp_eos () != MATCH_YES)
8347 : {
8348 0 : gfc_error ("Unexpected junk after $OMP BARRIER statement at %C");
8349 0 : return MATCH_ERROR;
8350 : }
8351 614 : new_st.op = EXEC_OMP_BARRIER;
8352 614 : new_st.ext.omp_clauses = NULL;
8353 614 : return MATCH_YES;
8354 : }
8355 :
8356 :
8357 : match
8358 188 : gfc_match_omp_taskgroup (void)
8359 : {
8360 188 : return match_omp (EXEC_OMP_TASKGROUP, OMP_TASKGROUP_CLAUSES);
8361 : }
8362 :
8363 :
8364 : static enum gfc_omp_cancel_kind
8365 494 : gfc_match_omp_cancel_kind (void)
8366 : {
8367 494 : if (gfc_match_space () != MATCH_YES)
8368 : return OMP_CANCEL_UNKNOWN;
8369 492 : if (gfc_match ("parallel") == MATCH_YES)
8370 : return OMP_CANCEL_PARALLEL;
8371 352 : if (gfc_match ("sections") == MATCH_YES)
8372 : return OMP_CANCEL_SECTIONS;
8373 253 : if (gfc_match ("do") == MATCH_YES)
8374 : return OMP_CANCEL_DO;
8375 123 : if (gfc_match ("taskgroup") == MATCH_YES)
8376 : return OMP_CANCEL_TASKGROUP;
8377 : return OMP_CANCEL_UNKNOWN;
8378 : }
8379 :
8380 :
8381 : match
8382 321 : gfc_match_omp_cancel (void)
8383 : {
8384 321 : gfc_omp_clauses *c;
8385 321 : enum gfc_omp_cancel_kind kind = gfc_match_omp_cancel_kind ();
8386 321 : if (kind == OMP_CANCEL_UNKNOWN)
8387 : return MATCH_ERROR;
8388 319 : if (gfc_match_omp_clauses (&c, omp_mask (OMP_CLAUSE_IF), false) != MATCH_YES)
8389 : return MATCH_ERROR;
8390 316 : c->cancel = kind;
8391 316 : new_st.op = EXEC_OMP_CANCEL;
8392 316 : new_st.ext.omp_clauses = c;
8393 316 : return MATCH_YES;
8394 : }
8395 :
8396 :
8397 : match
8398 173 : gfc_match_omp_cancellation_point (void)
8399 : {
8400 173 : gfc_omp_clauses *c;
8401 173 : enum gfc_omp_cancel_kind kind = gfc_match_omp_cancel_kind ();
8402 173 : if (kind == OMP_CANCEL_UNKNOWN)
8403 : {
8404 2 : gfc_error ("Expected construct-type PARALLEL, SECTIONS, DO or TASKGROUP "
8405 : "in $OMP CANCELLATION POINT statement at %C");
8406 2 : return MATCH_ERROR;
8407 : }
8408 171 : if (gfc_match_omp_eos () != MATCH_YES)
8409 : {
8410 0 : gfc_error ("Unexpected junk after $OMP CANCELLATION POINT statement "
8411 : "at %C");
8412 0 : return MATCH_ERROR;
8413 : }
8414 171 : c = gfc_get_omp_clauses ();
8415 171 : c->cancel = kind;
8416 171 : new_st.op = EXEC_OMP_CANCELLATION_POINT;
8417 171 : new_st.ext.omp_clauses = c;
8418 171 : return MATCH_YES;
8419 : }
8420 :
8421 :
8422 : match
8423 2479 : gfc_match_omp_end_nowait (void)
8424 : {
8425 2479 : bool nowait = false;
8426 2479 : if (gfc_match ("% nowait") == MATCH_YES)
8427 258 : nowait = true;
8428 2479 : if (gfc_match_omp_eos () != MATCH_YES)
8429 : {
8430 4 : if (nowait)
8431 3 : gfc_error ("Unexpected junk after NOWAIT clause at %C");
8432 : else
8433 1 : gfc_error ("Unexpected junk at %C");
8434 4 : return MATCH_ERROR;
8435 : }
8436 2475 : new_st.op = EXEC_OMP_END_NOWAIT;
8437 2475 : new_st.ext.omp_bool = nowait;
8438 2475 : return MATCH_YES;
8439 : }
8440 :
8441 :
8442 : match
8443 566 : gfc_match_omp_end_single (void)
8444 : {
8445 566 : gfc_omp_clauses *c;
8446 566 : if (gfc_match_omp_clauses (&c, omp_mask (OMP_CLAUSE_COPYPRIVATE)
8447 : | OMP_CLAUSE_NOWAIT) != MATCH_YES)
8448 : return MATCH_ERROR;
8449 566 : new_st.op = EXEC_OMP_END_SINGLE;
8450 566 : new_st.ext.omp_clauses = c;
8451 566 : return MATCH_YES;
8452 : }
8453 :
8454 :
8455 : static bool
8456 37004 : oacc_is_loop (gfc_code *code)
8457 : {
8458 37004 : return code->op == EXEC_OACC_PARALLEL_LOOP
8459 : || code->op == EXEC_OACC_KERNELS_LOOP
8460 19955 : || code->op == EXEC_OACC_SERIAL_LOOP
8461 13451 : || code->op == EXEC_OACC_LOOP;
8462 : }
8463 :
8464 : static void
8465 5713 : resolve_scalar_int_expr (gfc_expr *expr, const char *clause)
8466 : {
8467 5713 : if (!gfc_resolve_expr (expr)
8468 5713 : || expr->ts.type != BT_INTEGER
8469 11355 : || expr->rank != 0)
8470 89 : gfc_error ("%s clause at %L requires a scalar INTEGER expression",
8471 : clause, &expr->where);
8472 5713 : }
8473 :
8474 : static void
8475 3928 : resolve_positive_int_expr (gfc_expr *expr, const char *clause)
8476 : {
8477 3928 : resolve_scalar_int_expr (expr, clause);
8478 3928 : if (expr->expr_type == EXPR_CONSTANT
8479 3507 : && expr->ts.type == BT_INTEGER
8480 3474 : && mpz_sgn (expr->value.integer) <= 0)
8481 54 : gfc_warning ((flag_openmp || flag_openmp_simd) ? OPT_Wopenmp : 0,
8482 : "INTEGER expression of %s clause at %L must be positive",
8483 : clause, &expr->where);
8484 3928 : }
8485 :
8486 : static void
8487 86 : resolve_nonnegative_int_expr (gfc_expr *expr, const char *clause)
8488 : {
8489 86 : resolve_scalar_int_expr (expr, clause);
8490 86 : if (expr->expr_type == EXPR_CONSTANT
8491 13 : && expr->ts.type == BT_INTEGER
8492 11 : && mpz_sgn (expr->value.integer) < 0)
8493 6 : gfc_warning ((flag_openmp || flag_openmp_simd) ? OPT_Wopenmp : 0,
8494 : "INTEGER expression of %s clause at %L must be non-negative",
8495 : clause, &expr->where);
8496 86 : }
8497 :
8498 : /* Emits error when symbol is pointer, cray pointer or cray pointee
8499 : of derived of polymorphic type. */
8500 :
8501 : static void
8502 98 : check_symbol_not_pointer (gfc_symbol *sym, locus loc, const char *name)
8503 : {
8504 98 : if (sym->ts.type == BT_DERIVED && sym->attr.cray_pointer)
8505 0 : gfc_error ("Cray pointer object %qs of derived type in %s clause at %L",
8506 : sym->name, name, &loc);
8507 98 : if (sym->ts.type == BT_DERIVED && sym->attr.cray_pointee)
8508 0 : gfc_error ("Cray pointee object %qs of derived type in %s clause at %L",
8509 : sym->name, name, &loc);
8510 :
8511 98 : if ((sym->ts.type == BT_ASSUMED && sym->attr.pointer)
8512 98 : || (sym->ts.type == BT_CLASS && CLASS_DATA (sym)
8513 0 : && CLASS_DATA (sym)->attr.pointer))
8514 0 : gfc_error ("POINTER object %qs of polymorphic type in %s clause at %L",
8515 : sym->name, name, &loc);
8516 98 : if ((sym->ts.type == BT_ASSUMED && sym->attr.cray_pointer)
8517 98 : || (sym->ts.type == BT_CLASS && CLASS_DATA (sym)
8518 0 : && CLASS_DATA (sym)->attr.cray_pointer))
8519 0 : gfc_error ("Cray pointer object %qs of polymorphic type in %s clause at %L",
8520 : sym->name, name, &loc);
8521 98 : if ((sym->ts.type == BT_ASSUMED && sym->attr.cray_pointee)
8522 98 : || (sym->ts.type == BT_CLASS && CLASS_DATA (sym)
8523 0 : && CLASS_DATA (sym)->attr.cray_pointee))
8524 0 : gfc_error ("Cray pointee object %qs of polymorphic type in %s clause at %L",
8525 : sym->name, name, &loc);
8526 98 : }
8527 :
8528 : /* Emits error when symbol represents assumed size/rank array. */
8529 :
8530 : static void
8531 14831 : check_array_not_assumed (gfc_symbol *sym, locus loc, const char *name)
8532 : {
8533 14831 : if (sym->as && sym->as->type == AS_ASSUMED_SIZE)
8534 13 : gfc_error ("Assumed size array %qs in %s clause at %L",
8535 : sym->name, name, &loc);
8536 14831 : if (sym->as && sym->as->type == AS_ASSUMED_RANK)
8537 11 : gfc_error ("Assumed rank array %qs in %s clause at %L",
8538 : sym->name, name, &loc);
8539 14831 : }
8540 :
8541 : static void
8542 5841 : resolve_oacc_data_clauses (gfc_symbol *sym, locus loc, const char *name)
8543 : {
8544 0 : check_array_not_assumed (sym, loc, name);
8545 0 : }
8546 :
8547 : static void
8548 65 : resolve_oacc_deviceptr_clause (gfc_symbol *sym, locus loc, const char *name)
8549 : {
8550 65 : if (sym->attr.pointer
8551 64 : || (sym->ts.type == BT_CLASS && CLASS_DATA (sym)
8552 0 : && CLASS_DATA (sym)->attr.class_pointer))
8553 1 : gfc_error ("POINTER object %qs in %s clause at %L",
8554 : sym->name, name, &loc);
8555 65 : if (sym->attr.cray_pointer
8556 63 : || (sym->ts.type == BT_CLASS && CLASS_DATA (sym)
8557 0 : && CLASS_DATA (sym)->attr.cray_pointer))
8558 2 : gfc_error ("Cray pointer object %qs in %s clause at %L",
8559 : sym->name, name, &loc);
8560 65 : if (sym->attr.cray_pointee
8561 63 : || (sym->ts.type == BT_CLASS && CLASS_DATA (sym)
8562 0 : && CLASS_DATA (sym)->attr.cray_pointee))
8563 2 : gfc_error ("Cray pointee object %qs in %s clause at %L",
8564 : sym->name, name, &loc);
8565 65 : if (sym->attr.allocatable
8566 64 : || (sym->ts.type == BT_CLASS && CLASS_DATA (sym)
8567 0 : && CLASS_DATA (sym)->attr.allocatable))
8568 1 : gfc_error ("ALLOCATABLE object %qs in %s clause at %L",
8569 : sym->name, name, &loc);
8570 65 : if (sym->attr.value)
8571 1 : gfc_error ("VALUE object %qs in %s clause at %L",
8572 : sym->name, name, &loc);
8573 65 : check_array_not_assumed (sym, loc, name);
8574 65 : }
8575 :
8576 :
8577 : struct resolve_omp_udr_callback_data
8578 : {
8579 : gfc_symbol *sym1, *sym2;
8580 : };
8581 :
8582 :
8583 : static int
8584 1413 : resolve_omp_udr_callback (gfc_expr **e, int *, void *data)
8585 : {
8586 1413 : struct resolve_omp_udr_callback_data *rcd
8587 : = (struct resolve_omp_udr_callback_data *) data;
8588 1413 : if ((*e)->expr_type == EXPR_VARIABLE
8589 801 : && ((*e)->symtree->n.sym == rcd->sym1
8590 255 : || (*e)->symtree->n.sym == rcd->sym2))
8591 : {
8592 801 : gfc_ref *ref = gfc_get_ref ();
8593 801 : ref->type = REF_ARRAY;
8594 801 : ref->u.ar.where = (*e)->where;
8595 801 : ref->u.ar.as = (*e)->symtree->n.sym->as;
8596 801 : ref->u.ar.type = AR_FULL;
8597 801 : ref->u.ar.dimen = 0;
8598 801 : ref->next = (*e)->ref;
8599 801 : (*e)->ref = ref;
8600 : }
8601 1413 : return 0;
8602 : }
8603 :
8604 :
8605 : static int
8606 2990 : resolve_omp_udr_callback2 (gfc_expr **e, int *, void *)
8607 : {
8608 2990 : if ((*e)->expr_type == EXPR_FUNCTION
8609 360 : && (*e)->value.function.isym == NULL)
8610 : {
8611 174 : gfc_symbol *sym = (*e)->symtree->n.sym;
8612 174 : if (!sym->attr.intrinsic
8613 174 : && sym->attr.if_source == IFSRC_UNKNOWN)
8614 4 : gfc_error ("Implicitly declared function %s used in "
8615 : "!$OMP DECLARE REDUCTION at %L", sym->name, &(*e)->where);
8616 : }
8617 2990 : return 0;
8618 : }
8619 :
8620 :
8621 : static gfc_code *
8622 797 : resolve_omp_udr_clause (gfc_omp_namelist *n, gfc_namespace *ns,
8623 : gfc_symbol *sym1, gfc_symbol *sym2)
8624 : {
8625 797 : gfc_code *copy;
8626 797 : gfc_symbol sym1_copy, sym2_copy;
8627 :
8628 797 : if (ns->code->op == EXEC_ASSIGN)
8629 : {
8630 625 : copy = gfc_get_code (EXEC_ASSIGN);
8631 625 : copy->expr1 = gfc_copy_expr (ns->code->expr1);
8632 625 : copy->expr2 = gfc_copy_expr (ns->code->expr2);
8633 : }
8634 : else
8635 : {
8636 172 : copy = gfc_get_code (EXEC_CALL);
8637 172 : copy->symtree = ns->code->symtree;
8638 172 : copy->ext.actual = gfc_copy_actual_arglist (ns->code->ext.actual);
8639 : }
8640 797 : copy->loc = ns->code->loc;
8641 797 : sym1_copy = *sym1;
8642 797 : sym2_copy = *sym2;
8643 797 : *sym1 = *n->sym;
8644 797 : *sym2 = *n->sym;
8645 797 : sym1->name = sym1_copy.name;
8646 797 : sym2->name = sym2_copy.name;
8647 797 : ns->proc_name = ns->parent->proc_name;
8648 797 : if (n->sym->attr.dimension)
8649 : {
8650 348 : struct resolve_omp_udr_callback_data rcd;
8651 348 : rcd.sym1 = sym1;
8652 348 : rcd.sym2 = sym2;
8653 348 : gfc_code_walker (©, gfc_dummy_code_callback,
8654 : resolve_omp_udr_callback, &rcd);
8655 : }
8656 797 : gfc_resolve_code (copy, gfc_current_ns);
8657 797 : if (copy->op == EXEC_CALL && copy->resolved_isym == NULL)
8658 : {
8659 172 : gfc_symbol *sym = copy->resolved_sym;
8660 172 : if (sym
8661 170 : && !sym->attr.intrinsic
8662 170 : && sym->attr.if_source == IFSRC_UNKNOWN)
8663 4 : gfc_error ("Implicitly declared subroutine %s used in "
8664 : "!$OMP DECLARE REDUCTION at %L", sym->name,
8665 : ©->loc);
8666 : }
8667 797 : gfc_code_walker (©, gfc_dummy_code_callback,
8668 : resolve_omp_udr_callback2, NULL);
8669 797 : *sym1 = sym1_copy;
8670 797 : *sym2 = sym2_copy;
8671 797 : return copy;
8672 : }
8673 :
8674 : /* Assume that a constant expression in the range 1 (omp_default_mem_alloc)
8675 : to GOMP_OMP_PREDEF_ALLOC_MAX, or GOMP_OMPX_PREDEF_ALLOC_MIN to
8676 : GOMP_OMPX_PREDEF_ALLOC_MAX is fine. The original symbol name is already
8677 : lost during matching via gfc_match_expr. */
8678 : static bool
8679 130 : is_predefined_allocator (gfc_expr *expr)
8680 : {
8681 130 : return (gfc_resolve_expr (expr)
8682 129 : && expr->rank == 0
8683 124 : && expr->ts.type == BT_INTEGER
8684 119 : && expr->ts.kind == gfc_c_intptr_kind
8685 114 : && expr->expr_type == EXPR_CONSTANT
8686 239 : && ((mpz_sgn (expr->value.integer) > 0
8687 107 : && mpz_cmp_si (expr->value.integer,
8688 : GOMP_OMP_PREDEF_ALLOC_MAX) <= 0)
8689 4 : || (mpz_cmp_si (expr->value.integer,
8690 : GOMP_OMPX_PREDEF_ALLOC_MIN) >= 0
8691 1 : && mpz_cmp_si (expr->value.integer,
8692 130 : GOMP_OMPX_PREDEF_ALLOC_MAX) <= 0)));
8693 : }
8694 :
8695 : /* Resolve declarative ALLOCATE statement. Note: Common block vars only appear
8696 : as /block/ not individual, which is ensured during parsing. */
8697 :
8698 : void
8699 62 : gfc_resolve_omp_allocate (gfc_namespace *ns, gfc_omp_namelist *list)
8700 : {
8701 278 : for (gfc_omp_namelist *n = list; n; n = n->next)
8702 : {
8703 216 : if (n->sym->attr.result || n->sym->result == n->sym)
8704 : {
8705 1 : gfc_error ("Unexpected function-result variable %qs at %L in "
8706 : "declarative !$OMP ALLOCATE", n->sym->name, &n->where);
8707 31 : continue;
8708 : }
8709 215 : if (ns->omp_allocate->sym->attr.proc_pointer)
8710 : {
8711 0 : gfc_error ("Procedure pointer %qs not supported with !$OMP "
8712 : "ALLOCATE at %L", n->sym->name, &n->where);
8713 0 : continue;
8714 : }
8715 215 : if (n->sym->attr.flavor != FL_VARIABLE)
8716 : {
8717 3 : gfc_error ("Argument %qs at %L to declarative !$OMP ALLOCATE "
8718 : "directive must be a variable", n->sym->name,
8719 : &n->where);
8720 3 : continue;
8721 : }
8722 212 : if (ns != n->sym->ns || n->sym->attr.use_assoc || n->sym->attr.imported)
8723 : {
8724 8 : gfc_error ("Argument %qs at %L to declarative !$OMP ALLOCATE shall be"
8725 : " in the same scope as the variable declaration",
8726 : n->sym->name, &n->where);
8727 8 : continue;
8728 : }
8729 204 : if (n->sym->attr.dummy)
8730 : {
8731 3 : gfc_error ("Unexpected dummy argument %qs as argument at %L to "
8732 : "declarative !$OMP ALLOCATE", n->sym->name, &n->where);
8733 3 : continue;
8734 : }
8735 201 : if (n->sym->attr.codimension)
8736 : {
8737 0 : gfc_error ("Unexpected coarray argument %qs as argument at %L to "
8738 : "declarative !$OMP ALLOCATE", n->sym->name, &n->where);
8739 0 : continue;
8740 : }
8741 201 : if (n->sym->attr.omp_allocate)
8742 : {
8743 5 : if (n->sym->attr.in_common)
8744 : {
8745 1 : gfc_error ("Duplicated common block %</%s/%> in !$OMP ALLOCATE "
8746 1 : "at %L", n->sym->common_head->name, &n->where);
8747 3 : while (n->next && n->next->sym
8748 3 : && n->sym->common_head == n->next->sym->common_head)
8749 : n = n->next;
8750 : }
8751 : else
8752 4 : gfc_error ("Duplicated variable %qs in !$OMP ALLOCATE at %L",
8753 : n->sym->name, &n->where);
8754 5 : continue;
8755 : }
8756 : /* For 'equivalence(a,b)', a 'union_type {<type> a,b} equiv.0' is created
8757 : with a value expression for 'a' as 'equiv.0.a' (likewise for b); while
8758 : this can be handled, EQUIVALENCE is marked as obsolescent since Fortran
8759 : 2018 and also not widely used. However, it could be supported,
8760 : if needed. */
8761 196 : if (n->sym->attr.in_equivalence)
8762 : {
8763 2 : gfc_error ("Sorry, EQUIVALENCE object %qs not supported with !$OMP "
8764 : "ALLOCATE at %L", n->sym->name, &n->where);
8765 2 : continue;
8766 : }
8767 : /* Similar for Cray pointer/pointee - they could be implemented but as
8768 : common vendor extension but nowadays rarely used and requiring
8769 : -fcray-pointer, there is no need to support them. */
8770 194 : if (n->sym->attr.cray_pointer || n->sym->attr.cray_pointee)
8771 : {
8772 2 : gfc_error ("Sorry, Cray pointers and pointees such as %qs are not "
8773 : "supported with !$OMP ALLOCATE at %L",
8774 : n->sym->name, &n->where);
8775 2 : continue;
8776 : }
8777 192 : n->sym->attr.omp_allocate = 1;
8778 192 : if ((n->sym->ts.type == BT_CLASS && n->sym->attr.class_ok
8779 0 : && CLASS_DATA (n->sym)->attr.allocatable)
8780 192 : || (n->sym->ts.type != BT_CLASS && n->sym->attr.allocatable))
8781 1 : gfc_error ("Unexpected allocatable variable %qs at %L in declarative "
8782 : "!$OMP ALLOCATE directive", n->sym->name, &n->where);
8783 191 : else if ((n->sym->ts.type == BT_CLASS && n->sym->attr.class_ok
8784 0 : && CLASS_DATA (n->sym)->attr.class_pointer)
8785 191 : || (n->sym->ts.type != BT_CLASS && n->sym->attr.pointer))
8786 1 : gfc_error ("Unexpected pointer variable %qs at %L in declarative "
8787 : "!$OMP ALLOCATE directive", n->sym->name, &n->where);
8788 192 : HOST_WIDE_INT alignment = 0;
8789 198 : if (n->u.align
8790 192 : && (!gfc_resolve_expr (n->u.align)
8791 27 : || n->u.align->ts.type != BT_INTEGER
8792 26 : || n->u.align->rank != 0
8793 24 : || n->u.align->expr_type != EXPR_CONSTANT
8794 23 : || gfc_extract_hwi (n->u.align, &alignment)
8795 23 : || !pow2p_hwi (alignment)))
8796 : {
8797 6 : gfc_error ("ALIGN requires a scalar positive constant integer "
8798 : "alignment expression at %L that is a power of two",
8799 6 : &n->u.align->where);
8800 6 : while (n->sym->attr.in_common && n->next && n->next->sym
8801 6 : && n->sym->common_head == n->next->sym->common_head)
8802 : n = n->next;
8803 6 : continue;
8804 : }
8805 186 : if (n->sym->attr.in_common || n->sym->attr.save || n->sym->ns->save_all
8806 63 : || (n->sym->ns->proc_name
8807 63 : && (n->sym->ns->proc_name->attr.flavor == FL_PROGRAM
8808 : || n->sym->ns->proc_name->attr.flavor == FL_MODULE
8809 : || n->sym->ns->proc_name->attr.flavor == FL_BLOCK_DATA)))
8810 : {
8811 131 : bool com = n->sym->attr.in_common;
8812 131 : if (!n->u2.allocator)
8813 1 : gfc_error ("An ALLOCATOR clause is required as the list item "
8814 : "%<%s%s%s%> at %L has the SAVE attribute", com ? "/" : "",
8815 0 : com ? n->sym->common_head->name : n->sym->name,
8816 : com ? "/" : "", &n->where);
8817 130 : else if (!is_predefined_allocator (n->u2.allocator))
8818 24 : gfc_error ("Predefined allocator required in ALLOCATOR clause at %L"
8819 : " as the list item %<%s%s%s%> at %L has the SAVE attribute",
8820 24 : &n->u2.allocator->where, com ? "/" : "",
8821 24 : com ? n->sym->common_head->name : n->sym->name,
8822 : com ? "/" : "", &n->where);
8823 : /* Only local static variables might use omp_cgroup_mem_alloc (6),
8824 : omp_pteam_mem_alloc (7), or omp_thread_mem_alloc (8). */
8825 106 : else if ((!ns->proc_name
8826 98 : || ns->proc_name->attr.flavor == FL_PROGRAM
8827 : || ns->proc_name->attr.flavor == FL_BLOCK_DATA
8828 : || ns->proc_name->attr.flavor == FL_MODULE
8829 54 : || com)
8830 74 : && mpz_cmp_si (n->u2.allocator->value.integer,
8831 : 6 /* cgroup */) >= 0
8832 24 : && mpz_cmp_si (n->u2.allocator->value.integer,
8833 : 8 /* thread */) <= 0)
8834 : {
8835 24 : const char *alloc_name[] = {"omp_cgroup_mem_alloc",
8836 : "omp_pteam_mem_alloc",
8837 : "omp_thread_mem_alloc" };
8838 24 : gfc_error ("Predefined allocator %qs in ALLOCATOR clause at %L, "
8839 : "used for list item %<%s%s%s%> at %L, may only be used"
8840 : " for local static variables",
8841 24 : alloc_name[mpz_get_ui (n->u2.allocator->value.integer)
8842 24 : - 6 /* cgroup */], &n->u2.allocator->where,
8843 : com ? "/" : "",
8844 24 : com ? n->sym->common_head->name : n->sym->name,
8845 : com ? "/" : "", &n->where);
8846 : }
8847 67 : while (n->sym->attr.in_common && n->next && n->next->sym
8848 186 : && n->sym->common_head == n->next->sym->common_head)
8849 : n = n->next;
8850 : }
8851 55 : else if (n->u2.allocator
8852 55 : && (!gfc_resolve_expr (n->u2.allocator)
8853 20 : || n->u2.allocator->ts.type != BT_INTEGER
8854 19 : || n->u2.allocator->rank != 0
8855 18 : || n->u2.allocator->ts.kind != gfc_c_intptr_kind))
8856 3 : gfc_error ("Expected integer expression of the "
8857 : "%<omp_allocator_handle_kind%> kind at %L",
8858 3 : &n->u2.allocator->where);
8859 : }
8860 62 : }
8861 :
8862 : /* Resolve ASSUME's and ASSUMES' assumption clauses. Note that absent/contains
8863 : is handled during parse time in omp_verify_merge_absent_contains. */
8864 :
8865 : void
8866 29 : gfc_resolve_omp_assumptions (gfc_omp_assumptions *assume)
8867 : {
8868 46 : for (gfc_expr_list *el = assume->holds; el; el = el->next)
8869 17 : if (!gfc_resolve_expr (el->expr)
8870 17 : || el->expr->ts.type != BT_LOGICAL
8871 32 : || el->expr->rank != 0)
8872 4 : gfc_error ("HOLDS expression at %L must be a scalar logical expression",
8873 4 : &el->expr->where);
8874 29 : }
8875 :
8876 :
8877 : /* OpenMP directive resolving routines. */
8878 :
8879 : static void
8880 32157 : resolve_omp_clauses (gfc_code *code, gfc_omp_clauses *omp_clauses,
8881 : gfc_namespace *ns, bool openacc = false)
8882 : {
8883 32157 : gfc_omp_namelist *n, *last;
8884 32157 : gfc_expr_list *el;
8885 32157 : int list;
8886 32157 : int ifc;
8887 32157 : bool if_without_mod = false;
8888 32157 : gfc_omp_linear_op linear_op = OMP_LINEAR_DEFAULT;
8889 32157 : static const char *clause_names[]
8890 : = { "PRIVATE", "FIRSTPRIVATE", "LASTPRIVATE", "COPYPRIVATE", "SHARED",
8891 : "COPYIN", "UNIFORM", "AFFINITY", "ALIGNED", "LINEAR", "DEPEND", "MAP",
8892 : "TO", "FROM", "INCLUSIVE", "EXCLUSIVE",
8893 : "REDUCTION", "REDUCTION" /*inscan*/, "REDUCTION" /*task*/,
8894 : "IN_REDUCTION", "TASK_REDUCTION",
8895 : "DEVICE_RESIDENT", "LINK", "LOCAL", "USE_DEVICE",
8896 : "CACHE", "IS_DEVICE_PTR", "USE_DEVICE_PTR", "USE_DEVICE_ADDR",
8897 : "NONTEMPORAL", "ALLOCATE", "HAS_DEVICE_ADDR", "ENTER",
8898 : "USES_ALLOCATORS", "INIT", "USE", "DESTROY", "INTEROP", "ADJUST_ARGS" };
8899 32157 : STATIC_ASSERT (ARRAY_SIZE (clause_names) == OMP_LIST_NUM);
8900 :
8901 32157 : if (omp_clauses == NULL)
8902 : return;
8903 :
8904 32157 : if (ns == NULL)
8905 31736 : ns = gfc_current_ns;
8906 :
8907 32157 : if (omp_clauses->orderedc && omp_clauses->orderedc < omp_clauses->collapse)
8908 0 : gfc_error ("ORDERED clause parameter is less than COLLAPSE at %L",
8909 : &code->loc);
8910 32157 : if (omp_clauses->order_concurrent && omp_clauses->ordered)
8911 4 : gfc_error ("ORDER clause must not be used together with ORDERED at %L",
8912 : &code->loc);
8913 32157 : if (omp_clauses->if_expr)
8914 : {
8915 1184 : gfc_expr *expr = omp_clauses->if_expr;
8916 1184 : if (!gfc_resolve_expr (expr)
8917 1184 : || expr->ts.type != BT_LOGICAL || expr->rank != 0)
8918 16 : gfc_error ("IF clause at %L requires a scalar LOGICAL expression",
8919 : &expr->where);
8920 : if_without_mod = true;
8921 : }
8922 353727 : for (ifc = 0; ifc < OMP_IF_LAST; ifc++)
8923 321570 : if (omp_clauses->if_exprs[ifc])
8924 : {
8925 137 : gfc_expr *expr = omp_clauses->if_exprs[ifc];
8926 137 : bool ok = true;
8927 137 : if (!gfc_resolve_expr (expr)
8928 137 : || expr->ts.type != BT_LOGICAL || expr->rank != 0)
8929 0 : gfc_error ("IF clause at %L requires a scalar LOGICAL expression",
8930 : &expr->where);
8931 137 : else if (if_without_mod)
8932 : {
8933 1 : gfc_error ("IF clause without modifier at %L used together with "
8934 : "IF clauses with modifiers",
8935 1 : &omp_clauses->if_expr->where);
8936 1 : if_without_mod = false;
8937 : }
8938 : else
8939 136 : switch (code->op)
8940 : {
8941 13 : case EXEC_OMP_CANCEL:
8942 13 : ok = ifc == OMP_IF_CANCEL;
8943 13 : break;
8944 :
8945 16 : case EXEC_OMP_PARALLEL:
8946 16 : case EXEC_OMP_PARALLEL_DO:
8947 16 : case EXEC_OMP_PARALLEL_LOOP:
8948 16 : case EXEC_OMP_PARALLEL_MASKED:
8949 16 : case EXEC_OMP_PARALLEL_MASTER:
8950 16 : case EXEC_OMP_PARALLEL_SECTIONS:
8951 16 : case EXEC_OMP_PARALLEL_WORKSHARE:
8952 16 : case EXEC_OMP_DISTRIBUTE_PARALLEL_DO:
8953 16 : case EXEC_OMP_TEAMS_DISTRIBUTE_PARALLEL_DO:
8954 16 : ok = ifc == OMP_IF_PARALLEL;
8955 16 : break;
8956 :
8957 28 : case EXEC_OMP_PARALLEL_DO_SIMD:
8958 28 : case EXEC_OMP_DISTRIBUTE_PARALLEL_DO_SIMD:
8959 28 : case EXEC_OMP_TEAMS_DISTRIBUTE_PARALLEL_DO_SIMD:
8960 28 : ok = ifc == OMP_IF_PARALLEL || ifc == OMP_IF_SIMD;
8961 28 : break;
8962 :
8963 8 : case EXEC_OMP_PARALLEL_MASKED_TASKLOOP:
8964 8 : case EXEC_OMP_PARALLEL_MASTER_TASKLOOP:
8965 8 : ok = ifc == OMP_IF_PARALLEL || ifc == OMP_IF_TASKLOOP;
8966 8 : break;
8967 :
8968 12 : case EXEC_OMP_PARALLEL_MASKED_TASKLOOP_SIMD:
8969 12 : case EXEC_OMP_PARALLEL_MASTER_TASKLOOP_SIMD:
8970 12 : ok = (ifc == OMP_IF_PARALLEL
8971 12 : || ifc == OMP_IF_TASKLOOP
8972 : || ifc == OMP_IF_SIMD);
8973 : break;
8974 :
8975 0 : case EXEC_OMP_SIMD:
8976 0 : case EXEC_OMP_DO_SIMD:
8977 0 : case EXEC_OMP_DISTRIBUTE_SIMD:
8978 0 : case EXEC_OMP_TEAMS_DISTRIBUTE_SIMD:
8979 0 : ok = ifc == OMP_IF_SIMD;
8980 0 : break;
8981 :
8982 1 : case EXEC_OMP_TASK:
8983 1 : ok = ifc == OMP_IF_TASK;
8984 1 : break;
8985 :
8986 5 : case EXEC_OMP_TASKLOOP:
8987 5 : case EXEC_OMP_MASKED_TASKLOOP:
8988 5 : case EXEC_OMP_MASTER_TASKLOOP:
8989 5 : ok = ifc == OMP_IF_TASKLOOP;
8990 5 : break;
8991 :
8992 20 : case EXEC_OMP_TASKLOOP_SIMD:
8993 20 : case EXEC_OMP_MASKED_TASKLOOP_SIMD:
8994 20 : case EXEC_OMP_MASTER_TASKLOOP_SIMD:
8995 20 : ok = ifc == OMP_IF_TASKLOOP || ifc == OMP_IF_SIMD;
8996 20 : break;
8997 :
8998 5 : case EXEC_OMP_TARGET:
8999 5 : case EXEC_OMP_TARGET_TEAMS:
9000 5 : case EXEC_OMP_TARGET_TEAMS_DISTRIBUTE:
9001 5 : case EXEC_OMP_TARGET_TEAMS_LOOP:
9002 5 : ok = ifc == OMP_IF_TARGET;
9003 5 : break;
9004 :
9005 4 : case EXEC_OMP_TARGET_TEAMS_DISTRIBUTE_SIMD:
9006 4 : case EXEC_OMP_TARGET_SIMD:
9007 4 : ok = ifc == OMP_IF_TARGET || ifc == OMP_IF_SIMD;
9008 4 : break;
9009 :
9010 1 : case EXEC_OMP_TARGET_DATA:
9011 1 : ok = ifc == OMP_IF_TARGET_DATA;
9012 1 : break;
9013 :
9014 1 : case EXEC_OMP_TARGET_UPDATE:
9015 1 : ok = ifc == OMP_IF_TARGET_UPDATE;
9016 1 : break;
9017 :
9018 1 : case EXEC_OMP_TARGET_ENTER_DATA:
9019 1 : ok = ifc == OMP_IF_TARGET_ENTER_DATA;
9020 1 : break;
9021 :
9022 1 : case EXEC_OMP_TARGET_EXIT_DATA:
9023 1 : ok = ifc == OMP_IF_TARGET_EXIT_DATA;
9024 1 : break;
9025 :
9026 10 : case EXEC_OMP_TARGET_TEAMS_DISTRIBUTE_PARALLEL_DO:
9027 10 : case EXEC_OMP_TARGET_PARALLEL:
9028 10 : case EXEC_OMP_TARGET_PARALLEL_DO:
9029 10 : case EXEC_OMP_TARGET_PARALLEL_LOOP:
9030 10 : ok = ifc == OMP_IF_TARGET || ifc == OMP_IF_PARALLEL;
9031 10 : break;
9032 :
9033 10 : case EXEC_OMP_TARGET_PARALLEL_DO_SIMD:
9034 10 : case EXEC_OMP_TARGET_TEAMS_DISTRIBUTE_PARALLEL_DO_SIMD:
9035 10 : ok = (ifc == OMP_IF_TARGET
9036 10 : || ifc == OMP_IF_PARALLEL
9037 : || ifc == OMP_IF_SIMD);
9038 : break;
9039 :
9040 : default:
9041 : ok = false;
9042 : break;
9043 : }
9044 115 : if (!ok)
9045 : {
9046 2 : static const char *ifs[] = {
9047 : "CANCEL",
9048 : "PARALLEL",
9049 : "SIMD",
9050 : "TASK",
9051 : "TASKLOOP",
9052 : "TARGET",
9053 : "TARGET DATA",
9054 : "TARGET UPDATE",
9055 : "TARGET ENTER DATA",
9056 : "TARGET EXIT DATA"
9057 : };
9058 2 : gfc_error ("IF clause modifier %s at %L not appropriate for "
9059 : "the current OpenMP construct", ifs[ifc], &expr->where);
9060 : }
9061 : }
9062 :
9063 32157 : if (omp_clauses->self_expr)
9064 : {
9065 177 : gfc_expr *expr = omp_clauses->self_expr;
9066 177 : if (!gfc_resolve_expr (expr)
9067 177 : || expr->ts.type != BT_LOGICAL || expr->rank != 0)
9068 6 : gfc_error ("SELF clause at %L requires a scalar LOGICAL expression",
9069 : &expr->where);
9070 : }
9071 :
9072 32157 : if (omp_clauses->final_expr)
9073 : {
9074 64 : gfc_expr *expr = omp_clauses->final_expr;
9075 64 : if (!gfc_resolve_expr (expr)
9076 64 : || expr->ts.type != BT_LOGICAL || expr->rank != 0)
9077 0 : gfc_error ("FINAL clause at %L requires a scalar LOGICAL expression",
9078 : &expr->where);
9079 : }
9080 32157 : if (omp_clauses->novariants)
9081 : {
9082 9 : gfc_expr *expr = omp_clauses->novariants;
9083 18 : if (!gfc_resolve_expr (expr) || expr->ts.type != BT_LOGICAL
9084 17 : || expr->rank != 0)
9085 1 : gfc_error (
9086 : "NOVARIANTS clause at %L requires a scalar LOGICAL expression",
9087 : &expr->where);
9088 32157 : if_without_mod = true;
9089 : }
9090 32157 : if (omp_clauses->nocontext)
9091 : {
9092 12 : gfc_expr *expr = omp_clauses->nocontext;
9093 24 : if (!gfc_resolve_expr (expr) || expr->ts.type != BT_LOGICAL
9094 23 : || expr->rank != 0)
9095 1 : gfc_error (
9096 : "NOCONTEXT clause at %L requires a scalar LOGICAL expression",
9097 : &expr->where);
9098 32157 : if_without_mod = true;
9099 : }
9100 32157 : if (omp_clauses->num_threads)
9101 950 : resolve_positive_int_expr (omp_clauses->num_threads, "NUM_THREADS");
9102 32157 : if (omp_clauses->dyn_groupprivate)
9103 10 : resolve_nonnegative_int_expr (omp_clauses->dyn_groupprivate,
9104 : "DYN_GROUPPRIVATE");
9105 32157 : if (omp_clauses->chunk_size)
9106 : {
9107 510 : gfc_expr *expr = omp_clauses->chunk_size;
9108 510 : if (!gfc_resolve_expr (expr)
9109 510 : || expr->ts.type != BT_INTEGER || expr->rank != 0)
9110 0 : gfc_error ("SCHEDULE clause's chunk_size at %L requires "
9111 : "a scalar INTEGER expression", &expr->where);
9112 510 : else if (expr->expr_type == EXPR_CONSTANT
9113 : && expr->ts.type == BT_INTEGER
9114 485 : && mpz_sgn (expr->value.integer) <= 0)
9115 2 : gfc_warning (OPT_Wopenmp, "INTEGER expression of SCHEDULE clause's "
9116 : "chunk_size at %L must be positive", &expr->where);
9117 : }
9118 32157 : if (omp_clauses->sched_kind != OMP_SCHED_NONE
9119 891 : && omp_clauses->sched_nonmonotonic)
9120 : {
9121 34 : if (omp_clauses->sched_monotonic)
9122 2 : gfc_error ("Both MONOTONIC and NONMONOTONIC schedule modifiers "
9123 : "specified at %L", &code->loc);
9124 32 : else if (omp_clauses->ordered)
9125 4 : gfc_error ("NONMONOTONIC schedule modifier specified with ORDERED "
9126 : "clause at %L", &code->loc);
9127 : }
9128 :
9129 32157 : if (omp_clauses->depobj
9130 32157 : && (!gfc_resolve_expr (omp_clauses->depobj)
9131 115 : || omp_clauses->depobj->ts.type != BT_INTEGER
9132 114 : || omp_clauses->depobj->ts.kind != 2 * gfc_index_integer_kind
9133 113 : || omp_clauses->depobj->rank != 0))
9134 4 : gfc_error ("DEPOBJ in DEPOBJ construct at %L shall be a scalar integer "
9135 4 : "of OMP_DEPEND_KIND kind", &omp_clauses->depobj->where);
9136 :
9137 : /* Check that no symbol appears on multiple clauses, except that
9138 : a symbol can appear on both firstprivate and lastprivate. */
9139 1286280 : for (list = 0; list < OMP_LIST_NUM; list++)
9140 1299004 : for (n = omp_clauses->lists[list]; n; n = n->next)
9141 : {
9142 44881 : if (!n->sym) /* omp_all_memory. */
9143 47 : continue;
9144 44834 : n->sym->mark = 0;
9145 44834 : n->sym->comp_mark = 0;
9146 44834 : n->sym->data_mark = 0;
9147 44834 : n->sym->dev_mark = 0;
9148 44834 : n->sym->gen_mark = 0;
9149 44834 : n->sym->reduc_mark = 0;
9150 44834 : if (n->sym->attr.flavor == FL_VARIABLE
9151 274 : || n->sym->attr.proc_pointer
9152 233 : || (!code && (!n->sym->attr.dummy || n->sym->ns != ns)))
9153 : {
9154 44601 : if (!code && (!n->sym->attr.dummy || n->sym->ns != ns))
9155 0 : gfc_error ("Variable %qs is not a dummy argument at %L",
9156 : n->sym->name, &n->where);
9157 44601 : continue;
9158 : }
9159 233 : if (n->sym->attr.flavor == FL_PROCEDURE
9160 153 : && n->sym->result == n->sym
9161 138 : && n->sym->attr.function)
9162 : {
9163 138 : if (ns->proc_name == n->sym
9164 44 : || (ns->parent && ns->parent->proc_name == n->sym))
9165 101 : continue;
9166 37 : if (ns->proc_name->attr.entry_master)
9167 : {
9168 32 : gfc_entry_list *el = ns->entries;
9169 51 : for (; el; el = el->next)
9170 51 : if (el->sym == n->sym)
9171 : break;
9172 32 : if (el)
9173 32 : continue;
9174 : }
9175 5 : if (ns->parent
9176 3 : && ns->parent->proc_name->attr.entry_master)
9177 : {
9178 2 : gfc_entry_list *el = ns->parent->entries;
9179 3 : for (; el; el = el->next)
9180 3 : if (el->sym == n->sym)
9181 : break;
9182 2 : if (el)
9183 2 : continue;
9184 : }
9185 : }
9186 98 : if (list == OMP_LIST_MAP
9187 18 : && n->sym->attr.flavor == FL_PARAMETER)
9188 : {
9189 : /* OpenACC since 3.4 permits for Fortran named constants, but
9190 : permits removing then as optimization is not needed and such
9191 : ignore them. Likewise below for FIRSTPRIVATE. */
9192 12 : if (openacc)
9193 10 : gfc_warning (OPT_Wsurprising, "Clause for object %qs at %L is "
9194 : "ignored as parameters need not be copied",
9195 : n->sym->name, &n->where);
9196 : else
9197 2 : gfc_error ("Object %qs is not a variable at %L; parameters"
9198 : " cannot be and need not be mapped", n->sym->name,
9199 : &n->where);
9200 : }
9201 86 : else if (openacc && n->sym->attr.flavor == FL_PARAMETER)
9202 9 : gfc_warning (OPT_Wsurprising, "Clause for object %qs at %L is ignored"
9203 : " as it is a parameter", n->sym->name, &n->where);
9204 77 : else if (list != OMP_LIST_USES_ALLOCATORS)
9205 30 : gfc_error ("Object %qs is not a variable at %L", n->sym->name,
9206 : &n->where);
9207 : }
9208 32157 : if (omp_clauses->lists[OMP_LIST_REDUCTION_INSCAN])
9209 : {
9210 69 : locus *loc = &omp_clauses->lists[OMP_LIST_REDUCTION_INSCAN]->where;
9211 69 : if (code->op != EXEC_OMP_DO
9212 : && code->op != EXEC_OMP_SIMD
9213 : && code->op != EXEC_OMP_DO_SIMD
9214 : && code->op != EXEC_OMP_PARALLEL_DO
9215 : && code->op != EXEC_OMP_PARALLEL_DO_SIMD)
9216 23 : gfc_error ("%<inscan%> REDUCTION clause on construct other than DO, "
9217 : "SIMD, DO SIMD, PARALLEL DO, PARALLEL DO SIMD at %L",
9218 : loc);
9219 69 : if (omp_clauses->ordered)
9220 2 : gfc_error ("ORDERED clause specified together with %<inscan%> "
9221 : "REDUCTION clause at %L", loc);
9222 69 : if (omp_clauses->sched_kind != OMP_SCHED_NONE)
9223 3 : gfc_error ("SCHEDULE clause specified together with %<inscan%> "
9224 : "REDUCTION clause at %L", loc);
9225 : }
9226 :
9227 1286280 : for (list = 0; list < OMP_LIST_NUM; list++)
9228 1254123 : if (list != OMP_LIST_FIRSTPRIVATE
9229 1254123 : && list != OMP_LIST_LASTPRIVATE
9230 1254123 : && list != OMP_LIST_ALIGNED
9231 1157652 : && list != OMP_LIST_DEPEND
9232 1157652 : && list != OMP_LIST_FROM
9233 1093338 : && list != OMP_LIST_TO
9234 1093338 : && list != OMP_LIST_INTEROP
9235 1029024 : && (list != OMP_LIST_REDUCTION || !openacc)
9236 1016407 : && list != OMP_LIST_ALLOCATE)
9237 1018351 : for (n = omp_clauses->lists[list]; n; n = n->next)
9238 : {
9239 34101 : bool component_ref_p = false;
9240 :
9241 : /* Allow multiple components of the same (e.g. derived-type)
9242 : variable here. Duplicate components are detected elsewhere. */
9243 34101 : if (n->expr && n->expr->expr_type == EXPR_VARIABLE)
9244 15378 : for (gfc_ref *ref = n->expr->ref; ref; ref = ref->next)
9245 9379 : if (ref->type == REF_COMPONENT)
9246 3134 : component_ref_p = true;
9247 34101 : if ((list == OMP_LIST_IS_DEVICE_PTR
9248 34101 : || list == OMP_LIST_HAS_DEVICE_ADDR)
9249 313 : && !component_ref_p)
9250 : {
9251 313 : if (n->sym->gen_mark
9252 311 : || n->sym->dev_mark
9253 310 : || n->sym->reduc_mark
9254 310 : || n->sym->mark)
9255 5 : gfc_error ("Symbol %qs present on multiple clauses at %L",
9256 : n->sym->name, &n->where);
9257 : else
9258 308 : n->sym->dev_mark = 1;
9259 : }
9260 33788 : else if ((list == OMP_LIST_USE_DEVICE_PTR
9261 33788 : || list == OMP_LIST_USE_DEVICE_ADDR
9262 33788 : || list == OMP_LIST_PRIVATE
9263 : || list == OMP_LIST_SHARED)
9264 12817 : && !component_ref_p)
9265 : {
9266 12817 : if (n->sym->gen_mark || n->sym->dev_mark || n->sym->reduc_mark)
9267 13 : gfc_error ("Symbol %qs present on multiple clauses at %L",
9268 : n->sym->name, &n->where);
9269 : else
9270 : {
9271 12804 : n->sym->gen_mark = 1;
9272 : /* Set both generic and device bits if we have
9273 : use_device_*(x) or shared(x). This allows us to diagnose
9274 : "map(x) private(x)" below. */
9275 12804 : if (list != OMP_LIST_PRIVATE)
9276 3438 : n->sym->dev_mark = 1;
9277 : }
9278 : }
9279 20971 : else if ((list == OMP_LIST_REDUCTION
9280 20971 : || list == OMP_LIST_REDUCTION_TASK
9281 18515 : || list == OMP_LIST_REDUCTION_INSCAN
9282 18515 : || list == OMP_LIST_IN_REDUCTION
9283 18302 : || list == OMP_LIST_TASK_REDUCTION)
9284 2669 : && !component_ref_p)
9285 : {
9286 : /* Attempts to mix reduction types are diagnosed below. */
9287 2669 : if (n->sym->gen_mark || n->sym->dev_mark)
9288 2 : gfc_error ("Symbol %qs present on multiple clauses at %L",
9289 : n->sym->name, &n->where);
9290 2669 : n->sym->reduc_mark = 1;
9291 : }
9292 18302 : else if ((!component_ref_p && n->sym->comp_mark)
9293 2451 : || (component_ref_p && n->sym->mark))
9294 : {
9295 28 : if (openacc)
9296 3 : gfc_error ("Symbol %qs has mixed component and non-component "
9297 3 : "accesses at %L", n->sym->name, &n->where);
9298 : }
9299 18274 : else if (n->sym->mark)
9300 89 : gfc_error ("Symbol %qs present on multiple clauses at %L",
9301 : n->sym->name, &n->where);
9302 : else
9303 : {
9304 18185 : if (component_ref_p)
9305 2424 : n->sym->comp_mark = 1;
9306 : else
9307 15761 : n->sym->mark = 1;
9308 : }
9309 : }
9310 :
9311 32157 : if (code
9312 31939 : && code->op == EXEC_OMP_INTEROP
9313 63 : && omp_clauses->lists[OMP_LIST_DEPEND])
9314 : {
9315 12 : if (!omp_clauses->lists[OMP_LIST_INIT]
9316 5 : && !omp_clauses->lists[OMP_LIST_USE]
9317 1 : && !omp_clauses->lists[OMP_LIST_DESTROY])
9318 : {
9319 1 : gfc_error ("DEPEND clause at %L requires action clause with "
9320 : "%<targetsync%> interop-type",
9321 : &omp_clauses->lists[OMP_LIST_DEPEND]->where);
9322 : }
9323 22 : for (n = omp_clauses->lists[OMP_LIST_INIT]; n; n = n->next)
9324 12 : if (!n->u.init.targetsync)
9325 : {
9326 2 : gfc_error ("DEPEND clause at %L requires %<targetsync%> "
9327 : "interop-type, lacking it for %qs at %L",
9328 2 : &omp_clauses->lists[OMP_LIST_DEPEND]->where,
9329 2 : n->sym->name, &n->where);
9330 2 : break;
9331 : }
9332 : }
9333 31939 : if (code && (code->op == EXEC_OMP_INTEROP || code->op == EXEC_OMP_DISPATCH))
9334 1085 : for (list = OMP_LIST_INIT; list <= OMP_LIST_INTEROP; list++)
9335 1123 : for (n = omp_clauses->lists[list]; n; n = n->next)
9336 : {
9337 255 : if (n->sym->ts.type != BT_INTEGER
9338 252 : || n->sym->ts.kind != gfc_index_integer_kind
9339 248 : || n->sym->attr.dimension
9340 243 : || n->sym->attr.flavor != FL_VARIABLE)
9341 16 : gfc_error ("%qs at %L in %qs clause must be a scalar integer "
9342 : "variable of %<omp_interop_kind%> kind", n->sym->name,
9343 : &n->where, clause_names[list]);
9344 255 : if (list != OMP_LIST_USE && list != OMP_LIST_INTEROP
9345 109 : && n->sym->attr.intent == INTENT_IN)
9346 2 : gfc_error ("%qs at %L in %qs clause must be definable",
9347 : n->sym->name, &n->where, clause_names[list]);
9348 : }
9349 :
9350 : /* Detect specifically the case where we have "map(x) private(x)" and raise
9351 : an error. If we have "...simd" combined directives though, the "private"
9352 : applies to the simd part, so this is permitted though. */
9353 41531 : for (n = omp_clauses->lists[OMP_LIST_PRIVATE]; n; n = n->next)
9354 9374 : if (n->sym->mark
9355 6 : && n->sym->gen_mark
9356 6 : && !n->sym->dev_mark
9357 6 : && !n->sym->reduc_mark
9358 5 : && code->op != EXEC_OMP_TARGET_SIMD
9359 : && code->op != EXEC_OMP_TARGET_PARALLEL_DO_SIMD
9360 : && code->op != EXEC_OMP_TARGET_TEAMS_DISTRIBUTE_SIMD
9361 : && code->op != EXEC_OMP_TARGET_TEAMS_DISTRIBUTE_PARALLEL_DO_SIMD)
9362 1 : gfc_error ("Symbol %qs present on multiple clauses at %L",
9363 : n->sym->name, &n->where);
9364 :
9365 : gcc_assert (OMP_LIST_LASTPRIVATE == OMP_LIST_FIRSTPRIVATE + 1);
9366 96471 : for (list = OMP_LIST_FIRSTPRIVATE; list <= OMP_LIST_LASTPRIVATE; list++)
9367 68432 : for (n = omp_clauses->lists[list]; n; n = n->next)
9368 4118 : if (n->sym->data_mark || n->sym->gen_mark || n->sym->dev_mark)
9369 : {
9370 9 : gfc_error ("Symbol %qs present on multiple clauses at %L",
9371 : n->sym->name, &n->where);
9372 9 : n->sym->data_mark = n->sym->gen_mark = n->sym->dev_mark = 0;
9373 : }
9374 4109 : else if (n->sym->mark
9375 17 : && code->op != EXEC_OMP_TARGET_TEAMS
9376 : && code->op != EXEC_OMP_TARGET_TEAMS_DISTRIBUTE
9377 : && code->op != EXEC_OMP_TARGET_TEAMS_LOOP
9378 : && code->op != EXEC_OMP_TARGET_TEAMS_DISTRIBUTE_SIMD
9379 : && code->op != EXEC_OMP_TARGET_TEAMS_DISTRIBUTE_PARALLEL_DO
9380 : && code->op != EXEC_OMP_TARGET_PARALLEL
9381 : && code->op != EXEC_OMP_TARGET_PARALLEL_DO
9382 : && code->op != EXEC_OMP_TARGET_PARALLEL_LOOP
9383 : && code->op != EXEC_OMP_TARGET_PARALLEL_DO_SIMD
9384 : && code->op != EXEC_OMP_TARGET_TEAMS_DISTRIBUTE_PARALLEL_DO_SIMD)
9385 6 : gfc_error ("Symbol %qs present on both data and map clauses "
9386 : "at %L", n->sym->name, &n->where);
9387 :
9388 33969 : for (n = omp_clauses->lists[OMP_LIST_FIRSTPRIVATE]; n; n = n->next)
9389 : {
9390 1812 : if (n->sym->data_mark || n->sym->gen_mark || n->sym->dev_mark)
9391 7 : gfc_error ("Symbol %qs present on multiple clauses at %L",
9392 : n->sym->name, &n->where);
9393 : else
9394 1805 : n->sym->data_mark = 1;
9395 : }
9396 34463 : for (n = omp_clauses->lists[OMP_LIST_LASTPRIVATE]; n; n = n->next)
9397 2306 : n->sym->data_mark = 0;
9398 :
9399 34463 : for (n = omp_clauses->lists[OMP_LIST_LASTPRIVATE]; n; n = n->next)
9400 : {
9401 2306 : if (n->sym->data_mark || n->sym->gen_mark || n->sym->dev_mark)
9402 0 : gfc_error ("Symbol %qs present on multiple clauses at %L",
9403 : n->sym->name, &n->where);
9404 : else
9405 2306 : n->sym->data_mark = 1;
9406 : }
9407 :
9408 32307 : for (n = omp_clauses->lists[OMP_LIST_ALIGNED]; n; n = n->next)
9409 150 : n->sym->mark = 0;
9410 :
9411 32307 : for (n = omp_clauses->lists[OMP_LIST_ALIGNED]; n; n = n->next)
9412 : {
9413 150 : if (n->sym->mark)
9414 0 : gfc_error ("Symbol %qs present on multiple clauses at %L",
9415 : n->sym->name, &n->where);
9416 : else
9417 150 : n->sym->mark = 1;
9418 : }
9419 :
9420 32157 : if (omp_clauses->lists[OMP_LIST_ALLOCATE])
9421 : {
9422 791 : for (n = omp_clauses->lists[OMP_LIST_ALLOCATE]; n; n = n->next)
9423 : {
9424 513 : if (n->u2.allocator
9425 513 : && (!gfc_resolve_expr (n->u2.allocator)
9426 288 : || n->u2.allocator->ts.type != BT_INTEGER
9427 286 : || n->u2.allocator->rank != 0
9428 285 : || n->u2.allocator->ts.kind != gfc_c_intptr_kind))
9429 : {
9430 8 : gfc_error ("Expected integer expression of the "
9431 : "%<omp_allocator_handle_kind%> kind at %L",
9432 8 : &n->u2.allocator->where);
9433 28 : break;
9434 : }
9435 505 : if (!n->u.align)
9436 397 : continue;
9437 108 : HOST_WIDE_INT alignment = 0;
9438 108 : if (!gfc_resolve_expr (n->u.align)
9439 108 : || n->u.align->ts.type != BT_INTEGER
9440 105 : || n->u.align->rank != 0
9441 102 : || n->u.align->expr_type != EXPR_CONSTANT
9442 99 : || gfc_extract_hwi (n->u.align, &alignment)
9443 99 : || alignment <= 0
9444 207 : || !pow2p_hwi (alignment))
9445 : {
9446 12 : gfc_error ("ALIGN requires a scalar positive constant integer "
9447 : "alignment expression at %L that is a power of two",
9448 12 : &n->u.align->where);
9449 12 : break;
9450 : }
9451 : }
9452 :
9453 : /* Check for 2 things here.
9454 : 1. There is no duplication of variable in allocate clause.
9455 : 2. Variable in allocate clause are also present in some
9456 : privatization clase (non-composite case). */
9457 811 : for (n = omp_clauses->lists[OMP_LIST_ALLOCATE]; n; n = n->next)
9458 513 : if (n->sym)
9459 487 : n->sym->mark = 0;
9460 :
9461 : gfc_omp_namelist *prev = NULL;
9462 811 : for (n = omp_clauses->lists[OMP_LIST_ALLOCATE]; n; )
9463 : {
9464 513 : if (n->sym == NULL)
9465 : {
9466 26 : n = n->next;
9467 26 : continue;
9468 : }
9469 487 : if (n->sym->mark == 1)
9470 : {
9471 3 : gfc_warning (OPT_Wopenmp, "%qs appears more than once in "
9472 : "%<allocate%> at %L" , n->sym->name, &n->where);
9473 : /* We have already seen this variable so it is a duplicate.
9474 : Remove it. */
9475 3 : if (prev != NULL && prev->next == n)
9476 : {
9477 3 : prev->next = n->next;
9478 3 : n->next = NULL;
9479 3 : gfc_free_omp_namelist (n, false, true, false, false);
9480 3 : n = prev->next;
9481 : }
9482 3 : continue;
9483 : }
9484 484 : n->sym->mark = 1;
9485 484 : prev = n;
9486 484 : n = n->next;
9487 : }
9488 :
9489 : /* Non-composite constructs. */
9490 298 : if (code && code->op < EXEC_OMP_DO_SIMD)
9491 : {
9492 4760 : for (list = 0; list < OMP_LIST_NUM; list++)
9493 4641 : switch (list)
9494 : {
9495 1071 : case OMP_LIST_PRIVATE:
9496 1071 : case OMP_LIST_FIRSTPRIVATE:
9497 1071 : case OMP_LIST_LASTPRIVATE:
9498 1071 : case OMP_LIST_REDUCTION:
9499 1071 : case OMP_LIST_REDUCTION_INSCAN:
9500 1071 : case OMP_LIST_REDUCTION_TASK:
9501 1071 : case OMP_LIST_IN_REDUCTION:
9502 1071 : case OMP_LIST_TASK_REDUCTION:
9503 1071 : case OMP_LIST_LINEAR:
9504 1370 : for (n = omp_clauses->lists[list]; n; n = n->next)
9505 299 : n->sym->mark = 0;
9506 : break;
9507 : default:
9508 : break;
9509 : }
9510 :
9511 410 : for (n = omp_clauses->lists[OMP_LIST_ALLOCATE]; n; n = n->next)
9512 291 : if (n->sym->mark == 1)
9513 4 : gfc_error ("%qs specified in %<allocate%> clause at %L but not "
9514 : "in an explicit privatization clause",
9515 : n->sym->name, &n->where);
9516 : }
9517 : if (code
9518 298 : && (code->op == EXEC_OMP_ALLOCATORS || code->op == EXEC_OMP_ALLOCATE)
9519 73 : && code->block
9520 72 : && code->block->next
9521 71 : && code->block->next->op == EXEC_ALLOCATE)
9522 : {
9523 68 : if (code->op == EXEC_OMP_ALLOCATE)
9524 49 : gfc_warning (OPT_Wdeprecated_openmp,
9525 : "The use of one or more %<allocate%> directives with "
9526 : "an associated %<allocate%> statement at %L is "
9527 : "deprecated since OpenMP 5.2, use an %<allocators%> "
9528 : "directive", &code->loc);
9529 68 : gfc_alloc *a;
9530 68 : gfc_omp_namelist *n_null = NULL;
9531 68 : bool missing_allocator = false;
9532 68 : gfc_symbol *missing_allocator_sym = NULL;
9533 161 : for (n = omp_clauses->lists[OMP_LIST_ALLOCATE]; n; n = n->next)
9534 : {
9535 93 : if (n->u2.allocator == NULL)
9536 : {
9537 77 : if (!missing_allocator_sym)
9538 59 : missing_allocator_sym = n->sym;
9539 : missing_allocator = true;
9540 : }
9541 93 : if (n->sym == NULL)
9542 : {
9543 26 : n_null = n;
9544 26 : continue;
9545 : }
9546 67 : if (n->sym->attr.codimension)
9547 2 : gfc_error ("Unexpected coarray %qs in %<allocate%> at %L",
9548 : n->sym->name, &n->where);
9549 103 : for (a = code->block->next->ext.alloc.list; a; a = a->next)
9550 101 : if (a->expr->expr_type == EXPR_VARIABLE
9551 101 : && a->expr->symtree->n.sym == n->sym)
9552 : {
9553 65 : gfc_ref *ref;
9554 82 : for (ref = a->expr->ref; ref; ref = ref->next)
9555 17 : if (ref->type == REF_COMPONENT)
9556 : break;
9557 : if (ref == NULL)
9558 : break;
9559 : }
9560 67 : if (a == NULL)
9561 2 : gfc_error ("%qs specified in %<allocate%> at %L but not "
9562 : "in the associated ALLOCATE statement",
9563 2 : n->sym->name, &n->where);
9564 : }
9565 : /* If there is an ALLOCATE directive without list argument, a
9566 : namelist with its allocator/align clauses and n->sym = NULL is
9567 : created during parsing; here, we add all not otherwise specified
9568 : items from the Fortran allocate to that list.
9569 : For an ALLOCATORS directive, not listed items use the normal
9570 : Fortran way.
9571 : The behavior of an ALLOCATE directive that does not list all
9572 : arguments but there is no directive without list argument is not
9573 : well specified. Thus, we reject such code below. In OpenMP 5.2
9574 : the executable ALLOCATE directive is deprecated and in 6.0
9575 : deleted such that no spec clarification is to be expected. */
9576 125 : for (a = code->block->next->ext.alloc.list; a; a = a->next)
9577 89 : if (a->expr->expr_type == EXPR_VARIABLE)
9578 : {
9579 154 : for (n = omp_clauses->lists[OMP_LIST_ALLOCATE]; n; n = n->next)
9580 122 : if (a->expr->symtree->n.sym == n->sym)
9581 : {
9582 57 : gfc_ref *ref;
9583 72 : for (ref = a->expr->ref; ref; ref = ref->next)
9584 15 : if (ref->type == REF_COMPONENT)
9585 : break;
9586 : if (ref == NULL)
9587 : break;
9588 : }
9589 89 : if (n == NULL && n_null == NULL)
9590 : {
9591 : /* OK for ALLOCATORS but for ALLOCATE: Unspecified whether
9592 : that should use the default allocator of OpenMP or the
9593 : Fortran allocator. Thus, just reject it. */
9594 7 : if (code->op == EXEC_OMP_ALLOCATE)
9595 1 : gfc_error ("%qs listed in %<allocate%> statement at %L "
9596 : "but it is neither explicitly in listed in "
9597 : "the %<!$OMP ALLOCATE%> directive nor exists"
9598 : " a directive without argument list",
9599 1 : a->expr->symtree->n.sym->name,
9600 : &a->expr->where);
9601 : break;
9602 : }
9603 82 : if (n == NULL)
9604 : {
9605 25 : if (a->expr->symtree->n.sym->attr.codimension)
9606 1 : gfc_error ("Unexpected coarray %qs in %<allocate%> at "
9607 : "%L, implicitly listed in %<!$OMP ALLOCATE%>"
9608 : " at %L", a->expr->symtree->n.sym->name,
9609 : &a->expr->where, &n_null->where);
9610 : break;
9611 : }
9612 : }
9613 68 : gfc_namespace *prog_unit = ns;
9614 87 : while (prog_unit->parent)
9615 : prog_unit = prog_unit->parent;
9616 : gfc_namespace *fn_ns = ns;
9617 72 : while (fn_ns)
9618 : {
9619 70 : if (ns->proc_name
9620 70 : && (ns->proc_name->attr.subroutine
9621 6 : || ns->proc_name->attr.function))
9622 : break;
9623 4 : fn_ns = fn_ns->parent;
9624 : }
9625 68 : if (missing_allocator
9626 58 : && !(prog_unit->omp_requires & OMP_REQ_DYNAMIC_ALLOCATORS)
9627 58 : && ((fn_ns && fn_ns->proc_name->attr.omp_declare_target)
9628 55 : || omp_clauses->contained_in_target_construct))
9629 : {
9630 6 : if (code->op == EXEC_OMP_ALLOCATORS)
9631 2 : gfc_error ("ALLOCATORS directive at %L inside a target region "
9632 : "must specify an ALLOCATOR modifier for %qs",
9633 : &code->loc, missing_allocator_sym->name);
9634 4 : else if (missing_allocator_sym)
9635 2 : gfc_error ("ALLOCATE directive at %L inside a target region "
9636 : "must specify an ALLOCATOR clause for %qs",
9637 : &code->loc, missing_allocator_sym->name);
9638 : else
9639 2 : gfc_error ("ALLOCATE directive at %L inside a target region "
9640 : "must specify an ALLOCATOR clause", &code->loc);
9641 : }
9642 :
9643 : }
9644 : }
9645 :
9646 : /* OpenACC reductions. */
9647 32157 : if (openacc)
9648 : {
9649 14753 : for (n = omp_clauses->lists[OMP_LIST_REDUCTION]; n; n = n->next)
9650 2136 : n->sym->mark = 0;
9651 :
9652 14753 : for (n = omp_clauses->lists[OMP_LIST_REDUCTION]; n; n = n->next)
9653 : {
9654 2136 : if (n->sym->mark)
9655 0 : gfc_error ("Symbol %qs present on multiple clauses at %L",
9656 : n->sym->name, &n->where);
9657 : else
9658 2136 : n->sym->mark = 1;
9659 :
9660 : /* OpenACC does not support reductions on arrays. */
9661 2136 : if (n->sym->as)
9662 71 : gfc_error ("Array %qs is not permitted in reduction at %L",
9663 : n->sym->name, &n->where);
9664 : }
9665 : }
9666 :
9667 32911 : for (n = omp_clauses->lists[OMP_LIST_TO]; n; n = n->next)
9668 754 : n->sym->mark = 0;
9669 33188 : for (n = omp_clauses->lists[OMP_LIST_FROM]; n; n = n->next)
9670 1031 : if (n->expr == NULL)
9671 1015 : n->sym->mark = 1;
9672 32911 : for (n = omp_clauses->lists[OMP_LIST_TO]; n; n = n->next)
9673 : {
9674 754 : if (n->expr == NULL && n->sym->mark)
9675 0 : gfc_error ("Symbol %qs present on both FROM and TO clauses at %L",
9676 : n->sym->name, &n->where);
9677 : else
9678 754 : n->sym->mark = 1;
9679 : }
9680 :
9681 : bool has_inscan = false, has_notinscan = false;
9682 1286280 : for (list = 0; list < OMP_LIST_NUM; list++)
9683 1254123 : if ((n = omp_clauses->lists[list]) != NULL)
9684 : {
9685 28832 : const char *name = clause_names[list];
9686 :
9687 28832 : switch (list)
9688 : {
9689 : case OMP_LIST_COPYIN:
9690 267 : for (; n != NULL; n = n->next)
9691 : {
9692 170 : if (!n->sym->attr.threadprivate)
9693 0 : gfc_error ("Non-THREADPRIVATE object %qs in COPYIN clause"
9694 : " at %L", n->sym->name, &n->where);
9695 : }
9696 : break;
9697 83 : case OMP_LIST_COPYPRIVATE:
9698 83 : if (omp_clauses->nowait)
9699 6 : gfc_error ("NOWAIT clause must not be used with COPYPRIVATE "
9700 : "clause at %L", &n->where);
9701 376 : for (; n != NULL; n = n->next)
9702 : {
9703 293 : if (n->sym->as && n->sym->as->type == AS_ASSUMED_SIZE)
9704 0 : gfc_error ("Assumed size array %qs in COPYPRIVATE clause "
9705 : "at %L", n->sym->name, &n->where);
9706 293 : if (n->sym->attr.pointer && n->sym->attr.intent == INTENT_IN)
9707 1 : gfc_error ("INTENT(IN) POINTER %qs in COPYPRIVATE clause "
9708 : "at %L", n->sym->name, &n->where);
9709 : }
9710 : break;
9711 : case OMP_LIST_SHARED:
9712 2574 : for (; n != NULL; n = n->next)
9713 : {
9714 1624 : if (n->sym->attr.threadprivate)
9715 0 : gfc_error ("THREADPRIVATE object %qs in SHARED clause at "
9716 : "%L", n->sym->name, &n->where);
9717 1624 : if (n->sym->attr.cray_pointee)
9718 1 : gfc_error ("Cray pointee %qs in SHARED clause at %L",
9719 : n->sym->name, &n->where);
9720 1624 : if (n->sym->attr.associate_var)
9721 8 : gfc_error ("Associate name %qs in SHARED clause at %L",
9722 8 : n->sym->attr.select_type_temporary
9723 4 : ? n->sym->assoc->target->symtree->n.sym->name
9724 : : n->sym->name, &n->where);
9725 1624 : if (omp_clauses->detach
9726 1 : && n->sym == omp_clauses->detach->symtree->n.sym)
9727 1 : gfc_error ("DETACH event handle %qs in SHARED clause at %L",
9728 : n->sym->name, &n->where);
9729 : }
9730 : break;
9731 : case OMP_LIST_ALIGNED:
9732 256 : for (; n != NULL; n = n->next)
9733 : {
9734 150 : if (!n->sym->attr.pointer
9735 45 : && !n->sym->attr.allocatable
9736 30 : && !n->sym->attr.cray_pointer
9737 18 : && (n->sym->ts.type != BT_DERIVED
9738 18 : || (n->sym->ts.u.derived->from_intmod
9739 : != INTMOD_ISO_C_BINDING)
9740 18 : || (n->sym->ts.u.derived->intmod_sym_id
9741 : != ISOCBINDING_PTR)))
9742 0 : gfc_error ("%qs in ALIGNED clause must be POINTER, "
9743 : "ALLOCATABLE, Cray pointer or C_PTR at %L",
9744 : n->sym->name, &n->where);
9745 150 : else if (n->expr)
9746 : {
9747 147 : if (!gfc_resolve_expr (n->expr)
9748 147 : || n->expr->ts.type != BT_INTEGER
9749 146 : || n->expr->rank != 0
9750 146 : || n->expr->expr_type != EXPR_CONSTANT
9751 292 : || mpz_sgn (n->expr->value.integer) <= 0)
9752 4 : gfc_error ("%qs in ALIGNED clause at %L requires a scalar"
9753 : " positive constant integer alignment "
9754 4 : "expression", n->sym->name, &n->where);
9755 : }
9756 : }
9757 : break;
9758 : case OMP_LIST_AFFINITY:
9759 : case OMP_LIST_DEPEND:
9760 : case OMP_LIST_MAP:
9761 : case OMP_LIST_TO:
9762 : case OMP_LIST_FROM:
9763 : case OMP_LIST_CACHE:
9764 32038 : for (; n != NULL; n = n->next)
9765 : {
9766 20159 : if ((list == OMP_LIST_DEPEND || list == OMP_LIST_AFFINITY)
9767 1995 : && n->u2.ns && !n->u2.ns->resolved)
9768 : {
9769 53 : n->u2.ns->resolved = 1;
9770 53 : for (gfc_symbol *sym = n->u2.ns->omp_affinity_iterators;
9771 110 : sym; sym = sym->tlink)
9772 : {
9773 57 : gfc_constructor *c;
9774 57 : c = gfc_constructor_first (sym->value->value.constructor);
9775 57 : if (!gfc_resolve_expr (c->expr)
9776 57 : || c->expr->ts.type != BT_INTEGER
9777 112 : || c->expr->rank != 0)
9778 2 : gfc_error ("Scalar integer expression for range begin"
9779 2 : " expected at %L", &c->expr->where);
9780 57 : c = gfc_constructor_next (c);
9781 57 : if (!gfc_resolve_expr (c->expr)
9782 57 : || c->expr->ts.type != BT_INTEGER
9783 112 : || c->expr->rank != 0)
9784 2 : gfc_error ("Scalar integer expression for range end "
9785 2 : "expected at %L", &c->expr->where);
9786 57 : c = gfc_constructor_next (c);
9787 57 : if (c && (!gfc_resolve_expr (c->expr)
9788 16 : || c->expr->ts.type != BT_INTEGER
9789 14 : || c->expr->rank != 0))
9790 2 : gfc_error ("Scalar integer expression for range step "
9791 2 : "expected at %L", &c->expr->where);
9792 55 : else if (c
9793 14 : && c->expr->expr_type == EXPR_CONSTANT
9794 12 : && mpz_cmp_si (c->expr->value.integer, 0) == 0)
9795 2 : gfc_error ("Nonzero range step expected at %L",
9796 : &c->expr->where);
9797 : }
9798 : }
9799 :
9800 1995 : if (list == OMP_LIST_DEPEND)
9801 : {
9802 3193 : if (n->u.depend_doacross_op == OMP_DEPEND_SINK_FIRST
9803 : || n->u.depend_doacross_op == OMP_DOACROSS_SINK_FIRST
9804 1960 : || n->u.depend_doacross_op == OMP_DOACROSS_SINK)
9805 : {
9806 1233 : if (omp_clauses->doacross_source)
9807 : {
9808 0 : gfc_error ("Dependence-type SINK used together with"
9809 : " SOURCE on the same construct at %L",
9810 : &n->where);
9811 0 : omp_clauses->doacross_source = false;
9812 : }
9813 1233 : else if (n->expr)
9814 : {
9815 571 : if (!gfc_resolve_expr (n->expr)
9816 571 : || n->expr->ts.type != BT_INTEGER
9817 1142 : || n->expr->rank != 0)
9818 0 : gfc_error ("SINK addend not a constant integer "
9819 : "at %L", &n->where);
9820 : }
9821 1233 : if (n->sym == NULL
9822 4 : && (n->expr == NULL
9823 3 : || mpz_cmp_si (n->expr->value.integer, -1) != 0))
9824 2 : gfc_error ("omp_cur_iteration at %L requires %<-1%> "
9825 : "as logical offset", &n->where);
9826 1233 : continue;
9827 : }
9828 727 : else if (n->u.depend_doacross_op == OMP_DEPEND_DEPOBJ
9829 38 : && !n->expr
9830 22 : && (n->sym->ts.type != BT_INTEGER
9831 22 : || n->sym->ts.kind
9832 22 : != 2 * gfc_index_integer_kind
9833 22 : || n->sym->attr.dimension))
9834 0 : gfc_error ("Locator %qs at %L in DEPEND clause of depobj "
9835 : "type shall be a scalar integer of "
9836 : "OMP_DEPEND_KIND kind", n->sym->name,
9837 : &n->where);
9838 727 : else if (n->u.depend_doacross_op == OMP_DEPEND_DEPOBJ
9839 38 : && n->expr
9840 743 : && (!gfc_resolve_expr (n->expr)
9841 16 : || n->expr->ts.type != BT_INTEGER
9842 16 : || n->expr->ts.kind
9843 16 : != 2 * gfc_index_integer_kind
9844 16 : || n->expr->rank != 0))
9845 0 : gfc_error ("Locator at %L in DEPEND clause of depobj "
9846 : "type shall be a scalar integer of "
9847 0 : "OMP_DEPEND_KIND kind", &n->expr->where);
9848 : }
9849 18926 : gfc_ref *lastref = NULL, *lastslice = NULL;
9850 18926 : bool resolved = false;
9851 18926 : if (n->expr)
9852 : {
9853 6248 : lastref = n->expr->ref;
9854 6248 : resolved = gfc_resolve_expr (n->expr);
9855 :
9856 : /* Look through component refs to find last array
9857 : reference. */
9858 6248 : if (resolved)
9859 : {
9860 15872 : for (gfc_ref *ref = n->expr->ref; ref; ref = ref->next)
9861 9642 : if (ref->type == REF_COMPONENT
9862 : || ref->type == REF_SUBSTRING
9863 9642 : || ref->type == REF_INQUIRY)
9864 : lastref = ref;
9865 6462 : else if (ref->type == REF_ARRAY)
9866 : {
9867 13614 : for (int i = 0; i < ref->u.ar.dimen; i++)
9868 7152 : if (ref->u.ar.dimen_type[i] == DIMEN_RANGE)
9869 6002 : lastslice = ref;
9870 :
9871 : lastref = ref;
9872 : }
9873 :
9874 : /* The "!$acc cache" directive allows rectangular
9875 : subarrays to be specified, with some restrictions
9876 : on the form of bounds (not implemented).
9877 : Only raise an error here if we're really sure the
9878 : array isn't contiguous. An expression such as
9879 : arr(-n:n,-n:n) could be contiguous even if it looks
9880 : like it may not be. */
9881 6230 : if (code->op != EXEC_OACC_UPDATE
9882 5448 : && list != OMP_LIST_CACHE
9883 5448 : && list != OMP_LIST_DEPEND
9884 5129 : && !gfc_is_simply_contiguous (n->expr, false, true)
9885 1407 : && gfc_is_not_contiguous (n->expr)
9886 6243 : && !(lastslice
9887 13 : && (lastslice->next
9888 3 : || lastslice->type != REF_ARRAY)))
9889 3 : gfc_error ("Array is not contiguous at %L",
9890 : &n->where);
9891 : }
9892 : }
9893 18926 : if (list == OMP_LIST_MAP
9894 16278 : && (n->sym->attr.omp_groupprivate
9895 16277 : || n->sym->attr.omp_declare_target_local))
9896 2 : gfc_error ("%qs argument to MAP clause at %L must not be a "
9897 : "device-local variable, including GROUPPRIVATE",
9898 : n->sym->name, &n->where);
9899 18926 : if (openacc
9900 18926 : && list == OMP_LIST_MAP
9901 9562 : && (n->u.map.op == OMP_MAP_ATTACH
9902 9496 : || n->u.map.op == OMP_MAP_DETACH))
9903 : {
9904 109 : symbol_attribute attr;
9905 109 : if (n->expr)
9906 99 : attr = gfc_expr_attr (n->expr);
9907 : else
9908 10 : attr = n->sym->attr;
9909 109 : if (!attr.pointer && !attr.allocatable)
9910 7 : gfc_error ("%qs clause argument must be ALLOCATABLE or "
9911 : "a POINTER at %L",
9912 7 : (n->u.map.op == OMP_MAP_ATTACH) ? "attach"
9913 : : "detach", &n->where);
9914 : }
9915 18926 : if (lastref
9916 12690 : || (n->expr
9917 12 : && (!resolved || n->expr->expr_type != EXPR_VARIABLE)))
9918 : {
9919 6248 : if (!lastslice
9920 6248 : && lastref
9921 896 : && lastref->type == REF_SUBSTRING)
9922 11 : gfc_error ("Unexpected substring reference in %s clause "
9923 : "at %L", name, &n->where);
9924 6237 : else if (!lastslice
9925 : && lastref
9926 885 : && lastref->type == REF_INQUIRY)
9927 : {
9928 12 : gcc_assert (lastref->u.i == INQUIRY_RE
9929 : || lastref->u.i == INQUIRY_IM);
9930 12 : gfc_error ("Unexpected complex-parts designator "
9931 : "reference in %s clause at %L",
9932 : name, &n->where);
9933 : }
9934 6225 : else if (!resolved
9935 6207 : || n->expr->expr_type != EXPR_VARIABLE
9936 6195 : || (lastslice
9937 5340 : && (lastslice->next
9938 5324 : || lastslice->type != REF_ARRAY)))
9939 46 : gfc_error ("%qs in %s clause at %L is not a proper "
9940 46 : "array section", n->sym->name, name,
9941 : &n->where);
9942 : else if (lastslice)
9943 : {
9944 : int i;
9945 : gfc_array_ref *ar = &lastslice->u.ar;
9946 11323 : for (i = 0; i < ar->dimen; i++)
9947 6000 : if (ar->stride[i] && code->op != EXEC_OACC_UPDATE)
9948 : {
9949 1 : gfc_error ("Stride should not be specified for "
9950 : "array section in %s clause at %L",
9951 : name, &n->where);
9952 1 : break;
9953 : }
9954 5999 : else if (ar->dimen_type[i] != DIMEN_ELEMENT
9955 5999 : && ar->dimen_type[i] != DIMEN_RANGE)
9956 : {
9957 0 : gfc_error ("%qs in %s clause at %L is not a "
9958 : "proper array section",
9959 0 : n->sym->name, name, &n->where);
9960 0 : break;
9961 : }
9962 5999 : else if ((list == OMP_LIST_DEPEND
9963 : || list == OMP_LIST_AFFINITY)
9964 160 : && ar->start[i]
9965 133 : && ar->start[i]->expr_type == EXPR_CONSTANT
9966 97 : && ar->end[i]
9967 72 : && ar->end[i]->expr_type == EXPR_CONSTANT
9968 72 : && mpz_cmp (ar->start[i]->value.integer,
9969 72 : ar->end[i]->value.integer) > 0)
9970 : {
9971 0 : gfc_error ("%qs in %s clause at %L is a "
9972 : "zero size array section",
9973 0 : n->sym->name,
9974 : list == OMP_LIST_DEPEND
9975 : ? "DEPEND" : "AFFINITY", &n->where);
9976 0 : break;
9977 : }
9978 : }
9979 : }
9980 12678 : else if (openacc)
9981 : {
9982 5906 : if (list == OMP_LIST_MAP
9983 5891 : && n->u.map.op == OMP_MAP_FORCE_DEVICEPTR)
9984 65 : resolve_oacc_deviceptr_clause (n->sym, n->where, name);
9985 : else
9986 5841 : resolve_oacc_data_clauses (n->sym, n->where, name);
9987 : }
9988 6772 : else if (list != OMP_LIST_DEPEND
9989 6279 : && n->sym->as
9990 3007 : && n->sym->as->type == AS_ASSUMED_SIZE)
9991 5 : gfc_error ("Assumed size array %qs in %s clause at %L",
9992 : n->sym->name, name, &n->where);
9993 18926 : if (list == OMP_LIST_MAP && !openacc)
9994 6716 : switch (code->op)
9995 : {
9996 5592 : case EXEC_OMP_TARGET:
9997 5592 : case EXEC_OMP_TARGET_PARALLEL:
9998 5592 : case EXEC_OMP_TARGET_PARALLEL_DO:
9999 5592 : case EXEC_OMP_TARGET_PARALLEL_DO_SIMD:
10000 5592 : case EXEC_OMP_TARGET_PARALLEL_LOOP:
10001 5592 : case EXEC_OMP_TARGET_SIMD:
10002 5592 : case EXEC_OMP_TARGET_TEAMS:
10003 5592 : case EXEC_OMP_TARGET_TEAMS_DISTRIBUTE:
10004 5592 : case EXEC_OMP_TARGET_TEAMS_DISTRIBUTE_PARALLEL_DO:
10005 5592 : case EXEC_OMP_TARGET_TEAMS_DISTRIBUTE_PARALLEL_DO_SIMD:
10006 5592 : case EXEC_OMP_TARGET_TEAMS_DISTRIBUTE_SIMD:
10007 5592 : case EXEC_OMP_TARGET_TEAMS_LOOP:
10008 5592 : case EXEC_OMP_TARGET_DATA:
10009 5592 : switch (n->u.map.op)
10010 : {
10011 : case OMP_MAP_TO:
10012 : case OMP_MAP_ALWAYS_TO:
10013 : case OMP_MAP_PRESENT_TO:
10014 : case OMP_MAP_ALWAYS_PRESENT_TO:
10015 : case OMP_MAP_FROM:
10016 : case OMP_MAP_ALWAYS_FROM:
10017 : case OMP_MAP_PRESENT_FROM:
10018 : case OMP_MAP_ALWAYS_PRESENT_FROM:
10019 : case OMP_MAP_TOFROM:
10020 : case OMP_MAP_ALWAYS_TOFROM:
10021 : case OMP_MAP_PRESENT_TOFROM:
10022 : case OMP_MAP_ALWAYS_PRESENT_TOFROM:
10023 : case OMP_MAP_ALLOC:
10024 : case OMP_MAP_PRESENT_ALLOC:
10025 : break;
10026 2 : default:
10027 2 : gfc_error ("TARGET%s with map-type other than TO, "
10028 : "FROM, TOFROM, or ALLOC on MAP clause "
10029 : "at %L",
10030 : code->op == EXEC_OMP_TARGET_DATA
10031 : ? " DATA" : "", &n->where);
10032 2 : break;
10033 : }
10034 : break;
10035 625 : case EXEC_OMP_TARGET_ENTER_DATA:
10036 625 : switch (n->u.map.op)
10037 : {
10038 : case OMP_MAP_TO:
10039 : case OMP_MAP_ALWAYS_TO:
10040 : case OMP_MAP_PRESENT_TO:
10041 : case OMP_MAP_ALWAYS_PRESENT_TO:
10042 : case OMP_MAP_ALLOC:
10043 : case OMP_MAP_PRESENT_ALLOC:
10044 : break;
10045 176 : case OMP_MAP_TOFROM:
10046 176 : n->u.map.op = OMP_MAP_TO;
10047 176 : break;
10048 3 : case OMP_MAP_ALWAYS_TOFROM:
10049 3 : n->u.map.op = OMP_MAP_ALWAYS_TO;
10050 3 : break;
10051 2 : case OMP_MAP_PRESENT_TOFROM:
10052 2 : n->u.map.op = OMP_MAP_PRESENT_TO;
10053 2 : break;
10054 2 : case OMP_MAP_ALWAYS_PRESENT_TOFROM:
10055 2 : n->u.map.op = OMP_MAP_ALWAYS_PRESENT_TO;
10056 2 : break;
10057 2 : default:
10058 2 : gfc_error ("TARGET ENTER DATA with map-type other "
10059 : "than TO, TOFROM or ALLOC on MAP clause "
10060 : "at %L", &n->where);
10061 2 : break;
10062 : }
10063 : break;
10064 499 : case EXEC_OMP_TARGET_EXIT_DATA:
10065 499 : switch (n->u.map.op)
10066 : {
10067 : case OMP_MAP_FROM:
10068 : case OMP_MAP_ALWAYS_FROM:
10069 : case OMP_MAP_PRESENT_FROM:
10070 : case OMP_MAP_ALWAYS_PRESENT_FROM:
10071 : case OMP_MAP_RELEASE:
10072 : case OMP_MAP_DELETE:
10073 : break;
10074 132 : case OMP_MAP_TOFROM:
10075 132 : n->u.map.op = OMP_MAP_FROM;
10076 132 : break;
10077 1 : case OMP_MAP_ALWAYS_TOFROM:
10078 1 : n->u.map.op = OMP_MAP_ALWAYS_FROM;
10079 1 : break;
10080 0 : case OMP_MAP_PRESENT_TOFROM:
10081 0 : n->u.map.op = OMP_MAP_PRESENT_FROM;
10082 0 : break;
10083 0 : case OMP_MAP_ALWAYS_PRESENT_TOFROM:
10084 0 : n->u.map.op = OMP_MAP_ALWAYS_PRESENT_FROM;
10085 0 : break;
10086 2 : default:
10087 2 : gfc_error ("TARGET EXIT DATA with map-type other "
10088 : "than FROM, TOFROM, RELEASE, or DELETE on "
10089 : "MAP clause at %L", &n->where);
10090 2 : break;
10091 : }
10092 : break;
10093 : default:
10094 : break;
10095 : }
10096 : }
10097 :
10098 11879 : if (list != OMP_LIST_DEPEND)
10099 29234 : for (n = omp_clauses->lists[list]; n != NULL; n = n->next)
10100 : {
10101 18199 : n->sym->attr.referenced = 1;
10102 18199 : if (n->sym->attr.threadprivate)
10103 1 : gfc_error ("THREADPRIVATE object %qs in %s clause at %L",
10104 : n->sym->name, name, &n->where);
10105 18199 : if (n->sym->attr.cray_pointee)
10106 14 : gfc_error ("Cray pointee %qs in %s clause at %L",
10107 : n->sym->name, name, &n->where);
10108 : }
10109 : break;
10110 : case OMP_LIST_IS_DEVICE_PTR:
10111 : last = NULL;
10112 377 : for (n = omp_clauses->lists[list]; n != NULL; )
10113 : {
10114 257 : if ((n->sym->ts.type != BT_DERIVED
10115 71 : || !n->sym->ts.u.derived->ts.is_iso_c
10116 71 : || (n->sym->ts.u.derived->intmod_sym_id
10117 : != ISOCBINDING_PTR))
10118 187 : && code->op == EXEC_OMP_DISPATCH)
10119 : /* Non-TARGET (i.e. DISPATCH) requires a C_PTR. */
10120 3 : gfc_error ("List item %qs in %s clause at %L must be of "
10121 : "TYPE(C_PTR)", n->sym->name, name, &n->where);
10122 254 : else if (n->sym->ts.type != BT_DERIVED
10123 70 : || !n->sym->ts.u.derived->ts.is_iso_c
10124 70 : || (n->sym->ts.u.derived->intmod_sym_id
10125 : != ISOCBINDING_PTR))
10126 : {
10127 : /* For TARGET, non-C_PTR are deprecated and handled as
10128 : has_device_addr. */
10129 184 : gfc_warning (OPT_Wdeprecated_openmp,
10130 : "Non-C_PTR type argument at %L is deprecated, "
10131 : "use HAS_DEVICE_ADDR", &n->where);
10132 184 : gfc_omp_namelist *n2 = n;
10133 184 : n = n->next;
10134 184 : if (last)
10135 0 : last->next = n;
10136 : else
10137 184 : omp_clauses->lists[list] = n;
10138 184 : n2->next = omp_clauses->lists[OMP_LIST_HAS_DEVICE_ADDR];
10139 184 : omp_clauses->lists[OMP_LIST_HAS_DEVICE_ADDR] = n2;
10140 184 : continue;
10141 184 : }
10142 73 : last = n;
10143 73 : n = n->next;
10144 : }
10145 : break;
10146 : case OMP_LIST_HAS_DEVICE_ADDR:
10147 : case OMP_LIST_USE_DEVICE_ADDR:
10148 : break;
10149 : case OMP_LIST_USE_DEVICE_PTR:
10150 : /* Non-C_PTR are deprecated and handled as use_device_ADDR. */
10151 : last = NULL;
10152 475 : for (n = omp_clauses->lists[list]; n != NULL; )
10153 : {
10154 312 : gfc_omp_namelist *n2 = n;
10155 312 : if (n->sym->ts.type != BT_DERIVED
10156 18 : || !n->sym->ts.u.derived->ts.is_iso_c)
10157 : {
10158 294 : gfc_warning (OPT_Wdeprecated_openmp,
10159 : "Non-C_PTR type argument at %L is "
10160 : "deprecated, use USE_DEVICE_ADDR", &n->where);
10161 294 : n = n->next;
10162 294 : if (last)
10163 0 : last->next = n;
10164 : else
10165 294 : omp_clauses->lists[list] = n;
10166 294 : n2->next = omp_clauses->lists[OMP_LIST_USE_DEVICE_ADDR];
10167 294 : omp_clauses->lists[OMP_LIST_USE_DEVICE_ADDR] = n2;
10168 294 : continue;
10169 : }
10170 18 : last = n;
10171 18 : n = n->next;
10172 : }
10173 : break;
10174 48 : case OMP_LIST_USES_ALLOCATORS:
10175 48 : {
10176 48 : if (n != NULL
10177 48 : && n->u.memspace_sym
10178 14 : && (n->u.memspace_sym->attr.flavor != FL_PARAMETER
10179 13 : || n->u.memspace_sym->ts.type != BT_INTEGER
10180 13 : || n->u.memspace_sym->ts.kind != gfc_c_intptr_kind
10181 13 : || n->u.memspace_sym->attr.dimension
10182 13 : || (!startswith (n->u.memspace_sym->name, "omp_")
10183 0 : && !startswith (n->u.memspace_sym->name, "ompx_"))
10184 13 : || !endswith (n->u.memspace_sym->name, "_mem_space")))
10185 2 : gfc_error ("Memspace %qs at %L in USES_ALLOCATORS must be "
10186 : "a predefined memory space",
10187 : n->u.memspace_sym->name, &n->where);
10188 144 : for (; n != NULL; n = n->next)
10189 : {
10190 102 : if (n->sym->ts.type != BT_INTEGER
10191 102 : || n->sym->ts.kind != gfc_c_intptr_kind
10192 101 : || n->sym->attr.dimension)
10193 2 : gfc_error ("Allocator %qs at %L in USES_ALLOCATORS must "
10194 : "be a scalar integer of kind "
10195 : "%<omp_allocator_handle_kind%>", n->sym->name,
10196 : &n->where);
10197 100 : else if (n->sym->attr.flavor != FL_VARIABLE
10198 47 : && strcmp (n->sym->name, "omp_null_allocator") != 0
10199 144 : && ((!startswith (n->sym->name, "omp_")
10200 1 : && !startswith (n->sym->name, "ompx_"))
10201 43 : || !endswith (n->sym->name, "_mem_alloc")))
10202 2 : gfc_error ("Allocator %qs at %L in USES_ALLOCATORS must "
10203 : "either a variable or a predefined allocator",
10204 : n->sym->name, &n->where);
10205 98 : else if ((n->u.memspace_sym || n->u2.traits_sym)
10206 47 : && n->sym->attr.flavor != FL_VARIABLE)
10207 3 : gfc_error ("A memory space or traits array may not be "
10208 : "specified for predefined allocator %qs at %L",
10209 : n->sym->name, &n->where);
10210 102 : if (n->u2.traits_sym
10211 41 : && (n->u2.traits_sym->attr.flavor != FL_PARAMETER
10212 39 : || !n->u2.traits_sym->attr.dimension
10213 37 : || n->u2.traits_sym->as->rank != 1
10214 37 : || n->u2.traits_sym->ts.type != BT_DERIVED
10215 35 : || strcmp (n->u2.traits_sym->ts.u.derived->name,
10216 : "omp_alloctrait") != 0))
10217 : {
10218 6 : gfc_error ("Traits array %qs in USES_ALLOCATORS %L must "
10219 : "be a one-dimensional named constant array of "
10220 : "type %<omp_alloctrait%>",
10221 : n->u2.traits_sym->name, &n->where);
10222 6 : break;
10223 : }
10224 : }
10225 : break;
10226 : }
10227 : default:
10228 34580 : for (; n != NULL; n = n->next)
10229 : {
10230 20248 : if (n->sym == NULL)
10231 : {
10232 26 : gcc_assert (code->op == EXEC_OMP_ALLOCATORS
10233 : || code->op == EXEC_OMP_ALLOCATE);
10234 26 : continue;
10235 : }
10236 20222 : bool bad = false;
10237 20222 : bool is_reduction = (list == OMP_LIST_REDUCTION
10238 : || list == OMP_LIST_REDUCTION_INSCAN
10239 : || list == OMP_LIST_REDUCTION_TASK
10240 : || list == OMP_LIST_IN_REDUCTION
10241 20222 : || list == OMP_LIST_TASK_REDUCTION);
10242 20222 : if (list == OMP_LIST_REDUCTION_INSCAN)
10243 : has_inscan = true;
10244 20150 : else if (is_reduction)
10245 4733 : has_notinscan = true;
10246 20222 : if (has_inscan && has_notinscan && is_reduction)
10247 : {
10248 3 : gfc_error ("%<inscan%> and non-%<inscan%> %<reduction%> "
10249 : "clauses on the same construct at %L",
10250 : &n->where);
10251 3 : break;
10252 : }
10253 20219 : if (n->sym->attr.threadprivate)
10254 1 : gfc_error ("THREADPRIVATE object %qs in %s clause at %L",
10255 : n->sym->name, name, &n->where);
10256 20219 : if (n->sym->attr.cray_pointee)
10257 14 : gfc_error ("Cray pointee %qs in %s clause at %L",
10258 : n->sym->name, name, &n->where);
10259 20219 : if (n->sym->attr.associate_var)
10260 22 : gfc_error ("Associate name %qs in %s clause at %L",
10261 22 : n->sym->attr.select_type_temporary
10262 4 : ? n->sym->assoc->target->symtree->n.sym->name
10263 : : n->sym->name, name, &n->where);
10264 20219 : if (list != OMP_LIST_PRIVATE && is_reduction)
10265 : {
10266 4802 : if (n->sym->attr.proc_pointer)
10267 1 : gfc_error ("Procedure pointer %qs in %s clause at %L",
10268 : n->sym->name, name, &n->where);
10269 4802 : if (n->sym->attr.pointer)
10270 3 : gfc_error ("POINTER object %qs in %s clause at %L",
10271 : n->sym->name, name, &n->where);
10272 4802 : if (n->sym->attr.cray_pointer)
10273 5 : gfc_error ("Cray pointer %qs in %s clause at %L",
10274 : n->sym->name, name, &n->where);
10275 : }
10276 20219 : if (code
10277 20219 : && (oacc_is_loop (code)
10278 : || code->op == EXEC_OACC_PARALLEL
10279 : || code->op == EXEC_OACC_SERIAL))
10280 8737 : check_array_not_assumed (n->sym, n->where, name);
10281 11482 : else if (list != OMP_LIST_UNIFORM
10282 11365 : && n->sym->as && n->sym->as->type == AS_ASSUMED_SIZE)
10283 2 : gfc_error ("Assumed size array %qs in %s clause at %L",
10284 : n->sym->name, name, &n->where);
10285 20219 : if (n->sym->attr.in_namelist && !is_reduction)
10286 0 : gfc_error ("Variable %qs in %s clause is used in "
10287 : "NAMELIST statement at %L",
10288 : n->sym->name, name, &n->where);
10289 20219 : if (n->sym->attr.pointer && n->sym->attr.intent == INTENT_IN)
10290 3 : switch (list)
10291 : {
10292 3 : case OMP_LIST_PRIVATE:
10293 3 : case OMP_LIST_LASTPRIVATE:
10294 3 : case OMP_LIST_LINEAR:
10295 : /* case OMP_LIST_REDUCTION: */
10296 3 : gfc_error ("INTENT(IN) POINTER %qs in %s clause at %L",
10297 : n->sym->name, name, &n->where);
10298 3 : break;
10299 : default:
10300 : break;
10301 : }
10302 20219 : if (omp_clauses->detach
10303 3 : && (list == OMP_LIST_PRIVATE
10304 : || list == OMP_LIST_FIRSTPRIVATE
10305 : || list == OMP_LIST_LASTPRIVATE)
10306 3 : && n->sym == omp_clauses->detach->symtree->n.sym)
10307 1 : gfc_error ("DETACH event handle %qs in %s clause at %L",
10308 : n->sym->name, name, &n->where);
10309 :
10310 20219 : if (!openacc
10311 20219 : && (list == OMP_LIST_PRIVATE
10312 20219 : || list == OMP_LIST_FIRSTPRIVATE)
10313 4585 : && ((n->sym->ts.type == BT_DERIVED
10314 158 : && n->sym->ts.u.derived->attr.alloc_comp)
10315 4475 : || n->sym->ts.type == BT_CLASS))
10316 158 : switch (code->op)
10317 : {
10318 8 : case EXEC_OMP_TARGET:
10319 8 : case EXEC_OMP_TARGET_PARALLEL:
10320 8 : case EXEC_OMP_TARGET_PARALLEL_DO:
10321 8 : case EXEC_OMP_TARGET_PARALLEL_DO_SIMD:
10322 8 : case EXEC_OMP_TARGET_PARALLEL_LOOP:
10323 8 : case EXEC_OMP_TARGET_SIMD:
10324 8 : case EXEC_OMP_TARGET_TEAMS:
10325 8 : case EXEC_OMP_TARGET_TEAMS_DISTRIBUTE:
10326 8 : case EXEC_OMP_TARGET_TEAMS_DISTRIBUTE_PARALLEL_DO:
10327 8 : case EXEC_OMP_TARGET_TEAMS_DISTRIBUTE_PARALLEL_DO_SIMD:
10328 8 : case EXEC_OMP_TARGET_TEAMS_DISTRIBUTE_SIMD:
10329 8 : case EXEC_OMP_TARGET_TEAMS_LOOP:
10330 8 : if (n->sym->ts.type == BT_DERIVED
10331 2 : && n->sym->ts.u.derived->attr.alloc_comp)
10332 3 : gfc_error ("Sorry, list item %qs at %L with allocatable"
10333 : " components is not yet supported in %s "
10334 : "clause", n->sym->name, &n->where,
10335 : list == OMP_LIST_PRIVATE ? "PRIVATE"
10336 : : "FIRSTPRIVATE");
10337 : else
10338 9 : gfc_error ("Polymorphic list item %qs at %L in %s "
10339 : "clause has unspecified behavior and "
10340 : "unsupported", n->sym->name, &n->where,
10341 : list == OMP_LIST_PRIVATE ? "PRIVATE"
10342 : : "FIRSTPRIVATE");
10343 : break;
10344 : default:
10345 : break;
10346 : }
10347 :
10348 20219 : switch (list)
10349 : {
10350 103 : case OMP_LIST_REDUCTION_TASK:
10351 103 : if (code
10352 103 : && (code->op == EXEC_OMP_LOOP
10353 : || code->op == EXEC_OMP_TASKLOOP
10354 : || code->op == EXEC_OMP_TASKLOOP_SIMD
10355 : || code->op == EXEC_OMP_MASKED_TASKLOOP
10356 : || code->op == EXEC_OMP_MASKED_TASKLOOP_SIMD
10357 : || code->op == EXEC_OMP_MASTER_TASKLOOP
10358 : || code->op == EXEC_OMP_MASTER_TASKLOOP_SIMD
10359 : || code->op == EXEC_OMP_PARALLEL_LOOP
10360 : || code->op == EXEC_OMP_PARALLEL_MASKED_TASKLOOP
10361 : || code->op == EXEC_OMP_PARALLEL_MASKED_TASKLOOP_SIMD
10362 : || code->op == EXEC_OMP_PARALLEL_MASTER_TASKLOOP
10363 : || code->op == EXEC_OMP_PARALLEL_MASTER_TASKLOOP_SIMD
10364 : || code->op == EXEC_OMP_TARGET_PARALLEL_LOOP
10365 : || code->op == EXEC_OMP_TARGET_TEAMS_LOOP
10366 : || code->op == EXEC_OMP_TEAMS
10367 : || code->op == EXEC_OMP_TEAMS_DISTRIBUTE
10368 : || code->op == EXEC_OMP_TEAMS_LOOP))
10369 : {
10370 17 : gfc_error ("Only DEFAULT permitted as reduction-"
10371 : "modifier in REDUCTION clause at %L",
10372 : &n->where);
10373 17 : break;
10374 : }
10375 4785 : gcc_fallthrough ();
10376 4785 : case OMP_LIST_REDUCTION:
10377 4785 : case OMP_LIST_IN_REDUCTION:
10378 4785 : case OMP_LIST_TASK_REDUCTION:
10379 4785 : case OMP_LIST_REDUCTION_INSCAN:
10380 4785 : switch (n->u.reduction_op)
10381 : {
10382 2651 : case OMP_REDUCTION_PLUS:
10383 2651 : case OMP_REDUCTION_TIMES:
10384 2651 : case OMP_REDUCTION_MINUS:
10385 2651 : if (!gfc_numeric_ts (&n->sym->ts))
10386 : bad = true;
10387 : break;
10388 1112 : case OMP_REDUCTION_AND:
10389 1112 : case OMP_REDUCTION_OR:
10390 1112 : case OMP_REDUCTION_EQV:
10391 1112 : case OMP_REDUCTION_NEQV:
10392 1112 : if (n->sym->ts.type != BT_LOGICAL)
10393 : bad = true;
10394 : break;
10395 480 : case OMP_REDUCTION_MAX:
10396 480 : case OMP_REDUCTION_MIN:
10397 480 : if (n->sym->ts.type != BT_INTEGER
10398 212 : && n->sym->ts.type != BT_REAL)
10399 : bad = true;
10400 : break;
10401 192 : case OMP_REDUCTION_IAND:
10402 192 : case OMP_REDUCTION_IOR:
10403 192 : case OMP_REDUCTION_IEOR:
10404 192 : if (n->sym->ts.type != BT_INTEGER)
10405 : bad = true;
10406 : break;
10407 : case OMP_REDUCTION_USER:
10408 : bad = true;
10409 : break;
10410 : default:
10411 : break;
10412 : }
10413 : if (!bad)
10414 4214 : n->u2.udr = NULL;
10415 : else
10416 : {
10417 571 : const char *udr_name = NULL;
10418 571 : if (n->u2.udr)
10419 : {
10420 467 : udr_name = n->u2.udr->udr->name;
10421 467 : n->u2.udr->udr
10422 934 : = gfc_find_omp_udr (NULL, udr_name,
10423 467 : &n->sym->ts);
10424 467 : if (n->u2.udr->udr == NULL)
10425 : {
10426 0 : free (n->u2.udr);
10427 0 : n->u2.udr = NULL;
10428 : }
10429 : }
10430 571 : if (n->u2.udr == NULL)
10431 : {
10432 104 : if (udr_name == NULL)
10433 104 : switch (n->u.reduction_op)
10434 : {
10435 50 : case OMP_REDUCTION_PLUS:
10436 50 : case OMP_REDUCTION_TIMES:
10437 50 : case OMP_REDUCTION_MINUS:
10438 50 : case OMP_REDUCTION_AND:
10439 50 : case OMP_REDUCTION_OR:
10440 50 : case OMP_REDUCTION_EQV:
10441 50 : case OMP_REDUCTION_NEQV:
10442 50 : udr_name = gfc_op2string ((gfc_intrinsic_op)
10443 : n->u.reduction_op);
10444 50 : break;
10445 : case OMP_REDUCTION_MAX:
10446 : udr_name = "max";
10447 : break;
10448 9 : case OMP_REDUCTION_MIN:
10449 9 : udr_name = "min";
10450 9 : break;
10451 12 : case OMP_REDUCTION_IAND:
10452 12 : udr_name = "iand";
10453 12 : break;
10454 12 : case OMP_REDUCTION_IOR:
10455 12 : udr_name = "ior";
10456 12 : break;
10457 9 : case OMP_REDUCTION_IEOR:
10458 9 : udr_name = "ieor";
10459 9 : break;
10460 0 : default:
10461 0 : gcc_unreachable ();
10462 : }
10463 104 : gfc_error ("!$OMP DECLARE REDUCTION %s not found "
10464 : "for type %s at %L", udr_name,
10465 104 : gfc_typename (&n->sym->ts), &n->where);
10466 : }
10467 : else
10468 : {
10469 467 : gfc_omp_udr *udr = n->u2.udr->udr;
10470 467 : n->u.reduction_op = OMP_REDUCTION_USER;
10471 467 : n->u2.udr->combiner
10472 934 : = resolve_omp_udr_clause (n, udr->combiner_ns,
10473 467 : udr->omp_out,
10474 467 : udr->omp_in);
10475 467 : if (udr->initializer_ns)
10476 330 : n->u2.udr->initializer
10477 330 : = resolve_omp_udr_clause (n,
10478 : udr->initializer_ns,
10479 330 : udr->omp_priv,
10480 330 : udr->omp_orig);
10481 : }
10482 : }
10483 : break;
10484 873 : case OMP_LIST_LINEAR:
10485 873 : if (code
10486 726 : && n->u.linear.op != OMP_LINEAR_DEFAULT
10487 23 : && n->u.linear.op != linear_op)
10488 : {
10489 23 : if (n->u.linear.old_modifier)
10490 : {
10491 9 : gfc_error ("LINEAR clause modifier used on DO or "
10492 : "SIMD construct at %L", &n->where);
10493 9 : linear_op = n->u.linear.op;
10494 : }
10495 14 : else if (n->u.linear.op != OMP_LINEAR_VAL)
10496 : {
10497 6 : gfc_error ("LINEAR clause modifier other than VAL "
10498 : "used on DO or SIMD construct at %L",
10499 : &n->where);
10500 6 : linear_op = n->u.linear.op;
10501 : }
10502 : }
10503 850 : else if (n->u.linear.op != OMP_LINEAR_REF
10504 800 : && n->sym->ts.type != BT_INTEGER)
10505 1 : gfc_error ("LINEAR variable %qs must be INTEGER "
10506 : "at %L", n->sym->name, &n->where);
10507 849 : else if ((n->u.linear.op == OMP_LINEAR_REF
10508 799 : || n->u.linear.op == OMP_LINEAR_UVAL)
10509 61 : && n->sym->attr.value)
10510 0 : gfc_error ("LINEAR dummy argument %qs with VALUE "
10511 : "attribute with %s modifier at %L",
10512 : n->sym->name,
10513 : n->u.linear.op == OMP_LINEAR_REF
10514 : ? "REF" : "UVAL", &n->where);
10515 849 : else if (n->expr)
10516 : {
10517 830 : gfc_expr *expr = n->expr;
10518 830 : if (!gfc_resolve_expr (expr)
10519 830 : || expr->ts.type != BT_INTEGER
10520 1660 : || expr->rank != 0)
10521 0 : gfc_error ("%qs in LINEAR clause at %L requires "
10522 : "a scalar integer linear-step expression",
10523 0 : n->sym->name, &n->where);
10524 830 : else if (!code && expr->expr_type != EXPR_CONSTANT)
10525 : {
10526 11 : if (expr->expr_type == EXPR_VARIABLE
10527 7 : && expr->symtree->n.sym->attr.dummy
10528 6 : && expr->symtree->n.sym->ns == ns)
10529 : {
10530 6 : gfc_omp_namelist *n2;
10531 6 : for (n2 = omp_clauses->lists[OMP_LIST_UNIFORM];
10532 6 : n2; n2 = n2->next)
10533 6 : if (n2->sym == expr->symtree->n.sym)
10534 : break;
10535 6 : if (n2)
10536 : break;
10537 : }
10538 5 : gfc_error ("%qs in LINEAR clause at %L requires "
10539 : "a constant integer linear-step "
10540 : "expression or dummy argument "
10541 : "specified in UNIFORM clause",
10542 5 : n->sym->name, &n->where);
10543 : }
10544 : }
10545 : break;
10546 : /* Workaround for PR middle-end/26316, nothing really needs
10547 : to be done here for OMP_LIST_PRIVATE. */
10548 9374 : case OMP_LIST_PRIVATE:
10549 9374 : gcc_assert (code && code->op != EXEC_NOP);
10550 : break;
10551 98 : case OMP_LIST_USE_DEVICE:
10552 98 : if (n->sym->attr.allocatable
10553 98 : || (n->sym->ts.type == BT_CLASS && CLASS_DATA (n->sym)
10554 0 : && CLASS_DATA (n->sym)->attr.allocatable))
10555 0 : gfc_error ("ALLOCATABLE object %qs in %s clause at %L",
10556 : n->sym->name, name, &n->where);
10557 98 : if (n->sym->ts.type == BT_CLASS
10558 0 : && CLASS_DATA (n->sym)
10559 0 : && CLASS_DATA (n->sym)->attr.class_pointer)
10560 0 : gfc_error ("POINTER object %qs of polymorphic type in "
10561 : "%s clause at %L", n->sym->name, name,
10562 : &n->where);
10563 98 : if (n->sym->attr.cray_pointer)
10564 2 : gfc_error ("Cray pointer object %qs in %s clause at %L",
10565 : n->sym->name, name, &n->where);
10566 96 : else if (n->sym->attr.cray_pointee)
10567 2 : gfc_error ("Cray pointee object %qs in %s clause at %L",
10568 : n->sym->name, name, &n->where);
10569 94 : else if (n->sym->attr.flavor == FL_VARIABLE
10570 93 : && !n->sym->as
10571 54 : && !n->sym->attr.pointer)
10572 13 : gfc_error ("%s clause variable %qs at %L is neither "
10573 : "a POINTER nor an array", name,
10574 : n->sym->name, &n->where);
10575 : /* FALLTHRU */
10576 98 : case OMP_LIST_DEVICE_RESIDENT:
10577 98 : check_symbol_not_pointer (n->sym, n->where, name);
10578 98 : check_array_not_assumed (n->sym, n->where, name);
10579 98 : break;
10580 : default:
10581 : break;
10582 : }
10583 : }
10584 : break;
10585 : }
10586 : }
10587 : /* OpenMP 5.1: use_device_ptr acts like use_device_addr, except for
10588 : type(c_ptr). */
10589 32157 : if (omp_clauses->lists[OMP_LIST_USE_DEVICE_PTR])
10590 : {
10591 9 : gfc_omp_namelist *n_prev, *n_next, *n_addr;
10592 9 : n_addr = omp_clauses->lists[OMP_LIST_USE_DEVICE_ADDR];
10593 28 : for (; n_addr && n_addr->next; n_addr = n_addr->next)
10594 : ;
10595 : n_prev = NULL;
10596 : n = omp_clauses->lists[OMP_LIST_USE_DEVICE_PTR];
10597 27 : while (n)
10598 : {
10599 18 : n_next = n->next;
10600 18 : if (n->sym->ts.type != BT_DERIVED
10601 18 : || n->sym->ts.u.derived->ts.f90_type != BT_VOID)
10602 : {
10603 0 : n->next = NULL;
10604 0 : if (n_addr)
10605 0 : n_addr->next = n;
10606 : else
10607 0 : omp_clauses->lists[OMP_LIST_USE_DEVICE_ADDR] = n;
10608 0 : n_addr = n;
10609 0 : if (n_prev)
10610 0 : n_prev->next = n_next;
10611 : else
10612 0 : omp_clauses->lists[OMP_LIST_USE_DEVICE_PTR] = n_next;
10613 : }
10614 : else
10615 : n_prev = n;
10616 : n = n_next;
10617 : }
10618 : }
10619 32157 : if (omp_clauses->safelen_expr)
10620 93 : resolve_positive_int_expr (omp_clauses->safelen_expr, "SAFELEN");
10621 32157 : if (omp_clauses->simdlen_expr)
10622 123 : resolve_positive_int_expr (omp_clauses->simdlen_expr, "SIMDLEN");
10623 32157 : if (omp_clauses->num_teams_lower)
10624 21 : resolve_positive_int_expr (omp_clauses->num_teams_lower, "NUM_TEAMS");
10625 32157 : if (omp_clauses->num_teams_upper)
10626 127 : resolve_positive_int_expr (omp_clauses->num_teams_upper, "NUM_TEAMS");
10627 32157 : if (omp_clauses->num_teams_lower
10628 21 : && omp_clauses->num_teams_lower->expr_type == EXPR_CONSTANT
10629 7 : && omp_clauses->num_teams_upper->expr_type == EXPR_CONSTANT
10630 7 : && mpz_cmp (omp_clauses->num_teams_lower->value.integer,
10631 7 : omp_clauses->num_teams_upper->value.integer) > 0)
10632 2 : gfc_warning (OPT_Wopenmp, "NUM_TEAMS lower bound at %L larger than upper "
10633 : "bound at %L", &omp_clauses->num_teams_lower->where,
10634 : &omp_clauses->num_teams_upper->where);
10635 32157 : if (omp_clauses->device)
10636 331 : resolve_scalar_int_expr (omp_clauses->device, "DEVICE");
10637 32157 : if (omp_clauses->filter)
10638 42 : resolve_nonnegative_int_expr (omp_clauses->filter, "FILTER");
10639 32157 : if (omp_clauses->hint)
10640 : {
10641 42 : resolve_scalar_int_expr (omp_clauses->hint, "HINT");
10642 42 : if (omp_clauses->hint->ts.type != BT_INTEGER
10643 40 : || omp_clauses->hint->expr_type != EXPR_CONSTANT
10644 38 : || mpz_sgn (omp_clauses->hint->value.integer) < 0)
10645 5 : gfc_error ("Value of HINT clause at %L shall be a valid "
10646 : "constant hint expression", &omp_clauses->hint->where);
10647 : }
10648 32157 : if (omp_clauses->priority)
10649 34 : resolve_nonnegative_int_expr (omp_clauses->priority, "PRIORITY");
10650 32157 : if (omp_clauses->dist_chunk_size)
10651 : {
10652 83 : gfc_expr *expr = omp_clauses->dist_chunk_size;
10653 83 : if (!gfc_resolve_expr (expr)
10654 83 : || expr->ts.type != BT_INTEGER || expr->rank != 0)
10655 0 : gfc_error ("DIST_SCHEDULE clause's chunk_size at %L requires "
10656 : "a scalar INTEGER expression", &expr->where);
10657 : }
10658 32157 : if (omp_clauses->thread_limit)
10659 72 : resolve_positive_int_expr (omp_clauses->thread_limit, "THREAD_LIMIT");
10660 32157 : if (omp_clauses->grainsize)
10661 34 : resolve_positive_int_expr (omp_clauses->grainsize, "GRAINSIZE");
10662 32157 : if (omp_clauses->num_tasks)
10663 26 : resolve_positive_int_expr (omp_clauses->num_tasks, "NUM_TASKS");
10664 32157 : if (omp_clauses->grainsize && omp_clauses->num_tasks)
10665 1 : gfc_error ("%<GRAINSIZE%> clause at %L must not be used together with "
10666 : "%<NUM_TASKS%> clause", &omp_clauses->grainsize->where);
10667 32157 : if (omp_clauses->lists[OMP_LIST_REDUCTION] && omp_clauses->nogroup)
10668 1 : gfc_error ("%<REDUCTION%> clause at %L must not be used together with "
10669 : "%<NOGROUP%> clause",
10670 : &omp_clauses->lists[OMP_LIST_REDUCTION]->where);
10671 32157 : if (omp_clauses->full && omp_clauses->partial)
10672 0 : gfc_error ("%<FULL%> clause at %C must not be used together with "
10673 : "%<PARTIAL%> clause");
10674 32157 : if (omp_clauses->async)
10675 610 : if (omp_clauses->async_expr)
10676 610 : resolve_scalar_int_expr (omp_clauses->async_expr, "ASYNC");
10677 32157 : if (omp_clauses->num_gangs_expr)
10678 682 : resolve_positive_int_expr (omp_clauses->num_gangs_expr, "NUM_GANGS");
10679 32157 : if (omp_clauses->num_workers_expr)
10680 599 : resolve_positive_int_expr (omp_clauses->num_workers_expr, "NUM_WORKERS");
10681 32157 : if (omp_clauses->vector_length_expr)
10682 569 : resolve_positive_int_expr (omp_clauses->vector_length_expr,
10683 : "VECTOR_LENGTH");
10684 32157 : if (omp_clauses->gang_num_expr)
10685 114 : resolve_positive_int_expr (omp_clauses->gang_num_expr, "GANG");
10686 32157 : if (omp_clauses->gang_static_expr)
10687 94 : resolve_positive_int_expr (omp_clauses->gang_static_expr, "GANG");
10688 32157 : if (omp_clauses->worker_expr)
10689 101 : resolve_positive_int_expr (omp_clauses->worker_expr, "WORKER");
10690 32157 : if (omp_clauses->vector_expr)
10691 132 : resolve_positive_int_expr (omp_clauses->vector_expr, "VECTOR");
10692 32496 : for (el = omp_clauses->wait_list; el; el = el->next)
10693 339 : resolve_scalar_int_expr (el->expr, "WAIT");
10694 32157 : if (omp_clauses->collapse && omp_clauses->tile_list)
10695 4 : gfc_error ("Incompatible use of TILE and COLLAPSE at %L", &code->loc);
10696 32157 : if (omp_clauses->message)
10697 : {
10698 45 : gfc_expr *expr = omp_clauses->message;
10699 45 : if (!gfc_resolve_expr (expr)
10700 45 : || expr->ts.kind != gfc_default_character_kind
10701 87 : || expr->ts.type != BT_CHARACTER || expr->rank != 0)
10702 4 : gfc_error ("MESSAGE clause at %L requires a scalar default-kind "
10703 : "CHARACTER expression", &expr->where);
10704 : }
10705 32157 : if (!openacc
10706 32157 : && code
10707 19322 : && omp_clauses->lists[OMP_LIST_MAP] == NULL
10708 15865 : && omp_clauses->lists[OMP_LIST_USE_DEVICE_PTR] == NULL
10709 15862 : && omp_clauses->lists[OMP_LIST_USE_DEVICE_ADDR] == NULL)
10710 : {
10711 15839 : const char *p = NULL;
10712 15839 : switch (code->op)
10713 : {
10714 1 : case EXEC_OMP_TARGET_ENTER_DATA: p = "TARGET ENTER DATA"; break;
10715 1 : case EXEC_OMP_TARGET_EXIT_DATA: p = "TARGET EXIT DATA"; break;
10716 : default: break;
10717 : }
10718 15839 : if (code->op == EXEC_OMP_TARGET_DATA)
10719 1 : gfc_error ("TARGET DATA must contain at least one MAP, USE_DEVICE_PTR, "
10720 : "or USE_DEVICE_ADDR clause at %L", &code->loc);
10721 15838 : else if (p)
10722 2 : gfc_error ("%s must contain at least one MAP clause at %L",
10723 : p, &code->loc);
10724 : }
10725 32157 : if (omp_clauses->sizes_list)
10726 : {
10727 : gfc_expr_list *el;
10728 572 : for (el = omp_clauses->sizes_list; el; el = el->next)
10729 : {
10730 377 : resolve_scalar_int_expr (el->expr, "SIZES");
10731 377 : if (el->expr->expr_type != EXPR_CONSTANT)
10732 1 : gfc_error ("SIZES requires constant expression at %L",
10733 : &el->expr->where);
10734 376 : else if (el->expr->expr_type == EXPR_CONSTANT
10735 376 : && el->expr->ts.type == BT_INTEGER
10736 376 : && mpz_sgn (el->expr->value.integer) <= 0)
10737 2 : gfc_error ("INTEGER expression of %s clause at %L must be "
10738 : "positive", "SIZES", &el->expr->where);
10739 : }
10740 : }
10741 :
10742 32157 : if (!openacc && omp_clauses->detach)
10743 : {
10744 125 : if (!gfc_resolve_expr (omp_clauses->detach)
10745 125 : || omp_clauses->detach->ts.type != BT_INTEGER
10746 124 : || omp_clauses->detach->ts.kind != gfc_c_intptr_kind
10747 248 : || omp_clauses->detach->rank != 0)
10748 3 : gfc_error ("%qs at %L should be a scalar of type "
10749 : "integer(kind=omp_event_handle_kind)",
10750 3 : omp_clauses->detach->symtree->n.sym->name,
10751 3 : &omp_clauses->detach->where);
10752 122 : else if (omp_clauses->detach->symtree->n.sym->attr.dimension > 0)
10753 1 : gfc_error ("The event handle at %L must not be an array element",
10754 : &omp_clauses->detach->where);
10755 121 : else if (omp_clauses->detach->symtree->n.sym->ts.type == BT_DERIVED
10756 120 : || omp_clauses->detach->symtree->n.sym->ts.type == BT_CLASS)
10757 1 : gfc_error ("The event handle at %L must not be part of "
10758 : "a derived type or class", &omp_clauses->detach->where);
10759 :
10760 125 : if (omp_clauses->mergeable)
10761 2 : gfc_error ("%<DETACH%> clause at %L must not be used together with "
10762 2 : "%<MERGEABLE%> clause", &omp_clauses->detach->where);
10763 : }
10764 :
10765 12617 : if (openacc
10766 12617 : && code->op == EXEC_OACC_HOST_DATA
10767 60 : && omp_clauses->lists[OMP_LIST_USE_DEVICE] == NULL)
10768 1 : gfc_error ("%<host_data%> construct at %L requires %<use_device%> clause",
10769 : &code->loc);
10770 :
10771 32157 : if (omp_clauses->assume)
10772 16 : gfc_resolve_omp_assumptions (omp_clauses->assume);
10773 : }
10774 :
10775 :
10776 : /* Return true if SYM is ever referenced in EXPR except in the SE node. */
10777 :
10778 : static bool
10779 4991 : expr_references_sym (gfc_expr *e, gfc_symbol *s, gfc_expr *se)
10780 : {
10781 6617 : gfc_actual_arglist *arg;
10782 6617 : if (e == NULL || e == se)
10783 : return false;
10784 5366 : switch (e->expr_type)
10785 : {
10786 3120 : case EXPR_CONSTANT:
10787 3120 : case EXPR_NULL:
10788 3120 : case EXPR_VARIABLE:
10789 3120 : case EXPR_STRUCTURE:
10790 3120 : case EXPR_ARRAY:
10791 3120 : if (e->symtree != NULL
10792 1152 : && e->symtree->n.sym == s)
10793 : return true;
10794 : return false;
10795 0 : case EXPR_SUBSTRING:
10796 0 : if (e->ref != NULL
10797 0 : && (expr_references_sym (e->ref->u.ss.start, s, se)
10798 0 : || expr_references_sym (e->ref->u.ss.end, s, se)))
10799 0 : return true;
10800 : return false;
10801 1735 : case EXPR_OP:
10802 1735 : if (expr_references_sym (e->value.op.op2, s, se))
10803 : return true;
10804 1626 : return expr_references_sym (e->value.op.op1, s, se);
10805 511 : case EXPR_FUNCTION:
10806 896 : for (arg = e->value.function.actual; arg; arg = arg->next)
10807 586 : if (expr_references_sym (arg->expr, s, se))
10808 : return true;
10809 : return false;
10810 0 : default:
10811 0 : gcc_unreachable ();
10812 : }
10813 : }
10814 :
10815 :
10816 : /* If EXPR is a conversion function that widens the type
10817 : if WIDENING is true or narrows the type if NARROW is true,
10818 : return the inner expression, otherwise return NULL. */
10819 :
10820 : static gfc_expr *
10821 5911 : is_conversion (gfc_expr *expr, bool narrowing, bool widening)
10822 : {
10823 5911 : gfc_typespec *ts1, *ts2;
10824 :
10825 5911 : if (expr->expr_type != EXPR_FUNCTION
10826 917 : || expr->value.function.isym == NULL
10827 894 : || expr->value.function.esym != NULL
10828 894 : || expr->value.function.isym->id != GFC_ISYM_CONVERSION
10829 388 : || (!narrowing && !widening))
10830 : return NULL;
10831 :
10832 388 : if (narrowing && widening)
10833 267 : return expr->value.function.actual->expr;
10834 :
10835 121 : if (widening)
10836 : {
10837 121 : ts1 = &expr->ts;
10838 121 : ts2 = &expr->value.function.actual->expr->ts;
10839 : }
10840 : else
10841 : {
10842 0 : ts1 = &expr->value.function.actual->expr->ts;
10843 0 : ts2 = &expr->ts;
10844 : }
10845 :
10846 121 : if (ts1->type > ts2->type
10847 49 : || (ts1->type == ts2->type && ts1->kind > ts2->kind))
10848 121 : return expr->value.function.actual->expr;
10849 :
10850 : return NULL;
10851 : }
10852 :
10853 : static bool
10854 6855 : is_scalar_intrinsic_expr (gfc_expr *expr, bool must_be_var, bool conv_ok)
10855 : {
10856 6855 : if (must_be_var
10857 4020 : && (expr->expr_type != EXPR_VARIABLE || !expr->symtree))
10858 : {
10859 37 : if (!conv_ok)
10860 : return false;
10861 37 : gfc_expr *conv = is_conversion (expr, true, true);
10862 37 : if (!conv)
10863 : return false;
10864 36 : if (conv->expr_type != EXPR_VARIABLE || !conv->symtree)
10865 : return false;
10866 : }
10867 6852 : return (expr->rank == 0
10868 6848 : && !gfc_is_coindexed (expr)
10869 13700 : && (expr->ts.type == BT_INTEGER
10870 : || expr->ts.type == BT_REAL
10871 : || expr->ts.type == BT_COMPLEX
10872 : || expr->ts.type == BT_LOGICAL));
10873 : }
10874 :
10875 : static void
10876 2697 : resolve_omp_atomic (gfc_code *code)
10877 : {
10878 2697 : gfc_code *atomic_code = code->block;
10879 2697 : gfc_symbol *var;
10880 2697 : gfc_expr *stmt_expr2, *capt_expr2;
10881 2697 : gfc_omp_atomic_op aop
10882 2697 : = (gfc_omp_atomic_op) (atomic_code->ext.omp_clauses->atomic_op
10883 : & GFC_OMP_ATOMIC_MASK);
10884 2697 : gfc_code *stmt = NULL, *capture_stmt = NULL, *tailing_stmt = NULL;
10885 2697 : gfc_expr *comp_cond = NULL;
10886 2697 : locus *loc = NULL;
10887 :
10888 2697 : code = code->block->next;
10889 : /* resolve_blocks asserts this is initially EXEC_ASSIGN or EXEC_IF
10890 : If it changed to EXEC_NOP, assume an error has been emitted already. */
10891 2697 : if (code->op == EXEC_NOP)
10892 : return;
10893 :
10894 2696 : if (atomic_code->ext.omp_clauses->compare
10895 156 : && atomic_code->ext.omp_clauses->capture)
10896 : {
10897 : /* Must be either "if (x == e) then; x = d; else; v = x; end if"
10898 : or "v = expr" followed/preceded by
10899 : "if (x == e) then; x = d; end if" or "if (x == e) x = d". */
10900 103 : gfc_code *next = code;
10901 103 : if (code->op == EXEC_ASSIGN)
10902 : {
10903 19 : capture_stmt = code;
10904 19 : next = code->next;
10905 : }
10906 103 : if (next->op == EXEC_IF
10907 103 : && next->block
10908 103 : && next->block->op == EXEC_IF
10909 103 : && next->block->next
10910 102 : && next->block->next->op == EXEC_ASSIGN)
10911 : {
10912 102 : comp_cond = next->block->expr1;
10913 102 : stmt = next->block->next;
10914 102 : if (stmt->next)
10915 : {
10916 0 : loc = &stmt->loc;
10917 0 : goto unexpected;
10918 : }
10919 : }
10920 1 : else if (capture_stmt)
10921 : {
10922 0 : gfc_error ("Expected IF at %L in atomic compare capture",
10923 : &next->loc);
10924 0 : return;
10925 : }
10926 103 : if (stmt && !capture_stmt && next->block->block)
10927 : {
10928 64 : if (next->block->block->expr1)
10929 : {
10930 0 : gfc_error ("Expected ELSE at %L in atomic compare capture",
10931 : &next->block->block->expr1->where);
10932 0 : return;
10933 : }
10934 64 : if (!code->block->block->next
10935 64 : || code->block->block->next->op != EXEC_ASSIGN)
10936 : {
10937 0 : loc = (code->block->block->next ? &code->block->block->next->loc
10938 : : &code->block->block->loc);
10939 0 : goto unexpected;
10940 : }
10941 64 : capture_stmt = code->block->block->next;
10942 64 : if (capture_stmt->next)
10943 : {
10944 0 : loc = &capture_stmt->next->loc;
10945 0 : goto unexpected;
10946 : }
10947 : }
10948 103 : if (stmt && !capture_stmt && next->next->op == EXEC_ASSIGN)
10949 : capture_stmt = next->next;
10950 84 : else if (!capture_stmt)
10951 : {
10952 1 : loc = &code->loc;
10953 1 : goto unexpected;
10954 : }
10955 : }
10956 2593 : else if (atomic_code->ext.omp_clauses->compare)
10957 : {
10958 : /* Must be: "if (x == e) then; x = d; end if" or "if (x == e) x = d". */
10959 53 : if (code->op == EXEC_IF
10960 53 : && code->block
10961 53 : && code->block->op == EXEC_IF
10962 53 : && code->block->next
10963 51 : && code->block->next->op == EXEC_ASSIGN)
10964 : {
10965 51 : comp_cond = code->block->expr1;
10966 51 : stmt = code->block->next;
10967 51 : if (stmt->next || code->block->block)
10968 : {
10969 0 : loc = stmt->next ? &stmt->next->loc : &code->block->block->loc;
10970 0 : goto unexpected;
10971 : }
10972 : }
10973 : else
10974 : {
10975 2 : loc = &code->loc;
10976 2 : goto unexpected;
10977 : }
10978 : }
10979 2540 : else if (atomic_code->ext.omp_clauses->capture)
10980 : {
10981 : /* Must be: "v = x" followed/preceded by "x = ...". */
10982 489 : if (code->op != EXEC_ASSIGN)
10983 0 : goto unexpected;
10984 489 : if (code->next->op != EXEC_ASSIGN)
10985 : {
10986 0 : loc = &code->next->loc;
10987 0 : goto unexpected;
10988 : }
10989 489 : gfc_expr *expr2, *expr2_next;
10990 489 : expr2 = is_conversion (code->expr2, true, true);
10991 489 : if (expr2 == NULL)
10992 447 : expr2 = code->expr2;
10993 489 : expr2_next = is_conversion (code->next->expr2, true, true);
10994 489 : if (expr2_next == NULL)
10995 478 : expr2_next = code->next->expr2;
10996 489 : if (code->expr1->expr_type == EXPR_VARIABLE
10997 489 : && code->next->expr1->expr_type == EXPR_VARIABLE
10998 489 : && expr2->expr_type == EXPR_VARIABLE
10999 243 : && expr2_next->expr_type == EXPR_VARIABLE)
11000 : {
11001 1 : if (code->expr1->symtree->n.sym == expr2_next->symtree->n.sym)
11002 : {
11003 : stmt = code;
11004 : capture_stmt = code->next;
11005 : }
11006 : else
11007 : {
11008 489 : capture_stmt = code;
11009 489 : stmt = code->next;
11010 : }
11011 : }
11012 488 : else if (expr2->expr_type == EXPR_VARIABLE)
11013 : {
11014 : capture_stmt = code;
11015 : stmt = code->next;
11016 : }
11017 : else
11018 : {
11019 247 : stmt = code;
11020 247 : capture_stmt = code->next;
11021 : }
11022 : /* Shall be NULL but can happen for invalid code. */
11023 489 : tailing_stmt = code->next->next;
11024 : }
11025 : else
11026 : {
11027 : /* x = ... */
11028 2051 : stmt = code;
11029 2051 : if (!atomic_code->ext.omp_clauses->compare && stmt->op != EXEC_ASSIGN)
11030 1 : goto unexpected;
11031 : /* Shall be NULL but can happen for invalid code. */
11032 2050 : tailing_stmt = code->next;
11033 : }
11034 :
11035 2692 : if (comp_cond)
11036 : {
11037 153 : if (comp_cond->expr_type != EXPR_OP
11038 153 : || (comp_cond->value.op.op != INTRINSIC_EQ
11039 : && comp_cond->value.op.op != INTRINSIC_EQ_OS
11040 : && comp_cond->value.op.op != INTRINSIC_EQV))
11041 : {
11042 0 : gfc_error ("Expected %<==%>, %<.EQ.%> or %<.EQV.%> atomic comparison "
11043 : "expression at %L", &comp_cond->where);
11044 0 : return;
11045 : }
11046 153 : if (!is_scalar_intrinsic_expr (comp_cond->value.op.op1, true, true))
11047 : {
11048 1 : gfc_error ("Expected scalar intrinsic variable at %L in atomic "
11049 1 : "comparison", &comp_cond->value.op.op1->where);
11050 1 : return;
11051 : }
11052 152 : if (!gfc_resolve_expr (comp_cond->value.op.op2))
11053 : return;
11054 152 : if (!is_scalar_intrinsic_expr (comp_cond->value.op.op2, false, false))
11055 : {
11056 0 : gfc_error ("Expected scalar intrinsic expression at %L in atomic "
11057 0 : "comparison", &comp_cond->value.op.op1->where);
11058 0 : return;
11059 : }
11060 : }
11061 :
11062 2691 : if (!is_scalar_intrinsic_expr (stmt->expr1, true, false))
11063 : {
11064 4 : gfc_error ("!$OMP ATOMIC statement must set a scalar variable of "
11065 4 : "intrinsic type at %L", &stmt->expr1->where);
11066 4 : return;
11067 : }
11068 :
11069 2687 : if (!gfc_resolve_expr (stmt->expr2))
11070 : return;
11071 2683 : if (!is_scalar_intrinsic_expr (stmt->expr2, false, false))
11072 : {
11073 0 : gfc_error ("!$OMP ATOMIC statement must assign an expression of "
11074 0 : "intrinsic type at %L", &stmt->expr2->where);
11075 0 : return;
11076 : }
11077 :
11078 2683 : if (gfc_expr_attr (stmt->expr1).allocatable)
11079 : {
11080 0 : gfc_error ("!$OMP ATOMIC with ALLOCATABLE variable at %L",
11081 0 : &stmt->expr1->where);
11082 0 : return;
11083 : }
11084 :
11085 : /* Should be diagnosed above already. */
11086 2683 : gcc_assert (tailing_stmt == NULL);
11087 :
11088 2683 : var = stmt->expr1->symtree->n.sym;
11089 2683 : stmt_expr2 = is_conversion (stmt->expr2, true, true);
11090 2683 : if (stmt_expr2 == NULL)
11091 2527 : stmt_expr2 = stmt->expr2;
11092 :
11093 2683 : switch (aop)
11094 : {
11095 503 : case GFC_OMP_ATOMIC_READ:
11096 503 : if (stmt_expr2->expr_type != EXPR_VARIABLE)
11097 0 : gfc_error ("!$OMP ATOMIC READ statement must read from a scalar "
11098 : "variable of intrinsic type at %L", &stmt_expr2->where);
11099 : return;
11100 421 : case GFC_OMP_ATOMIC_WRITE:
11101 421 : if (expr_references_sym (stmt_expr2, var, NULL))
11102 0 : gfc_error ("expr in !$OMP ATOMIC WRITE assignment var = expr "
11103 : "must be scalar and cannot reference var at %L",
11104 : &stmt_expr2->where);
11105 : return;
11106 1759 : default:
11107 1759 : break;
11108 : }
11109 :
11110 1759 : if (atomic_code->ext.omp_clauses->capture)
11111 : {
11112 588 : if (!is_scalar_intrinsic_expr (capture_stmt->expr1, true, false))
11113 : {
11114 0 : gfc_error ("!$OMP ATOMIC capture-statement must set a scalar "
11115 : "variable of intrinsic type at %L",
11116 0 : &capture_stmt->expr1->where);
11117 0 : return;
11118 : }
11119 :
11120 588 : if (!is_scalar_intrinsic_expr (capture_stmt->expr2, true, true))
11121 : {
11122 2 : gfc_error ("!$OMP ATOMIC capture-statement requires a scalar variable"
11123 2 : " of intrinsic type at %L", &capture_stmt->expr2->where);
11124 2 : return;
11125 : }
11126 586 : capt_expr2 = is_conversion (capture_stmt->expr2, true, true);
11127 586 : if (capt_expr2 == NULL)
11128 564 : capt_expr2 = capture_stmt->expr2;
11129 :
11130 586 : if (capt_expr2->symtree->n.sym != var)
11131 : {
11132 1 : gfc_error ("!$OMP ATOMIC CAPTURE capture statement reads from "
11133 : "different variable than update statement writes "
11134 : "into at %L", &capture_stmt->expr2->where);
11135 1 : return;
11136 : }
11137 : }
11138 :
11139 1756 : if (atomic_code->ext.omp_clauses->compare)
11140 : {
11141 149 : gfc_expr *var_expr;
11142 149 : if (comp_cond->value.op.op1->expr_type == EXPR_VARIABLE)
11143 : var_expr = comp_cond->value.op.op1;
11144 : else
11145 12 : var_expr = comp_cond->value.op.op1->value.function.actual->expr;
11146 149 : if (var_expr->symtree->n.sym != var)
11147 : {
11148 2 : gfc_error ("For !$OMP ATOMIC COMPARE, the first operand in comparison"
11149 : " at %L must be the variable %qs that the update statement"
11150 : " writes into at %L", &var_expr->where, var->name,
11151 2 : &stmt->expr1->where);
11152 2 : return;
11153 : }
11154 147 : if (stmt_expr2->rank != 0 || expr_references_sym (stmt_expr2, var, NULL))
11155 : {
11156 1 : gfc_error ("expr in !$OMP ATOMIC COMPARE assignment var = expr "
11157 : "must be scalar and cannot reference var at %L",
11158 : &stmt_expr2->where);
11159 1 : return;
11160 : }
11161 : }
11162 1607 : else if (atomic_code->ext.omp_clauses->capture
11163 1607 : && !expr_references_sym (stmt_expr2, var, NULL))
11164 22 : atomic_code->ext.omp_clauses->atomic_op
11165 22 : = (gfc_omp_atomic_op) (atomic_code->ext.omp_clauses->atomic_op
11166 : | GFC_OMP_ATOMIC_SWAP);
11167 1585 : else if (stmt_expr2->expr_type == EXPR_OP)
11168 : {
11169 1229 : gfc_expr *v = NULL, *e, *c;
11170 1229 : gfc_intrinsic_op op = stmt_expr2->value.op.op;
11171 1229 : gfc_intrinsic_op alt_op = INTRINSIC_NONE;
11172 :
11173 1229 : if (atomic_code->ext.omp_clauses->fail != OMP_MEMORDER_UNSET)
11174 3 : gfc_error ("!$OMP ATOMIC UPDATE at %L with FAIL clause requires either"
11175 : " the COMPARE clause or using the intrinsic MIN/MAX "
11176 : "procedure", &atomic_code->loc);
11177 1229 : switch (op)
11178 : {
11179 742 : case INTRINSIC_PLUS:
11180 742 : alt_op = INTRINSIC_MINUS;
11181 742 : break;
11182 94 : case INTRINSIC_TIMES:
11183 94 : alt_op = INTRINSIC_DIVIDE;
11184 94 : break;
11185 120 : case INTRINSIC_MINUS:
11186 120 : alt_op = INTRINSIC_PLUS;
11187 120 : break;
11188 94 : case INTRINSIC_DIVIDE:
11189 94 : alt_op = INTRINSIC_TIMES;
11190 94 : break;
11191 : case INTRINSIC_AND:
11192 : case INTRINSIC_OR:
11193 : break;
11194 43 : case INTRINSIC_EQV:
11195 43 : alt_op = INTRINSIC_NEQV;
11196 43 : break;
11197 43 : case INTRINSIC_NEQV:
11198 43 : alt_op = INTRINSIC_EQV;
11199 43 : break;
11200 1 : default:
11201 1 : gfc_error ("!$OMP ATOMIC assignment operator must be binary "
11202 : "+, *, -, /, .AND., .OR., .EQV. or .NEQV. at %L",
11203 : &stmt_expr2->where);
11204 1 : return;
11205 : }
11206 :
11207 : /* Check for var = var op expr resp. var = expr op var where
11208 : expr doesn't reference var and var op expr is mathematically
11209 : equivalent to var op (expr) resp. expr op var equivalent to
11210 : (expr) op var. We rely here on the fact that the matcher
11211 : for x op1 y op2 z where op1 and op2 have equal precedence
11212 : returns (x op1 y) op2 z. */
11213 1228 : e = stmt_expr2->value.op.op2;
11214 1228 : if (e->expr_type == EXPR_VARIABLE
11215 288 : && e->symtree != NULL
11216 288 : && e->symtree->n.sym == var)
11217 : v = e;
11218 999 : else if ((c = is_conversion (e, false, true)) != NULL
11219 48 : && c->expr_type == EXPR_VARIABLE
11220 48 : && c->symtree != NULL
11221 1047 : && c->symtree->n.sym == var)
11222 : v = c;
11223 : else
11224 : {
11225 951 : gfc_expr **p = NULL, **q;
11226 1049 : for (q = &stmt_expr2->value.op.op1; (e = *q) != NULL; )
11227 1049 : if (e->expr_type == EXPR_VARIABLE
11228 948 : && e->symtree != NULL
11229 948 : && e->symtree->n.sym == var)
11230 : {
11231 : v = e;
11232 : break;
11233 : }
11234 101 : else if ((c = is_conversion (e, false, true)) != NULL)
11235 60 : q = &e->value.function.actual->expr;
11236 41 : else if (e->expr_type != EXPR_OP
11237 41 : || (e->value.op.op != op
11238 15 : && e->value.op.op != alt_op)
11239 38 : || e->rank != 0)
11240 : break;
11241 : else
11242 : {
11243 38 : p = q;
11244 38 : q = &e->value.op.op1;
11245 : }
11246 :
11247 951 : if (v == NULL)
11248 : {
11249 3 : gfc_error ("!$OMP ATOMIC assignment must be var = var op expr "
11250 : "or var = expr op var at %L", &stmt_expr2->where);
11251 3 : return;
11252 : }
11253 :
11254 948 : if (p != NULL)
11255 : {
11256 38 : e = *p;
11257 38 : switch (e->value.op.op)
11258 : {
11259 8 : case INTRINSIC_MINUS:
11260 8 : case INTRINSIC_DIVIDE:
11261 8 : case INTRINSIC_EQV:
11262 8 : case INTRINSIC_NEQV:
11263 8 : gfc_error ("!$OMP ATOMIC var = var op expr not "
11264 : "mathematically equivalent to var = var op "
11265 : "(expr) at %L", &stmt_expr2->where);
11266 8 : break;
11267 : default:
11268 : break;
11269 : }
11270 :
11271 : /* Canonicalize into var = var op (expr). */
11272 38 : *p = e->value.op.op2;
11273 38 : e->value.op.op2 = stmt_expr2;
11274 38 : e->ts = stmt_expr2->ts;
11275 38 : if (stmt->expr2 == stmt_expr2)
11276 26 : stmt->expr2 = stmt_expr2 = e;
11277 : else
11278 12 : stmt->expr2->value.function.actual->expr = stmt_expr2 = e;
11279 :
11280 38 : if (!gfc_compare_types (&stmt_expr2->value.op.op1->ts,
11281 : &stmt_expr2->ts))
11282 : {
11283 24 : for (p = &stmt_expr2->value.op.op1; *p != v;
11284 12 : p = &(*p)->value.function.actual->expr)
11285 : ;
11286 12 : *p = NULL;
11287 12 : gfc_free_expr (stmt_expr2->value.op.op1);
11288 12 : stmt_expr2->value.op.op1 = v;
11289 12 : gfc_convert_type (v, &stmt_expr2->ts, 2);
11290 : }
11291 : }
11292 : }
11293 :
11294 1225 : if (e->rank != 0 || expr_references_sym (stmt->expr2, var, v))
11295 : {
11296 1 : gfc_error ("expr in !$OMP ATOMIC assignment var = var op expr "
11297 : "must be scalar and cannot reference var at %L",
11298 : &stmt_expr2->where);
11299 1 : return;
11300 : }
11301 : }
11302 356 : else if (stmt_expr2->expr_type == EXPR_FUNCTION
11303 355 : && stmt_expr2->value.function.isym != NULL
11304 355 : && stmt_expr2->value.function.esym == NULL
11305 355 : && stmt_expr2->value.function.actual != NULL
11306 355 : && stmt_expr2->value.function.actual->next != NULL)
11307 : {
11308 355 : gfc_actual_arglist *arg, *var_arg;
11309 :
11310 355 : switch (stmt_expr2->value.function.isym->id)
11311 : {
11312 : case GFC_ISYM_MIN:
11313 : case GFC_ISYM_MAX:
11314 : break;
11315 147 : case GFC_ISYM_IAND:
11316 147 : case GFC_ISYM_IOR:
11317 147 : case GFC_ISYM_IEOR:
11318 147 : if (stmt_expr2->value.function.actual->next->next != NULL)
11319 : {
11320 0 : gfc_error ("!$OMP ATOMIC assignment intrinsic IAND, IOR "
11321 : "or IEOR must have two arguments at %L",
11322 : &stmt_expr2->where);
11323 0 : return;
11324 : }
11325 : break;
11326 1 : default:
11327 1 : gfc_error ("!$OMP ATOMIC assignment intrinsic must be "
11328 : "MIN, MAX, IAND, IOR or IEOR at %L",
11329 : &stmt_expr2->where);
11330 1 : return;
11331 : }
11332 :
11333 : var_arg = NULL;
11334 1088 : for (arg = stmt_expr2->value.function.actual; arg; arg = arg->next)
11335 : {
11336 741 : gfc_expr *e = NULL;
11337 741 : if (arg == stmt_expr2->value.function.actual
11338 387 : || (var_arg == NULL && arg->next == NULL))
11339 : {
11340 527 : e = is_conversion (arg->expr, false, true);
11341 527 : if (!e)
11342 514 : e = arg->expr;
11343 527 : if (e->expr_type == EXPR_VARIABLE
11344 453 : && e->symtree != NULL
11345 453 : && e->symtree->n.sym == var)
11346 741 : var_arg = arg;
11347 : }
11348 741 : if ((!var_arg || !e) && expr_references_sym (arg->expr, var, NULL))
11349 : {
11350 7 : gfc_error ("!$OMP ATOMIC intrinsic arguments except one must "
11351 : "not reference %qs at %L",
11352 : var->name, &arg->expr->where);
11353 7 : return;
11354 : }
11355 734 : if (arg->expr->rank != 0)
11356 : {
11357 0 : gfc_error ("!$OMP ATOMIC intrinsic arguments must be scalar "
11358 : "at %L", &arg->expr->where);
11359 0 : return;
11360 : }
11361 : }
11362 :
11363 347 : if (var_arg == NULL)
11364 : {
11365 1 : gfc_error ("First or last !$OMP ATOMIC intrinsic argument must "
11366 : "be %qs at %L", var->name, &stmt_expr2->where);
11367 1 : return;
11368 : }
11369 :
11370 346 : if (var_arg != stmt_expr2->value.function.actual)
11371 : {
11372 : /* Canonicalize, so that var comes first. */
11373 172 : gcc_assert (var_arg->next == NULL);
11374 : for (arg = stmt_expr2->value.function.actual;
11375 185 : arg->next != var_arg; arg = arg->next)
11376 : ;
11377 172 : var_arg->next = stmt_expr2->value.function.actual;
11378 172 : stmt_expr2->value.function.actual = var_arg;
11379 172 : arg->next = NULL;
11380 : }
11381 : }
11382 : else
11383 1 : gfc_error ("!$OMP ATOMIC assignment must have an operator or "
11384 : "intrinsic on right hand side at %L", &stmt_expr2->where);
11385 : return;
11386 :
11387 4 : unexpected:
11388 4 : gfc_error ("unexpected !$OMP ATOMIC expression at %L",
11389 : loc ? loc : &code->loc);
11390 4 : return;
11391 : }
11392 :
11393 :
11394 : static struct fortran_omp_context
11395 : {
11396 : gfc_code *code;
11397 : hash_set<gfc_symbol *> *sharing_clauses;
11398 : hash_set<gfc_symbol *> *private_iterators;
11399 : struct fortran_omp_context *previous;
11400 : bool is_openmp;
11401 : } *omp_current_ctx;
11402 : static gfc_code *omp_current_do_code;
11403 : static int omp_current_do_collapse;
11404 :
11405 : /* Forward declaration for mutually recursive functions. */
11406 : static gfc_code *
11407 : find_nested_loop_in_block (gfc_code *block);
11408 :
11409 : /* Return the first nested DO loop in CHAIN, or NULL if there
11410 : isn't one. Does no error checking on intervening code. */
11411 :
11412 : static gfc_code *
11413 27476 : find_nested_loop_in_chain (gfc_code *chain)
11414 : {
11415 27476 : gfc_code *code;
11416 :
11417 27476 : if (!chain)
11418 : return NULL;
11419 :
11420 31637 : for (code = chain; code; code = code->next)
11421 31216 : switch (code->op)
11422 : {
11423 : case EXEC_DO:
11424 : case EXEC_OMP_TILE:
11425 : case EXEC_OMP_UNROLL:
11426 : return code;
11427 621 : case EXEC_BLOCK:
11428 621 : if (gfc_code *c = find_nested_loop_in_block (code))
11429 : return c;
11430 : break;
11431 : default:
11432 : break;
11433 : }
11434 : return NULL;
11435 : }
11436 :
11437 : /* Return the first nested DO loop in BLOCK, or NULL if there
11438 : isn't one. Does no error checking on intervening code. */
11439 : static gfc_code *
11440 939 : find_nested_loop_in_block (gfc_code *block)
11441 : {
11442 939 : gfc_namespace *ns;
11443 939 : gcc_assert (block->op == EXEC_BLOCK);
11444 939 : ns = block->ext.block.ns;
11445 939 : gcc_assert (ns);
11446 939 : return find_nested_loop_in_chain (ns->code);
11447 : }
11448 :
11449 : void
11450 5412 : gfc_resolve_omp_do_blocks (gfc_code *code, gfc_namespace *ns)
11451 : {
11452 5412 : if (code->block->next && code->block->next->op == EXEC_DO)
11453 : {
11454 5059 : int i;
11455 :
11456 5059 : omp_current_do_code = code->block->next;
11457 5059 : if (code->ext.omp_clauses->orderedc)
11458 142 : omp_current_do_collapse = code->ext.omp_clauses->orderedc;
11459 4917 : else if (code->ext.omp_clauses->collapse)
11460 1120 : omp_current_do_collapse = code->ext.omp_clauses->collapse;
11461 3797 : else if (code->ext.omp_clauses->sizes_list)
11462 175 : omp_current_do_collapse
11463 175 : = gfc_expr_list_len (code->ext.omp_clauses->sizes_list);
11464 : else
11465 3622 : omp_current_do_collapse = 1;
11466 5059 : if (code->ext.omp_clauses->lists[OMP_LIST_REDUCTION_INSCAN])
11467 : {
11468 : /* Checking that there is a matching EXEC_OMP_SCAN in the
11469 : innermost body cannot be deferred to resolve_omp_do because
11470 : we process directives nested in the loop before we get
11471 : there. */
11472 60 : locus *loc
11473 : = &code->ext.omp_clauses->lists[OMP_LIST_REDUCTION_INSCAN]->where;
11474 60 : gfc_code *c;
11475 :
11476 80 : for (i = 1, c = omp_current_do_code;
11477 80 : i < omp_current_do_collapse; i++)
11478 : {
11479 22 : c = find_nested_loop_in_chain (c->block->next);
11480 22 : if (!c || c->op != EXEC_DO || c->block == NULL)
11481 : break;
11482 : }
11483 :
11484 : /* Skip this if we don't have enough nested loops. That
11485 : problem will be diagnosed elsewhere. */
11486 60 : if (c && c->op == EXEC_DO)
11487 : {
11488 58 : gfc_code *block = c->block ? c->block->next : NULL;
11489 58 : if (block && block->op != EXEC_OMP_SCAN)
11490 54 : while (block && block->next
11491 54 : && block->next->op != EXEC_OMP_SCAN)
11492 : block = block->next;
11493 43 : if (!block
11494 46 : || (block->op != EXEC_OMP_SCAN
11495 43 : && (!block->next || block->next->op != EXEC_OMP_SCAN)))
11496 19 : gfc_error ("With INSCAN at %L, expected loop body with "
11497 : "!$OMP SCAN between two "
11498 : "structured block sequences", loc);
11499 : else
11500 : {
11501 39 : if (block->op == EXEC_OMP_SCAN)
11502 3 : gfc_warning (OPT_Wopenmp,
11503 : "!$OMP SCAN at %L with zero executable "
11504 : "statements in preceding structured block "
11505 : "sequence", &block->loc);
11506 39 : if ((block->op == EXEC_OMP_SCAN && !block->next)
11507 38 : || (block->next && block->next->op == EXEC_OMP_SCAN
11508 36 : && !block->next->next))
11509 3 : gfc_warning (OPT_Wopenmp,
11510 : "!$OMP SCAN at %L with zero executable "
11511 : "statements in succeeding structured block "
11512 : "sequence", block->op == EXEC_OMP_SCAN
11513 1 : ? &block->loc : &block->next->loc);
11514 : }
11515 58 : if (block && block->op != EXEC_OMP_SCAN)
11516 43 : block = block->next;
11517 46 : if (block && block->op == EXEC_OMP_SCAN)
11518 : /* Mark 'omp scan' as checked; flag will be unset later. */
11519 39 : block->ext.omp_clauses->if_present = true;
11520 : }
11521 : }
11522 : }
11523 5412 : gfc_resolve_blocks (code->block, ns);
11524 5412 : omp_current_do_collapse = 0;
11525 5412 : omp_current_do_code = NULL;
11526 5412 : }
11527 :
11528 :
11529 : void
11530 6014 : gfc_resolve_omp_parallel_blocks (gfc_code *code, gfc_namespace *ns)
11531 : {
11532 6014 : struct fortran_omp_context ctx;
11533 6014 : gfc_omp_clauses *omp_clauses = code->ext.omp_clauses;
11534 6014 : gfc_omp_namelist *n;
11535 6014 : int list;
11536 :
11537 6014 : ctx.code = code;
11538 6014 : ctx.sharing_clauses = new hash_set<gfc_symbol *>;
11539 6014 : ctx.private_iterators = new hash_set<gfc_symbol *>;
11540 6014 : ctx.previous = omp_current_ctx;
11541 6014 : ctx.is_openmp = true;
11542 6014 : omp_current_ctx = &ctx;
11543 :
11544 240560 : for (list = 0; list < OMP_LIST_NUM; list++)
11545 234546 : switch (list)
11546 : {
11547 60140 : case OMP_LIST_SHARED:
11548 60140 : case OMP_LIST_PRIVATE:
11549 60140 : case OMP_LIST_FIRSTPRIVATE:
11550 60140 : case OMP_LIST_LASTPRIVATE:
11551 60140 : case OMP_LIST_REDUCTION:
11552 60140 : case OMP_LIST_REDUCTION_INSCAN:
11553 60140 : case OMP_LIST_REDUCTION_TASK:
11554 60140 : case OMP_LIST_IN_REDUCTION:
11555 60140 : case OMP_LIST_TASK_REDUCTION:
11556 60140 : case OMP_LIST_LINEAR:
11557 69059 : for (n = omp_clauses->lists[list]; n; n = n->next)
11558 8919 : ctx.sharing_clauses->add (n->sym);
11559 : break;
11560 : default:
11561 : break;
11562 : }
11563 :
11564 6014 : switch (code->op)
11565 : {
11566 2349 : case EXEC_OMP_DISTRIBUTE_PARALLEL_DO:
11567 2349 : case EXEC_OMP_DISTRIBUTE_PARALLEL_DO_SIMD:
11568 2349 : case EXEC_OMP_MASKED_TASKLOOP:
11569 2349 : case EXEC_OMP_MASKED_TASKLOOP_SIMD:
11570 2349 : case EXEC_OMP_MASTER_TASKLOOP:
11571 2349 : case EXEC_OMP_MASTER_TASKLOOP_SIMD:
11572 2349 : case EXEC_OMP_PARALLEL_DO:
11573 2349 : case EXEC_OMP_PARALLEL_DO_SIMD:
11574 2349 : case EXEC_OMP_PARALLEL_LOOP:
11575 2349 : case EXEC_OMP_PARALLEL_MASKED_TASKLOOP:
11576 2349 : case EXEC_OMP_PARALLEL_MASKED_TASKLOOP_SIMD:
11577 2349 : case EXEC_OMP_PARALLEL_MASTER_TASKLOOP:
11578 2349 : case EXEC_OMP_PARALLEL_MASTER_TASKLOOP_SIMD:
11579 2349 : case EXEC_OMP_TARGET_PARALLEL_DO:
11580 2349 : case EXEC_OMP_TARGET_PARALLEL_DO_SIMD:
11581 2349 : case EXEC_OMP_TARGET_PARALLEL_LOOP:
11582 2349 : case EXEC_OMP_TARGET_TEAMS_DISTRIBUTE:
11583 2349 : case EXEC_OMP_TARGET_TEAMS_DISTRIBUTE_PARALLEL_DO:
11584 2349 : case EXEC_OMP_TARGET_TEAMS_DISTRIBUTE_PARALLEL_DO_SIMD:
11585 2349 : case EXEC_OMP_TARGET_TEAMS_DISTRIBUTE_SIMD:
11586 2349 : case EXEC_OMP_TARGET_TEAMS_LOOP:
11587 2349 : case EXEC_OMP_TASKLOOP:
11588 2349 : case EXEC_OMP_TASKLOOP_SIMD:
11589 2349 : case EXEC_OMP_TEAMS_DISTRIBUTE:
11590 2349 : case EXEC_OMP_TEAMS_DISTRIBUTE_PARALLEL_DO:
11591 2349 : case EXEC_OMP_TEAMS_DISTRIBUTE_PARALLEL_DO_SIMD:
11592 2349 : case EXEC_OMP_TEAMS_DISTRIBUTE_SIMD:
11593 2349 : case EXEC_OMP_TEAMS_LOOP:
11594 2349 : gfc_resolve_omp_do_blocks (code, ns);
11595 2349 : break;
11596 3665 : default:
11597 3665 : gfc_resolve_blocks (code->block, ns);
11598 : }
11599 :
11600 6014 : omp_current_ctx = ctx.previous;
11601 12028 : delete ctx.sharing_clauses;
11602 12028 : delete ctx.private_iterators;
11603 6014 : }
11604 :
11605 :
11606 : /* Save and clear openmp.cc private state. */
11607 :
11608 : void
11609 284919 : gfc_omp_save_and_clear_state (struct gfc_omp_saved_state *state)
11610 : {
11611 284919 : state->ptrs[0] = omp_current_ctx;
11612 284919 : state->ptrs[1] = omp_current_do_code;
11613 284919 : state->ints[0] = omp_current_do_collapse;
11614 284919 : omp_current_ctx = NULL;
11615 284919 : omp_current_do_code = NULL;
11616 284919 : omp_current_do_collapse = 0;
11617 284919 : }
11618 :
11619 :
11620 : /* Restore openmp.cc private state from the saved state. */
11621 :
11622 : void
11623 284918 : gfc_omp_restore_state (struct gfc_omp_saved_state *state)
11624 : {
11625 284918 : omp_current_ctx = (struct fortran_omp_context *) state->ptrs[0];
11626 284918 : omp_current_do_code = (gfc_code *) state->ptrs[1];
11627 284918 : omp_current_do_collapse = state->ints[0];
11628 284918 : }
11629 :
11630 :
11631 : /* Note a DO iterator variable. This is special in !$omp parallel
11632 : construct, where they are predetermined private. */
11633 :
11634 : void
11635 32789 : gfc_resolve_do_iterator (gfc_code *code, gfc_symbol *sym, bool add_clause)
11636 : {
11637 32789 : if (omp_current_ctx == NULL)
11638 : return;
11639 :
11640 13083 : int i = omp_current_do_collapse;
11641 13083 : gfc_code *c = omp_current_do_code;
11642 :
11643 13083 : if (sym->attr.threadprivate)
11644 : return;
11645 :
11646 : /* !$omp do and !$omp parallel do iteration variable is predetermined
11647 : private just in the !$omp do resp. !$omp parallel do construct,
11648 : with no implications for the outer parallel constructs. */
11649 :
11650 17917 : while (i-- >= 1 && c)
11651 : {
11652 9480 : if (code == c)
11653 : return;
11654 4834 : c = find_nested_loop_in_chain (c->block->next);
11655 4834 : if (c && (c->op == EXEC_OMP_TILE || c->op == EXEC_OMP_UNROLL))
11656 : return;
11657 : }
11658 :
11659 : /* An openacc context may represent a data clause. Abort if so. */
11660 8437 : if (!omp_current_ctx->is_openmp && !oacc_is_loop (omp_current_ctx->code))
11661 : return;
11662 :
11663 7459 : if (omp_current_ctx->sharing_clauses->contains (sym))
11664 : return;
11665 :
11666 6457 : if (! omp_current_ctx->private_iterators->add (sym) && add_clause)
11667 : {
11668 6270 : gfc_omp_clauses *omp_clauses = omp_current_ctx->code->ext.omp_clauses;
11669 6270 : gfc_omp_namelist *p;
11670 :
11671 6270 : p = gfc_get_omp_namelist ();
11672 6270 : p->sym = sym;
11673 6270 : p->where = omp_current_ctx->code->loc;
11674 6270 : p->next = omp_clauses->lists[OMP_LIST_PRIVATE];
11675 6270 : omp_clauses->lists[OMP_LIST_PRIVATE] = p;
11676 : }
11677 : }
11678 :
11679 : static void
11680 698 : handle_local_var (gfc_symbol *sym)
11681 : {
11682 698 : if (sym->attr.flavor != FL_VARIABLE
11683 178 : || sym->as != NULL
11684 137 : || (sym->ts.type != BT_INTEGER && sym->ts.type != BT_REAL))
11685 : return;
11686 71 : gfc_resolve_do_iterator (sym->ns->code, sym, false);
11687 : }
11688 :
11689 : void
11690 330629 : gfc_resolve_omp_local_vars (gfc_namespace *ns)
11691 : {
11692 330629 : if (omp_current_ctx)
11693 452 : gfc_traverse_ns (ns, handle_local_var);
11694 330629 : }
11695 :
11696 :
11697 : /* Error checking on intervening code uses a code walker. */
11698 :
11699 : struct icode_error_state
11700 : {
11701 : const char *name;
11702 : bool errorp;
11703 : gfc_code *nested;
11704 : gfc_code *next;
11705 : };
11706 :
11707 : static int
11708 944 : icode_code_error_callback (gfc_code **codep,
11709 : int *walk_subtrees ATTRIBUTE_UNUSED, void *opaque)
11710 : {
11711 944 : gfc_code *code = *codep;
11712 944 : icode_error_state *state = (icode_error_state *)opaque;
11713 :
11714 : /* gfc_code_walker walks down CODE's next chain as well as
11715 : walking things that are actually nested in CODE. We need to
11716 : special-case traversal of outer blocks, so stop immediately if we
11717 : are heading down such a next chain. */
11718 944 : if (code == state->next)
11719 : return 1;
11720 :
11721 647 : switch (code->op)
11722 : {
11723 1 : case EXEC_DO:
11724 1 : case EXEC_DO_WHILE:
11725 1 : case EXEC_DO_CONCURRENT:
11726 1 : gfc_error ("%s cannot contain loop in intervening code at %L",
11727 : state->name, &code->loc);
11728 1 : state->errorp = true;
11729 1 : break;
11730 0 : case EXEC_CYCLE:
11731 0 : case EXEC_EXIT:
11732 : /* Errors have already been diagnosed in match_exit_cycle. */
11733 0 : state->errorp = true;
11734 0 : break;
11735 : case EXEC_OMP_ASSUME:
11736 : case EXEC_OMP_METADIRECTIVE:
11737 : /* Per OpenMP 6.0, some non-executable directives are allowed in
11738 : intervening code. */
11739 : break;
11740 477 : case EXEC_CALL:
11741 : /* Per OpenMP 5.2, the "omp_" prefix is reserved, so we don't have to
11742 : consider the possibility that some locally-bound definition
11743 : overrides the runtime routine. */
11744 477 : if (code->resolved_sym
11745 477 : && omp_runtime_api_procname (code->resolved_sym->name))
11746 : {
11747 1 : gfc_error ("%s cannot contain OpenMP API call in intervening code "
11748 : "at %L",
11749 : state->name, &code->loc);
11750 1 : state->errorp = true;
11751 : }
11752 : break;
11753 168 : default:
11754 168 : if (code->op >= EXEC_OMP_FIRST_OPENMP_EXEC
11755 168 : && code->op <= EXEC_OMP_LAST_OPENMP_EXEC)
11756 : {
11757 2 : gfc_error ("%s cannot contain OpenMP directive in intervening code "
11758 : "at %L",
11759 : state->name, &code->loc);
11760 2 : state->errorp = true;
11761 : }
11762 : }
11763 : return 0;
11764 : }
11765 :
11766 : static int
11767 1081 : icode_expr_error_callback (gfc_expr **expr,
11768 : int *walk_subtrees ATTRIBUTE_UNUSED, void *opaque)
11769 : {
11770 1081 : icode_error_state *state = (icode_error_state *)opaque;
11771 :
11772 1081 : switch ((*expr)->expr_type)
11773 : {
11774 : /* As for EXPR_CALL with "omp_"-prefixed symbols. */
11775 2 : case EXPR_FUNCTION:
11776 2 : {
11777 2 : gfc_symbol *sym = (*expr)->value.function.esym;
11778 2 : if (sym && omp_runtime_api_procname (sym->name))
11779 : {
11780 1 : gfc_error ("%s cannot contain OpenMP API call in intervening code "
11781 : "at %L",
11782 1 : state->name, &((*expr)->where));
11783 1 : state->errorp = true;
11784 : }
11785 : }
11786 :
11787 : break;
11788 : default:
11789 : break;
11790 : }
11791 :
11792 : /* FIXME: The description of canonical loop form in the OpenMP standard
11793 : also says "array expressions" are not permitted in intervening code.
11794 : That term is not defined in either the OpenMP spec or the Fortran
11795 : standard, although the latter uses it informally to refer to any
11796 : expression that is not scalar-valued. It is also apparently not the
11797 : thing GCC internally calls EXPR_ARRAY. It seems the intent of the
11798 : OpenMP restriction is to disallow elemental operations/intrinsics
11799 : (including things that are not expressions, like assignment
11800 : statements) that generate implicit loops over array operands
11801 : (even if the result is a scalar), but even if the spec said
11802 : that there is no list of all the cases that would be forbidden.
11803 : This is OpenMP issue 3326. */
11804 :
11805 1081 : return 0;
11806 : }
11807 :
11808 : static void
11809 267 : diagnose_intervening_code_errors_1 (gfc_code *chain,
11810 : struct icode_error_state *state)
11811 : {
11812 267 : gfc_code *code;
11813 1080 : for (code = chain; code; code = code->next)
11814 : {
11815 813 : if (code == state->nested)
11816 : /* Do not walk the nested loop or its body, we are only
11817 : interested in intervening code. */
11818 : ;
11819 636 : else if (code->op == EXEC_BLOCK
11820 636 : && find_nested_loop_in_block (code) == state->nested)
11821 : /* This block contains the nested loop, recurse on its
11822 : statements. */
11823 : {
11824 90 : gfc_namespace* ns = code->ext.block.ns;
11825 90 : diagnose_intervening_code_errors_1 (ns->code, state);
11826 : }
11827 : else
11828 : /* Treat the whole statement as a unit. */
11829 : {
11830 546 : gfc_code *temp = state->next;
11831 546 : state->next = code->next;
11832 546 : gfc_code_walker (&code, icode_code_error_callback,
11833 : icode_expr_error_callback, state);
11834 546 : state->next = temp;
11835 : }
11836 : }
11837 267 : }
11838 :
11839 : /* Diagnose intervening code errors in BLOCK with nested loop NESTED.
11840 : NAME is the user-friendly name of the OMP directive, used for error
11841 : messages. Returns true if any error was found. */
11842 : static bool
11843 177 : diagnose_intervening_code_errors (gfc_code *chain, const char *name,
11844 : gfc_code *nested)
11845 : {
11846 177 : struct icode_error_state state;
11847 177 : state.name = name;
11848 177 : state.errorp = false;
11849 177 : state.nested = nested;
11850 177 : state.next = NULL;
11851 0 : diagnose_intervening_code_errors_1 (chain, &state);
11852 177 : return state.errorp;
11853 : }
11854 :
11855 : /* Helper function for restructure_intervening_code: wrap CHAIN in
11856 : a marker to indicate that it is a structured block sequence. That
11857 : information will be used later on (in omp-low.cc) for error checking. */
11858 : static gfc_code *
11859 461 : make_structured_block (gfc_code *chain)
11860 : {
11861 461 : gcc_assert (chain);
11862 461 : gfc_namespace *ns = gfc_build_block_ns (gfc_current_ns);
11863 461 : gfc_code *result = gfc_get_code (EXEC_BLOCK);
11864 461 : result->op = EXEC_BLOCK;
11865 461 : result->ext.block.ns = ns;
11866 461 : result->ext.block.assoc = NULL;
11867 461 : result->loc = chain->loc;
11868 461 : ns->omp_structured_block = 1;
11869 461 : ns->code = chain;
11870 461 : return result;
11871 : }
11872 :
11873 : /* Push intervening code surrounding a loop, including nested scopes,
11874 : into the body of the loop. CHAINP is the pointer to the head of
11875 : the next-chain to scan, OUTER_LOOP is the EXEC_DO for the next outer
11876 : loop level, and COLLAPSE is the number of nested loops we need to
11877 : process.
11878 : Note that CHAINP may point at outer_loop->block->next when we
11879 : are scanning the body of a loop, but if there is an intervening block
11880 : CHAINP points into the block's chain rather than its enclosing outer
11881 : loop. This is why OUTER_LOOP is passed separately. */
11882 : static gfc_code *
11883 7161 : restructure_intervening_code (gfc_code **chainp, gfc_code *outer_loop,
11884 : int count)
11885 : {
11886 7161 : gfc_code *code;
11887 7161 : gfc_code *head = *chainp;
11888 7161 : gfc_code *tail = NULL;
11889 7161 : gfc_code *innermost_loop = NULL;
11890 :
11891 7425 : for (code = *chainp; code; code = code->next, chainp = &(*chainp)->next)
11892 : {
11893 7425 : if (code->op == EXEC_DO)
11894 : {
11895 : /* Cut CODE free from its chain, leaving the ends dangling. */
11896 7077 : *chainp = NULL;
11897 7077 : tail = code->next;
11898 7077 : code->next = NULL;
11899 :
11900 7077 : if (count == 1)
11901 : innermost_loop = code;
11902 : else
11903 2089 : innermost_loop
11904 2089 : = restructure_intervening_code (&code->block->next,
11905 : code, count - 1);
11906 : break;
11907 : }
11908 348 : else if (code->op == EXEC_BLOCK
11909 348 : && find_nested_loop_in_block (code))
11910 : {
11911 84 : gfc_namespace *ns = code->ext.block.ns;
11912 :
11913 : /* Cut CODE free from its chain, leaving the ends dangling. */
11914 84 : *chainp = NULL;
11915 84 : tail = code->next;
11916 84 : code->next = NULL;
11917 :
11918 84 : innermost_loop
11919 84 : = restructure_intervening_code (&ns->code, outer_loop,
11920 : count);
11921 :
11922 : /* At this point we have already pulled out the nested loop and
11923 : pointed outer_loop at it, and moved the intervening code that
11924 : was previously in the block into the body of innermost_loop.
11925 : Now we want to move the BLOCK itself so it wraps the entire
11926 : current body of innermost_loop. */
11927 84 : ns->code = innermost_loop->block->next;
11928 84 : innermost_loop->block->next = code;
11929 84 : break;
11930 : }
11931 : }
11932 :
11933 2173 : gcc_assert (innermost_loop);
11934 :
11935 : /* Now we have split the intervening code into two parts:
11936 : head is the start of the part before the loop/block, terminating
11937 : at *chainp, and tail is the part after it. Mark each part as
11938 : a structured block sequence, and splice the two parts around the
11939 : existing body of the innermost loop. */
11940 7161 : if (head != code)
11941 : {
11942 222 : gfc_code *block = make_structured_block (head);
11943 222 : if (innermost_loop->block->next)
11944 221 : gfc_append_code (block, innermost_loop->block->next);
11945 222 : innermost_loop->block->next = block;
11946 : }
11947 7161 : if (tail)
11948 : {
11949 239 : gfc_code *block = make_structured_block (tail);
11950 239 : if (innermost_loop->block->next)
11951 237 : gfc_append_code (innermost_loop->block->next, block);
11952 : else
11953 2 : innermost_loop->block->next = block;
11954 : }
11955 :
11956 : /* For loops, finally splice CODE into OUTER_LOOP. We already handled
11957 : relinking EXEC_BLOCK above. */
11958 7161 : if (code->op == EXEC_DO && outer_loop)
11959 7077 : outer_loop->block->next = code;
11960 :
11961 7161 : return innermost_loop;
11962 : }
11963 :
11964 : /* CODE is an OMP loop construct. Return true if VAR matches an iteration
11965 : variable outer to level DEPTH. */
11966 : static bool
11967 8074 : is_outer_iteration_variable (gfc_code *code, int depth, gfc_symbol *var)
11968 : {
11969 8074 : int i;
11970 8074 : gfc_code *do_code = code;
11971 :
11972 12600 : for (i = 1; i < depth; i++)
11973 : {
11974 5027 : do_code = find_nested_loop_in_chain (do_code->block->next);
11975 5027 : gcc_assert (do_code);
11976 5027 : if (do_code->op == EXEC_OMP_TILE || do_code->op == EXEC_OMP_UNROLL)
11977 : {
11978 51 : --i;
11979 51 : continue;
11980 : }
11981 4976 : gfc_symbol *ivar = do_code->ext.iterator->var->symtree->n.sym;
11982 4976 : if (var == ivar)
11983 : return true;
11984 : }
11985 : return false;
11986 : }
11987 :
11988 : /* Forward declaration for recursive functions. */
11989 : static gfc_code *
11990 : check_nested_loop_in_block (gfc_code *block, gfc_expr *expr, gfc_symbol *sym,
11991 : bool *bad);
11992 :
11993 : /* Like find_nested_loop_in_chain, but additionally check that EXPR
11994 : does not reference any variables bound in intervening EXEC_BLOCKs
11995 : and that SYM is not bound in such intervening blocks. Either EXPR or SYM
11996 : may be null. Sets *BAD to true if either test fails. */
11997 : static gfc_code *
11998 48125 : check_nested_loop_in_chain (gfc_code *chain, gfc_expr *expr, gfc_symbol *sym,
11999 : bool *bad)
12000 : {
12001 51729 : for (gfc_code *code = chain; code; code = code->next)
12002 : {
12003 51441 : if (code->op == EXEC_DO)
12004 : return code;
12005 4123 : else if (code->op == EXEC_OMP_TILE || code->op == EXEC_OMP_UNROLL)
12006 1682 : return check_nested_loop_in_chain (code->block->next, expr, sym, bad);
12007 2441 : else if (code->op == EXEC_BLOCK)
12008 : {
12009 807 : gfc_code *c = check_nested_loop_in_block (code, expr, sym, bad);
12010 807 : if (c)
12011 : return c;
12012 : }
12013 : }
12014 : return NULL;
12015 : }
12016 :
12017 : /* Code walker for block symtrees. It doesn't take any kind of state
12018 : argument, so use a static variable. */
12019 : static struct check_nested_loop_in_block_state_t {
12020 : gfc_expr *expr;
12021 : gfc_symbol *sym;
12022 : bool *bad;
12023 : } check_nested_loop_in_block_state;
12024 :
12025 : static void
12026 766 : check_nested_loop_in_block_symbol (gfc_symbol *sym)
12027 : {
12028 766 : if (sym == check_nested_loop_in_block_state.sym
12029 766 : || (check_nested_loop_in_block_state.expr
12030 567 : && gfc_find_sym_in_expr (sym,
12031 : check_nested_loop_in_block_state.expr)))
12032 5 : *check_nested_loop_in_block_state.bad = true;
12033 766 : }
12034 :
12035 : /* Return the first nested DO loop in BLOCK, or NULL if there
12036 : isn't one. Set *BAD to true if EXPR references any variables in BLOCK, or
12037 : SYM is bound in BLOCK. Either EXPR or SYM may be null. */
12038 : static gfc_code *
12039 807 : check_nested_loop_in_block (gfc_code *block, gfc_expr *expr,
12040 : gfc_symbol *sym, bool *bad)
12041 : {
12042 807 : gfc_namespace *ns;
12043 807 : gcc_assert (block->op == EXEC_BLOCK);
12044 807 : ns = block->ext.block.ns;
12045 807 : gcc_assert (ns);
12046 :
12047 : /* Skip the check if this block doesn't contain the nested loop, or
12048 : if we already know it's bad. */
12049 807 : gfc_code *result = check_nested_loop_in_chain (ns->code, expr, sym, bad);
12050 807 : if (result && !*bad)
12051 : {
12052 519 : check_nested_loop_in_block_state.expr = expr;
12053 519 : check_nested_loop_in_block_state.sym = sym;
12054 519 : check_nested_loop_in_block_state.bad = bad;
12055 519 : gfc_traverse_ns (ns, check_nested_loop_in_block_symbol);
12056 519 : check_nested_loop_in_block_state.expr = NULL;
12057 519 : check_nested_loop_in_block_state.sym = NULL;
12058 519 : check_nested_loop_in_block_state.bad = NULL;
12059 : }
12060 807 : return result;
12061 : }
12062 :
12063 : /* CODE is an OMP loop construct. Return true if EXPR references
12064 : any variables bound in intervening code, to level DEPTH. */
12065 : static bool
12066 22690 : expr_uses_intervening_var (gfc_code *code, int depth, gfc_expr *expr)
12067 : {
12068 22690 : int i;
12069 22690 : gfc_code *do_code = code;
12070 :
12071 58156 : for (i = 0; i < depth; i++)
12072 : {
12073 35469 : bool bad = false;
12074 35469 : do_code = check_nested_loop_in_chain (do_code->block->next,
12075 : expr, NULL, &bad);
12076 35469 : if (bad)
12077 3 : return true;
12078 : }
12079 : return false;
12080 : }
12081 :
12082 : /* CODE is an OMP loop construct. Return true if SYM is bound in
12083 : intervening code, to level DEPTH. */
12084 : static bool
12085 7573 : is_intervening_var (gfc_code *code, int depth, gfc_symbol *sym)
12086 : {
12087 7573 : int i;
12088 7573 : gfc_code *do_code = code;
12089 :
12090 19420 : for (i = 0; i < depth; i++)
12091 : {
12092 11849 : bool bad = false;
12093 11849 : do_code = check_nested_loop_in_chain (do_code->block->next,
12094 : NULL, sym, &bad);
12095 11849 : if (bad)
12096 2 : return true;
12097 : }
12098 : return false;
12099 : }
12100 :
12101 : /* CODE is an OMP loop construct. Return true if EXPR does not reference
12102 : any iteration variables outer to level DEPTH. */
12103 : static bool
12104 23769 : expr_is_invariant (gfc_code *code, int depth, gfc_expr *expr)
12105 : {
12106 23769 : int i;
12107 23769 : gfc_code *do_code = code;
12108 :
12109 37088 : for (i = 1; i < depth; i++)
12110 : {
12111 14385 : do_code = find_nested_loop_in_chain (do_code->block->next);
12112 14385 : gcc_assert (do_code);
12113 14385 : if (do_code->op == EXEC_OMP_TILE || do_code->op == EXEC_OMP_UNROLL)
12114 : {
12115 136 : --i;
12116 136 : continue;
12117 : }
12118 14249 : gfc_symbol *ivar = do_code->ext.iterator->var->symtree->n.sym;
12119 14249 : if (gfc_find_sym_in_expr (ivar, expr))
12120 : return false;
12121 : }
12122 : return true;
12123 : }
12124 :
12125 : /* CODE is an OMP loop construct. Return true if EXPR matches one of the
12126 : canonical forms for a bound expression. It may include references to
12127 : an iteration variable outer to level DEPTH; set OUTER_VARP if so. */
12128 : static bool
12129 15137 : bound_expr_is_canonical (gfc_code *code, int depth, gfc_expr *expr,
12130 : gfc_symbol **outer_varp)
12131 : {
12132 15137 : gfc_expr *expr2 = NULL;
12133 :
12134 : /* Rectangular case. */
12135 15137 : if (depth == 0 || expr_is_invariant (code, depth, expr))
12136 14569 : return true;
12137 :
12138 : /* Any simple variable that didn't pass expr_is_invariant must be
12139 : an outer_var. */
12140 568 : if (expr->expr_type == EXPR_VARIABLE && expr->rank == 0)
12141 : {
12142 63 : *outer_varp = expr->symtree->n.sym;
12143 63 : return true;
12144 : }
12145 :
12146 : /* All other permitted forms are binary operators. */
12147 505 : if (expr->expr_type != EXPR_OP)
12148 : return false;
12149 :
12150 : /* Check for plus/minus a loop invariant expr. */
12151 503 : if (expr->value.op.op == INTRINSIC_PLUS
12152 503 : || expr->value.op.op == INTRINSIC_MINUS)
12153 : {
12154 483 : if (expr_is_invariant (code, depth, expr->value.op.op1))
12155 48 : expr2 = expr->value.op.op2;
12156 435 : else if (expr_is_invariant (code, depth, expr->value.op.op2))
12157 434 : expr2 = expr->value.op.op1;
12158 : else
12159 : return false;
12160 : }
12161 : else
12162 : expr2 = expr;
12163 :
12164 : /* Check for a product with a loop-invariant expr. */
12165 502 : if (expr2->expr_type == EXPR_OP
12166 96 : && expr2->value.op.op == INTRINSIC_TIMES)
12167 : {
12168 96 : if (expr_is_invariant (code, depth, expr2->value.op.op1))
12169 40 : expr2 = expr2->value.op.op2;
12170 56 : else if (expr_is_invariant (code, depth, expr2->value.op.op2))
12171 53 : expr2 = expr2->value.op.op1;
12172 : else
12173 : return false;
12174 : }
12175 :
12176 : /* What's left must be a reference to an outer loop variable. */
12177 499 : if (expr2->expr_type == EXPR_VARIABLE
12178 499 : && expr2->rank == 0
12179 998 : && is_outer_iteration_variable (code, depth, expr2->symtree->n.sym))
12180 : {
12181 499 : *outer_varp = expr2->symtree->n.sym;
12182 499 : return true;
12183 : }
12184 :
12185 : return false;
12186 : }
12187 :
12188 : static void
12189 5412 : resolve_omp_do (gfc_code *code)
12190 : {
12191 5412 : gfc_code *do_code, *next;
12192 5412 : int list, i, count, non_generated_count;
12193 5412 : gfc_omp_namelist *n;
12194 5412 : gfc_symbol *dovar;
12195 5412 : const char *name;
12196 5412 : bool is_simd = false;
12197 5412 : bool errorp = false;
12198 5412 : bool perfect_nesting_errorp = false;
12199 5412 : bool imperfect = false;
12200 :
12201 5412 : switch (code->op)
12202 : {
12203 : case EXEC_OMP_DISTRIBUTE: name = "!$OMP DISTRIBUTE"; break;
12204 49 : case EXEC_OMP_DISTRIBUTE_PARALLEL_DO:
12205 49 : name = "!$OMP DISTRIBUTE PARALLEL DO";
12206 49 : break;
12207 32 : case EXEC_OMP_DISTRIBUTE_PARALLEL_DO_SIMD:
12208 32 : name = "!$OMP DISTRIBUTE PARALLEL DO SIMD";
12209 32 : is_simd = true;
12210 32 : break;
12211 50 : case EXEC_OMP_DISTRIBUTE_SIMD:
12212 50 : name = "!$OMP DISTRIBUTE SIMD";
12213 50 : is_simd = true;
12214 50 : break;
12215 1335 : case EXEC_OMP_DO: name = "!$OMP DO"; break;
12216 134 : case EXEC_OMP_DO_SIMD: name = "!$OMP DO SIMD"; is_simd = true; break;
12217 64 : case EXEC_OMP_LOOP: name = "!$OMP LOOP"; break;
12218 1208 : case EXEC_OMP_PARALLEL_DO: name = "!$OMP PARALLEL DO"; break;
12219 304 : case EXEC_OMP_PARALLEL_DO_SIMD:
12220 304 : name = "!$OMP PARALLEL DO SIMD";
12221 304 : is_simd = true;
12222 304 : break;
12223 46 : case EXEC_OMP_PARALLEL_LOOP: name = "!$OMP PARALLEL LOOP"; break;
12224 7 : case EXEC_OMP_PARALLEL_MASKED_TASKLOOP:
12225 7 : name = "!$OMP PARALLEL MASKED TASKLOOP";
12226 7 : break;
12227 10 : case EXEC_OMP_PARALLEL_MASKED_TASKLOOP_SIMD:
12228 10 : name = "!$OMP PARALLEL MASKED TASKLOOP SIMD";
12229 10 : is_simd = true;
12230 10 : break;
12231 12 : case EXEC_OMP_PARALLEL_MASTER_TASKLOOP:
12232 12 : name = "!$OMP PARALLEL MASTER TASKLOOP";
12233 12 : break;
12234 18 : case EXEC_OMP_PARALLEL_MASTER_TASKLOOP_SIMD:
12235 18 : name = "!$OMP PARALLEL MASTER TASKLOOP SIMD";
12236 18 : is_simd = true;
12237 18 : break;
12238 8 : case EXEC_OMP_MASKED_TASKLOOP: name = "!$OMP MASKED TASKLOOP"; break;
12239 14 : case EXEC_OMP_MASKED_TASKLOOP_SIMD:
12240 14 : name = "!$OMP MASKED TASKLOOP SIMD";
12241 14 : is_simd = true;
12242 14 : break;
12243 14 : case EXEC_OMP_MASTER_TASKLOOP: name = "!$OMP MASTER TASKLOOP"; break;
12244 19 : case EXEC_OMP_MASTER_TASKLOOP_SIMD:
12245 19 : name = "!$OMP MASTER TASKLOOP SIMD";
12246 19 : is_simd = true;
12247 19 : break;
12248 783 : case EXEC_OMP_SIMD: name = "!$OMP SIMD"; is_simd = true; break;
12249 88 : case EXEC_OMP_TARGET_PARALLEL_DO: name = "!$OMP TARGET PARALLEL DO"; break;
12250 19 : case EXEC_OMP_TARGET_PARALLEL_DO_SIMD:
12251 19 : name = "!$OMP TARGET PARALLEL DO SIMD";
12252 19 : is_simd = true;
12253 19 : break;
12254 16 : case EXEC_OMP_TARGET_PARALLEL_LOOP:
12255 16 : name = "!$OMP TARGET PARALLEL LOOP";
12256 16 : break;
12257 33 : case EXEC_OMP_TARGET_SIMD:
12258 33 : name = "!$OMP TARGET SIMD";
12259 33 : is_simd = true;
12260 33 : break;
12261 20 : case EXEC_OMP_TARGET_TEAMS_DISTRIBUTE:
12262 20 : name = "!$OMP TARGET TEAMS DISTRIBUTE";
12263 20 : break;
12264 75 : case EXEC_OMP_TARGET_TEAMS_DISTRIBUTE_PARALLEL_DO:
12265 75 : name = "!$OMP TARGET TEAMS DISTRIBUTE PARALLEL DO";
12266 75 : break;
12267 37 : case EXEC_OMP_TARGET_TEAMS_DISTRIBUTE_PARALLEL_DO_SIMD:
12268 37 : name = "!$OMP TARGET TEAMS DISTRIBUTE PARALLEL DO SIMD";
12269 37 : is_simd = true;
12270 37 : break;
12271 20 : case EXEC_OMP_TARGET_TEAMS_DISTRIBUTE_SIMD:
12272 20 : name = "!$OMP TARGET TEAMS DISTRIBUTE SIMD";
12273 20 : is_simd = true;
12274 20 : break;
12275 19 : case EXEC_OMP_TARGET_TEAMS_LOOP: name = "!$OMP TARGET TEAMS LOOP"; break;
12276 69 : case EXEC_OMP_TASKLOOP: name = "!$OMP TASKLOOP"; break;
12277 38 : case EXEC_OMP_TASKLOOP_SIMD:
12278 38 : name = "!$OMP TASKLOOP SIMD";
12279 38 : is_simd = true;
12280 38 : break;
12281 20 : case EXEC_OMP_TEAMS_DISTRIBUTE: name = "!$OMP TEAMS DISTRIBUTE"; break;
12282 37 : case EXEC_OMP_TEAMS_DISTRIBUTE_PARALLEL_DO:
12283 37 : name = "!$OMP TEAMS DISTRIBUTE PARALLEL DO";
12284 37 : break;
12285 60 : case EXEC_OMP_TEAMS_DISTRIBUTE_PARALLEL_DO_SIMD:
12286 60 : name = "!$OMP TEAMS DISTRIBUTE PARALLEL DO SIMD";
12287 60 : is_simd = true;
12288 60 : break;
12289 42 : case EXEC_OMP_TEAMS_DISTRIBUTE_SIMD:
12290 42 : name = "!$OMP TEAMS DISTRIBUTE SIMD";
12291 42 : is_simd = true;
12292 42 : break;
12293 48 : case EXEC_OMP_TEAMS_LOOP: name = "!$OMP TEAMS LOOP"; break;
12294 195 : case EXEC_OMP_TILE: name = "!$OMP TILE"; break;
12295 415 : case EXEC_OMP_UNROLL: name = "!$OMP UNROLL"; break;
12296 0 : default: gcc_unreachable ();
12297 : }
12298 :
12299 5412 : if (code->ext.omp_clauses)
12300 5412 : resolve_omp_clauses (code, code->ext.omp_clauses, NULL);
12301 :
12302 5412 : if (code->op == EXEC_OMP_TILE && code->ext.omp_clauses->sizes_list == NULL)
12303 0 : gfc_error ("SIZES clause is required on !$OMP TILE construct at %L",
12304 : &code->loc);
12305 :
12306 5412 : do_code = code->block->next;
12307 5412 : if (code->ext.omp_clauses->orderedc)
12308 : count = code->ext.omp_clauses->orderedc;
12309 5268 : else if (code->ext.omp_clauses->sizes_list)
12310 195 : count = gfc_expr_list_len (code->ext.omp_clauses->sizes_list);
12311 : else
12312 : {
12313 5073 : count = code->ext.omp_clauses->collapse;
12314 5073 : if (count <= 0)
12315 : count = 1;
12316 : }
12317 :
12318 5412 : non_generated_count = count;
12319 : /* While the spec defines the loop nest depth independently of the COLLAPSE
12320 : clause, in practice the middle end only pays attention to the COLLAPSE
12321 : depth and treats any further inner loops as the final-loop-body. So
12322 : here we also check canonical loop nest form only for the number of
12323 : outer loops specified by the COLLAPSE clause too. */
12324 8051 : for (i = 1; i <= count; i++)
12325 : {
12326 8051 : gfc_symbol *start_var = NULL, *end_var = NULL;
12327 : /* Parse errors are not recoverable. */
12328 8051 : if (do_code->op == EXEC_DO_WHILE)
12329 : {
12330 6 : gfc_error ("%s cannot be a DO WHILE or DO without loop control "
12331 : "at %L", name, &do_code->loc);
12332 106 : goto fail;
12333 : }
12334 8045 : if (do_code->op == EXEC_DO_CONCURRENT)
12335 : {
12336 4 : gfc_error ("%s cannot be a DO CONCURRENT loop at %L", name,
12337 : &do_code->loc);
12338 4 : goto fail;
12339 : }
12340 8041 : if (do_code->op == EXEC_OMP_TILE || do_code->op == EXEC_OMP_UNROLL)
12341 : {
12342 466 : if (do_code->op == EXEC_OMP_UNROLL)
12343 : {
12344 308 : if (!do_code->ext.omp_clauses->partial)
12345 : {
12346 53 : gfc_error ("Generated loop of UNROLL construct at %L "
12347 : "without PARTIAL clause does not have "
12348 : "canonical form", &do_code->loc);
12349 53 : goto fail;
12350 : }
12351 255 : else if (i != count)
12352 : {
12353 5 : gfc_error ("UNROLL construct at %L with PARTIAL clause "
12354 : "generates just one loop with canonical form "
12355 : "but %d loops are needed",
12356 5 : &do_code->loc, count - i + 1);
12357 5 : goto fail;
12358 : }
12359 : }
12360 158 : else if (do_code->op == EXEC_OMP_TILE)
12361 : {
12362 158 : if (do_code->ext.omp_clauses->sizes_list == NULL)
12363 : /* This should have been diagnosed earlier already. */
12364 0 : return;
12365 158 : int l = gfc_expr_list_len (do_code->ext.omp_clauses->sizes_list);
12366 158 : if (count - i + 1 > l)
12367 : {
12368 14 : gfc_error ("TILE construct at %L generates %d loops "
12369 : "with canonical form but %d loops are needed",
12370 : &do_code->loc, l, count - i + 1);
12371 14 : goto fail;
12372 : }
12373 : }
12374 394 : if (do_code->ext.omp_clauses && do_code->ext.omp_clauses->erroneous)
12375 17 : goto fail;
12376 377 : if (imperfect && !perfect_nesting_errorp)
12377 : {
12378 4 : sorry_at (gfc_get_location (&do_code->loc),
12379 : "Imperfectly nested loop using generated loops");
12380 4 : errorp = true;
12381 : }
12382 377 : if (non_generated_count == count)
12383 329 : non_generated_count = i - 1;
12384 377 : --i;
12385 377 : do_code = do_code->block->next;
12386 377 : continue;
12387 377 : }
12388 7575 : gcc_assert (do_code->op == EXEC_DO);
12389 7575 : if (do_code->ext.iterator->var->ts.type != BT_INTEGER)
12390 : {
12391 3 : gfc_error ("%s iteration variable must be of type integer at %L",
12392 : name, &do_code->loc);
12393 3 : errorp = true;
12394 : }
12395 7575 : dovar = do_code->ext.iterator->var->symtree->n.sym;
12396 7575 : if (dovar->attr.threadprivate)
12397 : {
12398 0 : gfc_error ("%s iteration variable must not be THREADPRIVATE "
12399 : "at %L", name, &do_code->loc);
12400 0 : errorp = true;
12401 : }
12402 7575 : if (code->ext.omp_clauses)
12403 303000 : for (list = 0; list < OMP_LIST_NUM; list++)
12404 97461 : if (!is_simd || code->ext.omp_clauses->collapse > 1
12405 295425 : ? (list != OMP_LIST_PRIVATE && list != OMP_LIST_LASTPRIVATE
12406 254319 : && list != OMP_LIST_ALLOCATE)
12407 41106 : : (list != OMP_LIST_PRIVATE && list != OMP_LIST_LASTPRIVATE
12408 41106 : && list != OMP_LIST_ALLOCATE && list != OMP_LIST_LINEAR))
12409 276020 : for (n = code->ext.omp_clauses->lists[list]; n; n = n->next)
12410 4374 : if (dovar == n->sym)
12411 : {
12412 5 : if (!is_simd || code->ext.omp_clauses->collapse > 1)
12413 4 : gfc_error ("%s iteration variable present on clause "
12414 : "other than PRIVATE, LASTPRIVATE or "
12415 : "ALLOCATE at %L", name, &do_code->loc);
12416 : else
12417 1 : gfc_error ("%s iteration variable present on clause "
12418 : "other than PRIVATE, LASTPRIVATE, ALLOCATE or "
12419 : "LINEAR at %L", name, &do_code->loc);
12420 : errorp = true;
12421 : }
12422 7575 : if (is_outer_iteration_variable (code, i, dovar))
12423 : {
12424 2 : gfc_error ("%s iteration variable used in more than one loop at %L",
12425 : name, &do_code->loc);
12426 2 : errorp = true;
12427 : }
12428 7573 : else if (is_intervening_var (code, i, dovar))
12429 : {
12430 2 : gfc_error ("%s iteration variable at %L is bound in "
12431 : "intervening code",
12432 : name, &do_code->loc);
12433 2 : errorp = true;
12434 : }
12435 7571 : else if (!bound_expr_is_canonical (code, i,
12436 7571 : do_code->ext.iterator->start,
12437 : &start_var))
12438 : {
12439 4 : gfc_error ("%s loop start expression not in canonical form at %L",
12440 : name, &do_code->loc);
12441 4 : errorp = true;
12442 : }
12443 7567 : else if (expr_uses_intervening_var (code, i,
12444 7567 : do_code->ext.iterator->start))
12445 : {
12446 1 : gfc_error ("%s loop start expression at %L uses variable bound in "
12447 : "intervening code",
12448 : name, &do_code->loc);
12449 1 : errorp = true;
12450 : }
12451 7566 : else if (!bound_expr_is_canonical (code, i,
12452 7566 : do_code->ext.iterator->end,
12453 : &end_var))
12454 : {
12455 2 : gfc_error ("%s loop end expression not in canonical form at %L",
12456 : name, &do_code->loc);
12457 2 : errorp = true;
12458 : }
12459 7564 : else if (expr_uses_intervening_var (code, i,
12460 7564 : do_code->ext.iterator->end))
12461 : {
12462 1 : gfc_error ("%s loop end expression at %L uses variable bound in "
12463 : "intervening code",
12464 : name, &do_code->loc);
12465 1 : errorp = true;
12466 : }
12467 7563 : else if (start_var && end_var && start_var != end_var)
12468 : {
12469 1 : gfc_error ("%s loop bounds reference different "
12470 : "iteration variables at %L", name, &do_code->loc);
12471 1 : errorp = true;
12472 : }
12473 7562 : else if (!expr_is_invariant (code, i, do_code->ext.iterator->step))
12474 : {
12475 3 : gfc_error ("%s loop increment not in canonical form at %L",
12476 : name, &do_code->loc);
12477 3 : errorp = true;
12478 : }
12479 7559 : else if (expr_uses_intervening_var (code, i,
12480 7559 : do_code->ext.iterator->step))
12481 : {
12482 1 : gfc_error ("%s loop increment expression at %L uses variable "
12483 : "bound in intervening code",
12484 : name, &do_code->loc);
12485 1 : errorp = true;
12486 : }
12487 7575 : if (start_var || end_var)
12488 : {
12489 528 : code->ext.omp_clauses->non_rectangular = 1;
12490 528 : if (i > non_generated_count)
12491 : {
12492 3 : sorry_at (gfc_get_location (&do_code->loc),
12493 : "Non-rectangular loops from generated loops "
12494 : "unsupported");
12495 3 : errorp = true;
12496 : }
12497 : }
12498 :
12499 : /* Only parse loop body into nested loop and intervening code if
12500 : there are supposed to be more loops in the nest to collapse. */
12501 7575 : if (i == count)
12502 : break;
12503 :
12504 2269 : next = find_nested_loop_in_chain (do_code->block->next);
12505 :
12506 2269 : if (!next)
12507 : {
12508 : /* Parse error, can't recover from this. */
12509 7 : gfc_error ("not enough DO loops for collapsed %s (level %d) at %L",
12510 : name, i, &code->loc);
12511 7 : goto fail;
12512 : }
12513 2262 : else if (next != do_code->block->next
12514 2102 : || (next->next && next->next->op != EXEC_CONTINUE))
12515 : /* Imperfectly nested loop found. */
12516 : {
12517 : /* Only diagnose violation of imperfect nesting constraints once. */
12518 177 : if (!perfect_nesting_errorp)
12519 : {
12520 176 : if (code->ext.omp_clauses->orderedc)
12521 : {
12522 3 : gfc_error ("%s inner loops must be perfectly nested with "
12523 : "ORDERED clause at %L",
12524 : name, &code->loc);
12525 3 : perfect_nesting_errorp = true;
12526 : }
12527 173 : else if (code->ext.omp_clauses->lists[OMP_LIST_REDUCTION_INSCAN])
12528 : {
12529 2 : gfc_error ("%s inner loops must be perfectly nested with "
12530 : "REDUCTION INSCAN clause at %L",
12531 : name, &code->loc);
12532 2 : perfect_nesting_errorp = true;
12533 : }
12534 171 : else if (code->op == EXEC_OMP_TILE)
12535 : {
12536 8 : gfc_error ("%s inner loops must be perfectly nested at %L",
12537 : name, &code->loc);
12538 8 : perfect_nesting_errorp = true;
12539 : }
12540 13 : if (perfect_nesting_errorp)
12541 : errorp = true;
12542 : }
12543 177 : if (diagnose_intervening_code_errors (do_code->block->next,
12544 : name, next))
12545 5 : errorp = true;
12546 : imperfect = true;
12547 : }
12548 2262 : do_code = next;
12549 : }
12550 :
12551 : /* Give up now if we found any constraint violations. */
12552 5306 : if (errorp)
12553 : {
12554 48 : fail:
12555 154 : if (code->ext.omp_clauses)
12556 154 : code->ext.omp_clauses->erroneous = 1;
12557 154 : return;
12558 : }
12559 :
12560 5258 : if (non_generated_count)
12561 4988 : restructure_intervening_code (&code->block->next, code,
12562 : non_generated_count);
12563 : }
12564 :
12565 : /* Resolve the context selector. In particular, SKIP_P is set to true,
12566 : the context can never be matched. */
12567 :
12568 : static void
12569 763 : gfc_resolve_omp_context_selector (gfc_omp_set_selector *oss,
12570 : bool is_metadirective, bool *skip_p)
12571 : {
12572 763 : if (skip_p)
12573 310 : *skip_p = false;
12574 1452 : for (gfc_omp_set_selector *set_selector = oss; set_selector;
12575 689 : set_selector = set_selector->next)
12576 1485 : for (gfc_omp_selector *os = set_selector->trait_selectors; os; os = os->next)
12577 : {
12578 814 : if (os->score)
12579 : {
12580 52 : if (!gfc_resolve_expr (os->score)
12581 52 : || os->score->ts.type != BT_INTEGER
12582 104 : || os->score->rank != 0)
12583 : {
12584 0 : gfc_error ("%<score%> argument must be constant integer "
12585 0 : "expression at %L", &os->score->where);
12586 0 : gfc_free_expr (os->score);
12587 0 : os->score = nullptr;
12588 : }
12589 52 : else if (os->score->expr_type == EXPR_CONSTANT
12590 52 : && mpz_sgn (os->score->value.integer) < 0)
12591 : {
12592 1 : gfc_error ("%<score%> argument must be non-negative at %L",
12593 : &os->score->where);
12594 1 : gfc_free_expr (os->score);
12595 1 : os->score = nullptr;
12596 : }
12597 : }
12598 :
12599 814 : if (os->code == OMP_TRAIT_INVALID)
12600 : break;
12601 796 : enum omp_tp_type property_kind = omp_ts_map[os->code].tp_type;
12602 796 : gfc_omp_trait_property *otp = os->properties;
12603 :
12604 796 : if (!otp)
12605 409 : continue;
12606 387 : switch (property_kind)
12607 : {
12608 139 : case OMP_TRAIT_PROPERTY_DEV_NUM_EXPR:
12609 139 : case OMP_TRAIT_PROPERTY_BOOL_EXPR:
12610 139 : if (!gfc_resolve_expr (otp->expr)
12611 138 : || (property_kind == OMP_TRAIT_PROPERTY_BOOL_EXPR
12612 124 : && otp->expr->ts.type != BT_LOGICAL)
12613 137 : || (property_kind == OMP_TRAIT_PROPERTY_DEV_NUM_EXPR
12614 14 : && otp->expr->ts.type != BT_INTEGER)
12615 137 : || otp->expr->rank != 0
12616 276 : || (!is_metadirective && otp->expr->expr_type != EXPR_CONSTANT))
12617 : {
12618 3 : if (is_metadirective)
12619 : {
12620 0 : if (property_kind == OMP_TRAIT_PROPERTY_BOOL_EXPR)
12621 0 : gfc_error ("property must be a "
12622 : "logical expression at %L",
12623 0 : &otp->expr->where);
12624 : else
12625 0 : gfc_error ("property must be an "
12626 : "integer expression at %L",
12627 0 : &otp->expr->where);
12628 : }
12629 : else
12630 : {
12631 3 : if (property_kind == OMP_TRAIT_PROPERTY_BOOL_EXPR)
12632 2 : gfc_error ("property must be a constant "
12633 : "logical expression at %L",
12634 2 : &otp->expr->where);
12635 : else
12636 1 : gfc_error ("property must be a constant "
12637 : "integer expression at %L",
12638 1 : &otp->expr->where);
12639 : }
12640 : /* Prevent later ICEs. */
12641 3 : gfc_expr *e;
12642 3 : if (property_kind == OMP_TRAIT_PROPERTY_BOOL_EXPR)
12643 2 : e = gfc_get_logical_expr (gfc_default_logical_kind,
12644 2 : &otp->expr->where, true);
12645 : else
12646 1 : e = gfc_get_int_expr (gfc_default_integer_kind,
12647 1 : &otp->expr->where, 0);
12648 3 : gfc_free_expr (otp->expr);
12649 3 : otp->expr = e;
12650 3 : continue;
12651 3 : }
12652 : /* Device number must be conforming, which includes
12653 : omp_initial_device (-1), omp_invalid_device (-4),
12654 : and omp_default_device (-5). */
12655 136 : if (property_kind == OMP_TRAIT_PROPERTY_DEV_NUM_EXPR
12656 14 : && otp->expr->expr_type == EXPR_CONSTANT
12657 5 : && mpz_sgn (otp->expr->value.integer) < 0
12658 3 : && mpz_cmp_si (otp->expr->value.integer, -1) != 0
12659 2 : && mpz_cmp_si (otp->expr->value.integer, -4) != 0
12660 1 : && mpz_cmp_si (otp->expr->value.integer, -5) != 0)
12661 1 : gfc_error ("property must be a conforming device number at %L",
12662 : &otp->expr->where);
12663 : break;
12664 : default:
12665 : break;
12666 : }
12667 : /* This only handles one specific case: User condition.
12668 : FIXME: Handle more cases by calling omp_context_selector_matches;
12669 : unfortunately, we cannot generate the tree here as, e.g., PARM_DECL
12670 : backend decl are not available at this stage - but might be used in,
12671 : e.g. user conditions. See PR122361. */
12672 384 : if (skip_p && otp
12673 138 : && os->code == OMP_TRAIT_USER_CONDITION
12674 81 : && otp->expr->expr_type == EXPR_CONSTANT
12675 14 : && otp->expr->value.logical == false)
12676 12 : *skip_p = true;
12677 : }
12678 763 : }
12679 :
12680 :
12681 : static void
12682 138 : resolve_omp_metadirective (gfc_code *code, gfc_namespace *ns)
12683 : {
12684 138 : gfc_omp_variant *variant = code->ext.omp_variants;
12685 138 : gfc_omp_variant *prev_variant = variant;
12686 :
12687 448 : while (variant)
12688 : {
12689 310 : bool skip;
12690 310 : gfc_resolve_omp_context_selector (variant->selectors, true, &skip);
12691 310 : gfc_code *variant_code = variant->code;
12692 310 : gfc_resolve_code (variant_code, ns);
12693 310 : if (skip)
12694 : {
12695 : /* The following should only be true if an error occurred
12696 : as the 'otherwise' clause should always match. */
12697 12 : if (variant == code->ext.omp_variants && !variant->next)
12698 : break;
12699 12 : gfc_omp_variant *tmp = variant;
12700 12 : if (variant == code->ext.omp_variants)
12701 11 : variant = prev_variant = code->ext.omp_variants = variant->next;
12702 : else
12703 1 : variant = prev_variant->next = variant->next;
12704 12 : gfc_free_omp_set_selector_list (tmp->selectors);
12705 12 : free (tmp);
12706 : }
12707 : else
12708 : {
12709 298 : prev_variant = variant;
12710 298 : variant = variant->next;
12711 : }
12712 : }
12713 : /* Replace metadirective by its body if only 'nothing' remains. */
12714 138 : if (!code->ext.omp_variants->next && code->ext.omp_variants->stmt == ST_NONE)
12715 : {
12716 11 : gfc_code *next = code->next;
12717 11 : gfc_code *inner = code->ext.omp_variants->code;
12718 11 : gfc_free_omp_set_selector_list (code->ext.omp_variants->selectors);
12719 11 : free (code->ext.omp_variants);
12720 11 : *code = *inner;
12721 11 : free (inner);
12722 11 : while (code->next)
12723 : code = code->next;
12724 11 : code->next = next;
12725 : }
12726 138 : }
12727 :
12728 :
12729 : static gfc_statement
12730 63 : omp_code_to_statement (gfc_code *code)
12731 : {
12732 63 : switch (code->op)
12733 : {
12734 : case EXEC_OMP_PARALLEL:
12735 : return ST_OMP_PARALLEL;
12736 0 : case EXEC_OMP_PARALLEL_MASKED:
12737 0 : return ST_OMP_PARALLEL_MASKED;
12738 0 : case EXEC_OMP_PARALLEL_MASKED_TASKLOOP:
12739 0 : return ST_OMP_PARALLEL_MASKED_TASKLOOP;
12740 0 : case EXEC_OMP_PARALLEL_MASKED_TASKLOOP_SIMD:
12741 0 : return ST_OMP_PARALLEL_MASKED_TASKLOOP_SIMD;
12742 0 : case EXEC_OMP_PARALLEL_MASTER:
12743 0 : return ST_OMP_PARALLEL_MASTER;
12744 0 : case EXEC_OMP_PARALLEL_MASTER_TASKLOOP:
12745 0 : return ST_OMP_PARALLEL_MASTER_TASKLOOP;
12746 0 : case EXEC_OMP_PARALLEL_MASTER_TASKLOOP_SIMD:
12747 0 : return ST_OMP_PARALLEL_MASTER_TASKLOOP_SIMD;
12748 1 : case EXEC_OMP_PARALLEL_SECTIONS:
12749 1 : return ST_OMP_PARALLEL_SECTIONS;
12750 1 : case EXEC_OMP_SECTIONS:
12751 1 : return ST_OMP_SECTIONS;
12752 1 : case EXEC_OMP_ORDERED:
12753 1 : return ST_OMP_ORDERED;
12754 1 : case EXEC_OMP_CRITICAL:
12755 1 : return ST_OMP_CRITICAL;
12756 0 : case EXEC_OMP_MASKED:
12757 0 : return ST_OMP_MASKED;
12758 0 : case EXEC_OMP_MASKED_TASKLOOP:
12759 0 : return ST_OMP_MASKED_TASKLOOP;
12760 0 : case EXEC_OMP_MASKED_TASKLOOP_SIMD:
12761 0 : return ST_OMP_MASKED_TASKLOOP_SIMD;
12762 1 : case EXEC_OMP_MASTER:
12763 1 : return ST_OMP_MASTER;
12764 0 : case EXEC_OMP_MASTER_TASKLOOP:
12765 0 : return ST_OMP_MASTER_TASKLOOP;
12766 0 : case EXEC_OMP_MASTER_TASKLOOP_SIMD:
12767 0 : return ST_OMP_MASTER_TASKLOOP_SIMD;
12768 1 : case EXEC_OMP_SINGLE:
12769 1 : return ST_OMP_SINGLE;
12770 1 : case EXEC_OMP_TASK:
12771 1 : return ST_OMP_TASK;
12772 1 : case EXEC_OMP_WORKSHARE:
12773 1 : return ST_OMP_WORKSHARE;
12774 1 : case EXEC_OMP_PARALLEL_WORKSHARE:
12775 1 : return ST_OMP_PARALLEL_WORKSHARE;
12776 3 : case EXEC_OMP_DO:
12777 3 : return ST_OMP_DO;
12778 0 : case EXEC_OMP_LOOP:
12779 0 : return ST_OMP_LOOP;
12780 0 : case EXEC_OMP_ALLOCATE:
12781 0 : return ST_OMP_ALLOCATE_EXEC;
12782 0 : case EXEC_OMP_ALLOCATORS:
12783 0 : return ST_OMP_ALLOCATORS;
12784 0 : case EXEC_OMP_ASSUME:
12785 0 : return ST_OMP_ASSUME;
12786 1 : case EXEC_OMP_ATOMIC:
12787 1 : return ST_OMP_ATOMIC;
12788 1 : case EXEC_OMP_BARRIER:
12789 1 : return ST_OMP_BARRIER;
12790 1 : case EXEC_OMP_CANCEL:
12791 1 : return ST_OMP_CANCEL;
12792 1 : case EXEC_OMP_CANCELLATION_POINT:
12793 1 : return ST_OMP_CANCELLATION_POINT;
12794 0 : case EXEC_OMP_ERROR:
12795 0 : return ST_OMP_ERROR;
12796 1 : case EXEC_OMP_FLUSH:
12797 1 : return ST_OMP_FLUSH;
12798 0 : case EXEC_OMP_INTEROP:
12799 0 : return ST_OMP_INTEROP;
12800 1 : case EXEC_OMP_DISTRIBUTE:
12801 1 : return ST_OMP_DISTRIBUTE;
12802 1 : case EXEC_OMP_DISTRIBUTE_PARALLEL_DO:
12803 1 : return ST_OMP_DISTRIBUTE_PARALLEL_DO;
12804 1 : case EXEC_OMP_DISTRIBUTE_PARALLEL_DO_SIMD:
12805 1 : return ST_OMP_DISTRIBUTE_PARALLEL_DO_SIMD;
12806 1 : case EXEC_OMP_DISTRIBUTE_SIMD:
12807 1 : return ST_OMP_DISTRIBUTE_SIMD;
12808 1 : case EXEC_OMP_DO_SIMD:
12809 1 : return ST_OMP_DO_SIMD;
12810 0 : case EXEC_OMP_SCAN:
12811 0 : return ST_OMP_SCAN;
12812 0 : case EXEC_OMP_SCOPE:
12813 0 : return ST_OMP_SCOPE;
12814 1 : case EXEC_OMP_SIMD:
12815 1 : return ST_OMP_SIMD;
12816 1 : case EXEC_OMP_TARGET:
12817 1 : return ST_OMP_TARGET;
12818 1 : case EXEC_OMP_TARGET_DATA:
12819 1 : return ST_OMP_TARGET_DATA;
12820 1 : case EXEC_OMP_TARGET_ENTER_DATA:
12821 1 : return ST_OMP_TARGET_ENTER_DATA;
12822 1 : case EXEC_OMP_TARGET_EXIT_DATA:
12823 1 : return ST_OMP_TARGET_EXIT_DATA;
12824 1 : case EXEC_OMP_TARGET_PARALLEL:
12825 1 : return ST_OMP_TARGET_PARALLEL;
12826 1 : case EXEC_OMP_TARGET_PARALLEL_DO:
12827 1 : return ST_OMP_TARGET_PARALLEL_DO;
12828 1 : case EXEC_OMP_TARGET_PARALLEL_DO_SIMD:
12829 1 : return ST_OMP_TARGET_PARALLEL_DO_SIMD;
12830 0 : case EXEC_OMP_TARGET_PARALLEL_LOOP:
12831 0 : return ST_OMP_TARGET_PARALLEL_LOOP;
12832 1 : case EXEC_OMP_TARGET_SIMD:
12833 1 : return ST_OMP_TARGET_SIMD;
12834 1 : case EXEC_OMP_TARGET_TEAMS:
12835 1 : return ST_OMP_TARGET_TEAMS;
12836 1 : case EXEC_OMP_TARGET_TEAMS_DISTRIBUTE:
12837 1 : return ST_OMP_TARGET_TEAMS_DISTRIBUTE;
12838 1 : case EXEC_OMP_TARGET_TEAMS_DISTRIBUTE_PARALLEL_DO:
12839 1 : return ST_OMP_TARGET_TEAMS_DISTRIBUTE_PARALLEL_DO;
12840 1 : case EXEC_OMP_TARGET_TEAMS_DISTRIBUTE_PARALLEL_DO_SIMD:
12841 1 : return ST_OMP_TARGET_TEAMS_DISTRIBUTE_PARALLEL_DO_SIMD;
12842 1 : case EXEC_OMP_TARGET_TEAMS_DISTRIBUTE_SIMD:
12843 1 : return ST_OMP_TARGET_TEAMS_DISTRIBUTE_SIMD;
12844 0 : case EXEC_OMP_TARGET_TEAMS_LOOP:
12845 0 : return ST_OMP_TARGET_TEAMS_LOOP;
12846 1 : case EXEC_OMP_TARGET_UPDATE:
12847 1 : return ST_OMP_TARGET_UPDATE;
12848 1 : case EXEC_OMP_TASKGROUP:
12849 1 : return ST_OMP_TASKGROUP;
12850 1 : case EXEC_OMP_TASKLOOP:
12851 1 : return ST_OMP_TASKLOOP;
12852 1 : case EXEC_OMP_TASKLOOP_SIMD:
12853 1 : return ST_OMP_TASKLOOP_SIMD;
12854 1 : case EXEC_OMP_TASKWAIT:
12855 1 : return ST_OMP_TASKWAIT;
12856 1 : case EXEC_OMP_TASKYIELD:
12857 1 : return ST_OMP_TASKYIELD;
12858 1 : case EXEC_OMP_TEAMS:
12859 1 : return ST_OMP_TEAMS;
12860 1 : case EXEC_OMP_TEAMS_DISTRIBUTE:
12861 1 : return ST_OMP_TEAMS_DISTRIBUTE;
12862 1 : case EXEC_OMP_TEAMS_DISTRIBUTE_PARALLEL_DO:
12863 1 : return ST_OMP_TEAMS_DISTRIBUTE_PARALLEL_DO;
12864 1 : case EXEC_OMP_TEAMS_DISTRIBUTE_PARALLEL_DO_SIMD:
12865 1 : return ST_OMP_TEAMS_DISTRIBUTE_PARALLEL_DO_SIMD;
12866 1 : case EXEC_OMP_TEAMS_DISTRIBUTE_SIMD:
12867 1 : return ST_OMP_TEAMS_DISTRIBUTE_SIMD;
12868 0 : case EXEC_OMP_TEAMS_LOOP:
12869 0 : return ST_OMP_TEAMS_LOOP;
12870 6 : case EXEC_OMP_PARALLEL_DO:
12871 6 : return ST_OMP_PARALLEL_DO;
12872 1 : case EXEC_OMP_PARALLEL_DO_SIMD:
12873 1 : return ST_OMP_PARALLEL_DO_SIMD;
12874 0 : case EXEC_OMP_PARALLEL_LOOP:
12875 0 : return ST_OMP_PARALLEL_LOOP;
12876 1 : case EXEC_OMP_DEPOBJ:
12877 1 : return ST_OMP_DEPOBJ;
12878 0 : case EXEC_OMP_TILE:
12879 0 : return ST_OMP_TILE;
12880 0 : case EXEC_OMP_UNROLL:
12881 0 : return ST_OMP_UNROLL;
12882 0 : case EXEC_OMP_DISPATCH:
12883 0 : return ST_OMP_DISPATCH;
12884 0 : default:
12885 0 : gcc_unreachable ();
12886 : }
12887 : }
12888 :
12889 : static gfc_statement
12890 63 : oacc_code_to_statement (gfc_code *code)
12891 : {
12892 63 : switch (code->op)
12893 : {
12894 : case EXEC_OACC_PARALLEL:
12895 : return ST_OACC_PARALLEL;
12896 : case EXEC_OACC_KERNELS:
12897 : return ST_OACC_KERNELS;
12898 : case EXEC_OACC_SERIAL:
12899 : return ST_OACC_SERIAL;
12900 : case EXEC_OACC_DATA:
12901 : return ST_OACC_DATA;
12902 : case EXEC_OACC_HOST_DATA:
12903 : return ST_OACC_HOST_DATA;
12904 : case EXEC_OACC_PARALLEL_LOOP:
12905 : return ST_OACC_PARALLEL_LOOP;
12906 : case EXEC_OACC_KERNELS_LOOP:
12907 : return ST_OACC_KERNELS_LOOP;
12908 : case EXEC_OACC_SERIAL_LOOP:
12909 : return ST_OACC_SERIAL_LOOP;
12910 : case EXEC_OACC_LOOP:
12911 : return ST_OACC_LOOP;
12912 : case EXEC_OACC_ATOMIC:
12913 : return ST_OACC_ATOMIC;
12914 : case EXEC_OACC_ROUTINE:
12915 : return ST_OACC_ROUTINE;
12916 : case EXEC_OACC_UPDATE:
12917 : return ST_OACC_UPDATE;
12918 : case EXEC_OACC_WAIT:
12919 : return ST_OACC_WAIT;
12920 : case EXEC_OACC_CACHE:
12921 : return ST_OACC_CACHE;
12922 : case EXEC_OACC_ENTER_DATA:
12923 : return ST_OACC_ENTER_DATA;
12924 : case EXEC_OACC_EXIT_DATA:
12925 : return ST_OACC_EXIT_DATA;
12926 : case EXEC_OACC_DECLARE:
12927 : return ST_OACC_DECLARE;
12928 0 : default:
12929 0 : gcc_unreachable ();
12930 : }
12931 : }
12932 :
12933 : static void
12934 13160 : resolve_oacc_directive_inside_omp_region (gfc_code *code)
12935 : {
12936 13160 : if (omp_current_ctx != NULL && omp_current_ctx->is_openmp)
12937 : {
12938 11 : gfc_statement st = omp_code_to_statement (omp_current_ctx->code);
12939 11 : gfc_statement oacc_st = oacc_code_to_statement (code);
12940 11 : gfc_error ("The %s directive cannot be specified within "
12941 : "a %s region at %L", gfc_ascii_statement (oacc_st),
12942 : gfc_ascii_statement (st), &code->loc);
12943 : }
12944 13160 : }
12945 :
12946 : static void
12947 20762 : resolve_omp_directive_inside_oacc_region (gfc_code *code)
12948 : {
12949 20762 : if (omp_current_ctx != NULL && !omp_current_ctx->is_openmp)
12950 : {
12951 52 : gfc_statement st = oacc_code_to_statement (omp_current_ctx->code);
12952 52 : gfc_statement omp_st = omp_code_to_statement (code);
12953 52 : gfc_error ("The %s directive cannot be specified within "
12954 : "a %s region at %L", gfc_ascii_statement (omp_st),
12955 : gfc_ascii_statement (st), &code->loc);
12956 : }
12957 20762 : }
12958 :
12959 :
12960 : static void
12961 5270 : resolve_oacc_nested_loops (gfc_code *code, gfc_code* do_code, int collapse,
12962 : const char *clause)
12963 : {
12964 5270 : gfc_symbol *dovar;
12965 5270 : gfc_code *c;
12966 5270 : int i;
12967 :
12968 5790 : for (i = 1; i <= collapse; i++)
12969 : {
12970 5790 : if (do_code->op == EXEC_DO_WHILE)
12971 : {
12972 10 : gfc_error ("!$ACC LOOP cannot be a DO WHILE or DO without loop control "
12973 : "at %L", &do_code->loc);
12974 10 : break;
12975 : }
12976 5780 : if (do_code->op == EXEC_DO_CONCURRENT)
12977 : {
12978 3 : gfc_error ("!$ACC LOOP cannot be a DO CONCURRENT loop at %L",
12979 : &do_code->loc);
12980 3 : break;
12981 : }
12982 5777 : gcc_assert (do_code->op == EXEC_DO);
12983 5777 : if (do_code->ext.iterator->var->ts.type != BT_INTEGER)
12984 6 : gfc_error ("!$ACC LOOP iteration variable must be of type integer at %L",
12985 : &do_code->loc);
12986 5777 : dovar = do_code->ext.iterator->var->symtree->n.sym;
12987 5777 : if (i > 1)
12988 : {
12989 518 : gfc_code *do_code2 = code->block->next;
12990 518 : int j;
12991 :
12992 1218 : for (j = 1; j < i; j++)
12993 : {
12994 710 : gfc_symbol *ivar = do_code2->ext.iterator->var->symtree->n.sym;
12995 710 : if (dovar == ivar
12996 710 : || gfc_find_sym_in_expr (ivar, do_code->ext.iterator->start)
12997 701 : || gfc_find_sym_in_expr (ivar, do_code->ext.iterator->end)
12998 1410 : || gfc_find_sym_in_expr (ivar, do_code->ext.iterator->step))
12999 : {
13000 10 : gfc_error ("!$ACC LOOP %s loops don't form rectangular "
13001 : "iteration space at %L", clause, &do_code->loc);
13002 10 : break;
13003 : }
13004 700 : do_code2 = do_code2->block->next;
13005 : }
13006 : }
13007 5777 : if (i == collapse)
13008 : break;
13009 577 : for (c = do_code->next; c; c = c->next)
13010 48 : if (c->op != EXEC_NOP && c->op != EXEC_CONTINUE)
13011 : {
13012 0 : gfc_error ("%s !$ACC LOOP loops not perfectly nested at %L",
13013 : clause, &c->loc);
13014 0 : break;
13015 : }
13016 529 : if (c)
13017 : break;
13018 529 : do_code = do_code->block;
13019 529 : if (do_code->op != EXEC_DO && do_code->op != EXEC_DO_WHILE
13020 0 : && do_code->op != EXEC_DO_CONCURRENT)
13021 : {
13022 0 : gfc_error ("not enough DO loops for %s !$ACC LOOP at %L",
13023 : clause, &code->loc);
13024 0 : break;
13025 : }
13026 529 : do_code = do_code->next;
13027 529 : if (do_code == NULL
13028 522 : || (do_code->op != EXEC_DO && do_code->op != EXEC_DO_WHILE
13029 2 : && do_code->op != EXEC_DO_CONCURRENT))
13030 : {
13031 9 : gfc_error ("not enough DO loops for %s !$ACC LOOP at %L",
13032 : clause, &code->loc);
13033 9 : break;
13034 : }
13035 : }
13036 5270 : }
13037 :
13038 :
13039 : static void
13040 10115 : resolve_oacc_loop_blocks (gfc_code *code)
13041 : {
13042 10115 : if (!oacc_is_loop (code))
13043 : return;
13044 :
13045 5270 : if (code->ext.omp_clauses->tile_list && code->ext.omp_clauses->gang
13046 24 : && code->ext.omp_clauses->worker && code->ext.omp_clauses->vector)
13047 0 : gfc_error ("Tiled loop cannot be parallelized across gangs, workers and "
13048 : "vectors at the same time at %L", &code->loc);
13049 :
13050 5270 : if (code->ext.omp_clauses->tile_list)
13051 : {
13052 : gfc_expr_list *el;
13053 501 : for (el = code->ext.omp_clauses->tile_list; el; el = el->next)
13054 : {
13055 304 : if (el->expr == NULL)
13056 : {
13057 : /* NULL expressions are used to represent '*' arguments.
13058 : Convert those to a 0 expressions. */
13059 113 : el->expr = gfc_get_constant_expr (BT_INTEGER,
13060 : gfc_default_integer_kind,
13061 : &code->loc);
13062 113 : mpz_set_si (el->expr->value.integer, 0);
13063 : }
13064 : else
13065 : {
13066 191 : resolve_positive_int_expr (el->expr, "TILE");
13067 191 : if (el->expr->expr_type != EXPR_CONSTANT)
13068 14 : gfc_error ("TILE requires constant expression at %L",
13069 : &code->loc);
13070 : }
13071 : }
13072 : }
13073 : }
13074 :
13075 :
13076 : void
13077 10115 : gfc_resolve_oacc_blocks (gfc_code *code, gfc_namespace *ns)
13078 : {
13079 10115 : fortran_omp_context ctx;
13080 10115 : gfc_omp_clauses *omp_clauses = code->ext.omp_clauses;
13081 10115 : gfc_omp_namelist *n;
13082 10115 : int list;
13083 :
13084 10115 : resolve_oacc_loop_blocks (code);
13085 :
13086 10115 : ctx.code = code;
13087 10115 : ctx.sharing_clauses = new hash_set<gfc_symbol *>;
13088 10115 : ctx.private_iterators = new hash_set<gfc_symbol *>;
13089 10115 : ctx.previous = omp_current_ctx;
13090 10115 : ctx.is_openmp = false;
13091 10115 : omp_current_ctx = &ctx;
13092 :
13093 404600 : for (list = 0; list < OMP_LIST_NUM; list++)
13094 394485 : switch (list)
13095 : {
13096 10115 : case OMP_LIST_PRIVATE:
13097 10704 : for (n = omp_clauses->lists[list]; n; n = n->next)
13098 589 : ctx.sharing_clauses->add (n->sym);
13099 : break;
13100 : default:
13101 : break;
13102 : }
13103 :
13104 10115 : gfc_resolve_blocks (code->block, ns);
13105 :
13106 10115 : omp_current_ctx = ctx.previous;
13107 20230 : delete ctx.sharing_clauses;
13108 20230 : delete ctx.private_iterators;
13109 10115 : }
13110 :
13111 :
13112 : static void
13113 5270 : resolve_oacc_loop (gfc_code *code)
13114 : {
13115 5270 : gfc_code *do_code;
13116 5270 : int collapse;
13117 :
13118 5270 : if (code->ext.omp_clauses)
13119 5270 : resolve_omp_clauses (code, code->ext.omp_clauses, NULL, true);
13120 :
13121 5270 : do_code = code->block->next;
13122 5270 : collapse = code->ext.omp_clauses->collapse;
13123 :
13124 : /* Both collapsed and tiled loops are lowered the same way, but are not
13125 : compatible. In gfc_trans_omp_do, the tile is prioritized. */
13126 5270 : if (code->ext.omp_clauses->tile_list)
13127 : {
13128 : int num = 0;
13129 : gfc_expr_list *el;
13130 501 : for (el = code->ext.omp_clauses->tile_list; el; el = el->next)
13131 304 : ++num;
13132 197 : resolve_oacc_nested_loops (code, code->block->next, num, "tiled");
13133 197 : return;
13134 : }
13135 :
13136 5073 : if (collapse <= 0)
13137 : collapse = 1;
13138 5073 : resolve_oacc_nested_loops (code, do_code, collapse, "collapsed");
13139 : }
13140 :
13141 : void
13142 330629 : gfc_resolve_oacc_declare (gfc_namespace *ns)
13143 : {
13144 330629 : int list;
13145 330629 : gfc_omp_namelist *n;
13146 330629 : gfc_oacc_declare *oc;
13147 :
13148 330629 : if (ns->oacc_declare == NULL)
13149 : return;
13150 :
13151 286 : for (oc = ns->oacc_declare; oc; oc = oc->next)
13152 : {
13153 6400 : for (list = 0; list < OMP_LIST_NUM; list++)
13154 6492 : for (n = oc->clauses->lists[list]; n; n = n->next)
13155 : {
13156 252 : n->sym->mark = 0;
13157 252 : if (n->sym->attr.flavor != FL_VARIABLE
13158 16 : && (n->sym->attr.flavor != FL_PROCEDURE
13159 8 : || n->sym->result != n->sym))
13160 : {
13161 14 : if (n->sym->attr.flavor != FL_PARAMETER)
13162 : {
13163 8 : gfc_error ("Object %qs is not a variable at %L",
13164 : n->sym->name, &oc->loc);
13165 8 : continue;
13166 : }
13167 : /* Note that OpenACC 3.4 permits name constants, but the
13168 : implementation is permitted to ignore the clause;
13169 : as semantically, device_resident kind of makes sense
13170 : (and the wording with it is a bit odd), the warning
13171 : is suppressed. */
13172 6 : if (list != OMP_LIST_DEVICE_RESIDENT)
13173 5 : gfc_warning (OPT_Wsurprising, "Object %qs at %L is ignored as"
13174 : " parameters need not be copied", n->sym->name,
13175 : &oc->loc);
13176 : }
13177 :
13178 244 : if (n->expr && n->expr->ref->type == REF_ARRAY)
13179 : {
13180 1 : gfc_error ("Array sections: %qs not allowed in"
13181 1 : " !$ACC DECLARE at %L", n->sym->name, &oc->loc);
13182 1 : continue;
13183 : }
13184 : }
13185 :
13186 250 : for (n = oc->clauses->lists[OMP_LIST_DEVICE_RESIDENT]; n; n = n->next)
13187 90 : check_array_not_assumed (n->sym, oc->loc, "DEVICE_RESIDENT");
13188 : }
13189 :
13190 286 : for (oc = ns->oacc_declare; oc; oc = oc->next)
13191 : {
13192 6400 : for (list = 0; list < OMP_LIST_NUM; list++)
13193 6492 : for (n = oc->clauses->lists[list]; n; n = n->next)
13194 : {
13195 252 : if (n->sym->mark)
13196 : {
13197 9 : gfc_error ("Symbol %qs present on multiple clauses at %L",
13198 : n->sym->name, &oc->loc);
13199 9 : continue;
13200 : }
13201 : else
13202 243 : n->sym->mark = 1;
13203 : }
13204 : }
13205 :
13206 286 : for (oc = ns->oacc_declare; oc; oc = oc->next)
13207 : {
13208 6400 : for (list = 0; list < OMP_LIST_NUM; list++)
13209 6492 : for (n = oc->clauses->lists[list]; n; n = n->next)
13210 252 : n->sym->mark = 0;
13211 : }
13212 : }
13213 :
13214 :
13215 : void
13216 330629 : gfc_resolve_oacc_routines (gfc_namespace *ns)
13217 : {
13218 330629 : for (gfc_oacc_routine_name *orn = ns->oacc_routine_names;
13219 330729 : orn;
13220 100 : orn = orn->next)
13221 : {
13222 100 : gfc_symbol *sym = orn->sym;
13223 100 : if (!sym->attr.external
13224 29 : && !sym->attr.function
13225 27 : && !sym->attr.subroutine)
13226 : {
13227 7 : gfc_error ("NAME %qs does not refer to a subroutine or function"
13228 : " in !$ACC ROUTINE ( NAME ) at %L", sym->name, &orn->loc);
13229 7 : continue;
13230 : }
13231 93 : if (!gfc_add_omp_declare_target (&sym->attr, sym->name, &orn->loc))
13232 : {
13233 20 : gfc_error ("NAME %qs invalid"
13234 : " in !$ACC ROUTINE ( NAME ) at %L", sym->name, &orn->loc);
13235 20 : continue;
13236 : }
13237 : }
13238 330629 : }
13239 :
13240 :
13241 : void
13242 13160 : gfc_resolve_oacc_directive (gfc_code *code, gfc_namespace *ns ATTRIBUTE_UNUSED)
13243 : {
13244 13160 : resolve_oacc_directive_inside_omp_region (code);
13245 :
13246 13160 : switch (code->op)
13247 : {
13248 7347 : case EXEC_OACC_PARALLEL:
13249 7347 : case EXEC_OACC_KERNELS:
13250 7347 : case EXEC_OACC_SERIAL:
13251 7347 : case EXEC_OACC_DATA:
13252 7347 : case EXEC_OACC_HOST_DATA:
13253 7347 : case EXEC_OACC_UPDATE:
13254 7347 : case EXEC_OACC_ENTER_DATA:
13255 7347 : case EXEC_OACC_EXIT_DATA:
13256 7347 : case EXEC_OACC_WAIT:
13257 7347 : case EXEC_OACC_CACHE:
13258 7347 : resolve_omp_clauses (code, code->ext.omp_clauses, NULL, true);
13259 7347 : break;
13260 5270 : case EXEC_OACC_PARALLEL_LOOP:
13261 5270 : case EXEC_OACC_KERNELS_LOOP:
13262 5270 : case EXEC_OACC_SERIAL_LOOP:
13263 5270 : case EXEC_OACC_LOOP:
13264 5270 : resolve_oacc_loop (code);
13265 5270 : break;
13266 543 : case EXEC_OACC_ATOMIC:
13267 543 : resolve_omp_atomic (code);
13268 543 : break;
13269 : default:
13270 : break;
13271 : }
13272 13160 : }
13273 :
13274 :
13275 : static void
13276 1913 : resolve_omp_target (gfc_code *code)
13277 : {
13278 : #define GFC_IS_TEAMS_CONSTRUCT(op) \
13279 : (op == EXEC_OMP_TEAMS \
13280 : || op == EXEC_OMP_TEAMS_DISTRIBUTE \
13281 : || op == EXEC_OMP_TEAMS_DISTRIBUTE_SIMD \
13282 : || op == EXEC_OMP_TEAMS_DISTRIBUTE_PARALLEL_DO \
13283 : || op == EXEC_OMP_TEAMS_DISTRIBUTE_PARALLEL_DO_SIMD \
13284 : || op == EXEC_OMP_TEAMS_LOOP)
13285 :
13286 1913 : if (!code->ext.omp_clauses->contains_teams_construct)
13287 : return;
13288 203 : gfc_code *c = code->block->next;
13289 203 : if (c->op == EXEC_BLOCK)
13290 30 : c = c->ext.block.ns->code;
13291 203 : if (code->ext.omp_clauses->target_first_st_is_teams_or_meta)
13292 : {
13293 192 : if (c->op == EXEC_OMP_METADIRECTIVE)
13294 : {
13295 15 : struct gfc_omp_variant *mc
13296 : = c->ext.omp_variants;
13297 : /* All mc->(next...->)code should be identical with regards
13298 : to the diagnostic below. */
13299 16 : do
13300 : {
13301 16 : if (mc->stmt != ST_NONE
13302 15 : && GFC_IS_TEAMS_CONSTRUCT (mc->code->op))
13303 : {
13304 14 : if (c->next == NULL && mc->code->next == NULL)
13305 : return;
13306 : c = mc->code;
13307 : break;
13308 : }
13309 2 : mc = mc->next;
13310 : }
13311 2 : while (mc);
13312 : }
13313 177 : else if (GFC_IS_TEAMS_CONSTRUCT (c->op) && c->next == NULL)
13314 : return;
13315 : }
13316 :
13317 31 : while (c && !GFC_IS_TEAMS_CONSTRUCT (c->op))
13318 8 : c = c->next;
13319 23 : if (c)
13320 19 : gfc_error ("!$OMP TARGET region at %L with a nested TEAMS at %L may not "
13321 : "contain any other statement, declaration or directive outside "
13322 : "of the single TEAMS construct", &c->loc, &code->loc);
13323 : else
13324 4 : gfc_error ("!$OMP TARGET region at %L with a nested TEAMS may not "
13325 : "contain any other statement, declaration or directive outside "
13326 : "of the single TEAMS construct", &code->loc);
13327 : #undef GFC_IS_TEAMS_CONSTRUCT
13328 : }
13329 :
13330 : static void
13331 154 : resolve_omp_dispatch (gfc_code *code)
13332 : {
13333 154 : gfc_code *next = code->block->next;
13334 154 : if (next == NULL)
13335 : return;
13336 :
13337 151 : gfc_exec_op op = next->op;
13338 151 : gcc_assert (op == EXEC_CALL || op == EXEC_ASSIGN);
13339 151 : if (op != EXEC_CALL
13340 74 : && (op != EXEC_ASSIGN || next->expr2->expr_type != EXPR_FUNCTION))
13341 3 : gfc_error (
13342 : "%<OMP DISPATCH%> directive at %L must be followed by a procedure "
13343 : "call with optional assignment",
13344 : &code->loc);
13345 :
13346 77 : if ((op == EXEC_CALL && next->resolved_sym != NULL
13347 76 : && next->resolved_sym->attr.proc_pointer)
13348 150 : || (op == EXEC_ASSIGN && gfc_expr_attr (next->expr2).proc_pointer))
13349 1 : gfc_error ("%<OMP DISPATCH%> directive at %L cannot be followed by a "
13350 : "procedure pointer",
13351 : &code->loc);
13352 : }
13353 :
13354 : /* Resolve OpenMP directive clauses and check various requirements
13355 : of each directive. */
13356 :
13357 : void
13358 20762 : gfc_resolve_omp_directive (gfc_code *code, gfc_namespace *ns)
13359 : {
13360 20762 : resolve_omp_directive_inside_oacc_region (code);
13361 :
13362 20762 : if (code->op != EXEC_OMP_ATOMIC)
13363 18608 : gfc_maybe_initialize_eh ();
13364 :
13365 20762 : switch (code->op)
13366 : {
13367 5412 : case EXEC_OMP_DISTRIBUTE:
13368 5412 : case EXEC_OMP_DISTRIBUTE_PARALLEL_DO:
13369 5412 : case EXEC_OMP_DISTRIBUTE_PARALLEL_DO_SIMD:
13370 5412 : case EXEC_OMP_DISTRIBUTE_SIMD:
13371 5412 : case EXEC_OMP_DO:
13372 5412 : case EXEC_OMP_DO_SIMD:
13373 5412 : case EXEC_OMP_LOOP:
13374 5412 : case EXEC_OMP_PARALLEL_DO:
13375 5412 : case EXEC_OMP_PARALLEL_DO_SIMD:
13376 5412 : case EXEC_OMP_PARALLEL_LOOP:
13377 5412 : case EXEC_OMP_PARALLEL_MASKED_TASKLOOP:
13378 5412 : case EXEC_OMP_PARALLEL_MASKED_TASKLOOP_SIMD:
13379 5412 : case EXEC_OMP_PARALLEL_MASTER_TASKLOOP:
13380 5412 : case EXEC_OMP_PARALLEL_MASTER_TASKLOOP_SIMD:
13381 5412 : case EXEC_OMP_MASKED_TASKLOOP:
13382 5412 : case EXEC_OMP_MASKED_TASKLOOP_SIMD:
13383 5412 : case EXEC_OMP_MASTER_TASKLOOP:
13384 5412 : case EXEC_OMP_MASTER_TASKLOOP_SIMD:
13385 5412 : case EXEC_OMP_SIMD:
13386 5412 : case EXEC_OMP_TARGET_PARALLEL_DO:
13387 5412 : case EXEC_OMP_TARGET_PARALLEL_DO_SIMD:
13388 5412 : case EXEC_OMP_TARGET_PARALLEL_LOOP:
13389 5412 : case EXEC_OMP_TARGET_SIMD:
13390 5412 : case EXEC_OMP_TARGET_TEAMS_DISTRIBUTE:
13391 5412 : case EXEC_OMP_TARGET_TEAMS_DISTRIBUTE_PARALLEL_DO:
13392 5412 : case EXEC_OMP_TARGET_TEAMS_DISTRIBUTE_PARALLEL_DO_SIMD:
13393 5412 : case EXEC_OMP_TARGET_TEAMS_DISTRIBUTE_SIMD:
13394 5412 : case EXEC_OMP_TARGET_TEAMS_LOOP:
13395 5412 : case EXEC_OMP_TASKLOOP:
13396 5412 : case EXEC_OMP_TASKLOOP_SIMD:
13397 5412 : case EXEC_OMP_TEAMS_DISTRIBUTE:
13398 5412 : case EXEC_OMP_TEAMS_DISTRIBUTE_PARALLEL_DO:
13399 5412 : case EXEC_OMP_TEAMS_DISTRIBUTE_PARALLEL_DO_SIMD:
13400 5412 : case EXEC_OMP_TEAMS_DISTRIBUTE_SIMD:
13401 5412 : case EXEC_OMP_TEAMS_LOOP:
13402 5412 : case EXEC_OMP_TILE:
13403 5412 : case EXEC_OMP_UNROLL:
13404 5412 : resolve_omp_do (code);
13405 5412 : break;
13406 1913 : case EXEC_OMP_TARGET:
13407 1913 : resolve_omp_target (code);
13408 9823 : gcc_fallthrough ();
13409 9823 : case EXEC_OMP_ALLOCATE:
13410 9823 : case EXEC_OMP_ALLOCATORS:
13411 9823 : case EXEC_OMP_ASSUME:
13412 9823 : case EXEC_OMP_CANCEL:
13413 9823 : case EXEC_OMP_ERROR:
13414 9823 : case EXEC_OMP_INTEROP:
13415 9823 : case EXEC_OMP_MASKED:
13416 9823 : case EXEC_OMP_ORDERED:
13417 9823 : case EXEC_OMP_PARALLEL_WORKSHARE:
13418 9823 : case EXEC_OMP_PARALLEL:
13419 9823 : case EXEC_OMP_PARALLEL_MASKED:
13420 9823 : case EXEC_OMP_PARALLEL_MASTER:
13421 9823 : case EXEC_OMP_PARALLEL_SECTIONS:
13422 9823 : case EXEC_OMP_SCOPE:
13423 9823 : case EXEC_OMP_SECTIONS:
13424 9823 : case EXEC_OMP_SINGLE:
13425 9823 : case EXEC_OMP_TARGET_DATA:
13426 9823 : case EXEC_OMP_TARGET_ENTER_DATA:
13427 9823 : case EXEC_OMP_TARGET_EXIT_DATA:
13428 9823 : case EXEC_OMP_TARGET_PARALLEL:
13429 9823 : case EXEC_OMP_TARGET_TEAMS:
13430 9823 : case EXEC_OMP_TASK:
13431 9823 : case EXEC_OMP_TASKWAIT:
13432 9823 : case EXEC_OMP_TEAMS:
13433 9823 : case EXEC_OMP_WORKSHARE:
13434 9823 : case EXEC_OMP_DEPOBJ:
13435 9823 : if (code->ext.omp_clauses)
13436 9690 : resolve_omp_clauses (code, code->ext.omp_clauses, NULL);
13437 : break;
13438 1704 : case EXEC_OMP_TARGET_UPDATE:
13439 1704 : if (code->ext.omp_clauses)
13440 1704 : resolve_omp_clauses (code, code->ext.omp_clauses, NULL);
13441 1704 : if (code->ext.omp_clauses == NULL
13442 1704 : || (code->ext.omp_clauses->lists[OMP_LIST_TO] == NULL
13443 992 : && code->ext.omp_clauses->lists[OMP_LIST_FROM] == NULL))
13444 0 : gfc_error ("OMP TARGET UPDATE at %L requires at least one TO or "
13445 : "FROM clause", &code->loc);
13446 : break;
13447 2154 : case EXEC_OMP_ATOMIC:
13448 2154 : resolve_omp_clauses (code, code->block->ext.omp_clauses, NULL);
13449 2154 : resolve_omp_atomic (code);
13450 2154 : break;
13451 159 : case EXEC_OMP_CRITICAL:
13452 159 : resolve_omp_clauses (code, code->ext.omp_clauses, NULL);
13453 159 : if (!code->ext.omp_clauses->critical_name
13454 112 : && code->ext.omp_clauses->hint
13455 3 : && code->ext.omp_clauses->hint->ts.type == BT_INTEGER
13456 3 : && code->ext.omp_clauses->hint->expr_type == EXPR_CONSTANT
13457 3 : && mpz_sgn (code->ext.omp_clauses->hint->value.integer) != 0)
13458 1 : gfc_error ("OMP CRITICAL at %L with HINT clause requires a NAME, "
13459 : "except when omp_sync_hint_none is used", &code->loc);
13460 : break;
13461 49 : case EXEC_OMP_SCAN:
13462 : /* Flag is only used to checking, hence, it is unset afterwards. */
13463 49 : if (!code->ext.omp_clauses->if_present)
13464 10 : gfc_error ("Unexpected !$OMP SCAN at %L outside loop construct with "
13465 : "%<inscan%> REDUCTION clause", &code->loc);
13466 49 : code->ext.omp_clauses->if_present = false;
13467 49 : resolve_omp_clauses (code, code->ext.omp_clauses, ns);
13468 49 : break;
13469 154 : case EXEC_OMP_DISPATCH:
13470 154 : if (code->ext.omp_clauses)
13471 154 : resolve_omp_clauses (code, code->ext.omp_clauses, ns);
13472 154 : resolve_omp_dispatch (code);
13473 154 : break;
13474 138 : case EXEC_OMP_METADIRECTIVE:
13475 138 : resolve_omp_metadirective (code, ns);
13476 138 : break;
13477 : default:
13478 : break;
13479 : }
13480 20762 : }
13481 :
13482 : /* Resolve !$omp declare {variant|simd} constructs in NS.
13483 : Note that !$omp declare target is resolved in resolve_symbol. */
13484 :
13485 : void
13486 341858 : gfc_resolve_omp_declare (gfc_namespace *ns)
13487 : {
13488 341858 : gfc_omp_declare_simd *ods;
13489 342094 : for (ods = ns->omp_declare_simd; ods; ods = ods->next)
13490 : {
13491 236 : if (ods->proc_name != NULL
13492 196 : && ods->proc_name != ns->proc_name)
13493 6 : gfc_error ("!$OMP DECLARE SIMD should refer to containing procedure "
13494 : "%qs at %L", ns->proc_name->name, &ods->where);
13495 236 : if (ods->clauses)
13496 218 : resolve_omp_clauses (NULL, ods->clauses, ns);
13497 : }
13498 :
13499 341858 : gfc_omp_declare_variant *odv;
13500 341858 : gfc_omp_namelist *range_begin = NULL;
13501 :
13502 342311 : for (odv = ns->omp_declare_variant; odv; odv = odv->next)
13503 453 : gfc_resolve_omp_context_selector (odv->set_selectors, false, nullptr);
13504 342311 : for (odv = ns->omp_declare_variant; odv; odv = odv->next)
13505 656 : for (gfc_omp_namelist *n = odv->adjust_args_list; n != NULL; n = n->next)
13506 : {
13507 203 : if ((n->expr == NULL
13508 6 : && (range_begin
13509 4 : || n->u.adj_args.range_start
13510 1 : || n->u.adj_args.omp_num_args_plus
13511 1 : || n->u.adj_args.omp_num_args_minus))
13512 198 : || n->u.adj_args.error_p)
13513 : {
13514 : }
13515 197 : else if (range_begin
13516 191 : || n->u.adj_args.range_start
13517 186 : || n->u.adj_args.omp_num_args_plus
13518 186 : || n->u.adj_args.omp_num_args_minus)
13519 : {
13520 11 : if (!n->expr
13521 11 : || !gfc_resolve_expr (n->expr)
13522 11 : || n->expr->expr_type != EXPR_CONSTANT
13523 10 : || n->expr->ts.type != BT_INTEGER
13524 10 : || n->expr->rank != 0
13525 10 : || mpz_sgn (n->expr->value.integer) < 0
13526 20 : || ((n->u.adj_args.omp_num_args_plus
13527 8 : || n->u.adj_args.omp_num_args_minus)
13528 5 : && mpz_sgn (n->expr->value.integer) == 0))
13529 : {
13530 2 : if (n->u.adj_args.omp_num_args_plus
13531 2 : || n->u.adj_args.omp_num_args_minus)
13532 0 : gfc_error ("Expected constant non-negative scalar integer "
13533 : "offset expression at %L", &n->where);
13534 : else
13535 2 : gfc_error ("For range-based %<adjust_args%>, a constant "
13536 : "positive scalar integer expression is required "
13537 : "at %L", &n->where);
13538 : }
13539 : }
13540 186 : else if (n->expr
13541 186 : && n->expr->expr_type == EXPR_CONSTANT
13542 21 : && n->expr->ts.type == BT_INTEGER
13543 20 : && mpz_sgn (n->expr->value.integer) > 0)
13544 : {
13545 : }
13546 166 : else if (!n->expr
13547 166 : || !gfc_resolve_expr (n->expr)
13548 331 : || n->expr->expr_type != EXPR_VARIABLE)
13549 2 : gfc_error ("Expected dummy parameter name or a positive integer "
13550 : "at %L", &n->where);
13551 164 : else if (n->expr->expr_type == EXPR_VARIABLE)
13552 164 : n->sym = n->expr->symtree->n.sym;
13553 :
13554 203 : range_begin = n->u.adj_args.range_start ? n : NULL;
13555 : }
13556 341858 : }
13557 :
13558 : struct omp_udr_callback_data
13559 : {
13560 : gfc_omp_udr *omp_udr;
13561 : bool is_initializer;
13562 : };
13563 :
13564 : static int
13565 3598 : omp_udr_callback (gfc_expr **e, int *walk_subtrees ATTRIBUTE_UNUSED,
13566 : void *data)
13567 : {
13568 3598 : struct omp_udr_callback_data *cd = (struct omp_udr_callback_data *) data;
13569 3598 : if ((*e)->expr_type == EXPR_VARIABLE)
13570 : {
13571 2203 : if (cd->is_initializer)
13572 : {
13573 535 : if ((*e)->symtree->n.sym != cd->omp_udr->omp_priv
13574 140 : && (*e)->symtree->n.sym != cd->omp_udr->omp_orig)
13575 4 : gfc_error ("Variable other than OMP_PRIV or OMP_ORIG used in "
13576 : "INITIALIZER clause of !$OMP DECLARE REDUCTION at %L",
13577 : &(*e)->where);
13578 : }
13579 : else
13580 : {
13581 1668 : if ((*e)->symtree->n.sym != cd->omp_udr->omp_out
13582 597 : && (*e)->symtree->n.sym != cd->omp_udr->omp_in)
13583 6 : gfc_error ("Variable other than OMP_OUT or OMP_IN used in "
13584 : "combiner of !$OMP DECLARE REDUCTION at %L",
13585 : &(*e)->where);
13586 : }
13587 : }
13588 3598 : return 0;
13589 : }
13590 :
13591 : /* Resolve !$omp declare reduction constructs. */
13592 :
13593 : static void
13594 600 : gfc_resolve_omp_udr (gfc_omp_udr *omp_udr)
13595 : {
13596 600 : gfc_actual_arglist *a;
13597 600 : const char *predef_name = NULL;
13598 :
13599 600 : switch (omp_udr->rop)
13600 : {
13601 599 : case OMP_REDUCTION_PLUS:
13602 599 : case OMP_REDUCTION_TIMES:
13603 599 : case OMP_REDUCTION_MINUS:
13604 599 : case OMP_REDUCTION_AND:
13605 599 : case OMP_REDUCTION_OR:
13606 599 : case OMP_REDUCTION_EQV:
13607 599 : case OMP_REDUCTION_NEQV:
13608 599 : case OMP_REDUCTION_MAX:
13609 599 : case OMP_REDUCTION_USER:
13610 599 : break;
13611 1 : default:
13612 1 : gfc_error ("Invalid operator for !$OMP DECLARE REDUCTION %s at %L",
13613 : omp_udr->name, &omp_udr->where);
13614 22 : return;
13615 : }
13616 :
13617 599 : if (gfc_omp_udr_predef (omp_udr->rop, omp_udr->name,
13618 : &omp_udr->ts, &predef_name))
13619 : {
13620 18 : if (predef_name)
13621 18 : gfc_error_now ("Redefinition of predefined %s "
13622 : "!$OMP DECLARE REDUCTION at %L",
13623 : predef_name, &omp_udr->where);
13624 : else
13625 0 : gfc_error_now ("Redefinition of predefined "
13626 : "!$OMP DECLARE REDUCTION at %L", &omp_udr->where);
13627 18 : return;
13628 : }
13629 :
13630 581 : if (omp_udr->ts.type == BT_CHARACTER
13631 62 : && omp_udr->ts.u.cl->length
13632 32 : && omp_udr->ts.u.cl->length->expr_type != EXPR_CONSTANT)
13633 : {
13634 1 : gfc_error ("CHARACTER length in !$OMP DECLARE REDUCTION %s not "
13635 : "constant at %L", omp_udr->name, &omp_udr->where);
13636 1 : return;
13637 : }
13638 :
13639 580 : struct omp_udr_callback_data cd;
13640 580 : cd.omp_udr = omp_udr;
13641 580 : cd.is_initializer = false;
13642 580 : gfc_code_walker (&omp_udr->combiner_ns->code, gfc_dummy_code_callback,
13643 : omp_udr_callback, &cd);
13644 580 : if (omp_udr->combiner_ns->code->op == EXEC_CALL)
13645 : {
13646 346 : for (a = omp_udr->combiner_ns->code->ext.actual; a; a = a->next)
13647 237 : if (a->expr == NULL)
13648 : break;
13649 110 : if (a)
13650 1 : gfc_error ("Subroutine call with alternate returns in combiner "
13651 : "of !$OMP DECLARE REDUCTION at %L",
13652 : &omp_udr->combiner_ns->code->loc);
13653 : }
13654 580 : if (omp_udr->initializer_ns)
13655 : {
13656 373 : cd.is_initializer = true;
13657 373 : gfc_code_walker (&omp_udr->initializer_ns->code, gfc_dummy_code_callback,
13658 : omp_udr_callback, &cd);
13659 373 : if (omp_udr->initializer_ns->code->op == EXEC_CALL)
13660 : {
13661 377 : for (a = omp_udr->initializer_ns->code->ext.actual; a; a = a->next)
13662 243 : if (a->expr == NULL)
13663 : break;
13664 135 : if (a)
13665 1 : gfc_error ("Subroutine call with alternate returns in "
13666 : "INITIALIZER clause of !$OMP DECLARE REDUCTION "
13667 : "at %L", &omp_udr->initializer_ns->code->loc);
13668 136 : for (a = omp_udr->initializer_ns->code->ext.actual; a; a = a->next)
13669 135 : if (a->expr
13670 135 : && a->expr->expr_type == EXPR_VARIABLE
13671 135 : && a->expr->symtree->n.sym == omp_udr->omp_priv
13672 134 : && a->expr->ref == NULL)
13673 : break;
13674 135 : if (a == NULL)
13675 1 : gfc_error ("One of actual subroutine arguments in INITIALIZER "
13676 : "clause of !$OMP DECLARE REDUCTION must be OMP_PRIV "
13677 : "at %L", &omp_udr->initializer_ns->code->loc);
13678 : }
13679 : }
13680 207 : else if (omp_udr->ts.type == BT_DERIVED
13681 207 : && !gfc_has_default_initializer (omp_udr->ts.u.derived))
13682 : {
13683 1 : gfc_error ("Missing INITIALIZER clause for !$OMP DECLARE REDUCTION "
13684 : "of derived type without default initializer at %L",
13685 : &omp_udr->where);
13686 1 : return;
13687 : }
13688 : }
13689 :
13690 : void
13691 342866 : gfc_resolve_omp_udrs (gfc_symtree *st)
13692 : {
13693 342866 : gfc_omp_udr *omp_udr;
13694 :
13695 342866 : if (st == NULL)
13696 : return;
13697 504 : gfc_resolve_omp_udrs (st->left);
13698 504 : gfc_resolve_omp_udrs (st->right);
13699 1104 : for (omp_udr = st->n.omp_udr; omp_udr; omp_udr = omp_udr->next)
13700 600 : gfc_resolve_omp_udr (omp_udr);
13701 : }
|
