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 55475 : gfc_match_omp_eos (void)
135 : {
136 55475 : locus old_loc;
137 55475 : char c;
138 :
139 55475 : old_loc = gfc_current_locus;
140 55475 : gfc_gobble_whitespace ();
141 :
142 55475 : if (gfc_matching_omp_context_selector)
143 : {
144 269 : if (gfc_peek_ascii_char () == ')')
145 : return MATCH_YES;
146 : }
147 : else
148 : {
149 55206 : c = gfc_next_ascii_char ();
150 55206 : 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 53479 : case '\n':
159 53479 : return MATCH_YES;
160 : }
161 : }
162 :
163 1728 : gfc_current_locus = old_loc;
164 1728 : return MATCH_NO;
165 : }
166 :
167 : match
168 13176 : gfc_match_omp_eos_error (void)
169 : {
170 13176 : 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 61577 : gfc_free_omp_clauses (gfc_omp_clauses *c)
182 : {
183 61577 : if (c == NULL)
184 : return;
185 :
186 34671 : gfc_free_expr (c->if_expr);
187 381381 : for (int i = 0; i < OMP_IF_LAST; i++)
188 346710 : gfc_free_expr (c->if_exprs[i]);
189 34671 : gfc_free_expr (c->self_expr);
190 34671 : gfc_free_expr (c->final_expr);
191 34671 : gfc_free_expr (c->num_threads);
192 34671 : gfc_free_expr (c->chunk_size);
193 34671 : gfc_free_expr (c->safelen_expr);
194 34671 : gfc_free_expr (c->simdlen_expr);
195 34671 : gfc_free_expr (c->num_teams_lower);
196 34671 : gfc_free_expr (c->num_teams_upper);
197 34671 : gfc_free_expr (c->device);
198 34671 : gfc_free_expr (c->dyn_groupprivate);
199 34671 : gfc_free_expr (c->thread_limit);
200 34671 : gfc_free_expr (c->dist_chunk_size);
201 34671 : gfc_free_expr (c->grainsize);
202 34671 : gfc_free_expr (c->hint);
203 34671 : gfc_free_expr (c->num_tasks);
204 34671 : gfc_free_expr (c->priority);
205 34671 : gfc_free_expr (c->detach);
206 34671 : gfc_free_expr (c->novariants);
207 34671 : gfc_free_expr (c->nocontext);
208 34671 : gfc_free_expr (c->async_expr);
209 34671 : gfc_free_expr (c->gang_num_expr);
210 34671 : gfc_free_expr (c->gang_static_expr);
211 34671 : gfc_free_expr (c->worker_expr);
212 34671 : gfc_free_expr (c->vector_expr);
213 34671 : gfc_free_expr (c->num_gangs_expr);
214 34671 : gfc_free_expr (c->num_workers_expr);
215 34671 : gfc_free_expr (c->vector_length_expr);
216 1386840 : for (enum gfc_omp_list_type t = OMP_LIST_FIRST; t < OMP_LIST_NUM;
217 1352169 : t = gfc_omp_list_type (t + 1))
218 1352169 : gfc_free_omp_namelist (c->lists[t], t);
219 34671 : gfc_free_expr_list (c->wait_list);
220 34671 : gfc_free_expr_list (c->tile_list);
221 34671 : gfc_free_expr_list (c->sizes_list);
222 34671 : free (const_cast<char *> (c->critical_name));
223 34671 : if (c->assume)
224 : {
225 24 : free (c->assume->absent);
226 24 : free (c->assume->contains);
227 24 : gfc_free_expr_list (c->assume->holds);
228 24 : free (c->assume);
229 : }
230 34671 : free (c);
231 : }
232 :
233 : /* Free oacc_declare structures. */
234 :
235 : void
236 76 : gfc_free_oacc_declare_clauses (struct gfc_oacc_declare *oc)
237 : {
238 76 : struct gfc_oacc_declare *decl = oc;
239 :
240 76 : do
241 : {
242 76 : struct gfc_oacc_declare *next;
243 :
244 76 : next = decl->next;
245 76 : gfc_free_omp_clauses (decl->clauses);
246 76 : free (decl);
247 76 : decl = next;
248 : }
249 76 : while (decl);
250 76 : }
251 :
252 : /* Free expression list. */
253 : void
254 105016 : gfc_free_expr_list (gfc_expr_list *list)
255 : {
256 105016 : gfc_expr_list *n;
257 :
258 106423 : for (; list; list = n)
259 : {
260 1407 : n = list->next;
261 1407 : free (list);
262 : }
263 105016 : }
264 :
265 : /* Free an !$omp declare simd construct list. */
266 :
267 : void
268 236 : gfc_free_omp_declare_simd (gfc_omp_declare_simd *ods)
269 : {
270 236 : if (ods)
271 : {
272 236 : gfc_free_omp_clauses (ods->clauses);
273 236 : free (ods);
274 : }
275 236 : }
276 :
277 : void
278 528839 : gfc_free_omp_declare_simd_list (gfc_omp_declare_simd *list)
279 : {
280 529075 : while (list)
281 : {
282 236 : gfc_omp_declare_simd *current = list;
283 236 : list = list->next;
284 236 : gfc_free_omp_declare_simd (current);
285 : }
286 528839 : }
287 :
288 : static void
289 727 : gfc_free_omp_trait_property_list (gfc_omp_trait_property *list)
290 : {
291 1134 : while (list)
292 : {
293 407 : gfc_omp_trait_property *current = list;
294 407 : list = list->next;
295 407 : switch (current->property_kind)
296 : {
297 24 : case OMP_TRAIT_PROPERTY_ID:
298 24 : free (current->name);
299 24 : break;
300 261 : case OMP_TRAIT_PROPERTY_NAME_LIST:
301 261 : if (current->is_name)
302 168 : free (current->name);
303 : break;
304 15 : case OMP_TRAIT_PROPERTY_CLAUSE_LIST:
305 15 : gfc_free_omp_clauses (current->clauses);
306 15 : break;
307 : default:
308 : break;
309 : }
310 407 : free (current);
311 : }
312 727 : }
313 :
314 : static void
315 599 : gfc_free_omp_selector_list (gfc_omp_selector *list)
316 : {
317 1326 : while (list)
318 : {
319 727 : gfc_omp_selector *current = list;
320 727 : list = list->next;
321 727 : gfc_free_omp_trait_property_list (current->properties);
322 727 : free (current);
323 : }
324 599 : }
325 :
326 : static void
327 668 : gfc_free_omp_set_selector_list (gfc_omp_set_selector *list)
328 : {
329 1267 : while (list)
330 : {
331 599 : gfc_omp_set_selector *current = list;
332 599 : list = list->next;
333 599 : gfc_free_omp_selector_list (current->trait_selectors);
334 599 : free (current);
335 : }
336 668 : }
337 :
338 : /* Free an !$omp declare variant construct list. */
339 :
340 : void
341 528839 : gfc_free_omp_declare_variant_list (gfc_omp_declare_variant *list)
342 : {
343 529293 : while (list)
344 : {
345 454 : gfc_omp_declare_variant *current = list;
346 454 : list = list->next;
347 454 : gfc_free_omp_set_selector_list (current->set_selectors);
348 454 : gfc_free_omp_namelist (current->adjust_args_list, OMP_LIST_NONE);
349 454 : free (current);
350 : }
351 528839 : }
352 :
353 : /* Free an !$omp declare reduction. */
354 :
355 : void
356 1271 : gfc_free_omp_udr (gfc_omp_udr *omp_udr)
357 : {
358 1271 : if (omp_udr)
359 : {
360 685 : gfc_free_omp_udr (omp_udr->next);
361 685 : gfc_free_namespace (omp_udr->combiner_ns);
362 685 : if (omp_udr->initializer_ns)
363 386 : gfc_free_namespace (omp_udr->initializer_ns);
364 685 : free (omp_udr);
365 : }
366 1271 : }
367 :
368 : /* Free variants of an !$omp metadirective construct. */
369 :
370 : void
371 93 : gfc_free_omp_variants (gfc_omp_variant *variant)
372 : {
373 284 : while (variant)
374 : {
375 191 : gfc_omp_variant *next_variant = variant->next;
376 191 : gfc_free_omp_set_selector_list (variant->selectors);
377 191 : free (variant);
378 191 : variant = next_variant;
379 : }
380 93 : }
381 :
382 : /* Free an !$omp declare mapper. */
383 :
384 : void
385 44 : gfc_free_omp_udm (gfc_omp_udm *omp_udm)
386 : {
387 44 : if (omp_udm)
388 : {
389 22 : gfc_free_omp_udm (omp_udm->next);
390 22 : gfc_free_namespace (omp_udm->mapper_ns);
391 22 : free (omp_udm);
392 : }
393 44 : }
394 :
395 : static gfc_omp_udr *
396 4716 : gfc_find_omp_udr (gfc_namespace *ns, const char *name, gfc_typespec *ts)
397 : {
398 4716 : gfc_symtree *st;
399 :
400 4716 : if (ns == NULL)
401 470 : ns = gfc_current_ns;
402 5664 : do
403 : {
404 5664 : gfc_omp_udr *omp_udr;
405 :
406 5664 : st = gfc_find_symtree (ns->omp_udr_root, name);
407 5664 : if (st != NULL)
408 : {
409 941 : for (omp_udr = st->n.omp_udr; omp_udr; omp_udr = omp_udr->next)
410 941 : if (ts == NULL)
411 : return omp_udr;
412 571 : else if (gfc_compare_types (&omp_udr->ts, ts))
413 : {
414 482 : if (ts->type == BT_CHARACTER)
415 : {
416 60 : if (omp_udr->ts.u.cl->length == NULL)
417 : return omp_udr;
418 36 : if (ts->u.cl->length == NULL)
419 0 : continue;
420 36 : if (gfc_compare_expr (omp_udr->ts.u.cl->length,
421 : ts->u.cl->length,
422 : INTRINSIC_EQ) != 0)
423 12 : continue;
424 : }
425 446 : return omp_udr;
426 : }
427 : }
428 :
429 : /* Don't escape an interface block. */
430 4824 : if (ns && !ns->has_import_set
431 4824 : && ns->proc_name && ns->proc_name->attr.if_source == IFSRC_IFBODY)
432 : break;
433 :
434 4824 : ns = ns->parent;
435 : }
436 4824 : while (ns != NULL);
437 :
438 : return NULL;
439 : }
440 :
441 :
442 : /* Match a variable/common block list and construct a namelist from it;
443 : if has_all_memory != NULL, *has_all_memory is set and omp_all_memory
444 : yields a list->sym NULL entry. */
445 :
446 : static match
447 31730 : gfc_match_omp_variable_list (const char *str, gfc_omp_namelist **list,
448 : bool allow_common, bool *end_colon = NULL,
449 : gfc_omp_namelist ***headp = NULL,
450 : bool allow_sections = false,
451 : bool allow_derived = false,
452 : bool *has_all_memory = NULL,
453 : bool reject_common_vars = false,
454 : bool reverse_order = false)
455 : {
456 31730 : gfc_omp_namelist *head, *tail, *p;
457 31730 : locus old_loc, cur_loc;
458 31730 : char n[GFC_MAX_SYMBOL_LEN+1];
459 31730 : gfc_symbol *sym;
460 31730 : match m;
461 31730 : gfc_symtree *st;
462 :
463 31730 : head = tail = NULL;
464 :
465 31730 : old_loc = gfc_current_locus;
466 31730 : if (has_all_memory)
467 708 : *has_all_memory = false;
468 31730 : m = gfc_match (str);
469 31730 : if (m != MATCH_YES)
470 : return m;
471 :
472 38485 : for (;;)
473 : {
474 38485 : gfc_gobble_whitespace ();
475 38485 : cur_loc = gfc_current_locus;
476 :
477 38485 : m = gfc_match_name (n);
478 38485 : if (m == MATCH_YES && strcmp (n, "omp_all_memory") == 0)
479 : {
480 23 : locus loc = gfc_get_location_range (NULL, 0, &cur_loc, 1,
481 : &gfc_current_locus);
482 23 : if (!has_all_memory)
483 : {
484 2 : gfc_error ("%<omp_all_memory%> at %L not permitted in this "
485 : "clause", &loc);
486 2 : goto cleanup;
487 : }
488 21 : *has_all_memory = true;
489 21 : p = gfc_get_omp_namelist ();
490 21 : if (head == NULL)
491 : head = tail = p;
492 : else
493 : {
494 3 : tail->next = p;
495 3 : tail = tail->next;
496 : }
497 21 : tail->where = loc;
498 21 : goto next_item;
499 : }
500 38206 : if (m == MATCH_YES)
501 : {
502 38206 : gfc_symtree *st;
503 38206 : if ((m = gfc_get_ha_sym_tree (n, &st) ? MATCH_ERROR : MATCH_YES)
504 : == MATCH_YES)
505 38206 : sym = st->n.sym;
506 : }
507 38462 : switch (m)
508 : {
509 38206 : case MATCH_YES:
510 38206 : gfc_expr *expr;
511 38206 : expr = NULL;
512 38206 : gfc_gobble_whitespace ();
513 23523 : if ((allow_sections && gfc_peek_ascii_char () == '(')
514 57368 : || (allow_derived && gfc_peek_ascii_char () == '%'))
515 : {
516 6600 : gfc_current_locus = cur_loc;
517 6600 : m = gfc_match_variable (&expr, 0);
518 6600 : switch (m)
519 : {
520 4 : case MATCH_ERROR:
521 12 : goto cleanup;
522 0 : case MATCH_NO:
523 0 : goto syntax;
524 6596 : default:
525 6596 : break;
526 : }
527 6596 : if (gfc_is_coindexed (expr))
528 : {
529 5 : gfc_error ("List item shall not be coindexed at %L",
530 5 : &expr->where);
531 5 : goto cleanup;
532 : }
533 : }
534 38197 : gfc_set_sym_referenced (sym);
535 38197 : p = gfc_get_omp_namelist ();
536 38197 : if (head == NULL)
537 : head = tail = p;
538 10164 : else if (reverse_order)
539 : {
540 57 : p->next = head;
541 57 : head = p;
542 : }
543 : else
544 : {
545 10107 : tail->next = p;
546 10107 : tail = tail->next;
547 : }
548 38197 : p->sym = sym;
549 38197 : p->expr = expr;
550 38197 : p->where = gfc_get_location_range (NULL, 0, &cur_loc, 1,
551 : &gfc_current_locus);
552 38197 : if (reject_common_vars && sym->attr.in_common)
553 : {
554 3 : gcc_assert (allow_common);
555 3 : gfc_error ("%qs at %L is part of the common block %</%s/%> and "
556 : "may only be specified implicitly via the named "
557 : "common block", sym->name, &cur_loc,
558 3 : sym->common_head->name);
559 3 : goto cleanup;
560 : }
561 38194 : goto next_item;
562 256 : case MATCH_NO:
563 256 : break;
564 0 : case MATCH_ERROR:
565 0 : goto cleanup;
566 : }
567 :
568 256 : if (!allow_common)
569 12 : goto syntax;
570 :
571 244 : m = gfc_match ("/ %n /", n);
572 244 : if (m == MATCH_ERROR)
573 0 : goto cleanup;
574 244 : if (m == MATCH_NO)
575 19 : goto syntax;
576 :
577 225 : cur_loc = gfc_get_location_range (NULL, 0, &cur_loc, 1,
578 : &gfc_current_locus);
579 225 : st = gfc_find_symtree (gfc_current_ns->common_root, n);
580 225 : if (st == NULL)
581 : {
582 2 : gfc_error ("COMMON block %</%s/%> not found at %L", n, &cur_loc);
583 2 : goto cleanup;
584 : }
585 724 : for (sym = st->n.common->head; sym; sym = sym->common_next)
586 : {
587 501 : gfc_set_sym_referenced (sym);
588 501 : p = gfc_get_omp_namelist ();
589 501 : if (head == NULL)
590 : head = tail = p;
591 325 : else if (reverse_order)
592 : {
593 0 : p->next = head;
594 0 : head = p;
595 : }
596 : else
597 : {
598 325 : tail->next = p;
599 325 : tail = tail->next;
600 : }
601 501 : p->sym = sym;
602 501 : p->where = cur_loc;
603 : }
604 :
605 223 : next_item:
606 38438 : if (end_colon && gfc_match_char (':') == MATCH_YES)
607 : {
608 793 : *end_colon = true;
609 793 : break;
610 : }
611 37645 : if (gfc_match_char (')') == MATCH_YES)
612 : break;
613 10234 : if (gfc_match_char (',') != MATCH_YES)
614 20 : goto syntax;
615 : }
616 :
617 38242 : while (*list)
618 10038 : list = &(*list)->next;
619 :
620 28204 : *list = head;
621 28204 : if (headp)
622 22311 : *headp = list;
623 : return MATCH_YES;
624 :
625 51 : syntax:
626 51 : gfc_error ("Syntax error in OpenMP variable list at %C");
627 :
628 67 : cleanup:
629 67 : gfc_free_omp_namelist (head, OMP_LIST_NONE);
630 67 : gfc_current_locus = old_loc;
631 67 : return MATCH_ERROR;
632 : }
633 :
634 : /* Match a variable/procedure/common block list and construct a namelist
635 : from it. */
636 :
637 : static match
638 363 : gfc_match_omp_to_link (const char *str, gfc_omp_namelist **list)
639 : {
640 363 : gfc_omp_namelist *head, *tail, *p;
641 363 : locus old_loc, cur_loc;
642 363 : char n[GFC_MAX_SYMBOL_LEN+1];
643 363 : gfc_symbol *sym;
644 363 : match m;
645 363 : gfc_symtree *st;
646 :
647 363 : head = tail = NULL;
648 :
649 363 : old_loc = gfc_current_locus;
650 :
651 363 : m = gfc_match (str);
652 363 : if (m != MATCH_YES)
653 : return m;
654 :
655 549 : for (;;)
656 : {
657 549 : cur_loc = gfc_current_locus;
658 549 : m = gfc_match_symbol (&sym, 1);
659 549 : switch (m)
660 : {
661 508 : case MATCH_YES:
662 508 : p = gfc_get_omp_namelist ();
663 508 : if (head == NULL)
664 : head = tail = p;
665 : else
666 : {
667 194 : tail->next = p;
668 194 : tail = tail->next;
669 : }
670 508 : tail->sym = sym;
671 508 : tail->where = cur_loc;
672 508 : goto next_item;
673 : case MATCH_NO:
674 : break;
675 0 : case MATCH_ERROR:
676 0 : goto cleanup;
677 : }
678 :
679 41 : m = gfc_match (" / %n /", n);
680 41 : if (m == MATCH_ERROR)
681 0 : goto cleanup;
682 41 : if (m == MATCH_NO)
683 0 : goto syntax;
684 :
685 41 : st = gfc_find_symtree (gfc_current_ns->common_root, n);
686 41 : if (st == NULL)
687 : {
688 0 : gfc_error ("COMMON block /%s/ not found at %C", n);
689 0 : goto cleanup;
690 : }
691 41 : p = gfc_get_omp_namelist ();
692 41 : if (head == NULL)
693 : head = tail = p;
694 : else
695 : {
696 4 : tail->next = p;
697 4 : tail = tail->next;
698 : }
699 41 : tail->u.common = st->n.common;
700 41 : tail->where = cur_loc;
701 :
702 549 : next_item:
703 549 : if (gfc_match_char (')') == MATCH_YES)
704 : break;
705 198 : if (gfc_match_char (',') != MATCH_YES)
706 0 : goto syntax;
707 : }
708 :
709 362 : while (*list)
710 11 : list = &(*list)->next;
711 :
712 351 : *list = head;
713 351 : return MATCH_YES;
714 :
715 0 : syntax:
716 0 : gfc_error ("Syntax error in OpenMP variable list at %C");
717 :
718 0 : cleanup:
719 0 : gfc_free_omp_namelist (head, OMP_LIST_NONE);
720 0 : gfc_current_locus = old_loc;
721 0 : return MATCH_ERROR;
722 : }
723 :
724 : /* Match detach(event-handle). */
725 :
726 : static match
727 126 : gfc_match_omp_detach (gfc_expr **expr)
728 : {
729 126 : locus old_loc = gfc_current_locus;
730 :
731 126 : if (gfc_match ("detach ( ") != MATCH_YES)
732 0 : goto syntax_error;
733 :
734 126 : if (gfc_match_variable (expr, 0) != MATCH_YES)
735 0 : goto syntax_error;
736 :
737 126 : if (gfc_match_char (')') != MATCH_YES)
738 0 : goto syntax_error;
739 :
740 : return MATCH_YES;
741 :
742 0 : syntax_error:
743 0 : gfc_error ("Syntax error in OpenMP detach clause at %C");
744 0 : gfc_current_locus = old_loc;
745 0 : return MATCH_ERROR;
746 :
747 : }
748 :
749 : /* Match doacross(sink : ...) construct a namelist from it;
750 : if depend is true, match legacy 'depend(sink : ...)'. */
751 :
752 : static match
753 241 : gfc_match_omp_doacross_sink (gfc_omp_namelist **list, bool depend)
754 : {
755 241 : char n[GFC_MAX_SYMBOL_LEN+1];
756 241 : gfc_omp_namelist *head, *tail, *p;
757 241 : locus old_loc, cur_loc;
758 241 : gfc_symbol *sym;
759 :
760 241 : head = tail = NULL;
761 :
762 241 : old_loc = gfc_current_locus;
763 :
764 2231 : for (;;)
765 : {
766 1236 : gfc_gobble_whitespace ();
767 1236 : cur_loc = gfc_current_locus;
768 :
769 1236 : if (gfc_match_name (n) != MATCH_YES)
770 1 : goto syntax;
771 1235 : locus loc = gfc_get_location_range (NULL, 0, &cur_loc, 1,
772 : &gfc_current_locus);
773 1235 : if (UNLIKELY (strcmp (n, "omp_all_memory") == 0))
774 : {
775 1 : gfc_error ("%<omp_all_memory%> used with dependence-type "
776 : "other than OUT or INOUT at %L", &loc);
777 1 : goto cleanup;
778 : }
779 1234 : sym = NULL;
780 1234 : if (!(strcmp (n, "omp_cur_iteration") == 0))
781 : {
782 1229 : gfc_symtree *st;
783 1229 : if (gfc_get_ha_sym_tree (n, &st))
784 0 : goto syntax;
785 1229 : sym = st->n.sym;
786 1229 : gfc_set_sym_referenced (sym);
787 : }
788 1234 : p = gfc_get_omp_namelist ();
789 1234 : if (head == NULL)
790 : {
791 239 : head = tail = p;
792 253 : head->u.depend_doacross_op = (depend ? OMP_DEPEND_SINK_FIRST
793 : : OMP_DOACROSS_SINK_FIRST);
794 : }
795 : else
796 : {
797 995 : tail->next = p;
798 995 : tail = tail->next;
799 995 : tail->u.depend_doacross_op = OMP_DOACROSS_SINK;
800 : }
801 1234 : tail->sym = sym;
802 1234 : tail->expr = NULL;
803 1234 : tail->where = loc;
804 1234 : if (gfc_match_char ('+') == MATCH_YES)
805 : {
806 154 : if (gfc_match_literal_constant (&tail->expr, 0) != MATCH_YES)
807 0 : goto syntax;
808 : }
809 1080 : else if (gfc_match_char ('-') == MATCH_YES)
810 : {
811 418 : if (gfc_match_literal_constant (&tail->expr, 0) != MATCH_YES)
812 1 : goto syntax;
813 417 : tail->expr = gfc_uminus (tail->expr);
814 : }
815 1233 : if (gfc_match_char (')') == MATCH_YES)
816 : break;
817 995 : if (gfc_match_char (',') != MATCH_YES)
818 0 : goto syntax;
819 995 : }
820 :
821 1030 : while (*list)
822 792 : list = &(*list)->next;
823 :
824 238 : *list = head;
825 238 : return MATCH_YES;
826 :
827 2 : syntax:
828 2 : gfc_error ("Syntax error in OpenMP SINK dependence-type list at %C");
829 :
830 3 : cleanup:
831 3 : gfc_free_omp_namelist (head, OMP_LIST_DEPEND);
832 3 : gfc_current_locus = old_loc;
833 3 : return MATCH_ERROR;
834 : }
835 :
836 : static match
837 818 : match_omp_oacc_expr_list (const char *str, gfc_expr_list **list,
838 : bool allow_asterisk, bool is_omp)
839 : {
840 818 : gfc_expr_list *head, *tail, *p;
841 818 : locus old_loc;
842 818 : gfc_expr *expr;
843 818 : match m;
844 :
845 818 : head = tail = NULL;
846 :
847 818 : old_loc = gfc_current_locus;
848 :
849 818 : m = gfc_match (str);
850 818 : if (m != MATCH_YES)
851 : return m;
852 :
853 1030 : for (;;)
854 : {
855 1030 : m = gfc_match_expr (&expr);
856 1030 : if (m == MATCH_YES || allow_asterisk)
857 : {
858 1018 : p = gfc_get_expr_list ();
859 1018 : if (head == NULL)
860 : head = tail = p;
861 : else
862 : {
863 335 : tail->next = p;
864 335 : tail = tail->next;
865 : }
866 1018 : if (m == MATCH_YES)
867 885 : tail->expr = expr;
868 133 : else if (gfc_match (" *") != MATCH_YES)
869 18 : goto syntax;
870 1000 : goto next_item;
871 : }
872 12 : if (m == MATCH_ERROR)
873 0 : goto cleanup;
874 12 : goto syntax;
875 :
876 1000 : next_item:
877 1000 : if (gfc_match_char (')') == MATCH_YES)
878 : break;
879 346 : if (gfc_match_char (',') != MATCH_YES)
880 6 : goto syntax;
881 : }
882 :
883 660 : while (*list)
884 6 : list = &(*list)->next;
885 :
886 654 : *list = head;
887 654 : return MATCH_YES;
888 :
889 36 : syntax:
890 36 : if (is_omp)
891 7 : gfc_error ("Syntax error in OpenMP expression list at %C");
892 : else
893 29 : gfc_error ("Syntax error in OpenACC expression list at %C");
894 :
895 36 : cleanup:
896 36 : gfc_free_expr_list (head);
897 36 : gfc_current_locus = old_loc;
898 36 : return MATCH_ERROR;
899 : }
900 :
901 : static match
902 3056 : match_oacc_clause_gwv (gfc_omp_clauses *cp, unsigned gwv)
903 : {
904 3056 : match ret = MATCH_YES;
905 :
906 3056 : if (gfc_match (" ( ") != MATCH_YES)
907 : return MATCH_NO;
908 :
909 470 : if (gwv == GOMP_DIM_GANG)
910 : {
911 : /* The gang clause accepts two optional arguments, num and static.
912 : The num argument may either be explicit (num: <val>) or
913 : implicit without (<val> without num:). */
914 :
915 457 : while (ret == MATCH_YES)
916 : {
917 236 : if (gfc_match (" static :") == MATCH_YES)
918 : {
919 114 : if (cp->gang_static)
920 : return MATCH_ERROR;
921 : else
922 113 : cp->gang_static = true;
923 113 : if (gfc_match_char ('*') == MATCH_YES)
924 18 : cp->gang_static_expr = NULL;
925 95 : else if (gfc_match (" %e ", &cp->gang_static_expr) != MATCH_YES)
926 : return MATCH_ERROR;
927 : }
928 : else
929 : {
930 122 : if (cp->gang_num_expr)
931 : return MATCH_ERROR;
932 :
933 : /* The 'num' argument is optional. */
934 121 : gfc_match (" num :");
935 :
936 121 : if (gfc_match (" %e ", &cp->gang_num_expr) != MATCH_YES)
937 : return MATCH_ERROR;
938 : }
939 :
940 231 : ret = gfc_match (" , ");
941 : }
942 : }
943 244 : else if (gwv == GOMP_DIM_WORKER)
944 : {
945 : /* The 'num' argument is optional. */
946 107 : gfc_match (" num :");
947 :
948 107 : if (gfc_match (" %e ", &cp->worker_expr) != MATCH_YES)
949 : return MATCH_ERROR;
950 : }
951 137 : else if (gwv == GOMP_DIM_VECTOR)
952 : {
953 : /* The 'length' argument is optional. */
954 137 : gfc_match (" length :");
955 :
956 137 : if (gfc_match (" %e ", &cp->vector_expr) != MATCH_YES)
957 : return MATCH_ERROR;
958 : }
959 : else
960 0 : gfc_fatal_error ("Unexpected OpenACC parallelism.");
961 :
962 459 : return gfc_match (" )");
963 : }
964 :
965 : static match
966 8 : gfc_match_oacc_clause_link (const char *str, gfc_omp_namelist **list)
967 : {
968 8 : gfc_omp_namelist *head = NULL;
969 8 : gfc_omp_namelist *tail, *p;
970 8 : locus old_loc;
971 8 : char n[GFC_MAX_SYMBOL_LEN+1];
972 8 : gfc_symbol *sym;
973 8 : match m;
974 8 : gfc_symtree *st;
975 :
976 8 : old_loc = gfc_current_locus;
977 :
978 8 : m = gfc_match (str);
979 8 : if (m != MATCH_YES)
980 : return m;
981 :
982 8 : m = gfc_match (" (");
983 :
984 14 : for (;;)
985 : {
986 14 : m = gfc_match_symbol (&sym, 0);
987 14 : switch (m)
988 : {
989 8 : case MATCH_YES:
990 8 : if (sym->attr.in_common)
991 : {
992 2 : gfc_error_now ("Variable at %C is an element of a COMMON block");
993 2 : goto cleanup;
994 : }
995 6 : gfc_set_sym_referenced (sym);
996 6 : p = gfc_get_omp_namelist ();
997 6 : if (head == NULL)
998 : head = tail = p;
999 : else
1000 : {
1001 4 : tail->next = p;
1002 4 : tail = tail->next;
1003 : }
1004 6 : tail->sym = sym;
1005 6 : tail->expr = NULL;
1006 6 : tail->where = gfc_current_locus;
1007 6 : goto next_item;
1008 : case MATCH_NO:
1009 : break;
1010 :
1011 0 : case MATCH_ERROR:
1012 0 : goto cleanup;
1013 : }
1014 :
1015 6 : m = gfc_match (" / %n /", n);
1016 6 : if (m == MATCH_ERROR)
1017 0 : goto cleanup;
1018 6 : if (m == MATCH_NO || n[0] == '\0')
1019 0 : goto syntax;
1020 :
1021 6 : st = gfc_find_symtree (gfc_current_ns->common_root, n);
1022 6 : if (st == NULL)
1023 : {
1024 1 : gfc_error ("COMMON block /%s/ not found at %C", n);
1025 1 : goto cleanup;
1026 : }
1027 :
1028 20 : for (sym = st->n.common->head; sym; sym = sym->common_next)
1029 : {
1030 15 : gfc_set_sym_referenced (sym);
1031 15 : p = gfc_get_omp_namelist ();
1032 15 : if (head == NULL)
1033 : head = tail = p;
1034 : else
1035 : {
1036 12 : tail->next = p;
1037 12 : tail = tail->next;
1038 : }
1039 15 : tail->sym = sym;
1040 15 : tail->where = gfc_current_locus;
1041 : }
1042 :
1043 5 : next_item:
1044 11 : if (gfc_match_char (')') == MATCH_YES)
1045 : break;
1046 6 : if (gfc_match_char (',') != MATCH_YES)
1047 0 : goto syntax;
1048 : }
1049 :
1050 5 : if (gfc_match_omp_eos () != MATCH_YES)
1051 : {
1052 1 : gfc_error ("Unexpected junk after !$ACC DECLARE at %C");
1053 1 : goto cleanup;
1054 : }
1055 :
1056 4 : while (*list)
1057 0 : list = &(*list)->next;
1058 4 : *list = head;
1059 4 : return MATCH_YES;
1060 :
1061 0 : syntax:
1062 0 : gfc_error ("Syntax error in !$ACC DECLARE list at %C");
1063 :
1064 4 : cleanup:
1065 4 : gfc_current_locus = old_loc;
1066 4 : return MATCH_ERROR;
1067 : }
1068 :
1069 : /* OpenMP clauses. */
1070 : enum omp_mask1
1071 : {
1072 : OMP_CLAUSE_PRIVATE,
1073 : OMP_CLAUSE_FIRSTPRIVATE,
1074 : OMP_CLAUSE_LASTPRIVATE,
1075 : OMP_CLAUSE_COPYPRIVATE,
1076 : OMP_CLAUSE_SHARED,
1077 : OMP_CLAUSE_COPYIN,
1078 : OMP_CLAUSE_REDUCTION,
1079 : OMP_CLAUSE_IN_REDUCTION,
1080 : OMP_CLAUSE_TASK_REDUCTION,
1081 : OMP_CLAUSE_IF,
1082 : OMP_CLAUSE_NUM_THREADS,
1083 : OMP_CLAUSE_SCHEDULE,
1084 : OMP_CLAUSE_DEFAULT,
1085 : OMP_CLAUSE_ORDER,
1086 : OMP_CLAUSE_ORDERED,
1087 : OMP_CLAUSE_COLLAPSE,
1088 : OMP_CLAUSE_UNTIED,
1089 : OMP_CLAUSE_FINAL,
1090 : OMP_CLAUSE_MERGEABLE,
1091 : OMP_CLAUSE_ALIGNED,
1092 : OMP_CLAUSE_DEPEND,
1093 : OMP_CLAUSE_INBRANCH,
1094 : OMP_CLAUSE_LINEAR,
1095 : OMP_CLAUSE_NOTINBRANCH,
1096 : OMP_CLAUSE_PROC_BIND,
1097 : OMP_CLAUSE_SAFELEN,
1098 : OMP_CLAUSE_SIMDLEN,
1099 : OMP_CLAUSE_UNIFORM,
1100 : OMP_CLAUSE_DEVICE,
1101 : OMP_CLAUSE_MAP,
1102 : OMP_CLAUSE_TO,
1103 : OMP_CLAUSE_FROM,
1104 : OMP_CLAUSE_NUM_TEAMS,
1105 : OMP_CLAUSE_THREAD_LIMIT,
1106 : OMP_CLAUSE_DIST_SCHEDULE,
1107 : OMP_CLAUSE_DEFAULTMAP,
1108 : OMP_CLAUSE_GRAINSIZE,
1109 : OMP_CLAUSE_HINT,
1110 : OMP_CLAUSE_IS_DEVICE_PTR,
1111 : OMP_CLAUSE_LINK,
1112 : OMP_CLAUSE_NOGROUP,
1113 : OMP_CLAUSE_NOTEMPORAL,
1114 : OMP_CLAUSE_NUM_TASKS,
1115 : OMP_CLAUSE_PRIORITY,
1116 : OMP_CLAUSE_SIMD,
1117 : OMP_CLAUSE_THREADS,
1118 : OMP_CLAUSE_USE_DEVICE_PTR,
1119 : OMP_CLAUSE_USE_DEVICE_ADDR, /* OpenMP 5.0. */
1120 : OMP_CLAUSE_DEVICE_TYPE, /* OpenMP 5.0. */
1121 : OMP_CLAUSE_ATOMIC, /* OpenMP 5.0. */
1122 : OMP_CLAUSE_CAPTURE, /* OpenMP 5.0. */
1123 : OMP_CLAUSE_MEMORDER, /* OpenMP 5.0. */
1124 : OMP_CLAUSE_DETACH, /* OpenMP 5.0. */
1125 : OMP_CLAUSE_AFFINITY, /* OpenMP 5.0. */
1126 : OMP_CLAUSE_ALLOCATE, /* OpenMP 5.0. */
1127 : OMP_CLAUSE_BIND, /* OpenMP 5.0. */
1128 : OMP_CLAUSE_FILTER, /* OpenMP 5.1. */
1129 : OMP_CLAUSE_AT, /* OpenMP 5.1. */
1130 : OMP_CLAUSE_MESSAGE, /* OpenMP 5.1. */
1131 : OMP_CLAUSE_SEVERITY, /* OpenMP 5.1. */
1132 : OMP_CLAUSE_COMPARE, /* OpenMP 5.1. */
1133 : OMP_CLAUSE_FAIL, /* OpenMP 5.1. */
1134 : OMP_CLAUSE_WEAK, /* OpenMP 5.1. */
1135 : OMP_CLAUSE_NOWAIT,
1136 : /* This must come last. */
1137 : OMP_MASK1_LAST
1138 : };
1139 :
1140 : /* More OpenMP clauses and OpenACC 2.0+ specific clauses. */
1141 : enum omp_mask2
1142 : {
1143 : OMP_CLAUSE_ASYNC,
1144 : OMP_CLAUSE_NUM_GANGS,
1145 : OMP_CLAUSE_NUM_WORKERS,
1146 : OMP_CLAUSE_VECTOR_LENGTH,
1147 : OMP_CLAUSE_COPY,
1148 : OMP_CLAUSE_COPYOUT,
1149 : OMP_CLAUSE_CREATE,
1150 : OMP_CLAUSE_NO_CREATE,
1151 : OMP_CLAUSE_PRESENT,
1152 : OMP_CLAUSE_DEVICEPTR,
1153 : OMP_CLAUSE_GANG,
1154 : OMP_CLAUSE_WORKER,
1155 : OMP_CLAUSE_VECTOR,
1156 : OMP_CLAUSE_SEQ,
1157 : OMP_CLAUSE_INDEPENDENT,
1158 : OMP_CLAUSE_USE_DEVICE,
1159 : OMP_CLAUSE_DEVICE_RESIDENT,
1160 : OMP_CLAUSE_SELF,
1161 : OMP_CLAUSE_HOST,
1162 : OMP_CLAUSE_WAIT,
1163 : OMP_CLAUSE_DELETE,
1164 : OMP_CLAUSE_AUTO,
1165 : OMP_CLAUSE_TILE,
1166 : OMP_CLAUSE_IF_PRESENT,
1167 : OMP_CLAUSE_FINALIZE,
1168 : OMP_CLAUSE_ATTACH,
1169 : OMP_CLAUSE_NOHOST,
1170 : OMP_CLAUSE_HAS_DEVICE_ADDR, /* OpenMP 5.1 */
1171 : OMP_CLAUSE_ENTER, /* OpenMP 5.2 */
1172 : OMP_CLAUSE_DOACROSS, /* OpenMP 5.2 */
1173 : OMP_CLAUSE_ASSUMPTIONS, /* OpenMP 5.1. */
1174 : OMP_CLAUSE_USES_ALLOCATORS, /* OpenMP 5.0 */
1175 : OMP_CLAUSE_INDIRECT, /* OpenMP 5.1 */
1176 : OMP_CLAUSE_FULL, /* OpenMP 5.1. */
1177 : OMP_CLAUSE_PARTIAL, /* OpenMP 5.1. */
1178 : OMP_CLAUSE_SIZES, /* OpenMP 5.1. */
1179 : OMP_CLAUSE_INIT, /* OpenMP 5.1. */
1180 : OMP_CLAUSE_DESTROY, /* OpenMP 5.1. */
1181 : OMP_CLAUSE_USE, /* OpenMP 5.1. */
1182 : OMP_CLAUSE_NOVARIANTS, /* OpenMP 5.1 */
1183 : OMP_CLAUSE_NOCONTEXT, /* OpenMP 5.1 */
1184 : OMP_CLAUSE_INTEROP, /* OpenMP 5.1 */
1185 : OMP_CLAUSE_LOCAL, /* OpenMP 6.0 */
1186 : OMP_CLAUSE_DYN_GROUPPRIVATE, /* OpenMP 6.1 */
1187 : /* This must come last. */
1188 : OMP_MASK2_LAST
1189 : };
1190 :
1191 : struct omp_inv_mask;
1192 :
1193 : /* Customized bitset for up to 128-bits.
1194 : The two enums above provide bit numbers to use, and which of the
1195 : two enums it is determines which of the two mask fields is used.
1196 : Supported operations are defining a mask, like:
1197 : #define XXX_CLAUSES \
1198 : (omp_mask (OMP_CLAUSE_XXX) | OMP_CLAUSE_YYY | OMP_CLAUSE_ZZZ)
1199 : oring such bitsets together or removing selected bits:
1200 : (XXX_CLAUSES | YYY_CLAUSES) & ~(omp_mask (OMP_CLAUSE_VVV))
1201 : and testing individual bits:
1202 : if (mask & OMP_CLAUSE_UUU) */
1203 :
1204 : struct omp_mask {
1205 : const uint64_t mask1;
1206 : const uint64_t mask2;
1207 : inline omp_mask ();
1208 : inline omp_mask (omp_mask1);
1209 : inline omp_mask (omp_mask2);
1210 : inline omp_mask (uint64_t, uint64_t);
1211 : inline omp_mask operator| (omp_mask1) const;
1212 : inline omp_mask operator| (omp_mask2) const;
1213 : inline omp_mask operator| (omp_mask) const;
1214 : inline omp_mask operator& (const omp_inv_mask &) const;
1215 : inline bool operator& (omp_mask1) const;
1216 : inline bool operator& (omp_mask2) const;
1217 : inline omp_inv_mask operator~ () const;
1218 : };
1219 :
1220 : struct omp_inv_mask : public omp_mask {
1221 : inline omp_inv_mask (const omp_mask &);
1222 : };
1223 :
1224 : omp_mask::omp_mask () : mask1 (0), mask2 (0)
1225 : {
1226 : }
1227 :
1228 32320 : omp_mask::omp_mask (omp_mask1 m) : mask1 (((uint64_t) 1) << m), mask2 (0)
1229 : {
1230 : }
1231 :
1232 2205 : omp_mask::omp_mask (omp_mask2 m) : mask1 (0), mask2 (((uint64_t) 1) << m)
1233 : {
1234 : }
1235 :
1236 33203 : omp_mask::omp_mask (uint64_t m1, uint64_t m2) : mask1 (m1), mask2 (m2)
1237 : {
1238 : }
1239 :
1240 : omp_mask
1241 32252 : omp_mask::operator| (omp_mask1 m) const
1242 : {
1243 32252 : return omp_mask (mask1 | (((uint64_t) 1) << m), mask2);
1244 : }
1245 :
1246 : omp_mask
1247 16837 : omp_mask::operator| (omp_mask2 m) const
1248 : {
1249 16837 : return omp_mask (mask1, mask2 | (((uint64_t) 1) << m));
1250 : }
1251 :
1252 : omp_mask
1253 4360 : omp_mask::operator| (omp_mask m) const
1254 : {
1255 4360 : return omp_mask (mask1 | m.mask1, mask2 | m.mask2);
1256 : }
1257 :
1258 : omp_mask
1259 2021 : omp_mask::operator& (const omp_inv_mask &m) const
1260 : {
1261 2021 : return omp_mask (mask1 & ~m.mask1, mask2 & ~m.mask2);
1262 : }
1263 :
1264 : bool
1265 125743 : omp_mask::operator& (omp_mask1 m) const
1266 : {
1267 125743 : return (mask1 & (((uint64_t) 1) << m)) != 0;
1268 : }
1269 :
1270 : bool
1271 88317 : omp_mask::operator& (omp_mask2 m) const
1272 : {
1273 88317 : return (mask2 & (((uint64_t) 1) << m)) != 0;
1274 : }
1275 :
1276 : omp_inv_mask
1277 2021 : omp_mask::operator~ () const
1278 : {
1279 2021 : return omp_inv_mask (*this);
1280 : }
1281 :
1282 2021 : omp_inv_mask::omp_inv_mask (const omp_mask &m) : omp_mask (m)
1283 : {
1284 : }
1285 :
1286 : /* Helper function for OpenACC and OpenMP clauses involving memory
1287 : mapping. */
1288 :
1289 : static bool
1290 5544 : gfc_match_omp_map_clause (gfc_omp_namelist **list, gfc_omp_map_op map_op,
1291 : bool allow_common, bool allow_derived)
1292 : {
1293 5544 : gfc_omp_namelist **head = NULL;
1294 5544 : if (gfc_match_omp_variable_list ("", list, allow_common, NULL, &head, true,
1295 : allow_derived)
1296 : == MATCH_YES)
1297 : {
1298 5535 : gfc_omp_namelist *n;
1299 13409 : for (n = *head; n; n = n->next)
1300 7874 : n->u.map.op = map_op;
1301 : return true;
1302 : }
1303 :
1304 : return false;
1305 : }
1306 :
1307 : static match
1308 8726 : gfc_match_iterator (gfc_namespace **ns, bool permit_var)
1309 : {
1310 8726 : locus old_loc = gfc_current_locus;
1311 :
1312 8726 : if (gfc_match ("iterator ( ") != MATCH_YES)
1313 : return MATCH_NO;
1314 :
1315 142 : gfc_typespec ts;
1316 142 : gfc_symbol *last = NULL;
1317 142 : gfc_expr *begin, *end, *step;
1318 142 : *ns = gfc_build_block_ns (gfc_current_ns);
1319 161 : char name[GFC_MAX_SYMBOL_LEN + 1];
1320 180 : while (true)
1321 : {
1322 161 : locus prev_loc = gfc_current_locus;
1323 161 : if (gfc_match_type_spec (&ts) == MATCH_YES
1324 161 : && gfc_match (" :: ") == MATCH_YES)
1325 : {
1326 5 : if (ts.type != BT_INTEGER)
1327 : {
1328 2 : gfc_error ("Expected INTEGER type at %L", &prev_loc);
1329 5 : return MATCH_ERROR;
1330 : }
1331 : permit_var = false;
1332 : }
1333 : else
1334 : {
1335 156 : ts.type = BT_INTEGER;
1336 156 : ts.kind = gfc_default_integer_kind;
1337 156 : gfc_current_locus = prev_loc;
1338 : }
1339 159 : prev_loc = gfc_current_locus;
1340 159 : if (gfc_match_name (name) != MATCH_YES)
1341 : {
1342 4 : gfc_error ("Expected identifier at %C");
1343 4 : goto failed;
1344 : }
1345 155 : if (gfc_find_symtree ((*ns)->sym_root, name))
1346 : {
1347 2 : gfc_error ("Same identifier %qs specified again at %C", name);
1348 2 : goto failed;
1349 : }
1350 :
1351 153 : gfc_symbol *sym = gfc_new_symbol (name, *ns);
1352 153 : if (last)
1353 17 : last->tlink = sym;
1354 : else
1355 136 : (*ns)->omp_affinity_iterators = sym;
1356 153 : last = sym;
1357 153 : sym->declared_at = prev_loc;
1358 153 : sym->ts = ts;
1359 153 : sym->attr.flavor = FL_VARIABLE;
1360 153 : sym->attr.artificial = 1;
1361 153 : sym->attr.referenced = 1;
1362 153 : sym->refs++;
1363 153 : gfc_symtree *st = gfc_new_symtree (&(*ns)->sym_root, name);
1364 153 : st->n.sym = sym;
1365 :
1366 153 : prev_loc = gfc_current_locus;
1367 153 : if (gfc_match (" = ") != MATCH_YES)
1368 3 : goto failed;
1369 150 : permit_var = false;
1370 150 : begin = end = step = NULL;
1371 150 : if (gfc_match ("%e : ", &begin) != MATCH_YES
1372 150 : || gfc_match ("%e ", &end) != MATCH_YES)
1373 : {
1374 3 : gfc_error ("Expected range-specification at %C");
1375 3 : gfc_free_expr (begin);
1376 3 : gfc_free_expr (end);
1377 3 : return MATCH_ERROR;
1378 : }
1379 147 : if (':' == gfc_peek_ascii_char ())
1380 : {
1381 23 : if (gfc_match (": %e ", &step) != MATCH_YES)
1382 : {
1383 5 : gfc_free_expr (begin);
1384 5 : gfc_free_expr (end);
1385 5 : gfc_free_expr (step);
1386 5 : goto failed;
1387 : }
1388 : }
1389 :
1390 142 : gfc_expr *e = gfc_get_expr ();
1391 142 : e->where = prev_loc;
1392 142 : e->expr_type = EXPR_ARRAY;
1393 142 : e->ts = ts;
1394 142 : e->rank = 1;
1395 142 : e->shape = gfc_get_shape (1);
1396 266 : mpz_init_set_ui (e->shape[0], step ? 3 : 2);
1397 142 : gfc_constructor_append_expr (&e->value.constructor, begin, &begin->where);
1398 142 : gfc_constructor_append_expr (&e->value.constructor, end, &end->where);
1399 142 : if (step)
1400 18 : gfc_constructor_append_expr (&e->value.constructor, step, &step->where);
1401 142 : sym->value = e;
1402 :
1403 142 : if (gfc_match (") ") == MATCH_YES)
1404 : break;
1405 19 : if (gfc_match (", ") != MATCH_YES)
1406 0 : goto failed;
1407 19 : }
1408 123 : return MATCH_YES;
1409 :
1410 14 : failed:
1411 14 : gfc_namespace *prev_ns = NULL;
1412 14 : for (gfc_namespace *it = gfc_current_ns->contained; it; it = it->sibling)
1413 : {
1414 0 : if (it == *ns)
1415 : {
1416 0 : if (prev_ns)
1417 0 : prev_ns->sibling = it->sibling;
1418 : else
1419 0 : gfc_current_ns->contained = it->sibling;
1420 0 : gfc_free_namespace (it);
1421 0 : break;
1422 : }
1423 0 : prev_ns = it;
1424 : }
1425 14 : *ns = NULL;
1426 14 : if (!permit_var)
1427 : return MATCH_ERROR;
1428 4 : gfc_current_locus = old_loc;
1429 4 : return MATCH_NO;
1430 : }
1431 :
1432 : /* Match target update's to/from( [present:] var-list). */
1433 :
1434 : static match
1435 1735 : gfc_match_motion_var_list (const char *str, gfc_omp_namelist **list,
1436 : gfc_omp_namelist ***headp)
1437 : {
1438 1735 : match m = gfc_match (str);
1439 1735 : if (m != MATCH_YES)
1440 : return m;
1441 :
1442 1735 : gfc_namespace *ns_iter = NULL, *ns_curr = gfc_current_ns;
1443 1735 : locus old_loc = gfc_current_locus;
1444 1735 : int present_modifier = 0;
1445 1735 : int iterator_modifier = 0;
1446 1735 : locus second_present_locus = old_loc;
1447 1735 : locus second_iterator_locus = old_loc;
1448 1735 : bool saw_modifier = false;
1449 :
1450 1747 : for (;;)
1451 : {
1452 1741 : locus current_locus = gfc_current_locus;
1453 1741 : if (gfc_match ("present ") == MATCH_YES)
1454 : {
1455 8 : if (present_modifier++ == 1)
1456 0 : second_present_locus = current_locus;
1457 : }
1458 1733 : else if (gfc_match_iterator (&ns_iter, true) == MATCH_YES)
1459 : {
1460 20 : if (iterator_modifier++ == 1)
1461 1 : second_iterator_locus = current_locus;
1462 : }
1463 1713 : else if (!saw_modifier)
1464 : break;
1465 : else
1466 : {
1467 2 : gfc_error ("Expected clause modifier at %C");
1468 4 : return MATCH_ERROR;
1469 : }
1470 :
1471 : /* OpenMP 5.1 syntax mistakenly allowed commas to be optional
1472 : between and after modifiers in a clause. This was corrected
1473 : in 5.2 and later specifications: they're now required between
1474 : modifiers and a trailing comma is not permitted. We implement
1475 : the 5.2 syntax here. */
1476 28 : saw_modifier = true;
1477 28 : if (gfc_match (" : ") == MATCH_YES)
1478 : break;
1479 8 : else if (gfc_match (", ") == MATCH_YES)
1480 6 : continue;
1481 : else
1482 : {
1483 2 : gfc_error ("Expected %<,%> or %<:%> after clause modifier at %C");
1484 2 : return MATCH_ERROR;
1485 : }
1486 : }
1487 :
1488 1731 : if (!saw_modifier)
1489 : {
1490 1711 : gfc_current_locus = old_loc;
1491 1711 : present_modifier = 0;
1492 1711 : iterator_modifier = 0;
1493 : }
1494 :
1495 1731 : if (present_modifier > 1)
1496 : {
1497 0 : gfc_error ("Too many %<present%> modifiers at %L", &second_present_locus);
1498 0 : return MATCH_ERROR;
1499 : }
1500 1731 : if (iterator_modifier > 1)
1501 : {
1502 1 : gfc_error ("Too many %<iterator%> modifiers at %L",
1503 : &second_iterator_locus);
1504 1 : return MATCH_ERROR;
1505 : }
1506 :
1507 1730 : if (ns_iter)
1508 14 : gfc_current_ns = ns_iter;
1509 :
1510 1730 : m = gfc_match_omp_variable_list ("", list, false, NULL, headp, true, true);
1511 1730 : gfc_current_ns = ns_curr;
1512 1730 : if (m != MATCH_YES)
1513 : return m;
1514 1729 : gfc_omp_namelist *n;
1515 3532 : for (n = **headp; n; n = n->next)
1516 : {
1517 1803 : if (present_modifier)
1518 6 : n->u.present_modifier = true;
1519 1803 : if (iterator_modifier)
1520 : {
1521 18 : n->u2.ns = ns_iter;
1522 18 : ns_iter->refs++;
1523 : }
1524 : }
1525 : return MATCH_YES;
1526 : }
1527 :
1528 : /* reduction ( reduction-modifier, reduction-operator : variable-list )
1529 : in_reduction ( reduction-operator : variable-list )
1530 : task_reduction ( reduction-operator : variable-list ) */
1531 :
1532 : static match
1533 4360 : gfc_match_omp_clause_reduction (char pc, gfc_omp_clauses *c, bool openacc,
1534 : bool allow_derived, bool openmp_target = false)
1535 : {
1536 4360 : if (pc == 'r' && gfc_match ("reduction ( ") != MATCH_YES)
1537 : return MATCH_NO;
1538 4360 : else if (pc == 'i' && gfc_match ("in_reduction ( ") != MATCH_YES)
1539 : return MATCH_NO;
1540 4248 : else if (pc == 't' && gfc_match ("task_reduction ( ") != MATCH_YES)
1541 : return MATCH_NO;
1542 :
1543 4248 : locus old_loc = gfc_current_locus;
1544 4248 : enum gfc_omp_list_type list_idx = OMP_LIST_NONE;
1545 :
1546 4248 : if (pc == 'r' && !openacc)
1547 : {
1548 2121 : if (gfc_match ("inscan") == MATCH_YES)
1549 : list_idx = OMP_LIST_REDUCTION_INSCAN;
1550 2051 : else if (gfc_match ("task") == MATCH_YES)
1551 : list_idx = OMP_LIST_REDUCTION_TASK;
1552 1946 : else if (gfc_match ("default") == MATCH_YES)
1553 : list_idx = OMP_LIST_REDUCTION;
1554 231 : if (list_idx != OMP_LIST_NONE && gfc_match (", ") != MATCH_YES)
1555 : {
1556 1 : gfc_error ("Comma expected at %C");
1557 1 : gfc_current_locus = old_loc;
1558 1 : return MATCH_NO;
1559 : }
1560 2120 : if (list_idx == OMP_LIST_NONE)
1561 3834 : list_idx = OMP_LIST_REDUCTION;
1562 : }
1563 2127 : else if (pc == 'i')
1564 : list_idx = OMP_LIST_IN_REDUCTION;
1565 2009 : else if (pc == 't')
1566 : list_idx = OMP_LIST_TASK_REDUCTION;
1567 : else
1568 3834 : list_idx = OMP_LIST_REDUCTION;
1569 :
1570 4247 : gfc_omp_reduction_op rop = OMP_REDUCTION_NONE;
1571 4247 : char buffer[GFC_MAX_SYMBOL_LEN + 3];
1572 4247 : if (gfc_match_char ('+') == MATCH_YES)
1573 : rop = OMP_REDUCTION_PLUS;
1574 2223 : else if (gfc_match_char ('*') == MATCH_YES)
1575 : rop = OMP_REDUCTION_TIMES;
1576 1991 : else if (gfc_match_char ('-') == MATCH_YES)
1577 : {
1578 171 : if (!openacc)
1579 16 : gfc_warning (OPT_Wdeprecated_openmp,
1580 : "%<-%> operator at %C for reductions deprecated in "
1581 : "OpenMP 5.2");
1582 : rop = OMP_REDUCTION_MINUS;
1583 : }
1584 1820 : else if (gfc_match (".and.") == MATCH_YES)
1585 : rop = OMP_REDUCTION_AND;
1586 1714 : else if (gfc_match (".or.") == MATCH_YES)
1587 : rop = OMP_REDUCTION_OR;
1588 929 : else if (gfc_match (".eqv.") == MATCH_YES)
1589 : rop = OMP_REDUCTION_EQV;
1590 831 : else if (gfc_match (".neqv.") == MATCH_YES)
1591 : rop = OMP_REDUCTION_NEQV;
1592 736 : if (rop != OMP_REDUCTION_NONE)
1593 3511 : snprintf (buffer, sizeof buffer, "operator %s",
1594 : gfc_op2string ((gfc_intrinsic_op) rop));
1595 736 : else if (gfc_match_defined_op_name (buffer + 1, 1) == MATCH_YES)
1596 : {
1597 38 : buffer[0] = '.';
1598 38 : strcat (buffer, ".");
1599 : }
1600 698 : else if (gfc_match_name (buffer) == MATCH_YES)
1601 : {
1602 697 : gfc_symbol *sym;
1603 697 : const char *n = buffer;
1604 :
1605 697 : gfc_find_symbol (buffer, NULL, 1, &sym);
1606 697 : if (sym != NULL)
1607 : {
1608 216 : if (sym->attr.intrinsic)
1609 139 : n = sym->name;
1610 77 : else if ((sym->attr.flavor != FL_UNKNOWN
1611 75 : && sym->attr.flavor != FL_PROCEDURE)
1612 75 : || sym->attr.external
1613 64 : || sym->attr.generic
1614 64 : || sym->attr.entry
1615 64 : || sym->attr.result
1616 64 : || sym->attr.dummy
1617 64 : || sym->attr.subroutine
1618 63 : || sym->attr.pointer
1619 63 : || sym->attr.target
1620 63 : || sym->attr.cray_pointer
1621 63 : || sym->attr.cray_pointee
1622 63 : || (sym->attr.proc != PROC_UNKNOWN
1623 1 : && sym->attr.proc != PROC_INTRINSIC)
1624 62 : || sym->attr.if_source != IFSRC_UNKNOWN
1625 62 : || sym == sym->ns->proc_name)
1626 : {
1627 : sym = NULL;
1628 : n = NULL;
1629 : }
1630 : else
1631 62 : n = sym->name;
1632 : }
1633 201 : if (n == NULL)
1634 : rop = OMP_REDUCTION_NONE;
1635 682 : else if (strcmp (n, "max") == 0)
1636 : rop = OMP_REDUCTION_MAX;
1637 517 : else if (strcmp (n, "min") == 0)
1638 : rop = OMP_REDUCTION_MIN;
1639 376 : else if (strcmp (n, "iand") == 0)
1640 : rop = OMP_REDUCTION_IAND;
1641 321 : else if (strcmp (n, "ior") == 0)
1642 : rop = OMP_REDUCTION_IOR;
1643 255 : else if (strcmp (n, "ieor") == 0)
1644 : rop = OMP_REDUCTION_IEOR;
1645 : if (rop != OMP_REDUCTION_NONE
1646 477 : && sym != NULL
1647 200 : && ! sym->attr.intrinsic
1648 61 : && ! sym->attr.use_assoc
1649 61 : && ((sym->attr.flavor == FL_UNKNOWN
1650 2 : && !gfc_add_flavor (&sym->attr, FL_PROCEDURE,
1651 : sym->name, NULL))
1652 61 : || !gfc_add_intrinsic (&sym->attr, NULL)))
1653 : rop = OMP_REDUCTION_NONE;
1654 : }
1655 : else
1656 1 : buffer[0] = '\0';
1657 4247 : gfc_omp_udr *udr = (buffer[0] ? gfc_find_omp_udr (gfc_current_ns, buffer, NULL)
1658 : : NULL);
1659 4247 : gfc_omp_namelist **head = NULL;
1660 4247 : if (rop == OMP_REDUCTION_NONE && udr)
1661 250 : rop = OMP_REDUCTION_USER;
1662 :
1663 4247 : if (gfc_match_omp_variable_list (" :", &c->lists[list_idx], false, NULL,
1664 : &head, openacc, allow_derived) != MATCH_YES)
1665 : {
1666 9 : gfc_current_locus = old_loc;
1667 9 : return MATCH_NO;
1668 : }
1669 4238 : gfc_omp_namelist *n;
1670 4238 : if (rop == OMP_REDUCTION_NONE)
1671 : {
1672 6 : n = *head;
1673 6 : *head = NULL;
1674 6 : gfc_error_now ("!$OMP DECLARE REDUCTION %s not found at %L",
1675 : buffer, &old_loc);
1676 6 : gfc_free_omp_namelist (n, OMP_LIST_NONE);
1677 : }
1678 : else
1679 9116 : for (n = *head; n; n = n->next)
1680 : {
1681 4884 : n->u.reduction_op = rop;
1682 4884 : if (udr)
1683 : {
1684 476 : n->u2.udr = gfc_get_omp_namelist_udr ();
1685 476 : n->u2.udr->udr = udr;
1686 : }
1687 4884 : if (openmp_target && list_idx == OMP_LIST_IN_REDUCTION)
1688 : {
1689 40 : gfc_omp_namelist *p = gfc_get_omp_namelist (), **tl;
1690 40 : p->sym = n->sym;
1691 40 : p->where = n->where;
1692 40 : p->u.map.op = OMP_MAP_ALWAYS_TOFROM;
1693 :
1694 40 : tl = &c->lists[OMP_LIST_MAP];
1695 52 : while (*tl)
1696 12 : tl = &((*tl)->next);
1697 40 : *tl = p;
1698 40 : p->next = NULL;
1699 : }
1700 : }
1701 : return MATCH_YES;
1702 : }
1703 :
1704 : static match
1705 40 : gfc_omp_absent_contains_clause (gfc_omp_assumptions **assume, bool is_absent)
1706 : {
1707 40 : if (*assume == NULL)
1708 15 : *assume = gfc_get_omp_assumptions ();
1709 62 : do
1710 : {
1711 51 : gfc_statement st = ST_NONE;
1712 51 : gfc_gobble_whitespace ();
1713 51 : locus old_loc = gfc_current_locus;
1714 51 : char c = gfc_peek_ascii_char ();
1715 51 : enum gfc_omp_directive_kind kind
1716 : = GFC_OMP_DIR_DECLARATIVE; /* Silence warning. */
1717 1585 : for (size_t i = 0; i < ARRAY_SIZE (gfc_omp_directives); i++)
1718 : {
1719 1585 : if (gfc_omp_directives[i].name[0] > c)
1720 : break;
1721 1534 : if (gfc_omp_directives[i].name[0] != c)
1722 1182 : continue;
1723 352 : if (gfc_match (gfc_omp_directives[i].name) == MATCH_YES)
1724 : {
1725 51 : st = gfc_omp_directives[i].st;
1726 51 : kind = gfc_omp_directives[i].kind;
1727 : }
1728 : }
1729 51 : gfc_gobble_whitespace ();
1730 51 : c = gfc_peek_ascii_char ();
1731 51 : if (st == ST_NONE || (c != ',' && c != ')'))
1732 : {
1733 0 : if (st == ST_NONE)
1734 0 : gfc_error ("Unknown directive at %L", &old_loc);
1735 : else
1736 0 : gfc_error ("Invalid combined or composite directive at %L",
1737 : &old_loc);
1738 4 : return MATCH_ERROR;
1739 : }
1740 51 : if (kind == GFC_OMP_DIR_DECLARATIVE
1741 51 : || kind == GFC_OMP_DIR_INFORMATIONAL
1742 : || kind == GFC_OMP_DIR_META)
1743 : {
1744 5 : gfc_error ("Invalid %qs directive at %L in %s clause: declarative, "
1745 : "informational, and meta directives not permitted",
1746 : gfc_ascii_statement (st, true), &old_loc,
1747 : is_absent ? "ABSENT" : "CONTAINS");
1748 4 : return MATCH_ERROR;
1749 : }
1750 47 : if (is_absent)
1751 : {
1752 : /* Use exponential allocation; equivalent to pow2p(x). */
1753 33 : int i = (*assume)->n_absent;
1754 33 : int size = ((i == 0) ? 4
1755 10 : : pow2p_hwi (i) == 1 ? i*2 : 0);
1756 8 : if (size != 0)
1757 31 : (*assume)->absent = XRESIZEVEC (gfc_statement,
1758 : (*assume)->absent, size);
1759 33 : (*assume)->absent[(*assume)->n_absent++] = st;
1760 : }
1761 : else
1762 : {
1763 14 : int i = (*assume)->n_contains;
1764 14 : int size = ((i == 0) ? 4
1765 4 : : pow2p_hwi (i) == 1 ? i*2 : 0);
1766 4 : if (size != 0)
1767 14 : (*assume)->contains = XRESIZEVEC (gfc_statement,
1768 : (*assume)->contains, size);
1769 14 : (*assume)->contains[(*assume)->n_contains++] = st;
1770 : }
1771 47 : gfc_gobble_whitespace ();
1772 47 : if (gfc_match(",") == MATCH_YES)
1773 11 : continue;
1774 36 : if (gfc_match(")") == MATCH_YES)
1775 : break;
1776 0 : gfc_error ("Expected %<,%> or %<)%> at %C");
1777 0 : return MATCH_ERROR;
1778 : }
1779 : while (true);
1780 :
1781 36 : return MATCH_YES;
1782 : }
1783 :
1784 : /* Check 'check' argument for duplicated statements in absent and/or contains
1785 : clauses. If 'merge', merge them from check to 'merge'. */
1786 :
1787 : static match
1788 43 : omp_verify_merge_absent_contains (gfc_statement st, gfc_omp_assumptions *check,
1789 : gfc_omp_assumptions *merge, locus *loc)
1790 : {
1791 43 : if (check == NULL)
1792 : return MATCH_YES;
1793 43 : bitmap_head absent_head, contains_head;
1794 43 : bitmap_obstack_initialize (NULL);
1795 43 : bitmap_initialize (&absent_head, &bitmap_default_obstack);
1796 43 : bitmap_initialize (&contains_head, &bitmap_default_obstack);
1797 :
1798 43 : match m = MATCH_YES;
1799 76 : for (int i = 0; i < check->n_absent; i++)
1800 33 : if (!bitmap_set_bit (&absent_head, check->absent[i]))
1801 : {
1802 2 : gfc_error ("%qs directive mentioned multiple times in %s clause in %s "
1803 : "directive at %L",
1804 2 : gfc_ascii_statement (check->absent[i], true),
1805 : "ABSENT", gfc_ascii_statement (st), loc);
1806 2 : m = MATCH_ERROR;
1807 : }
1808 57 : for (int i = 0; i < check->n_contains; i++)
1809 : {
1810 14 : if (!bitmap_set_bit (&contains_head, check->contains[i]))
1811 : {
1812 2 : gfc_error ("%qs directive mentioned multiple times in %s clause in %s "
1813 : "directive at %L",
1814 2 : gfc_ascii_statement (check->contains[i], true),
1815 : "CONTAINS", gfc_ascii_statement (st), loc);
1816 2 : m = MATCH_ERROR;
1817 : }
1818 14 : if (bitmap_bit_p (&absent_head, check->contains[i]))
1819 : {
1820 2 : gfc_error ("%qs directive mentioned both times in ABSENT and CONTAINS "
1821 : "clauses in %s directive at %L",
1822 2 : gfc_ascii_statement (check->absent[i], true),
1823 : gfc_ascii_statement (st), loc);
1824 2 : m = MATCH_ERROR;
1825 : }
1826 : }
1827 :
1828 43 : if (m == MATCH_ERROR)
1829 : return MATCH_ERROR;
1830 37 : if (merge == NULL)
1831 : return MATCH_YES;
1832 2 : if (merge->absent == NULL && check->absent)
1833 : {
1834 1 : merge->n_absent = check->n_absent;
1835 1 : merge->absent = check->absent;
1836 1 : check->absent = NULL;
1837 : }
1838 1 : else if (merge->absent && check->absent)
1839 : {
1840 0 : check->absent = XRESIZEVEC (gfc_statement, check->absent,
1841 : merge->n_absent + check->n_absent);
1842 0 : for (int i = 0; i < merge->n_absent; i++)
1843 0 : if (!bitmap_bit_p (&absent_head, merge->absent[i]))
1844 0 : check->absent[check->n_absent++] = merge->absent[i];
1845 0 : free (merge->absent);
1846 0 : merge->absent = check->absent;
1847 0 : merge->n_absent = check->n_absent;
1848 0 : check->absent = NULL;
1849 : }
1850 2 : if (merge->contains == NULL && check->contains)
1851 : {
1852 0 : merge->n_contains = check->n_contains;
1853 0 : merge->contains = check->contains;
1854 0 : check->contains = NULL;
1855 : }
1856 2 : else if (merge->contains && check->contains)
1857 : {
1858 0 : check->contains = XRESIZEVEC (gfc_statement, check->contains,
1859 : merge->n_contains + check->n_contains);
1860 0 : for (int i = 0; i < merge->n_contains; i++)
1861 0 : if (!bitmap_bit_p (&contains_head, merge->contains[i]))
1862 0 : check->contains[check->n_contains++] = merge->contains[i];
1863 0 : free (merge->contains);
1864 0 : merge->contains = check->contains;
1865 0 : merge->n_contains = check->n_contains;
1866 0 : check->contains = NULL;
1867 : }
1868 : return MATCH_YES;
1869 : }
1870 :
1871 : /* OpenMP 5.0
1872 : uses_allocators ( allocator-list )
1873 :
1874 : allocator:
1875 : predefined-allocator
1876 : variable ( traits-array )
1877 :
1878 : OpenMP 5.2 deprecated, 6.0 deleted: 'variable ( traits-array )'
1879 :
1880 : OpenMP 5.2:
1881 : uses_allocators ( [modifier-list :] allocator-list )
1882 :
1883 : OpenMP 6.0:
1884 : uses_allocators ( [modifier-list :] allocator-list [; ...])
1885 :
1886 : allocator:
1887 : variable or predefined-allocator
1888 : modifier:
1889 : traits ( traits-array )
1890 : memspace ( mem-space-handle ) */
1891 :
1892 : static match
1893 56 : gfc_match_omp_clause_uses_allocators (gfc_omp_clauses *c)
1894 : {
1895 60 : parse_next:
1896 60 : gfc_symbol *memspace_sym = NULL;
1897 60 : gfc_symbol *traits_sym = NULL;
1898 60 : gfc_omp_namelist *head = NULL;
1899 60 : gfc_omp_namelist *p, *tail, **list;
1900 60 : int ntraits, nmemspace;
1901 60 : bool has_modifiers;
1902 60 : locus old_loc, cur_loc;
1903 :
1904 60 : gfc_gobble_whitespace ();
1905 60 : old_loc = gfc_current_locus;
1906 60 : ntraits = nmemspace = 0;
1907 92 : do
1908 : {
1909 76 : cur_loc = gfc_current_locus;
1910 76 : if (gfc_match ("traits ( %S ) ", &traits_sym) == MATCH_YES)
1911 24 : ntraits++;
1912 52 : else if (gfc_match ("memspace ( %S ) ", &memspace_sym) == MATCH_YES)
1913 23 : nmemspace++;
1914 76 : if (ntraits > 1 || nmemspace > 1)
1915 : {
1916 2 : gfc_error ("Duplicate %s modifier at %L in USES_ALLOCATORS clause",
1917 : ntraits > 1 ? "TRAITS" : "MEMSPACE", &cur_loc);
1918 2 : return MATCH_ERROR;
1919 : }
1920 74 : if (gfc_match (", ") == MATCH_YES)
1921 16 : continue;
1922 58 : if (gfc_match (": ") != MATCH_YES)
1923 : {
1924 : /* Assume no modifier. */
1925 31 : memspace_sym = traits_sym = NULL;
1926 31 : gfc_current_locus = old_loc;
1927 31 : break;
1928 : }
1929 : break;
1930 : } while (true);
1931 :
1932 85 : has_modifiers = traits_sym != NULL || memspace_sym != NULL;
1933 150 : do
1934 : {
1935 104 : p = gfc_get_omp_namelist ();
1936 104 : p->where = gfc_current_locus;
1937 104 : if (head == NULL)
1938 : head = tail = p;
1939 : else
1940 : {
1941 46 : tail->next = p;
1942 46 : tail = tail->next;
1943 : }
1944 104 : if (gfc_match ("%S ", &p->sym) != MATCH_YES)
1945 0 : goto error;
1946 104 : if (!has_modifiers)
1947 : {
1948 72 : if (gfc_match ("( %S ) ", &p->u2.traits_sym) == MATCH_YES)
1949 17 : gfc_warning (OPT_Wdeprecated_openmp,
1950 : "The specification of arguments to "
1951 : "%<uses_allocators%> at %L where each item is of "
1952 : "the form %<allocator(traits)%> is deprecated since "
1953 : "OpenMP 5.2; instead use %<uses_allocators(traits(%s"
1954 17 : "): %s)%>", &p->where, p->u2.traits_sym->name,
1955 17 : p->sym->name);
1956 : }
1957 32 : else if (gfc_peek_ascii_char () == '(')
1958 : {
1959 0 : gfc_error ("Unexpected %<(%> at %C");
1960 0 : goto error;
1961 : }
1962 : else
1963 : {
1964 32 : p->u.memspace_sym = memspace_sym;
1965 32 : p->u2.traits_sym = traits_sym;
1966 : }
1967 104 : gfc_gobble_whitespace ();
1968 104 : const char c = gfc_peek_ascii_char ();
1969 104 : if (c == ';' || c == ')')
1970 : break;
1971 48 : if (c != ',')
1972 : {
1973 2 : gfc_error ("Expected %<,%>, %<)%> or %<;%> at %C");
1974 2 : goto error;
1975 : }
1976 46 : gfc_match_char (',');
1977 46 : gfc_gobble_whitespace ();
1978 46 : } while (true);
1979 :
1980 56 : list = &c->lists[OMP_LIST_USES_ALLOCATORS];
1981 74 : while (*list)
1982 18 : list = &(*list)->next;
1983 56 : *list = head;
1984 :
1985 56 : if (gfc_match_char (';') == MATCH_YES)
1986 4 : goto parse_next;
1987 :
1988 52 : gfc_match_char (')');
1989 52 : return MATCH_YES;
1990 :
1991 2 : error:
1992 2 : gfc_free_omp_namelist (head, OMP_LIST_USES_ALLOCATORS);
1993 2 : return MATCH_ERROR;
1994 : }
1995 :
1996 :
1997 : /* Match the 'prefer_type' modifier of the interop 'init' clause:
1998 : with either OpenMP 5.1's
1999 : prefer_type ( <const-int-expr|string literal> [, ...]
2000 : or
2001 : prefer_type ( '{' <fr(...) | attr (...)>, ...] '}' [, '{' ... '}' ] )
2002 : where 'fr' takes a constant expression or a string literal
2003 : and 'attr takes a list of string literals, starting with 'ompx_')
2004 :
2005 : For the foreign runtime identifiers, string values are converted to
2006 : their integer value; unknown string or integer values are set to
2007 : GOMP_INTEROP_IFR_KNOWN.
2008 :
2009 : Data format:
2010 : For the foreign runtime identifiers, string values are converted to
2011 : their integer value; unknown string or integer values are set to 0.
2012 :
2013 : Each item (a) GOMP_INTEROP_IFR_SEPARATOR
2014 : (b) for any 'fr', its integer value.
2015 : Note: Spec only permits 1 'fr' entry (6.0; changed after TR13)
2016 : (c) GOMP_INTEROP_IFR_SEPARATOR
2017 : (d) list of \0-terminated non-empty strings for 'attr'
2018 : (e) '\0'
2019 : Tailing '\0'. */
2020 :
2021 : static match
2022 82 : gfc_match_omp_prefer_type (char **type_str, int *type_str_len)
2023 : {
2024 82 : gfc_expr *e;
2025 82 : std::string type_string, attr_string;
2026 : /* New syntax. */
2027 82 : if (gfc_peek_ascii_char () == '{')
2028 115 : do
2029 : {
2030 85 : attr_string.clear ();
2031 85 : type_string += (char) GOMP_INTEROP_IFR_SEPARATOR;
2032 85 : if (gfc_match ("{ ") != MATCH_YES)
2033 : {
2034 1 : gfc_error ("Expected %<{%> at %C");
2035 1 : return MATCH_ERROR;
2036 : }
2037 : bool fr_found = false;
2038 148 : do
2039 : {
2040 116 : if (gfc_match ("fr ( ") == MATCH_YES)
2041 : {
2042 62 : if (fr_found)
2043 : {
2044 1 : gfc_error ("Duplicated %<fr%> preference-selector-name "
2045 : "at %C");
2046 1 : return MATCH_ERROR;
2047 : }
2048 61 : fr_found = true;
2049 61 : do
2050 : {
2051 61 : bool found_literal = false;
2052 61 : match m = MATCH_YES;
2053 61 : if (gfc_match_literal_constant (&e, false) == MATCH_YES)
2054 : found_literal = true;
2055 : else
2056 12 : m = gfc_match_expr (&e);
2057 12 : if (m != MATCH_YES
2058 61 : || !gfc_resolve_expr (e)
2059 61 : || e->rank != 0
2060 60 : || e->expr_type != EXPR_CONSTANT
2061 59 : || (e->ts.type != BT_INTEGER
2062 43 : && (!found_literal || e->ts.type != BT_CHARACTER))
2063 58 : || (e->ts.type == BT_INTEGER
2064 16 : && !mpz_fits_sint_p (e->value.integer))
2065 70 : || (e->ts.type == BT_CHARACTER
2066 42 : && (e->ts.kind != gfc_default_character_kind
2067 41 : || e->value.character.length == 0)))
2068 : {
2069 5 : gfc_error ("Expected constant scalar integer expression"
2070 : " or non-empty default-kind character "
2071 5 : "literal at %L", &e->where);
2072 5 : gfc_free_expr (e);
2073 5 : return MATCH_ERROR;
2074 : }
2075 56 : gfc_gobble_whitespace ();
2076 56 : int val;
2077 56 : if (e->ts.type == BT_INTEGER)
2078 : {
2079 16 : val = mpz_get_si (e->value.integer);
2080 16 : if (val < 1 || val > GOMP_INTEROP_IFR_LAST)
2081 : {
2082 0 : gfc_warning_now (OPT_Wopenmp,
2083 : "Unknown foreign runtime "
2084 : "identifier %qd at %L",
2085 : val, &e->where);
2086 0 : val = GOMP_INTEROP_IFR_UNKNOWN;
2087 : }
2088 : }
2089 : else
2090 : {
2091 40 : char *str = XALLOCAVEC (char,
2092 : e->value.character.length+1);
2093 229 : for (int i = 0; i < e->value.character.length + 1; i++)
2094 189 : str[i] = e->value.character.string[i];
2095 40 : if (memchr (str, '\0', e->value.character.length) != 0)
2096 : {
2097 0 : gfc_error ("Unexpected null character in character "
2098 : "literal at %L", &e->where);
2099 0 : return MATCH_ERROR;
2100 : }
2101 40 : val = omp_get_fr_id_from_name (str);
2102 40 : if (val == GOMP_INTEROP_IFR_UNKNOWN)
2103 2 : gfc_warning_now (OPT_Wopenmp,
2104 : "Unknown foreign runtime identifier "
2105 2 : "%qs at %L", str, &e->where);
2106 : }
2107 :
2108 56 : type_string += (char) val;
2109 56 : if (gfc_match (") ") == MATCH_YES)
2110 : break;
2111 4 : gfc_error ("Expected %<)%> at %C");
2112 4 : return MATCH_ERROR;
2113 : }
2114 : while (true);
2115 : }
2116 54 : else if (gfc_match ("attr ( ") == MATCH_YES)
2117 : {
2118 60 : do
2119 : {
2120 57 : if (gfc_match_literal_constant (&e, false) != MATCH_YES
2121 56 : || !gfc_resolve_expr (e)
2122 56 : || e->expr_type != EXPR_CONSTANT
2123 56 : || e->rank != 0
2124 56 : || e->ts.type != BT_CHARACTER
2125 113 : || e->ts.kind != gfc_default_character_kind)
2126 : {
2127 1 : gfc_error ("Expected default-kind character literal "
2128 1 : "at %L", &e->where);
2129 1 : gfc_free_expr (e);
2130 1 : return MATCH_ERROR;
2131 : }
2132 56 : gfc_gobble_whitespace ();
2133 56 : char *str = XALLOCAVEC (char, e->value.character.length+1);
2134 564 : for (int i = 0; i < e->value.character.length + 1; i++)
2135 508 : str[i] = e->value.character.string[i];
2136 56 : if (!startswith (str, "ompx_"))
2137 : {
2138 1 : gfc_error ("Character literal at %L must start with "
2139 : "%<ompx_%>", &e->where);
2140 1 : gfc_free_expr (e);
2141 1 : return MATCH_ERROR;
2142 : }
2143 55 : if (memchr (str, '\0', e->value.character.length) != 0
2144 55 : || memchr (str, ',', e->value.character.length) != 0)
2145 : {
2146 1 : gfc_error ("Unexpected null or %<,%> character in "
2147 : "character literal at %L", &e->where);
2148 1 : return MATCH_ERROR;
2149 : }
2150 54 : attr_string += str;
2151 54 : attr_string += '\0';
2152 54 : if (gfc_match (", ") == MATCH_YES)
2153 3 : continue;
2154 51 : if (gfc_match (") ") == MATCH_YES)
2155 : break;
2156 0 : gfc_error ("Expected %<,%> or %<)%> at %C");
2157 0 : return MATCH_ERROR;
2158 3 : }
2159 : while (true);
2160 : }
2161 : else
2162 : {
2163 0 : gfc_error ("Expected %<fr(%> or %<attr(%> at %C");
2164 0 : return MATCH_ERROR;
2165 : }
2166 103 : if (gfc_match (", ") == MATCH_YES)
2167 32 : continue;
2168 71 : if (gfc_match ("} ") == MATCH_YES)
2169 : break;
2170 2 : gfc_error ("Expected %<,%> or %<}%> at %C");
2171 2 : return MATCH_ERROR;
2172 32 : }
2173 : while (true);
2174 69 : type_string += (char) GOMP_INTEROP_IFR_SEPARATOR;
2175 69 : type_string += attr_string;
2176 69 : type_string += '\0';
2177 69 : if (gfc_match (", ") == MATCH_YES)
2178 30 : continue;
2179 39 : if (gfc_match (") ") == MATCH_YES)
2180 : break;
2181 1 : gfc_error ("Expected %<,%> or %<)%> at %C");
2182 1 : return MATCH_ERROR;
2183 30 : }
2184 : while (true);
2185 : else
2186 75 : do
2187 : {
2188 51 : type_string += (char) GOMP_INTEROP_IFR_SEPARATOR;
2189 51 : bool found_literal = false;
2190 51 : match m = MATCH_YES;
2191 51 : if (gfc_match_literal_constant (&e, false) == MATCH_YES)
2192 : found_literal = true;
2193 : else
2194 19 : m = gfc_match_expr (&e);
2195 19 : if (m != MATCH_YES
2196 51 : || !gfc_resolve_expr (e)
2197 51 : || e->rank != 0
2198 50 : || e->expr_type != EXPR_CONSTANT
2199 49 : || (e->ts.type != BT_INTEGER
2200 28 : && (!found_literal || e->ts.type != BT_CHARACTER))
2201 48 : || (e->ts.type == BT_INTEGER
2202 21 : && !mpz_fits_sint_p (e->value.integer))
2203 67 : || (e->ts.type == BT_CHARACTER
2204 27 : && (e->ts.kind != gfc_default_character_kind
2205 27 : || e->value.character.length == 0)))
2206 : {
2207 3 : gfc_error ("Expected constant scalar integer expression or "
2208 3 : "non-empty default-kind character literal at %L", &e->where);
2209 3 : gfc_free_expr (e);
2210 3 : return MATCH_ERROR;
2211 : }
2212 48 : gfc_gobble_whitespace ();
2213 48 : int val;
2214 48 : if (e->ts.type == BT_INTEGER)
2215 : {
2216 21 : val = mpz_get_si (e->value.integer);
2217 21 : if (val < 1 || val > GOMP_INTEROP_IFR_LAST)
2218 : {
2219 3 : gfc_warning_now (OPT_Wopenmp,
2220 : "Unknown foreign runtime identifier %qd at %L",
2221 : val, &e->where);
2222 3 : val = 0;
2223 : }
2224 : }
2225 : else
2226 : {
2227 27 : char *str = XALLOCAVEC (char, e->value.character.length+1);
2228 169 : for (int i = 0; i < e->value.character.length + 1; i++)
2229 142 : str[i] = e->value.character.string[i];
2230 27 : if (memchr (str, '\0', e->value.character.length) != 0)
2231 : {
2232 0 : gfc_error ("Unexpected null character in character "
2233 : "literal at %L", &e->where);
2234 0 : return MATCH_ERROR;
2235 : }
2236 27 : val = omp_get_fr_id_from_name (str);
2237 27 : if (val == GOMP_INTEROP_IFR_UNKNOWN)
2238 5 : gfc_warning_now (OPT_Wopenmp,
2239 : "Unknown foreign runtime identifier %qs at %L",
2240 5 : str, &e->where);
2241 : }
2242 48 : type_string += (char) val;
2243 48 : type_string += (char) GOMP_INTEROP_IFR_SEPARATOR;
2244 48 : type_string += '\0';
2245 48 : gfc_free_expr (e);
2246 48 : if (gfc_match (", ") == MATCH_YES)
2247 24 : continue;
2248 24 : if (gfc_match (") ") == MATCH_YES)
2249 : break;
2250 2 : gfc_error ("Expected %<,%> or %<)%> at %C");
2251 2 : return MATCH_ERROR;
2252 24 : }
2253 : while (true);
2254 60 : type_string += '\0';
2255 60 : *type_str_len = type_string.length();
2256 60 : *type_str = XNEWVEC (char, type_string.length ());
2257 60 : memcpy (*type_str, type_string.data (), type_string.length ());
2258 60 : return MATCH_YES;
2259 82 : }
2260 :
2261 :
2262 : /* Match OpenMP 5.1's 'init'-clause modifiers, used by the 'init' clause of
2263 : the 'interop' directive and the 'append_args' directive of 'declare variant'.
2264 : [prefer_type(...)][,][<target|targetsync>, ...])
2265 :
2266 : If is_init_clause, the modifier parsing ends with a ':'.
2267 : If not is_init_clause (i.e. append_args), the parsing ends with ')'. */
2268 :
2269 : static match
2270 164 : gfc_parser_omp_clause_init_modifiers (bool &target, bool &targetsync,
2271 : char **type_str, int &type_str_len,
2272 : bool is_init_clause)
2273 : {
2274 164 : target = false;
2275 164 : targetsync = false;
2276 164 : *type_str = NULL;
2277 164 : type_str_len = 0;
2278 286 : match m;
2279 :
2280 286 : do
2281 : {
2282 286 : if (gfc_match ("prefer_type ( ") == MATCH_YES)
2283 : {
2284 83 : if (*type_str)
2285 : {
2286 1 : gfc_error ("Duplicate %<prefer_type%> modifier at %C");
2287 1 : return MATCH_ERROR;
2288 : }
2289 82 : m = gfc_match_omp_prefer_type (type_str, &type_str_len);
2290 82 : if (m != MATCH_YES)
2291 : return m;
2292 60 : if (gfc_match (", ") == MATCH_YES)
2293 14 : continue;
2294 46 : if (is_init_clause)
2295 : {
2296 24 : if (gfc_match (": ") == MATCH_YES)
2297 : break;
2298 0 : gfc_error ("Expected %<,%> or %<:%> at %C");
2299 : }
2300 : else
2301 : {
2302 22 : if (gfc_match (") ") == MATCH_YES)
2303 : break;
2304 0 : gfc_error ("Expected %<,%> or %<)%> at %C");
2305 : }
2306 0 : return MATCH_ERROR;
2307 : }
2308 :
2309 203 : if (gfc_match ("prefer_type ") == MATCH_YES)
2310 : {
2311 2 : gfc_error ("Expected %<(%> after %<prefer_type%> at %C");
2312 2 : return MATCH_ERROR;
2313 : }
2314 :
2315 201 : if (gfc_match ("targetsync ") == MATCH_YES)
2316 : {
2317 57 : if (targetsync)
2318 : {
2319 3 : gfc_error ("Duplicate %<targetsync%> at %C");
2320 3 : return MATCH_ERROR;
2321 : }
2322 54 : targetsync = true;
2323 54 : if (gfc_match (", ") == MATCH_YES)
2324 13 : continue;
2325 41 : if (!is_init_clause)
2326 : {
2327 23 : if (gfc_match (") ") == MATCH_YES)
2328 : break;
2329 0 : gfc_error ("Expected %<,%> or %<)%> at %C");
2330 0 : return MATCH_ERROR;
2331 : }
2332 18 : if (gfc_match (": ") == MATCH_YES)
2333 : break;
2334 1 : gfc_error ("Expected %<,%> or %<:%> at %C");
2335 1 : return MATCH_ERROR;
2336 : }
2337 144 : if (gfc_match ("target ") == MATCH_YES)
2338 : {
2339 135 : if (target)
2340 : {
2341 3 : gfc_error ("Duplicate %<target%> at %C");
2342 3 : return MATCH_ERROR;
2343 : }
2344 132 : target = true;
2345 132 : if (gfc_match (", ") == MATCH_YES)
2346 95 : continue;
2347 37 : if (!is_init_clause)
2348 : {
2349 11 : if (gfc_match (") ") == MATCH_YES)
2350 : break;
2351 0 : gfc_error ("Expected %<,%> or %<)%> at %C");
2352 0 : return MATCH_ERROR;
2353 : }
2354 26 : if (gfc_match (": ") == MATCH_YES)
2355 : break;
2356 1 : gfc_error ("Expected %<,%> or %<:%> at %C");
2357 1 : return MATCH_ERROR;
2358 : }
2359 9 : gfc_error ("Expected %<prefer_type%>, %<target%>, or %<targetsync%> "
2360 : "at %C");
2361 9 : return MATCH_ERROR;
2362 : }
2363 : while (true);
2364 :
2365 122 : if (!target && !targetsync)
2366 : {
2367 4 : gfc_error ("Missing required %<target%> and/or %<targetsync%> "
2368 : "modifier at %C");
2369 4 : return MATCH_ERROR;
2370 : }
2371 : return MATCH_YES;
2372 : }
2373 :
2374 : /* Match OpenMP 5.1's 'init' clause for 'interop' objects:
2375 : init([prefer_type(...)][,][<target|targetsync>, ...] :] interop-obj-list) */
2376 :
2377 : static match
2378 108 : gfc_match_omp_init (gfc_omp_namelist **list)
2379 : {
2380 108 : bool target, targetsync;
2381 108 : char *type_str = NULL;
2382 108 : int type_str_len;
2383 108 : if (gfc_parser_omp_clause_init_modifiers (target, targetsync, &type_str,
2384 : type_str_len, true) == MATCH_ERROR)
2385 : return MATCH_ERROR;
2386 :
2387 64 : gfc_omp_namelist **head = NULL;
2388 64 : if (gfc_match_omp_variable_list ("", list, false, NULL, &head) != MATCH_YES)
2389 : return MATCH_ERROR;
2390 147 : for (gfc_omp_namelist *n = *head; n; n = n->next)
2391 : {
2392 84 : n->u.init.target = target;
2393 84 : n->u.init.targetsync = targetsync;
2394 84 : n->u.init.len = type_str_len;
2395 84 : n->u2.init_interop = type_str;
2396 : }
2397 : return MATCH_YES;
2398 : }
2399 :
2400 :
2401 : /* Match with duplicate check. Matches 'name'. If expr != NULL, it
2402 : then matches '(expr)', otherwise, if open_parens is true,
2403 : it matches a ' ( ' after 'name'.
2404 : dupl_message requires '%qs %L' - and is used by
2405 : gfc_match_dupl_memorder and gfc_match_dupl_atomic. */
2406 :
2407 : static match
2408 22386 : gfc_match_dupl_check (bool not_dupl, const char *name, bool open_parens = false,
2409 : gfc_expr **expr = NULL, const char *dupl_msg = NULL)
2410 : {
2411 22386 : match m;
2412 22386 : char c;
2413 22386 : locus old_loc = gfc_current_locus;
2414 22386 : if ((m = gfc_match (name)) != MATCH_YES)
2415 : return m;
2416 : /* Ensure that no partial string is matched. */
2417 17423 : if (gfc_current_form == FORM_FREE
2418 16925 : && gfc_match_eos () != MATCH_YES
2419 30212 : && ((c = gfc_peek_ascii_char ()) == '_' || ISALNUM (c)))
2420 : {
2421 8 : gfc_current_locus = old_loc;
2422 8 : return MATCH_NO;
2423 : }
2424 17415 : if (!not_dupl)
2425 : {
2426 44 : if (dupl_msg)
2427 2 : gfc_error (dupl_msg, name, &old_loc);
2428 : else
2429 42 : gfc_error ("Duplicated %qs clause at %L", name, &old_loc);
2430 44 : return MATCH_ERROR;
2431 : }
2432 17371 : if (open_parens || expr)
2433 : {
2434 9481 : if (gfc_match (" ( ") != MATCH_YES)
2435 : {
2436 22 : gfc_error ("Expected %<(%> after %qs at %C", name);
2437 22 : return MATCH_ERROR;
2438 : }
2439 9459 : if (expr)
2440 : {
2441 4419 : if (gfc_match ("%e )", expr) != MATCH_YES)
2442 : {
2443 9 : gfc_error ("Invalid expression after %<%s(%> at %C", name);
2444 9 : return MATCH_ERROR;
2445 : }
2446 : }
2447 : }
2448 : return MATCH_YES;
2449 : }
2450 :
2451 : static match
2452 211 : gfc_match_dupl_memorder (bool not_dupl, const char *name)
2453 : {
2454 0 : return gfc_match_dupl_check (not_dupl, name, false, NULL,
2455 : "Duplicated memory-order clause: unexpected %s "
2456 0 : "clause at %L");
2457 : }
2458 :
2459 : static match
2460 1175 : gfc_match_dupl_atomic (bool not_dupl, const char *name)
2461 : {
2462 0 : return gfc_match_dupl_check (not_dupl, name, false, NULL,
2463 : "Duplicated atomic clause: unexpected %s "
2464 0 : "clause at %L");
2465 : }
2466 :
2467 :
2468 : /* Search upwards though namespace NS and its parents to find an
2469 : !$omp declare mapper named MAPPER_ID, for typespec TS. The default
2470 : mapper has mapper_id == "". */
2471 :
2472 : gfc_omp_udm *
2473 997 : gfc_find_omp_udm (gfc_namespace *ns, const char *mapper_id, gfc_typespec *ts)
2474 : {
2475 997 : gfc_symtree *st;
2476 :
2477 997 : if (ns == NULL)
2478 0 : ns = gfc_current_ns;
2479 :
2480 1174 : do
2481 : {
2482 1174 : gfc_omp_udm *omp_udm;
2483 :
2484 1174 : st = gfc_find_symtree (ns->omp_udm_root, mapper_id);
2485 :
2486 1174 : if (st != NULL)
2487 : {
2488 27 : for (omp_udm = st->n.omp_udm; omp_udm; omp_udm = omp_udm->next)
2489 27 : if (gfc_compare_types (&omp_udm->ts, ts))
2490 : return omp_udm;
2491 : }
2492 :
2493 : /* Don't escape an interface block. */
2494 1149 : if (ns && !ns->has_import_set
2495 1149 : && ns->proc_name && ns->proc_name->attr.if_source == IFSRC_IFBODY)
2496 : break;
2497 :
2498 1149 : ns = ns->parent;
2499 : }
2500 1149 : while (ns != NULL);
2501 :
2502 : return NULL;
2503 : }
2504 :
2505 :
2506 : /* Match OpenMP and OpenACC directive clauses. MASK is a bitmask of
2507 : clauses that are allowed for a particular directive. */
2508 :
2509 : static match
2510 34525 : gfc_match_omp_clauses (gfc_omp_clauses **cp, const omp_mask mask,
2511 : bool first = true, bool needs_space = true,
2512 : bool openacc = false, bool openmp_target = false,
2513 : gfc_omp_map_op default_map_op = OMP_MAP_TOFROM)
2514 : {
2515 34525 : bool error = false;
2516 34525 : gfc_omp_clauses *c = gfc_get_omp_clauses ();
2517 34525 : locus old_loc;
2518 : /* Determine whether we're dealing with an OpenACC directive that permits
2519 : derived type member accesses. This in particular disallows
2520 : "!$acc declare" from using such accesses, because it's not clear if/how
2521 : that should work. */
2522 34525 : bool allow_derived = (openacc
2523 34525 : && ((mask & OMP_CLAUSE_ATTACH)
2524 5932 : || (mask & OMP_CLAUSE_DETACH)));
2525 :
2526 34525 : gcc_checking_assert (OMP_MASK1_LAST <= 64 && OMP_MASK2_LAST <= 64);
2527 34525 : *cp = NULL;
2528 126949 : while (1)
2529 : {
2530 80737 : match m = MATCH_NO;
2531 59982 : if ((first || (m = gfc_match_char (',')) != MATCH_YES)
2532 140363 : && (needs_space && gfc_match_space () != MATCH_YES))
2533 : break;
2534 76172 : needs_space = false;
2535 76172 : first = false;
2536 76172 : gfc_gobble_whitespace ();
2537 76172 : bool end_colon;
2538 76172 : gfc_omp_namelist **head;
2539 76172 : old_loc = gfc_current_locus;
2540 76172 : char pc = gfc_peek_ascii_char ();
2541 76172 : if (pc == '\n' && m == MATCH_YES)
2542 : {
2543 1 : gfc_error ("Clause expected at %C after trailing comma");
2544 1 : goto error;
2545 : }
2546 76171 : switch (pc)
2547 : {
2548 1312 : case 'a':
2549 1312 : end_colon = false;
2550 1312 : head = NULL;
2551 1336 : if ((mask & OMP_CLAUSE_ASSUMPTIONS)
2552 1312 : && gfc_match ("absent ( ") == MATCH_YES)
2553 : {
2554 27 : if (gfc_omp_absent_contains_clause (&c->assume, true)
2555 : != MATCH_YES)
2556 3 : goto error;
2557 24 : continue;
2558 : }
2559 1285 : if ((mask & OMP_CLAUSE_ALIGNED)
2560 1285 : && gfc_match_omp_variable_list ("aligned (",
2561 : &c->lists[OMP_LIST_ALIGNED],
2562 : false, &end_colon,
2563 : &head) == MATCH_YES)
2564 : {
2565 112 : gfc_expr *alignment = NULL;
2566 112 : gfc_omp_namelist *n;
2567 :
2568 112 : if (end_colon && gfc_match (" %e )", &alignment) != MATCH_YES)
2569 : {
2570 0 : gfc_free_omp_namelist (*head, OMP_LIST_ALIGNED);
2571 0 : gfc_current_locus = old_loc;
2572 0 : *head = NULL;
2573 0 : break;
2574 : }
2575 268 : for (n = *head; n; n = n->next)
2576 156 : if (n->next && alignment)
2577 42 : n->expr = gfc_copy_expr (alignment);
2578 : else
2579 114 : n->expr = alignment;
2580 112 : continue;
2581 112 : }
2582 1183 : if ((mask & OMP_CLAUSE_MEMORDER)
2583 1190 : && (m = gfc_match_dupl_memorder ((c->memorder
2584 17 : == OMP_MEMORDER_UNSET),
2585 : "acq_rel")) != MATCH_NO)
2586 : {
2587 10 : if (m == MATCH_ERROR)
2588 0 : goto error;
2589 10 : c->memorder = OMP_MEMORDER_ACQ_REL;
2590 10 : continue;
2591 : }
2592 1170 : if ((mask & OMP_CLAUSE_MEMORDER)
2593 1170 : && (m = gfc_match_dupl_memorder ((c->memorder
2594 7 : == OMP_MEMORDER_UNSET),
2595 : "acquire")) != MATCH_NO)
2596 : {
2597 7 : if (m == MATCH_ERROR)
2598 0 : goto error;
2599 7 : c->memorder = OMP_MEMORDER_ACQUIRE;
2600 7 : continue;
2601 : }
2602 1156 : if ((mask & OMP_CLAUSE_AFFINITY)
2603 1156 : && gfc_match ("affinity ( ") == MATCH_YES)
2604 : {
2605 41 : gfc_namespace *ns_iter = NULL, *ns_curr = gfc_current_ns;
2606 41 : m = gfc_match_iterator (&ns_iter, true);
2607 41 : if (m == MATCH_ERROR)
2608 : break;
2609 31 : if (m == MATCH_YES && gfc_match (" : ") != MATCH_YES)
2610 : {
2611 1 : gfc_error ("Expected %<:%> at %C");
2612 1 : break;
2613 : }
2614 30 : if (ns_iter)
2615 18 : gfc_current_ns = ns_iter;
2616 30 : head = NULL;
2617 30 : m = gfc_match_omp_variable_list ("", &c->lists[OMP_LIST_AFFINITY],
2618 : false, NULL, &head, true);
2619 30 : gfc_current_ns = ns_curr;
2620 30 : if (m == MATCH_ERROR)
2621 : break;
2622 27 : if (ns_iter)
2623 : {
2624 45 : for (gfc_omp_namelist *n = *head; n; n = n->next)
2625 : {
2626 27 : n->u2.ns = ns_iter;
2627 27 : ns_iter->refs++;
2628 : }
2629 : }
2630 27 : continue;
2631 27 : }
2632 1115 : if ((mask & OMP_CLAUSE_ALLOCATE)
2633 1115 : && gfc_match ("allocate ( ") == MATCH_YES)
2634 : {
2635 279 : gfc_expr *allocator = NULL;
2636 279 : gfc_expr *align = NULL;
2637 279 : old_loc = gfc_current_locus;
2638 279 : if ((m = gfc_match ("allocator ( %e )", &allocator)) == MATCH_YES)
2639 50 : gfc_match (" , align ( %e )", &align);
2640 229 : else if ((m = gfc_match ("align ( %e )", &align)) == MATCH_YES)
2641 29 : gfc_match (" , allocator ( %e )", &allocator);
2642 :
2643 279 : if (m == MATCH_YES)
2644 : {
2645 79 : if (gfc_match (" : ") != MATCH_YES)
2646 : {
2647 5 : gfc_error ("Expected %<:%> at %C");
2648 8 : goto error;
2649 : }
2650 : }
2651 : else
2652 : {
2653 200 : m = gfc_match_expr (&allocator);
2654 200 : if (m == MATCH_YES && gfc_match (" : ") != MATCH_YES)
2655 : {
2656 : /* If no ":" then there is no allocator, we backtrack
2657 : and read the variable list. */
2658 101 : gfc_free_expr (allocator);
2659 101 : allocator = NULL;
2660 101 : gfc_current_locus = old_loc;
2661 : }
2662 : }
2663 274 : gfc_omp_namelist **head = NULL;
2664 274 : m = gfc_match_omp_variable_list ("", &c->lists[OMP_LIST_ALLOCATE],
2665 : true, NULL, &head);
2666 :
2667 274 : if (m != MATCH_YES)
2668 : {
2669 3 : gfc_free_expr (allocator);
2670 3 : gfc_free_expr (align);
2671 3 : gfc_error ("Expected variable list at %C");
2672 3 : goto error;
2673 : }
2674 :
2675 725 : for (gfc_omp_namelist *n = *head; n; n = n->next)
2676 : {
2677 454 : n->u2.allocator = allocator;
2678 454 : n->u.align = (align) ? gfc_copy_expr (align) : NULL;
2679 : }
2680 271 : gfc_free_expr (align);
2681 271 : continue;
2682 271 : }
2683 896 : if ((mask & OMP_CLAUSE_AT)
2684 836 : && (m = gfc_match_dupl_check (c->at == OMP_AT_UNSET, "at", true))
2685 : != MATCH_NO)
2686 : {
2687 66 : if (m == MATCH_ERROR)
2688 2 : goto error;
2689 64 : if (gfc_match ("compilation )") == MATCH_YES)
2690 15 : c->at = OMP_AT_COMPILATION;
2691 49 : else if (gfc_match ("execution )") == MATCH_YES)
2692 45 : c->at = OMP_AT_EXECUTION;
2693 : else
2694 : {
2695 4 : gfc_error ("Expected COMPILATION or EXECUTION in AT clause "
2696 : "at %C");
2697 4 : goto error;
2698 : }
2699 60 : continue;
2700 : }
2701 1413 : if ((mask & OMP_CLAUSE_ASYNC)
2702 770 : && (m = gfc_match_dupl_check (!c->async, "async")) != MATCH_NO)
2703 : {
2704 643 : if (m == MATCH_ERROR)
2705 0 : goto error;
2706 643 : c->async = true;
2707 643 : m = gfc_match (" ( %e )", &c->async_expr);
2708 643 : if (m == MATCH_ERROR)
2709 : {
2710 0 : gfc_current_locus = old_loc;
2711 0 : break;
2712 : }
2713 643 : else if (m == MATCH_NO)
2714 : {
2715 133 : c->async_expr
2716 133 : = gfc_get_constant_expr (BT_INTEGER,
2717 : gfc_default_integer_kind,
2718 : &gfc_current_locus);
2719 133 : mpz_set_si (c->async_expr->value.integer, GOMP_ASYNC_NOVAL);
2720 : }
2721 643 : continue;
2722 : }
2723 190 : if ((mask & OMP_CLAUSE_AUTO)
2724 127 : && (m = gfc_match_dupl_check (!c->par_auto, "auto"))
2725 : != MATCH_NO)
2726 : {
2727 63 : if (m == MATCH_ERROR)
2728 0 : goto error;
2729 63 : c->par_auto = true;
2730 63 : continue;
2731 : }
2732 125 : if ((mask & OMP_CLAUSE_ATTACH)
2733 62 : && gfc_match ("attach ( ") == MATCH_YES
2734 125 : && gfc_match_omp_map_clause (&c->lists[OMP_LIST_MAP],
2735 : OMP_MAP_ATTACH, false,
2736 : allow_derived))
2737 61 : continue;
2738 : break;
2739 36 : case 'b':
2740 70 : if ((mask & OMP_CLAUSE_BIND)
2741 36 : && (m = gfc_match_dupl_check (c->bind == OMP_BIND_UNSET, "bind",
2742 : true)) != MATCH_NO)
2743 : {
2744 36 : if (m == MATCH_ERROR)
2745 1 : goto error;
2746 35 : if (gfc_match ("teams )") == MATCH_YES)
2747 11 : c->bind = OMP_BIND_TEAMS;
2748 24 : else if (gfc_match ("parallel )") == MATCH_YES)
2749 15 : c->bind = OMP_BIND_PARALLEL;
2750 9 : else if (gfc_match ("thread )") == MATCH_YES)
2751 8 : c->bind = OMP_BIND_THREAD;
2752 : else
2753 : {
2754 1 : gfc_error ("Expected TEAMS, PARALLEL or THREAD as binding in "
2755 : "BIND at %C");
2756 1 : break;
2757 : }
2758 34 : continue;
2759 : }
2760 : break;
2761 7110 : case 'c':
2762 7383 : if ((mask & OMP_CLAUSE_CAPTURE)
2763 7110 : && (m = gfc_match_dupl_check (!c->capture, "capture"))
2764 : != MATCH_NO)
2765 : {
2766 274 : if (m == MATCH_ERROR)
2767 1 : goto error;
2768 273 : c->capture = true;
2769 273 : continue;
2770 : }
2771 6836 : if (mask & OMP_CLAUSE_COLLAPSE)
2772 : {
2773 1996 : gfc_expr *cexpr = NULL;
2774 1996 : if ((m = gfc_match_dupl_check (!c->collapse, "collapse", true,
2775 : &cexpr)) != MATCH_NO)
2776 : {
2777 1506 : int collapse;
2778 1506 : if (m == MATCH_ERROR)
2779 0 : goto error;
2780 1506 : if (gfc_extract_int (cexpr, &collapse, -1))
2781 4 : collapse = 1;
2782 1502 : else if (collapse <= 0)
2783 : {
2784 8 : gfc_error_now ("COLLAPSE clause argument not constant "
2785 : "positive integer at %C");
2786 8 : collapse = 1;
2787 : }
2788 1506 : gfc_free_expr (cexpr);
2789 1506 : c->collapse = collapse;
2790 1506 : continue;
2791 1506 : }
2792 : }
2793 5496 : if ((mask & OMP_CLAUSE_COMPARE)
2794 5330 : && (m = gfc_match_dupl_check (!c->compare, "compare"))
2795 : != MATCH_NO)
2796 : {
2797 167 : if (m == MATCH_ERROR)
2798 1 : goto error;
2799 166 : c->compare = true;
2800 166 : continue;
2801 : }
2802 5175 : if ((mask & OMP_CLAUSE_ASSUMPTIONS)
2803 5163 : && gfc_match ("contains ( ") == MATCH_YES)
2804 : {
2805 13 : if (gfc_omp_absent_contains_clause (&c->assume, false)
2806 : != MATCH_YES)
2807 1 : goto error;
2808 12 : continue;
2809 : }
2810 7266 : if ((mask & OMP_CLAUSE_COPY)
2811 3723 : && gfc_match ("copy ( ") == MATCH_YES
2812 7267 : && gfc_match_omp_map_clause (&c->lists[OMP_LIST_MAP],
2813 : OMP_MAP_TOFROM, true,
2814 : allow_derived))
2815 2116 : continue;
2816 3034 : if (mask & OMP_CLAUSE_COPYIN)
2817 : {
2818 2628 : if (openacc)
2819 : {
2820 2529 : if (gfc_match ("copyin ( ") == MATCH_YES)
2821 : {
2822 1458 : bool readonly = gfc_match ("readonly : ") == MATCH_YES;
2823 1458 : head = NULL;
2824 1458 : if (gfc_match_omp_variable_list ("",
2825 : &c->lists[OMP_LIST_MAP],
2826 : true, NULL, &head, true,
2827 : allow_derived)
2828 : == MATCH_YES)
2829 : {
2830 1452 : gfc_omp_namelist *n;
2831 3349 : for (n = *head; n; n = n->next)
2832 : {
2833 1897 : n->u.map.op = OMP_MAP_TO;
2834 1897 : n->u.map.readonly = readonly;
2835 : }
2836 1452 : continue;
2837 1452 : }
2838 : }
2839 : }
2840 99 : else if (gfc_match_omp_variable_list ("copyin (",
2841 : &c->lists[OMP_LIST_COPYIN],
2842 : true) == MATCH_YES)
2843 97 : continue;
2844 : }
2845 2556 : if ((mask & OMP_CLAUSE_COPYOUT)
2846 1216 : && gfc_match ("copyout ( ") == MATCH_YES
2847 2556 : && gfc_match_omp_map_clause (&c->lists[OMP_LIST_MAP],
2848 : OMP_MAP_FROM, true, allow_derived))
2849 1071 : continue;
2850 498 : if ((mask & OMP_CLAUSE_COPYPRIVATE)
2851 414 : && gfc_match_omp_variable_list ("copyprivate (",
2852 : &c->lists[OMP_LIST_COPYPRIVATE],
2853 : true) == MATCH_YES)
2854 84 : continue;
2855 651 : if ((mask & OMP_CLAUSE_CREATE)
2856 328 : && gfc_match ("create ( ") == MATCH_YES
2857 651 : && gfc_match_omp_map_clause (&c->lists[OMP_LIST_MAP],
2858 : OMP_MAP_ALLOC, true, allow_derived))
2859 321 : continue;
2860 : break;
2861 3739 : case 'd':
2862 3739 : if ((mask & OMP_CLAUSE_DEFAULTMAP)
2863 3739 : && gfc_match ("defaultmap ( ") == MATCH_YES)
2864 : {
2865 180 : enum gfc_omp_defaultmap behavior;
2866 180 : gfc_omp_defaultmap_category category
2867 : = OMP_DEFAULTMAP_CAT_UNCATEGORIZED;
2868 180 : if (gfc_match ("alloc ") == MATCH_YES)
2869 : behavior = OMP_DEFAULTMAP_ALLOC;
2870 174 : else if (gfc_match ("tofrom ") == MATCH_YES)
2871 : behavior = OMP_DEFAULTMAP_TOFROM;
2872 142 : else if (gfc_match ("to ") == MATCH_YES)
2873 : behavior = OMP_DEFAULTMAP_TO;
2874 132 : else if (gfc_match ("from ") == MATCH_YES)
2875 : behavior = OMP_DEFAULTMAP_FROM;
2876 129 : else if (gfc_match ("firstprivate ") == MATCH_YES)
2877 : behavior = OMP_DEFAULTMAP_FIRSTPRIVATE;
2878 94 : else if (gfc_match ("present ") == MATCH_YES)
2879 : behavior = OMP_DEFAULTMAP_PRESENT;
2880 90 : else if (gfc_match ("none ") == MATCH_YES)
2881 : behavior = OMP_DEFAULTMAP_NONE;
2882 10 : else if (gfc_match ("default ") == MATCH_YES)
2883 : behavior = OMP_DEFAULTMAP_DEFAULT;
2884 : else
2885 : {
2886 1 : gfc_error ("Expected ALLOC, TO, FROM, TOFROM, FIRSTPRIVATE, "
2887 : "PRESENT, NONE or DEFAULT at %C");
2888 1 : break;
2889 : }
2890 179 : if (')' == gfc_peek_ascii_char ())
2891 : ;
2892 102 : else if (gfc_match (": ") != MATCH_YES)
2893 : break;
2894 : else
2895 : {
2896 102 : if (gfc_match ("scalar ") == MATCH_YES)
2897 : category = OMP_DEFAULTMAP_CAT_SCALAR;
2898 67 : else if (gfc_match ("aggregate ") == MATCH_YES)
2899 : category = OMP_DEFAULTMAP_CAT_AGGREGATE;
2900 43 : else if (gfc_match ("allocatable ") == MATCH_YES)
2901 : category = OMP_DEFAULTMAP_CAT_ALLOCATABLE;
2902 31 : else if (gfc_match ("pointer ") == MATCH_YES)
2903 : category = OMP_DEFAULTMAP_CAT_POINTER;
2904 14 : else if (gfc_match ("all ") == MATCH_YES)
2905 : category = OMP_DEFAULTMAP_CAT_ALL;
2906 : else
2907 : {
2908 1 : gfc_error ("Expected SCALAR, AGGREGATE, ALLOCATABLE, "
2909 : "POINTER or ALL at %C");
2910 1 : break;
2911 : }
2912 : }
2913 1193 : for (int i = 0; i < OMP_DEFAULTMAP_CAT_NUM; ++i)
2914 : {
2915 1028 : if (i != category
2916 1028 : && category != OMP_DEFAULTMAP_CAT_UNCATEGORIZED
2917 486 : && category != OMP_DEFAULTMAP_CAT_ALL
2918 486 : && i != OMP_DEFAULTMAP_CAT_UNCATEGORIZED
2919 341 : && i != OMP_DEFAULTMAP_CAT_ALL)
2920 254 : continue;
2921 774 : if (c->defaultmap[i] != OMP_DEFAULTMAP_UNSET)
2922 : {
2923 13 : const char *pcategory = NULL;
2924 13 : switch (i)
2925 : {
2926 : case OMP_DEFAULTMAP_CAT_UNCATEGORIZED: break;
2927 : case OMP_DEFAULTMAP_CAT_ALL: pcategory = "ALL"; break;
2928 1 : case OMP_DEFAULTMAP_CAT_SCALAR: pcategory = "SCALAR"; break;
2929 2 : case OMP_DEFAULTMAP_CAT_AGGREGATE:
2930 2 : pcategory = "AGGREGATE";
2931 2 : break;
2932 1 : case OMP_DEFAULTMAP_CAT_ALLOCATABLE:
2933 1 : pcategory = "ALLOCATABLE";
2934 1 : break;
2935 2 : case OMP_DEFAULTMAP_CAT_POINTER:
2936 2 : pcategory = "POINTER";
2937 2 : break;
2938 : default: gcc_unreachable ();
2939 : }
2940 6 : if (i == OMP_DEFAULTMAP_CAT_UNCATEGORIZED)
2941 4 : gfc_error ("DEFAULTMAP at %C but prior DEFAULTMAP with "
2942 : "unspecified category");
2943 : else
2944 9 : gfc_error ("DEFAULTMAP at %C but prior DEFAULTMAP for "
2945 : "category %s", pcategory);
2946 13 : goto error;
2947 : }
2948 : }
2949 165 : c->defaultmap[category] = behavior;
2950 165 : if (gfc_match (")") != MATCH_YES)
2951 : break;
2952 165 : continue;
2953 165 : }
2954 4526 : if ((mask & OMP_CLAUSE_DEFAULT)
2955 3559 : && (m = gfc_match_dupl_check (c->default_sharing
2956 : == OMP_DEFAULT_UNKNOWN, "default",
2957 : true)) != MATCH_NO)
2958 : {
2959 1012 : if (m == MATCH_ERROR)
2960 6 : goto error;
2961 1006 : if (gfc_match ("none") == MATCH_YES)
2962 596 : c->default_sharing = OMP_DEFAULT_NONE;
2963 410 : else if (openacc)
2964 : {
2965 225 : if (gfc_match ("present") == MATCH_YES)
2966 195 : c->default_sharing = OMP_DEFAULT_PRESENT;
2967 : }
2968 : else
2969 : {
2970 185 : if (gfc_match ("firstprivate") == MATCH_YES)
2971 8 : c->default_sharing = OMP_DEFAULT_FIRSTPRIVATE;
2972 177 : else if (gfc_match ("private") == MATCH_YES)
2973 24 : c->default_sharing = OMP_DEFAULT_PRIVATE;
2974 153 : else if (gfc_match ("shared") == MATCH_YES)
2975 153 : c->default_sharing = OMP_DEFAULT_SHARED;
2976 : }
2977 1006 : if (c->default_sharing == OMP_DEFAULT_UNKNOWN)
2978 : {
2979 30 : if (openacc)
2980 30 : gfc_error ("Expected NONE or PRESENT in DEFAULT clause "
2981 : "at %C");
2982 : else
2983 0 : gfc_error ("Expected NONE, FIRSTPRIVATE, PRIVATE or SHARED "
2984 : "in DEFAULT clause at %C");
2985 30 : goto error;
2986 : }
2987 976 : if (gfc_match (" )") != MATCH_YES)
2988 9 : goto error;
2989 967 : continue;
2990 : }
2991 2855 : if ((mask & OMP_CLAUSE_DELETE)
2992 345 : && gfc_match ("delete ( ") == MATCH_YES
2993 2855 : && gfc_match_omp_map_clause (&c->lists[OMP_LIST_MAP],
2994 : OMP_MAP_RELEASE, true,
2995 : allow_derived))
2996 308 : continue;
2997 : /* DOACROSS: match 'doacross' and 'depend' with sink/source.
2998 : DEPEND: match 'depend' but not sink/source. */
2999 2239 : m = MATCH_NO;
3000 2239 : if (((mask & OMP_CLAUSE_DOACROSS)
3001 383 : && gfc_match ("doacross ( ") == MATCH_YES)
3002 2595 : || (((mask & OMP_CLAUSE_DEPEND) || (mask & OMP_CLAUSE_DOACROSS))
3003 1598 : && (m = gfc_match ("depend ( ")) == MATCH_YES))
3004 : {
3005 1100 : bool has_omp_all_memory;
3006 1100 : bool is_depend = m == MATCH_YES;
3007 1100 : gfc_namespace *ns_iter = NULL, *ns_curr = gfc_current_ns;
3008 1100 : match m_it = MATCH_NO;
3009 1100 : if (is_depend)
3010 1073 : m_it = gfc_match_iterator (&ns_iter, false);
3011 1073 : if (m_it == MATCH_ERROR)
3012 : break;
3013 1095 : if (m_it == MATCH_YES && gfc_match (" , ") != MATCH_YES)
3014 : break;
3015 1095 : m = MATCH_YES;
3016 1095 : gfc_omp_depend_doacross_op depend_op = OMP_DEPEND_OUT;
3017 1095 : if (gfc_match ("inoutset") == MATCH_YES)
3018 : depend_op = OMP_DEPEND_INOUTSET;
3019 1083 : else if (gfc_match ("inout") == MATCH_YES)
3020 : depend_op = OMP_DEPEND_INOUT;
3021 991 : else if (gfc_match ("in") == MATCH_YES)
3022 : depend_op = OMP_DEPEND_IN;
3023 704 : else if (gfc_match ("out") == MATCH_YES)
3024 : depend_op = OMP_DEPEND_OUT;
3025 442 : else if (gfc_match ("mutexinoutset") == MATCH_YES)
3026 : depend_op = OMP_DEPEND_MUTEXINOUTSET;
3027 424 : else if (gfc_match ("depobj") == MATCH_YES)
3028 : depend_op = OMP_DEPEND_DEPOBJ;
3029 387 : else if (gfc_match ("source") == MATCH_YES)
3030 : {
3031 143 : if (m_it == MATCH_YES)
3032 : {
3033 1 : gfc_error ("ITERATOR may not be combined with SOURCE "
3034 : "at %C");
3035 17 : goto error;
3036 : }
3037 142 : if (!(mask & OMP_CLAUSE_DOACROSS))
3038 : {
3039 1 : gfc_error ("SOURCE at %C not permitted as dependence-type"
3040 : " for this directive");
3041 1 : goto error;
3042 : }
3043 141 : if (c->doacross_source)
3044 : {
3045 0 : gfc_error ("Duplicated clause with SOURCE dependence-type"
3046 : " at %C");
3047 0 : goto error;
3048 : }
3049 141 : gfc_gobble_whitespace ();
3050 141 : m = gfc_match (": ");
3051 141 : if (m != MATCH_YES && !is_depend)
3052 : {
3053 1 : gfc_error ("Expected %<:%> at %C");
3054 1 : goto error;
3055 : }
3056 140 : if (gfc_match (")") != MATCH_YES
3057 146 : && !(m == MATCH_YES
3058 6 : && gfc_match ("omp_cur_iteration )") == MATCH_YES))
3059 : {
3060 2 : gfc_error ("Expected %<)%> or %<omp_cur_iteration)%> "
3061 : "at %C");
3062 2 : goto error;
3063 : }
3064 138 : if (is_depend)
3065 130 : gfc_warning (OPT_Wdeprecated_openmp,
3066 : "%<source%> modifier with %<depend%> clause "
3067 : "at %L deprecated since OpenMP 5.2, use with "
3068 : "%<doacross%>", &old_loc);
3069 138 : c->doacross_source = true;
3070 138 : c->depend_source = is_depend;
3071 1078 : continue;
3072 : }
3073 244 : else if (gfc_match ("sink ") == MATCH_YES)
3074 : {
3075 244 : if (!(mask & OMP_CLAUSE_DOACROSS))
3076 : {
3077 2 : gfc_error ("SINK at %C not permitted as dependence-type "
3078 : "for this directive");
3079 2 : goto error;
3080 : }
3081 242 : if (gfc_match (": ") != MATCH_YES)
3082 : {
3083 1 : gfc_error ("Expected %<:%> at %C");
3084 1 : goto error;
3085 : }
3086 241 : if (m_it == MATCH_YES)
3087 : {
3088 0 : gfc_error ("ITERATOR may not be combined with SINK "
3089 : "at %C");
3090 0 : goto error;
3091 : }
3092 241 : if (is_depend)
3093 226 : gfc_warning (OPT_Wdeprecated_openmp,
3094 : "%<sink%> modifier with %<depend%> clause at "
3095 : "%L deprecated since OpenMP 5.2, use with "
3096 : "%<doacross%>", &old_loc);
3097 241 : m = gfc_match_omp_doacross_sink (&c->lists[OMP_LIST_DEPEND],
3098 : is_depend);
3099 241 : if (m == MATCH_YES)
3100 238 : continue;
3101 3 : goto error;
3102 : }
3103 : else
3104 : m = MATCH_NO;
3105 708 : if (!(mask & OMP_CLAUSE_DEPEND))
3106 : {
3107 0 : gfc_error ("Expected dependence-type SINK or SOURCE at %C");
3108 0 : goto error;
3109 : }
3110 708 : head = NULL;
3111 708 : if (ns_iter)
3112 40 : gfc_current_ns = ns_iter;
3113 708 : if (m == MATCH_YES)
3114 708 : m = gfc_match_omp_variable_list (" : ",
3115 : &c->lists[OMP_LIST_DEPEND],
3116 : false, NULL, &head, true,
3117 : false, &has_omp_all_memory);
3118 708 : if (m != MATCH_YES)
3119 2 : goto error;
3120 706 : gfc_current_ns = ns_curr;
3121 706 : if (has_omp_all_memory && depend_op != OMP_DEPEND_INOUT
3122 21 : && depend_op != OMP_DEPEND_OUT)
3123 : {
3124 4 : gfc_error ("%<omp_all_memory%> used with DEPEND kind "
3125 : "other than OUT or INOUT at %C");
3126 4 : goto error;
3127 : }
3128 702 : gfc_omp_namelist *n;
3129 1435 : for (n = *head; n; n = n->next)
3130 : {
3131 733 : n->u.depend_doacross_op = depend_op;
3132 733 : n->u2.ns = ns_iter;
3133 733 : if (ns_iter)
3134 39 : ns_iter->refs++;
3135 : }
3136 702 : continue;
3137 702 : }
3138 1160 : if ((mask & OMP_CLAUSE_DESTROY)
3139 1139 : && gfc_match_omp_variable_list ("destroy (",
3140 : &c->lists[OMP_LIST_DESTROY],
3141 : true) == MATCH_YES)
3142 21 : continue;
3143 1244 : if ((mask & OMP_CLAUSE_DETACH)
3144 164 : && !openacc
3145 127 : && !c->detach
3146 1244 : && gfc_match_omp_detach (&c->detach) == MATCH_YES)
3147 126 : continue;
3148 1029 : if ((mask & OMP_CLAUSE_DETACH)
3149 38 : && openacc
3150 37 : && gfc_match ("detach ( ") == MATCH_YES
3151 1029 : && gfc_match_omp_map_clause (&c->lists[OMP_LIST_MAP],
3152 : OMP_MAP_DETACH, false,
3153 : allow_derived))
3154 37 : continue;
3155 991 : if ((mask & OMP_CLAUSE_DEVICEPTR)
3156 87 : && gfc_match ("deviceptr ( ") == MATCH_YES
3157 993 : && gfc_match_omp_map_clause (&c->lists[OMP_LIST_MAP],
3158 : OMP_MAP_FORCE_DEVICEPTR, false,
3159 : allow_derived))
3160 36 : continue;
3161 1010 : if ((mask & OMP_CLAUSE_DEVICE_TYPE)
3162 919 : && gfc_match_dupl_check (c->device_type == OMP_DEVICE_TYPE_UNSET,
3163 : "device_type", true) == MATCH_YES)
3164 : {
3165 92 : if (gfc_match ("host") == MATCH_YES)
3166 32 : c->device_type = OMP_DEVICE_TYPE_HOST;
3167 60 : else if (gfc_match ("nohost") == MATCH_YES)
3168 21 : c->device_type = OMP_DEVICE_TYPE_NOHOST;
3169 39 : else if (gfc_match ("any") == MATCH_YES)
3170 38 : c->device_type = OMP_DEVICE_TYPE_ANY;
3171 : else
3172 : {
3173 1 : gfc_error ("Expected HOST, NOHOST or ANY at %C");
3174 1 : break;
3175 : }
3176 91 : if (gfc_match (" )") != MATCH_YES)
3177 : break;
3178 91 : continue;
3179 : }
3180 875 : if ((mask & OMP_CLAUSE_DEVICE_RESIDENT)
3181 876 : && gfc_match_omp_variable_list
3182 49 : ("device_resident (",
3183 : &c->lists[OMP_LIST_DEVICE_RESIDENT], true) == MATCH_YES)
3184 48 : continue;
3185 1091 : if ((mask & OMP_CLAUSE_DEVICE)
3186 703 : && openacc
3187 314 : && gfc_match ("device ( ") == MATCH_YES
3188 1092 : && gfc_match_omp_map_clause (&c->lists[OMP_LIST_MAP],
3189 : OMP_MAP_FORCE_TO, true,
3190 : /* allow_derived = */ true))
3191 312 : continue;
3192 467 : if ((mask & OMP_CLAUSE_DEVICE)
3193 391 : && !openacc
3194 856 : && ((m = gfc_match_dupl_check (!c->device, "device", true))
3195 : != MATCH_NO))
3196 : {
3197 349 : if (m == MATCH_ERROR)
3198 0 : goto error;
3199 349 : c->ancestor = false;
3200 349 : if (gfc_match ("device_num : ") == MATCH_YES)
3201 : {
3202 18 : if (gfc_match ("%e )", &c->device) != MATCH_YES)
3203 : {
3204 1 : gfc_error ("Expected integer expression at %C");
3205 1 : break;
3206 : }
3207 : }
3208 331 : else if (gfc_match ("ancestor : ") == MATCH_YES)
3209 : {
3210 45 : bool has_requires = false;
3211 45 : c->ancestor = true;
3212 82 : for (gfc_namespace *ns = gfc_current_ns; ns; ns = ns->parent)
3213 80 : if (ns->omp_requires & OMP_REQ_REVERSE_OFFLOAD)
3214 : {
3215 : has_requires = true;
3216 : break;
3217 : }
3218 45 : if (!has_requires)
3219 : {
3220 2 : gfc_error ("%<ancestor%> device modifier not "
3221 : "preceded by %<requires%> directive "
3222 : "with %<reverse_offload%> clause at %C");
3223 5 : break;
3224 : }
3225 43 : locus old_loc2 = gfc_current_locus;
3226 43 : if (gfc_match ("%e )", &c->device) == MATCH_YES)
3227 : {
3228 43 : int device = 0;
3229 43 : if (!gfc_extract_int (c->device, &device) && device != 1)
3230 : {
3231 1 : gfc_current_locus = old_loc2;
3232 1 : gfc_error ("the %<device%> clause expression must "
3233 : "evaluate to %<1%> at %C");
3234 1 : break;
3235 : }
3236 : }
3237 : else
3238 : {
3239 0 : gfc_error ("Expected integer expression at %C");
3240 0 : break;
3241 : }
3242 : }
3243 286 : else if (gfc_match ("%e )", &c->device) != MATCH_YES)
3244 : {
3245 13 : gfc_error ("Expected integer expression or a single device-"
3246 : "modifier %<device_num%> or %<ancestor%> at %C");
3247 13 : break;
3248 : }
3249 332 : continue;
3250 332 : }
3251 118 : if ((mask & OMP_CLAUSE_DIST_SCHEDULE)
3252 97 : && c->dist_sched_kind == OMP_SCHED_NONE
3253 215 : && gfc_match ("dist_schedule ( static") == MATCH_YES)
3254 : {
3255 97 : m = MATCH_NO;
3256 97 : c->dist_sched_kind = OMP_SCHED_STATIC;
3257 97 : m = gfc_match (" , %e )", &c->dist_chunk_size);
3258 97 : if (m != MATCH_YES)
3259 14 : m = gfc_match_char (')');
3260 14 : if (m != MATCH_YES)
3261 : {
3262 0 : c->dist_sched_kind = OMP_SCHED_NONE;
3263 0 : gfc_current_locus = old_loc;
3264 : }
3265 : else
3266 97 : continue;
3267 : }
3268 32 : if ((mask & OMP_CLAUSE_DYN_GROUPPRIVATE)
3269 21 : && gfc_match_dupl_check (!c->dyn_groupprivate,
3270 : "dyn_groupprivate", true) == MATCH_YES)
3271 : {
3272 12 : if (gfc_match ("fallback ( abort ) : ") == MATCH_YES)
3273 1 : c->fallback = OMP_FALLBACK_ABORT;
3274 11 : else if (gfc_match ("fallback ( default_mem ) : ") == MATCH_YES)
3275 1 : c->fallback = OMP_FALLBACK_DEFAULT_MEM;
3276 10 : else if (gfc_match ("fallback ( null ) : ") == MATCH_YES)
3277 1 : c->fallback = OMP_FALLBACK_NULL;
3278 12 : if (gfc_match_expr (&c->dyn_groupprivate) != MATCH_YES)
3279 0 : return MATCH_ERROR;
3280 12 : if (gfc_match (" )") != MATCH_YES)
3281 1 : goto error;
3282 11 : continue;
3283 : }
3284 : break;
3285 90 : case 'e':
3286 90 : if ((mask & OMP_CLAUSE_ENTER))
3287 : {
3288 90 : m = gfc_match_omp_to_link ("enter (", &c->lists[OMP_LIST_ENTER]);
3289 90 : if (m == MATCH_ERROR)
3290 0 : goto error;
3291 90 : if (m == MATCH_YES)
3292 90 : continue;
3293 : }
3294 : break;
3295 2309 : case 'f':
3296 2358 : if ((mask & OMP_CLAUSE_FAIL)
3297 2309 : && (m = gfc_match_dupl_check (c->fail == OMP_MEMORDER_UNSET,
3298 : "fail", true)) != MATCH_NO)
3299 : {
3300 58 : if (m == MATCH_ERROR)
3301 3 : goto error;
3302 55 : if (gfc_match ("seq_cst") == MATCH_YES)
3303 6 : c->fail = OMP_MEMORDER_SEQ_CST;
3304 49 : else if (gfc_match ("acquire") == MATCH_YES)
3305 14 : c->fail = OMP_MEMORDER_ACQUIRE;
3306 35 : else if (gfc_match ("relaxed") == MATCH_YES)
3307 30 : c->fail = OMP_MEMORDER_RELAXED;
3308 : else
3309 : {
3310 5 : gfc_error ("Expected SEQ_CST, ACQUIRE or RELAXED at %C");
3311 5 : break;
3312 : }
3313 50 : if (gfc_match (" )") != MATCH_YES)
3314 1 : goto error;
3315 49 : continue;
3316 : }
3317 2294 : if ((mask & OMP_CLAUSE_FILTER)
3318 2251 : && (m = gfc_match_dupl_check (!c->filter, "filter", true,
3319 : &c->filter)) != MATCH_NO)
3320 : {
3321 44 : if (m == MATCH_ERROR)
3322 1 : goto error;
3323 43 : continue;
3324 : }
3325 2271 : if ((mask & OMP_CLAUSE_FINAL)
3326 2207 : && (m = gfc_match_dupl_check (!c->final_expr, "final", true,
3327 : &c->final_expr)) != MATCH_NO)
3328 : {
3329 64 : if (m == MATCH_ERROR)
3330 0 : goto error;
3331 64 : continue;
3332 : }
3333 2169 : if ((mask & OMP_CLAUSE_FINALIZE)
3334 2143 : && (m = gfc_match_dupl_check (!c->finalize, "finalize"))
3335 : != MATCH_NO)
3336 : {
3337 26 : if (m == MATCH_ERROR)
3338 0 : goto error;
3339 26 : c->finalize = true;
3340 26 : continue;
3341 : }
3342 3155 : if ((mask & OMP_CLAUSE_FIRSTPRIVATE)
3343 2117 : && gfc_match_omp_variable_list ("firstprivate (",
3344 : &c->lists[OMP_LIST_FIRSTPRIVATE],
3345 : true) == MATCH_YES)
3346 1038 : continue;
3347 2080 : if ((mask & OMP_CLAUSE_FROM)
3348 1079 : && gfc_match_motion_var_list ("from (", &c->lists[OMP_LIST_FROM],
3349 : &head) == MATCH_YES)
3350 1001 : continue;
3351 143 : if ((mask & OMP_CLAUSE_FULL)
3352 78 : && (m = gfc_match_dupl_check (!c->full, "full")) != MATCH_NO)
3353 : {
3354 65 : if (m == MATCH_ERROR)
3355 0 : goto error;
3356 65 : c->full = true;
3357 65 : continue;
3358 : }
3359 : break;
3360 1231 : case 'g':
3361 2423 : if ((mask & OMP_CLAUSE_GANG)
3362 1231 : && (m = gfc_match_dupl_check (!c->gang, "gang")) != MATCH_NO)
3363 : {
3364 1197 : if (m == MATCH_ERROR)
3365 0 : goto error;
3366 1197 : c->gang = true;
3367 1197 : m = match_oacc_clause_gwv (c, GOMP_DIM_GANG);
3368 1197 : if (m == MATCH_ERROR)
3369 : {
3370 5 : gfc_current_locus = old_loc;
3371 5 : break;
3372 : }
3373 1192 : continue;
3374 : }
3375 68 : if ((mask & OMP_CLAUSE_GRAINSIZE)
3376 34 : && (m = gfc_match_dupl_check (!c->grainsize, "grainsize", true))
3377 : != MATCH_NO)
3378 : {
3379 34 : if (m == MATCH_ERROR)
3380 0 : goto error;
3381 34 : if (gfc_match ("strict : ") == MATCH_YES)
3382 1 : c->grainsize_strict = true;
3383 34 : if (gfc_match (" %e )", &c->grainsize) != MATCH_YES)
3384 0 : goto error;
3385 34 : continue;
3386 : }
3387 : break;
3388 465 : case 'h':
3389 513 : if ((mask & OMP_CLAUSE_HAS_DEVICE_ADDR)
3390 513 : && gfc_match_omp_variable_list
3391 48 : ("has_device_addr (", &c->lists[OMP_LIST_HAS_DEVICE_ADDR],
3392 : false, NULL, NULL, true) == MATCH_YES)
3393 48 : continue;
3394 460 : if ((mask & OMP_CLAUSE_HINT)
3395 417 : && (m = gfc_match_dupl_check (!c->hint, "hint", true, &c->hint))
3396 : != MATCH_NO)
3397 : {
3398 43 : if (m == MATCH_ERROR)
3399 0 : goto error;
3400 43 : continue;
3401 : }
3402 374 : if ((mask & OMP_CLAUSE_ASSUMPTIONS)
3403 374 : && gfc_match ("holds ( ") == MATCH_YES)
3404 : {
3405 19 : gfc_expr *e;
3406 19 : if (gfc_match ("%e )", &e) != MATCH_YES)
3407 0 : goto error;
3408 19 : if (c->assume == NULL)
3409 12 : c->assume = gfc_get_omp_assumptions ();
3410 19 : gfc_expr_list *el = XCNEW (gfc_expr_list);
3411 19 : el->expr = e;
3412 19 : el->next = c->assume->holds;
3413 19 : c->assume->holds = el;
3414 19 : continue;
3415 19 : }
3416 709 : if ((mask & OMP_CLAUSE_HOST)
3417 355 : && gfc_match ("host ( ") == MATCH_YES
3418 710 : && gfc_match_omp_map_clause (&c->lists[OMP_LIST_MAP],
3419 : OMP_MAP_FORCE_FROM, true,
3420 : /* allow_derived = */ true))
3421 354 : continue;
3422 : break;
3423 2125 : case 'i':
3424 2148 : if ((mask & OMP_CLAUSE_IF_PRESENT)
3425 2125 : && (m = gfc_match_dupl_check (!c->if_present, "if_present"))
3426 : != MATCH_NO)
3427 : {
3428 23 : if (m == MATCH_ERROR)
3429 0 : goto error;
3430 23 : c->if_present = true;
3431 23 : continue;
3432 : }
3433 2102 : if ((mask & OMP_CLAUSE_IF)
3434 2102 : && (m = gfc_match_dupl_check (!c->if_expr, "if", true))
3435 : != MATCH_NO)
3436 : {
3437 1353 : if (m == MATCH_ERROR)
3438 12 : goto error;
3439 1341 : if (!openacc)
3440 : {
3441 : /* This should match the enum gfc_omp_if_kind order. */
3442 : static const char *ifs[OMP_IF_LAST] = {
3443 : "cancel : %e )",
3444 : "parallel : %e )",
3445 : "simd : %e )",
3446 : "task : %e )",
3447 : "taskloop : %e )",
3448 : "target : %e )",
3449 : "target data : %e )",
3450 : "target update : %e )",
3451 : "target enter data : %e )",
3452 : "target exit data : %e )" };
3453 : int i;
3454 4907 : for (i = 0; i < OMP_IF_LAST; i++)
3455 4503 : if (c->if_exprs[i] == NULL
3456 4503 : && gfc_match (ifs[i], &c->if_exprs[i]) == MATCH_YES)
3457 : break;
3458 542 : if (i < OMP_IF_LAST)
3459 138 : continue;
3460 : }
3461 1203 : if (gfc_match (" %e )", &c->if_expr) == MATCH_YES)
3462 1198 : continue;
3463 5 : goto error;
3464 : }
3465 866 : if ((mask & OMP_CLAUSE_IN_REDUCTION)
3466 749 : && gfc_match_omp_clause_reduction (pc, c, openacc, allow_derived,
3467 : openmp_target) == MATCH_YES)
3468 117 : continue;
3469 657 : if ((mask & OMP_CLAUSE_INBRANCH)
3470 632 : && (m = gfc_match_dupl_check (!c->inbranch && !c->notinbranch,
3471 : "inbranch")) != MATCH_NO)
3472 : {
3473 25 : if (m == MATCH_ERROR)
3474 0 : goto error;
3475 25 : c->inbranch = true;
3476 25 : continue;
3477 : }
3478 849 : if ((mask & OMP_CLAUSE_INDEPENDENT)
3479 607 : && (m = gfc_match_dupl_check (!c->independent, "independent"))
3480 : != MATCH_NO)
3481 : {
3482 242 : if (m == MATCH_ERROR)
3483 0 : goto error;
3484 242 : c->independent = true;
3485 242 : continue;
3486 : }
3487 365 : if ((mask & OMP_CLAUSE_INDIRECT)
3488 365 : && (m = gfc_match_dupl_check (!c->indirect, "indirect"))
3489 : != MATCH_NO)
3490 : {
3491 61 : if (m == MATCH_ERROR)
3492 5 : goto error;
3493 60 : gfc_expr *indirect_expr = NULL;
3494 60 : m = gfc_match (" ( %e )", &indirect_expr);
3495 60 : if (m == MATCH_YES)
3496 : {
3497 13 : if (!gfc_resolve_expr (indirect_expr)
3498 13 : || indirect_expr->ts.type != BT_LOGICAL
3499 23 : || indirect_expr->expr_type != EXPR_CONSTANT)
3500 : {
3501 4 : gfc_error ("INDIRECT clause at %C requires a constant "
3502 : "logical expression");
3503 4 : gfc_free_expr (indirect_expr);
3504 4 : goto error;
3505 : }
3506 9 : c->indirect = indirect_expr->value.logical;
3507 9 : gfc_free_expr (indirect_expr);
3508 : }
3509 : else
3510 47 : c->indirect = 1;
3511 56 : continue;
3512 56 : }
3513 304 : if ((mask & OMP_CLAUSE_INIT)
3514 304 : && gfc_match ("init ( ") == MATCH_YES)
3515 : {
3516 108 : m = gfc_match_omp_init (&c->lists[OMP_LIST_INIT]);
3517 108 : if (m == MATCH_YES)
3518 63 : continue;
3519 45 : goto error;
3520 : }
3521 196 : if ((mask & OMP_CLAUSE_INTEROP)
3522 196 : && (m = gfc_match_dupl_check (!c->lists[OMP_LIST_INTEROP],
3523 : "interop", true)) != MATCH_NO)
3524 : {
3525 : /* Note: the interop objects are saved in reverse order to match
3526 : the order in C/C++. */
3527 125 : if (m == MATCH_YES
3528 63 : && (gfc_match_omp_variable_list ("",
3529 : &c->lists[OMP_LIST_INTEROP],
3530 : false, NULL, NULL, false,
3531 : false, NULL, false, true)
3532 : == MATCH_YES))
3533 62 : continue;
3534 1 : goto error;
3535 : }
3536 253 : if ((mask & OMP_CLAUSE_IS_DEVICE_PTR)
3537 253 : && gfc_match_omp_variable_list
3538 120 : ("is_device_ptr (",
3539 : &c->lists[OMP_LIST_IS_DEVICE_PTR], false) == MATCH_YES)
3540 120 : continue;
3541 : break;
3542 2334 : case 'l':
3543 2334 : if ((mask & OMP_CLAUSE_LASTPRIVATE)
3544 2334 : && gfc_match ("lastprivate ( ") == MATCH_YES)
3545 : {
3546 1431 : bool conditional = gfc_match ("conditional : ") == MATCH_YES;
3547 1431 : head = NULL;
3548 1431 : if (gfc_match_omp_variable_list ("",
3549 : &c->lists[OMP_LIST_LASTPRIVATE],
3550 : false, NULL, &head) == MATCH_YES)
3551 : {
3552 1431 : gfc_omp_namelist *n;
3553 3737 : for (n = *head; n; n = n->next)
3554 2306 : n->u.lastprivate_conditional = conditional;
3555 1431 : continue;
3556 1431 : }
3557 0 : gfc_current_locus = old_loc;
3558 0 : break;
3559 : }
3560 903 : end_colon = false;
3561 903 : head = NULL;
3562 903 : if ((mask & OMP_CLAUSE_LINEAR)
3563 903 : && gfc_match ("linear (") == MATCH_YES)
3564 : {
3565 836 : bool old_linear_modifier = false;
3566 836 : gfc_omp_linear_op linear_op = OMP_LINEAR_DEFAULT;
3567 836 : gfc_expr *step = NULL;
3568 836 : locus saved_loc = gfc_current_locus;
3569 :
3570 836 : if (gfc_match_omp_variable_list (" ref (",
3571 : &c->lists[OMP_LIST_LINEAR],
3572 : false, NULL, &head)
3573 : == MATCH_YES)
3574 : {
3575 : linear_op = OMP_LINEAR_REF;
3576 : old_linear_modifier = true;
3577 : }
3578 808 : else if (gfc_match_omp_variable_list (" val (",
3579 : &c->lists[OMP_LIST_LINEAR],
3580 : false, NULL, &head)
3581 : == MATCH_YES)
3582 : {
3583 : linear_op = OMP_LINEAR_VAL;
3584 : old_linear_modifier = true;
3585 : }
3586 797 : else if (gfc_match_omp_variable_list (" uval (",
3587 : &c->lists[OMP_LIST_LINEAR],
3588 : false, NULL, &head)
3589 : == MATCH_YES)
3590 : {
3591 : linear_op = OMP_LINEAR_UVAL;
3592 : old_linear_modifier = true;
3593 : }
3594 788 : else if (gfc_match_omp_variable_list ("",
3595 : &c->lists[OMP_LIST_LINEAR],
3596 : false, &end_colon, &head)
3597 : == MATCH_YES)
3598 : linear_op = OMP_LINEAR_DEFAULT;
3599 : else
3600 : {
3601 2 : gfc_current_locus = old_loc;
3602 2 : break;
3603 : }
3604 : if (linear_op != OMP_LINEAR_DEFAULT)
3605 : {
3606 48 : if (gfc_match (" :") == MATCH_YES)
3607 31 : end_colon = true;
3608 17 : else if (gfc_match (" )") != MATCH_YES)
3609 : {
3610 0 : gfc_free_omp_namelist (*head, OMP_LIST_LINEAR);
3611 0 : gfc_current_locus = old_loc;
3612 0 : *head = NULL;
3613 0 : break;
3614 : }
3615 : }
3616 834 : gfc_gobble_whitespace ();
3617 834 : if (old_linear_modifier && end_colon)
3618 : {
3619 31 : if (gfc_match (" %e )", &step) != MATCH_YES)
3620 : {
3621 1 : gfc_free_omp_namelist (*head, OMP_LIST_LINEAR);
3622 1 : gfc_current_locus = old_loc;
3623 1 : *head = NULL;
3624 5 : goto error;
3625 : }
3626 : }
3627 833 : if (old_linear_modifier)
3628 : {
3629 47 : char var_names[512]{};
3630 47 : int count, offset = 0;
3631 106 : for (gfc_omp_namelist *n = *head; n; n = n->next)
3632 : {
3633 59 : if (!n->next)
3634 47 : count = snprintf (var_names + offset,
3635 47 : sizeof (var_names) - offset,
3636 47 : "%s", n->sym->name);
3637 : else
3638 12 : count = snprintf (var_names + offset,
3639 12 : sizeof (var_names) - offset,
3640 12 : "%s, ", n->sym->name);
3641 59 : if (count < 0 || count >= ((int)sizeof (var_names))
3642 59 : - offset)
3643 : {
3644 0 : snprintf (var_names, 512, "%s, ..., ",
3645 0 : (*head)->sym->name);
3646 0 : while (n->next)
3647 : n = n->next;
3648 0 : offset = strlen (var_names);
3649 0 : snprintf (var_names + offset,
3650 0 : sizeof (var_names) - offset,
3651 0 : "%s", n->sym->name);
3652 0 : break;
3653 : }
3654 59 : offset += count;
3655 : }
3656 47 : char *var_names_for_warn = var_names;
3657 47 : const char *op_name;
3658 47 : switch (linear_op)
3659 : {
3660 : case OMP_LINEAR_REF: op_name = "ref"; break;
3661 10 : case OMP_LINEAR_VAL: op_name = "val"; break;
3662 9 : case OMP_LINEAR_UVAL: op_name = "uval"; break;
3663 0 : default: gcc_unreachable ();
3664 : }
3665 47 : gfc_warning (OPT_Wdeprecated_openmp,
3666 : "Specification of the list items as "
3667 : "arguments to the modifiers at %L is "
3668 : "deprecated; since OpenMP 5.2, use "
3669 : "%<linear(%s : %s%s)%>", &saved_loc,
3670 : var_names_for_warn, op_name,
3671 47 : step == nullptr ? "" : ", step(...)");
3672 : }
3673 786 : else if (end_colon)
3674 : {
3675 713 : bool has_error = false;
3676 : bool has_modifiers = false;
3677 : bool has_step = false;
3678 713 : bool duplicate_step = false;
3679 713 : bool duplicate_mod = false;
3680 713 : while (true)
3681 : {
3682 713 : old_loc = gfc_current_locus;
3683 713 : bool close_paren = gfc_match ("val )") == MATCH_YES;
3684 713 : if (close_paren || gfc_match ("val , ") == MATCH_YES)
3685 : {
3686 17 : if (linear_op != OMP_LINEAR_DEFAULT)
3687 : {
3688 : duplicate_mod = true;
3689 : break;
3690 : }
3691 16 : linear_op = OMP_LINEAR_VAL;
3692 16 : has_modifiers = true;
3693 16 : if (close_paren)
3694 : break;
3695 10 : continue;
3696 : }
3697 696 : close_paren = gfc_match ("uval )") == MATCH_YES;
3698 696 : if (close_paren || gfc_match ("uval , ") == MATCH_YES)
3699 : {
3700 7 : if (linear_op != OMP_LINEAR_DEFAULT)
3701 : {
3702 : duplicate_mod = true;
3703 : break;
3704 : }
3705 7 : linear_op = OMP_LINEAR_UVAL;
3706 7 : has_modifiers = true;
3707 7 : if (close_paren)
3708 : break;
3709 2 : continue;
3710 : }
3711 689 : close_paren = gfc_match ("ref )") == MATCH_YES;
3712 689 : if (close_paren || gfc_match ("ref , ") == MATCH_YES)
3713 : {
3714 16 : if (linear_op != OMP_LINEAR_DEFAULT)
3715 : {
3716 : duplicate_mod = true;
3717 : break;
3718 : }
3719 15 : linear_op = OMP_LINEAR_REF;
3720 15 : has_modifiers = true;
3721 15 : if (close_paren)
3722 : break;
3723 7 : continue;
3724 : }
3725 673 : close_paren = (gfc_match ("step ( %e ) )", &step)
3726 : == MATCH_YES);
3727 684 : if (close_paren
3728 673 : || gfc_match ("step ( %e ) , ", &step) == MATCH_YES)
3729 : {
3730 38 : if (has_step)
3731 : {
3732 : duplicate_step = true;
3733 : break;
3734 : }
3735 37 : has_modifiers = has_step = true;
3736 37 : if (close_paren)
3737 : break;
3738 11 : continue;
3739 : }
3740 635 : if (!has_modifiers
3741 635 : && gfc_match ("%e )", &step) == MATCH_YES)
3742 : {
3743 635 : if ((step->expr_type == EXPR_FUNCTION
3744 634 : || step->expr_type == EXPR_VARIABLE)
3745 31 : && strcmp (step->symtree->name, "step") == 0)
3746 : {
3747 1 : gfc_current_locus = old_loc;
3748 1 : gfc_match ("step (");
3749 1 : has_error = true;
3750 : }
3751 : break;
3752 : }
3753 : has_error = true;
3754 : break;
3755 : }
3756 49 : if (duplicate_mod || duplicate_step)
3757 : {
3758 3 : gfc_error ("Multiple %qs modifiers specified at %C",
3759 : duplicate_mod ? "linear" : "step");
3760 3 : has_error = true;
3761 : }
3762 683 : if (has_error)
3763 : {
3764 4 : gfc_free_omp_namelist (*head, OMP_LIST_LINEAR);
3765 4 : *head = NULL;
3766 4 : goto error;
3767 : }
3768 : }
3769 829 : if (step == NULL)
3770 : {
3771 130 : step = gfc_get_constant_expr (BT_INTEGER,
3772 : gfc_default_integer_kind,
3773 : &old_loc);
3774 130 : mpz_set_si (step->value.integer, 1);
3775 : }
3776 829 : (*head)->expr = step;
3777 829 : if (linear_op != OMP_LINEAR_DEFAULT || old_linear_modifier)
3778 176 : for (gfc_omp_namelist *n = *head; n; n = n->next)
3779 : {
3780 94 : n->u.linear.op = linear_op;
3781 94 : n->u.linear.old_modifier = old_linear_modifier;
3782 : }
3783 829 : continue;
3784 829 : }
3785 71 : if ((mask & OMP_CLAUSE_LINK)
3786 67 : && openacc
3787 75 : && (gfc_match_oacc_clause_link ("link (",
3788 : &c->lists[OMP_LIST_LINK])
3789 : == MATCH_YES))
3790 4 : continue;
3791 110 : else if ((mask & OMP_CLAUSE_LINK)
3792 63 : && !openacc
3793 122 : && (gfc_match_omp_to_link ("link (",
3794 : &c->lists[OMP_LIST_LINK])
3795 : == MATCH_YES))
3796 47 : continue;
3797 28 : if ((mask & OMP_CLAUSE_LOCAL)
3798 16 : && (gfc_match_omp_to_link ("local (", &c->lists[OMP_LIST_LOCAL])
3799 : == MATCH_YES))
3800 12 : continue;
3801 : break;
3802 5929 : case 'm':
3803 5929 : if ((mask & OMP_CLAUSE_MAP)
3804 5929 : && gfc_match ("map ( ") == MATCH_YES)
3805 : {
3806 5837 : locus old_loc2 = gfc_current_locus;
3807 5837 : int always_modifier = 0;
3808 5837 : int close_modifier = 0;
3809 5837 : int present_modifier = 0;
3810 5837 : int mapper_modifier = 0;
3811 5837 : int iterator_modifier = 0;
3812 5837 : gfc_namespace *ns_iter = NULL, *ns_curr = gfc_current_ns;
3813 5837 : locus second_always_locus = old_loc2;
3814 5837 : locus second_close_locus = old_loc2;
3815 5837 : locus second_mapper_locus = old_loc2;
3816 5837 : locus second_present_locus = old_loc2;
3817 5837 : char mapper_id[GFC_MAX_SYMBOL_LEN + 1] = { '\0' };
3818 5837 : locus second_iterator_locus = old_loc2;
3819 :
3820 6501 : for (;;)
3821 : {
3822 6169 : locus current_locus = gfc_current_locus;
3823 6169 : if (gfc_match ("always ") == MATCH_YES)
3824 : {
3825 148 : if (always_modifier++ == 1)
3826 5 : second_always_locus = current_locus;
3827 : }
3828 6021 : else if (gfc_match ("close ") == MATCH_YES)
3829 : {
3830 69 : if (close_modifier++ == 1)
3831 5 : second_close_locus = current_locus;
3832 : }
3833 5952 : else if (gfc_match ("present ") == MATCH_YES)
3834 : {
3835 67 : if (present_modifier++ == 1)
3836 4 : second_present_locus = current_locus;
3837 : }
3838 5885 : else if (gfc_match ("mapper ( ") == MATCH_YES)
3839 : {
3840 6 : if (mapper_modifier++ == 1)
3841 0 : second_mapper_locus = current_locus;
3842 6 : m = gfc_match (" %n ) ", mapper_id);
3843 6 : if (m != MATCH_YES)
3844 0 : goto error;
3845 6 : if (strcmp (mapper_id, "default") == 0)
3846 3 : mapper_id[0] = '\0';
3847 : }
3848 5879 : else if (gfc_match_iterator (&ns_iter, true) == MATCH_YES)
3849 : {
3850 42 : if (iterator_modifier++ == 1)
3851 1 : second_iterator_locus = current_locus;
3852 : }
3853 : else
3854 : break;
3855 332 : if (gfc_match (", ") != MATCH_YES)
3856 62 : gfc_warning (OPT_Wdeprecated_openmp,
3857 : "The specification of modifiers without "
3858 : "comma separators for the %<map%> clause "
3859 : "at %C has been deprecated since "
3860 : "OpenMP 5.2");
3861 332 : }
3862 :
3863 5837 : gfc_omp_map_op map_op = default_map_op;
3864 5837 : int always_present_modifier
3865 5837 : = always_modifier && present_modifier;
3866 :
3867 5837 : if (gfc_match ("alloc : ") == MATCH_YES)
3868 799 : map_op = (present_modifier ? OMP_MAP_PRESENT_ALLOC
3869 : : OMP_MAP_ALLOC);
3870 5038 : else if (gfc_match ("tofrom : ") == MATCH_YES)
3871 954 : map_op = (always_present_modifier ? OMP_MAP_ALWAYS_PRESENT_TOFROM
3872 950 : : present_modifier ? OMP_MAP_PRESENT_TOFROM
3873 945 : : always_modifier ? OMP_MAP_ALWAYS_TOFROM
3874 : : OMP_MAP_TOFROM);
3875 4084 : else if (gfc_match ("to : ") == MATCH_YES)
3876 1812 : map_op = (always_present_modifier ? OMP_MAP_ALWAYS_PRESENT_TO
3877 1806 : : present_modifier ? OMP_MAP_PRESENT_TO
3878 1794 : : always_modifier ? OMP_MAP_ALWAYS_TO
3879 : : OMP_MAP_TO);
3880 2272 : else if (gfc_match ("from : ") == MATCH_YES)
3881 1654 : map_op = (always_present_modifier ? OMP_MAP_ALWAYS_PRESENT_FROM
3882 1650 : : present_modifier ? OMP_MAP_PRESENT_FROM
3883 1645 : : always_modifier ? OMP_MAP_ALWAYS_FROM
3884 : : OMP_MAP_FROM);
3885 618 : else if (gfc_match ("release : ") == MATCH_YES)
3886 : map_op = OMP_MAP_RELEASE;
3887 564 : else if (gfc_match ("delete : ") == MATCH_YES)
3888 : map_op = OMP_MAP_DELETE;
3889 : else
3890 : {
3891 487 : gfc_current_locus = old_loc2;
3892 487 : always_modifier = 0;
3893 487 : close_modifier = 0;
3894 487 : mapper_modifier = 0;
3895 : }
3896 :
3897 1565 : if (always_modifier > 1)
3898 : {
3899 5 : gfc_error ("too many %<always%> modifiers at %L",
3900 : &second_always_locus);
3901 24 : break;
3902 : }
3903 5832 : if (close_modifier > 1)
3904 : {
3905 4 : gfc_error ("too many %<close%> modifiers at %L",
3906 : &second_close_locus);
3907 4 : break;
3908 : }
3909 5828 : if (present_modifier > 1)
3910 : {
3911 4 : gfc_error ("too many %<present%> modifiers at %L",
3912 : &second_present_locus);
3913 4 : break;
3914 : }
3915 5824 : if (mapper_modifier > 1)
3916 : {
3917 0 : gfc_error ("too many %<mapper%> modifiers at %L",
3918 : &second_mapper_locus);
3919 0 : break;
3920 : }
3921 5824 : if (iterator_modifier > 1)
3922 : {
3923 1 : gfc_error ("too many %<iterator%> modifiers at %L",
3924 : &second_iterator_locus);
3925 1 : break;
3926 : }
3927 :
3928 5823 : head = NULL;
3929 5823 : if (ns_iter)
3930 40 : gfc_current_ns = ns_iter;
3931 5823 : m = gfc_match_omp_variable_list ("", &c->lists[OMP_LIST_MAP],
3932 : false, NULL, &head, true, true);
3933 5823 : gfc_current_ns = ns_curr;
3934 5823 : if (m == MATCH_YES)
3935 : {
3936 5818 : gfc_omp_namelist *n;
3937 13218 : for (n = *head; n; n = n->next)
3938 : {
3939 7400 : n->u.map.op = map_op;
3940 7400 : if (mapper_id[0] != '\0')
3941 : {
3942 3 : n->u3.udm = gfc_get_omp_namelist_udm ();
3943 3 : n->u3.udm->requested_mapper_id
3944 3 : = gfc_get_string ("%s", mapper_id);
3945 : }
3946 7400 : n->u2.ns = ns_iter;
3947 7400 : if (ns_iter)
3948 42 : ns_iter->refs++;
3949 : }
3950 5818 : continue;
3951 5818 : }
3952 5 : gfc_current_locus = old_loc;
3953 5 : break;
3954 : }
3955 126 : if ((mask & OMP_CLAUSE_MERGEABLE)
3956 92 : && (m = gfc_match_dupl_check (!c->mergeable, "mergeable"))
3957 : != MATCH_NO)
3958 : {
3959 34 : if (m == MATCH_ERROR)
3960 0 : goto error;
3961 34 : c->mergeable = true;
3962 34 : continue;
3963 : }
3964 111 : if ((mask & OMP_CLAUSE_MESSAGE)
3965 58 : && (m = gfc_match_dupl_check (!c->message, "message", true,
3966 : &c->message)) != MATCH_NO)
3967 : {
3968 58 : if (m == MATCH_ERROR)
3969 5 : goto error;
3970 53 : continue;
3971 : }
3972 : break;
3973 2910 : case 'n':
3974 2962 : if ((mask & OMP_CLAUSE_NO_CREATE)
3975 1343 : && gfc_match ("no_create ( ") == MATCH_YES
3976 2962 : && gfc_match_omp_map_clause (&c->lists[OMP_LIST_MAP],
3977 : OMP_MAP_IF_PRESENT, true,
3978 : allow_derived))
3979 52 : continue;
3980 2859 : if ((mask & OMP_CLAUSE_ASSUMPTIONS)
3981 2884 : && (m = gfc_match_dupl_check (!c->assume
3982 26 : || !c->assume->no_openmp_constructs,
3983 : "no_openmp_constructs")) != MATCH_NO)
3984 : {
3985 2 : if (m == MATCH_ERROR)
3986 1 : goto error;
3987 1 : if (c->assume == NULL)
3988 0 : c->assume = gfc_get_omp_assumptions ();
3989 1 : c->assume->no_openmp_constructs = true;
3990 1 : continue;
3991 : }
3992 2869 : if ((mask & OMP_CLAUSE_ASSUMPTIONS)
3993 2880 : && (m = gfc_match_dupl_check (!c->assume
3994 24 : || !c->assume->no_openmp_routines,
3995 : "no_openmp_routines")) != MATCH_NO)
3996 : {
3997 13 : if (m == MATCH_ERROR)
3998 0 : goto error;
3999 13 : if (c->assume == NULL)
4000 12 : c->assume = gfc_get_omp_assumptions ();
4001 13 : c->assume->no_openmp_routines = true;
4002 13 : continue;
4003 : }
4004 2847 : if ((mask & OMP_CLAUSE_ASSUMPTIONS)
4005 2853 : && (m = gfc_match_dupl_check (!c->assume || !c->assume->no_openmp,
4006 : "no_openmp")) != MATCH_NO)
4007 : {
4008 4 : if (m == MATCH_ERROR)
4009 0 : goto error;
4010 4 : if (c->assume == NULL)
4011 4 : c->assume = gfc_get_omp_assumptions ();
4012 4 : c->assume->no_openmp = true;
4013 4 : continue;
4014 : }
4015 2845 : if ((mask & OMP_CLAUSE_ASSUMPTIONS)
4016 2846 : && (m = gfc_match_dupl_check (!c->assume
4017 7 : || !c->assume->no_parallelism,
4018 : "no_parallelism")) != MATCH_NO)
4019 : {
4020 6 : if (m == MATCH_ERROR)
4021 0 : goto error;
4022 6 : if (c->assume == NULL)
4023 6 : c->assume = gfc_get_omp_assumptions ();
4024 6 : c->assume->no_parallelism = true;
4025 6 : continue;
4026 : }
4027 :
4028 2843 : if ((mask & OMP_CLAUSE_NOVARIANTS)
4029 2833 : && (m = gfc_match_dupl_check (!c->novariants, "novariants", true,
4030 : &c->novariants))
4031 : != MATCH_NO)
4032 : {
4033 12 : if (m == MATCH_ERROR)
4034 2 : goto error;
4035 10 : continue;
4036 : }
4037 2834 : if ((mask & OMP_CLAUSE_NOCONTEXT)
4038 2821 : && (m = gfc_match_dupl_check (!c->nocontext, "nocontext", true,
4039 : &c->nocontext))
4040 : != MATCH_NO)
4041 : {
4042 15 : if (m == MATCH_ERROR)
4043 2 : goto error;
4044 13 : continue;
4045 : }
4046 2820 : if ((mask & OMP_CLAUSE_NOGROUP)
4047 2806 : && (m = gfc_match_dupl_check (!c->nogroup, "nogroup"))
4048 : != MATCH_NO)
4049 : {
4050 14 : if (m == MATCH_ERROR)
4051 0 : goto error;
4052 14 : c->nogroup = true;
4053 14 : continue;
4054 : }
4055 2942 : if ((mask & OMP_CLAUSE_NOHOST)
4056 2792 : && (m = gfc_match_dupl_check (!c->nohost, "nohost")) != MATCH_NO)
4057 : {
4058 151 : if (m == MATCH_ERROR)
4059 1 : goto error;
4060 150 : c->nohost = true;
4061 150 : continue;
4062 : }
4063 2683 : if ((mask & OMP_CLAUSE_NOTEMPORAL)
4064 2641 : && gfc_match_omp_variable_list ("nontemporal (",
4065 : &c->lists[OMP_LIST_NONTEMPORAL],
4066 : true) == MATCH_YES)
4067 42 : continue;
4068 2623 : if ((mask & OMP_CLAUSE_NOTINBRANCH)
4069 2600 : && (m = gfc_match_dupl_check (!c->notinbranch && !c->inbranch,
4070 : "notinbranch")) != MATCH_NO)
4071 : {
4072 25 : if (m == MATCH_ERROR)
4073 1 : goto error;
4074 24 : c->notinbranch = true;
4075 24 : continue;
4076 : }
4077 2703 : if ((mask & OMP_CLAUSE_NOWAIT)
4078 2574 : && (m = gfc_match_dupl_check (!c->nowait, "nowait")) != MATCH_NO)
4079 : {
4080 132 : if (m == MATCH_ERROR)
4081 3 : goto error;
4082 129 : c->nowait = true;
4083 129 : continue;
4084 : }
4085 3124 : if ((mask & OMP_CLAUSE_NUM_GANGS)
4086 2442 : && (m = gfc_match_dupl_check (!c->num_gangs_expr, "num_gangs",
4087 : true)) != MATCH_NO)
4088 : {
4089 686 : if (m == MATCH_ERROR)
4090 2 : goto error;
4091 684 : if (gfc_match (" %e )", &c->num_gangs_expr) != MATCH_YES)
4092 2 : goto error;
4093 682 : continue;
4094 : }
4095 1782 : if ((mask & OMP_CLAUSE_NUM_TASKS)
4096 1756 : && (m = gfc_match_dupl_check (!c->num_tasks, "num_tasks", true))
4097 : != MATCH_NO)
4098 : {
4099 26 : if (m == MATCH_ERROR)
4100 0 : goto error;
4101 26 : if (gfc_match ("strict : ") == MATCH_YES)
4102 1 : c->num_tasks_strict = true;
4103 26 : if (gfc_match (" %e )", &c->num_tasks) != MATCH_YES)
4104 0 : goto error;
4105 26 : continue;
4106 : }
4107 1857 : if ((mask & OMP_CLAUSE_NUM_TEAMS)
4108 1730 : && (m = gfc_match_dupl_check (!c->num_teams_upper, "num_teams",
4109 : true)) != MATCH_NO)
4110 : {
4111 127 : if (m == MATCH_ERROR)
4112 0 : goto error;
4113 127 : if (gfc_match ("%e ", &c->num_teams_upper) != MATCH_YES)
4114 0 : goto error;
4115 127 : if (gfc_peek_ascii_char () == ':')
4116 : {
4117 21 : c->num_teams_lower = c->num_teams_upper;
4118 21 : c->num_teams_upper = NULL;
4119 21 : if (gfc_match (": %e ", &c->num_teams_upper) != MATCH_YES)
4120 0 : goto error;
4121 : }
4122 127 : if (gfc_match (") ") != MATCH_YES)
4123 0 : goto error;
4124 127 : continue;
4125 : }
4126 2565 : if ((mask & OMP_CLAUSE_NUM_THREADS)
4127 1603 : && (m = gfc_match_dupl_check (!c->num_threads, "num_threads", true,
4128 : &c->num_threads)) != MATCH_NO)
4129 : {
4130 962 : if (m == MATCH_ERROR)
4131 0 : goto error;
4132 962 : continue;
4133 : }
4134 1240 : if ((mask & OMP_CLAUSE_NUM_WORKERS)
4135 641 : && (m = gfc_match_dupl_check (!c->num_workers_expr, "num_workers",
4136 : true, &c->num_workers_expr))
4137 : != MATCH_NO)
4138 : {
4139 603 : if (m == MATCH_ERROR)
4140 4 : goto error;
4141 599 : continue;
4142 : }
4143 : break;
4144 591 : case 'o':
4145 591 : if ((mask & OMP_CLAUSE_ORDERED)
4146 591 : && (m = gfc_match_dupl_check (!c->ordered, "ordered"))
4147 : != MATCH_NO)
4148 : {
4149 343 : if (m == MATCH_ERROR)
4150 0 : goto error;
4151 343 : gfc_expr *cexpr = NULL;
4152 343 : m = gfc_match (" ( %e )", &cexpr);
4153 :
4154 343 : c->ordered = true;
4155 343 : if (m == MATCH_YES)
4156 : {
4157 144 : int ordered = 0;
4158 144 : if (gfc_extract_int (cexpr, &ordered, -1))
4159 0 : ordered = 0;
4160 144 : else if (ordered <= 0)
4161 : {
4162 0 : gfc_error_now ("ORDERED clause argument not"
4163 : " constant positive integer at %C");
4164 0 : ordered = 0;
4165 : }
4166 144 : c->orderedc = ordered;
4167 144 : gfc_free_expr (cexpr);
4168 144 : continue;
4169 144 : }
4170 :
4171 199 : continue;
4172 199 : }
4173 482 : if ((mask & OMP_CLAUSE_ORDER)
4174 248 : && (m = gfc_match_dupl_check (!c->order_concurrent, "order", true))
4175 : != MATCH_NO)
4176 : {
4177 247 : if (m == MATCH_ERROR)
4178 10 : goto error;
4179 237 : if (gfc_match (" reproducible : concurrent )") == MATCH_YES)
4180 55 : c->order_reproducible = true;
4181 182 : else if (gfc_match (" concurrent )") == MATCH_YES)
4182 : ;
4183 50 : else if (gfc_match (" unconstrained : concurrent )") == MATCH_YES)
4184 47 : c->order_unconstrained = true;
4185 : else
4186 : {
4187 3 : gfc_error ("Expected ORDER(CONCURRENT) at %C "
4188 : "with optional %<reproducible%> or "
4189 : "%<unconstrained%> modifier");
4190 3 : goto error;
4191 : }
4192 234 : c->order_concurrent = true;
4193 234 : continue;
4194 : }
4195 : break;
4196 3101 : case 'p':
4197 3101 : if (mask & OMP_CLAUSE_PARTIAL)
4198 : {
4199 276 : if ((m = gfc_match_dupl_check (!c->partial, "partial"))
4200 : != MATCH_NO)
4201 : {
4202 276 : int expr;
4203 276 : if (m == MATCH_ERROR)
4204 0 : goto error;
4205 :
4206 276 : c->partial = -1;
4207 :
4208 276 : gfc_expr *cexpr = NULL;
4209 276 : m = gfc_match (" ( %e )", &cexpr);
4210 276 : if (m == MATCH_NO)
4211 : ;
4212 251 : else if (m == MATCH_YES
4213 251 : && !gfc_extract_int (cexpr, &expr, -1)
4214 502 : && expr > 0)
4215 247 : c->partial = expr;
4216 : else
4217 4 : gfc_error_now ("PARTIAL clause argument not constant "
4218 : "positive integer at %C");
4219 276 : gfc_free_expr (cexpr);
4220 276 : continue;
4221 276 : }
4222 : }
4223 2894 : if ((mask & OMP_CLAUSE_COPY)
4224 877 : && gfc_match ("pcopy ( ") == MATCH_YES
4225 2895 : && gfc_match_omp_map_clause (&c->lists[OMP_LIST_MAP],
4226 : OMP_MAP_TOFROM, true, allow_derived))
4227 69 : continue;
4228 2830 : if ((mask & OMP_CLAUSE_COPYIN)
4229 1910 : && gfc_match ("pcopyin ( ") == MATCH_YES
4230 2830 : && gfc_match_omp_map_clause (&c->lists[OMP_LIST_MAP],
4231 : OMP_MAP_TO, true, allow_derived))
4232 74 : continue;
4233 2755 : if ((mask & OMP_CLAUSE_COPYOUT)
4234 735 : && gfc_match ("pcopyout ( ") == MATCH_YES
4235 2755 : && gfc_match_omp_map_clause (&c->lists[OMP_LIST_MAP],
4236 : OMP_MAP_FROM, true, allow_derived))
4237 73 : continue;
4238 2624 : if ((mask & OMP_CLAUSE_CREATE)
4239 672 : && gfc_match ("pcreate ( ") == MATCH_YES
4240 2624 : && gfc_match_omp_map_clause (&c->lists[OMP_LIST_MAP],
4241 : OMP_MAP_ALLOC, true, allow_derived))
4242 15 : continue;
4243 3010 : if ((mask & OMP_CLAUSE_PRESENT)
4244 647 : && gfc_match ("present ( ") == MATCH_YES
4245 3012 : && gfc_match_omp_map_clause (&c->lists[OMP_LIST_MAP],
4246 : OMP_MAP_FORCE_PRESENT, false,
4247 : allow_derived))
4248 416 : continue;
4249 2201 : if ((mask & OMP_CLAUSE_COPY)
4250 231 : && gfc_match ("present_or_copy ( ") == MATCH_YES
4251 2201 : && gfc_match_omp_map_clause (&c->lists[OMP_LIST_MAP],
4252 : OMP_MAP_TOFROM, true,
4253 : allow_derived))
4254 23 : continue;
4255 2195 : if ((mask & OMP_CLAUSE_COPYIN)
4256 1309 : && gfc_match ("present_or_copyin ( ") == MATCH_YES
4257 2195 : && gfc_match_omp_map_clause (&c->lists[OMP_LIST_MAP],
4258 : OMP_MAP_TO, true, allow_derived))
4259 40 : continue;
4260 2150 : if ((mask & OMP_CLAUSE_COPYOUT)
4261 173 : && gfc_match ("present_or_copyout ( ") == MATCH_YES
4262 2150 : && gfc_match_omp_map_clause (&c->lists[OMP_LIST_MAP],
4263 : OMP_MAP_FROM, true, allow_derived))
4264 35 : continue;
4265 2108 : if ((mask & OMP_CLAUSE_CREATE)
4266 143 : && gfc_match ("present_or_create ( ") == MATCH_YES
4267 2108 : && gfc_match_omp_map_clause (&c->lists[OMP_LIST_MAP],
4268 : OMP_MAP_ALLOC, true, allow_derived))
4269 28 : continue;
4270 2086 : if ((mask & OMP_CLAUSE_PRIORITY)
4271 2052 : && (m = gfc_match_dupl_check (!c->priority, "priority", true,
4272 : &c->priority)) != MATCH_NO)
4273 : {
4274 34 : if (m == MATCH_ERROR)
4275 0 : goto error;
4276 34 : continue;
4277 : }
4278 3959 : if ((mask & OMP_CLAUSE_PRIVATE)
4279 2018 : && gfc_match_omp_variable_list ("private (",
4280 : &c->lists[OMP_LIST_PRIVATE],
4281 : true) == MATCH_YES)
4282 1941 : continue;
4283 141 : if ((mask & OMP_CLAUSE_PROC_BIND)
4284 141 : && (m = gfc_match_dupl_check ((c->proc_bind
4285 64 : == OMP_PROC_BIND_UNKNOWN),
4286 : "proc_bind", true)) != MATCH_NO)
4287 : {
4288 64 : if (m == MATCH_ERROR)
4289 0 : goto error;
4290 64 : if (gfc_match ("primary )") == MATCH_YES)
4291 1 : c->proc_bind = OMP_PROC_BIND_PRIMARY;
4292 63 : else if (gfc_match ("master )") == MATCH_YES)
4293 : {
4294 9 : gfc_warning (OPT_Wdeprecated_openmp,
4295 : "%<master%> affinity policy at %C deprecated "
4296 : "since OpenMP 5.1, use %<primary%>");
4297 9 : c->proc_bind = OMP_PROC_BIND_MASTER;
4298 : }
4299 54 : else if (gfc_match ("spread )") == MATCH_YES)
4300 53 : c->proc_bind = OMP_PROC_BIND_SPREAD;
4301 1 : else if (gfc_match ("close )") == MATCH_YES)
4302 1 : c->proc_bind = OMP_PROC_BIND_CLOSE;
4303 : else
4304 0 : goto error;
4305 64 : continue;
4306 : }
4307 : break;
4308 4583 : case 'r':
4309 5073 : if ((mask & OMP_CLAUSE_ATOMIC)
4310 4583 : && (m = gfc_match_dupl_atomic ((c->atomic_op
4311 : == GFC_OMP_ATOMIC_UNSET),
4312 : "read")) != MATCH_NO)
4313 : {
4314 490 : if (m == MATCH_ERROR)
4315 0 : goto error;
4316 490 : c->atomic_op = GFC_OMP_ATOMIC_READ;
4317 490 : continue;
4318 : }
4319 8149 : if ((mask & OMP_CLAUSE_REDUCTION)
4320 4093 : && gfc_match_omp_clause_reduction (pc, c, openacc,
4321 : allow_derived) == MATCH_YES)
4322 4056 : continue;
4323 47 : if ((mask & OMP_CLAUSE_MEMORDER)
4324 65 : && (m = gfc_match_dupl_memorder ((c->memorder
4325 28 : == OMP_MEMORDER_UNSET),
4326 : "relaxed")) != MATCH_NO)
4327 : {
4328 10 : if (m == MATCH_ERROR)
4329 0 : goto error;
4330 10 : c->memorder = OMP_MEMORDER_RELAXED;
4331 10 : continue;
4332 : }
4333 44 : if ((mask & OMP_CLAUSE_MEMORDER)
4334 45 : && (m = gfc_match_dupl_memorder ((c->memorder
4335 18 : == OMP_MEMORDER_UNSET),
4336 : "release")) != MATCH_NO)
4337 : {
4338 18 : if (m == MATCH_ERROR)
4339 1 : goto error;
4340 17 : c->memorder = OMP_MEMORDER_RELEASE;
4341 17 : continue;
4342 : }
4343 : break;
4344 3036 : case 's':
4345 3129 : if ((mask & OMP_CLAUSE_SAFELEN)
4346 3036 : && (m = gfc_match_dupl_check (!c->safelen_expr, "safelen",
4347 : true, &c->safelen_expr))
4348 : != MATCH_NO)
4349 : {
4350 93 : if (m == MATCH_ERROR)
4351 0 : goto error;
4352 93 : continue;
4353 : }
4354 2943 : if ((mask & OMP_CLAUSE_SCHEDULE)
4355 2943 : && (m = gfc_match_dupl_check (c->sched_kind == OMP_SCHED_NONE,
4356 : "schedule", true)) != MATCH_NO)
4357 : {
4358 809 : if (m == MATCH_ERROR)
4359 0 : goto error;
4360 809 : int nmodifiers = 0;
4361 809 : locus old_loc2 = gfc_current_locus;
4362 827 : do
4363 : {
4364 818 : if (gfc_match ("simd") == MATCH_YES)
4365 : {
4366 18 : c->sched_simd = true;
4367 18 : nmodifiers++;
4368 : }
4369 800 : else if (gfc_match ("monotonic") == MATCH_YES)
4370 : {
4371 30 : c->sched_monotonic = true;
4372 30 : nmodifiers++;
4373 : }
4374 770 : else if (gfc_match ("nonmonotonic") == MATCH_YES)
4375 : {
4376 35 : c->sched_nonmonotonic = true;
4377 35 : nmodifiers++;
4378 : }
4379 : else
4380 : {
4381 735 : if (nmodifiers)
4382 0 : gfc_current_locus = old_loc2;
4383 : break;
4384 : }
4385 92 : if (nmodifiers == 1
4386 83 : && gfc_match (" , ") == MATCH_YES)
4387 9 : continue;
4388 74 : else if (gfc_match (" : ") == MATCH_YES)
4389 : break;
4390 0 : gfc_current_locus = old_loc2;
4391 0 : break;
4392 : }
4393 : while (1);
4394 809 : if (gfc_match ("static") == MATCH_YES)
4395 425 : c->sched_kind = OMP_SCHED_STATIC;
4396 384 : else if (gfc_match ("dynamic") == MATCH_YES)
4397 164 : c->sched_kind = OMP_SCHED_DYNAMIC;
4398 220 : else if (gfc_match ("guided") == MATCH_YES)
4399 127 : c->sched_kind = OMP_SCHED_GUIDED;
4400 93 : else if (gfc_match ("runtime") == MATCH_YES)
4401 85 : c->sched_kind = OMP_SCHED_RUNTIME;
4402 8 : else if (gfc_match ("auto") == MATCH_YES)
4403 8 : c->sched_kind = OMP_SCHED_AUTO;
4404 809 : if (c->sched_kind != OMP_SCHED_NONE)
4405 : {
4406 809 : m = MATCH_NO;
4407 809 : if (c->sched_kind != OMP_SCHED_RUNTIME
4408 809 : && c->sched_kind != OMP_SCHED_AUTO)
4409 716 : m = gfc_match (" , %e )", &c->chunk_size);
4410 716 : if (m != MATCH_YES)
4411 299 : m = gfc_match_char (')');
4412 299 : if (m != MATCH_YES)
4413 0 : c->sched_kind = OMP_SCHED_NONE;
4414 : }
4415 809 : if (c->sched_kind != OMP_SCHED_NONE)
4416 809 : continue;
4417 : else
4418 0 : gfc_current_locus = old_loc;
4419 : }
4420 2317 : if ((mask & OMP_CLAUSE_SELF)
4421 335 : && !(mask & OMP_CLAUSE_HOST) /* OpenACC compute construct */
4422 2374 : && (m = gfc_match_dupl_check (!c->self_expr, "self"))
4423 : != MATCH_NO)
4424 : {
4425 186 : if (m == MATCH_ERROR)
4426 3 : goto error;
4427 183 : m = gfc_match (" ( %e )", &c->self_expr);
4428 183 : if (m == MATCH_ERROR)
4429 : {
4430 0 : gfc_current_locus = old_loc;
4431 0 : break;
4432 : }
4433 183 : else if (m == MATCH_NO)
4434 9 : c->self_expr = gfc_get_logical_expr (gfc_default_logical_kind,
4435 : NULL, true);
4436 183 : continue;
4437 : }
4438 2042 : if ((mask & OMP_CLAUSE_SELF)
4439 149 : && (mask & OMP_CLAUSE_HOST) /* OpenACC 'update' directive */
4440 95 : && gfc_match ("self ( ") == MATCH_YES
4441 2043 : && gfc_match_omp_map_clause (&c->lists[OMP_LIST_MAP],
4442 : OMP_MAP_FORCE_FROM, true,
4443 : /* allow_derived = */ true))
4444 94 : continue;
4445 2202 : if ((mask & OMP_CLAUSE_SEQ)
4446 1854 : && (m = gfc_match_dupl_check (!c->seq, "seq")) != MATCH_NO)
4447 : {
4448 348 : if (m == MATCH_ERROR)
4449 0 : goto error;
4450 348 : c->seq = true;
4451 348 : continue;
4452 : }
4453 1647 : if ((mask & OMP_CLAUSE_MEMORDER)
4454 1647 : && (m = gfc_match_dupl_memorder ((c->memorder
4455 141 : == OMP_MEMORDER_UNSET),
4456 : "seq_cst")) != MATCH_NO)
4457 : {
4458 141 : if (m == MATCH_ERROR)
4459 0 : goto error;
4460 141 : c->memorder = OMP_MEMORDER_SEQ_CST;
4461 141 : continue;
4462 : }
4463 2340 : if ((mask & OMP_CLAUSE_SHARED)
4464 1365 : && gfc_match_omp_variable_list ("shared (",
4465 : &c->lists[OMP_LIST_SHARED],
4466 : true) == MATCH_YES)
4467 975 : continue;
4468 508 : if ((mask & OMP_CLAUSE_SIMDLEN)
4469 390 : && (m = gfc_match_dupl_check (!c->simdlen_expr, "simdlen", true,
4470 : &c->simdlen_expr)) != MATCH_NO)
4471 : {
4472 118 : if (m == MATCH_ERROR)
4473 0 : goto error;
4474 118 : continue;
4475 : }
4476 294 : if ((mask & OMP_CLAUSE_SIMD)
4477 272 : && (m = gfc_match_dupl_check (!c->simd, "simd")) != MATCH_NO)
4478 : {
4479 22 : if (m == MATCH_ERROR)
4480 0 : goto error;
4481 22 : c->simd = true;
4482 22 : continue;
4483 : }
4484 289 : if ((mask & OMP_CLAUSE_SEVERITY)
4485 250 : && (m = gfc_match_dupl_check (!c->severity, "severity", true))
4486 : != MATCH_NO)
4487 : {
4488 45 : if (m == MATCH_ERROR)
4489 2 : goto error;
4490 43 : if (gfc_match ("fatal )") == MATCH_YES)
4491 10 : c->severity = OMP_SEVERITY_FATAL;
4492 33 : else if (gfc_match ("warning )") == MATCH_YES)
4493 29 : c->severity = OMP_SEVERITY_WARNING;
4494 : else
4495 : {
4496 4 : gfc_error ("Expected FATAL or WARNING in SEVERITY clause "
4497 : "at %C");
4498 4 : goto error;
4499 : }
4500 39 : continue;
4501 : }
4502 205 : if ((mask & OMP_CLAUSE_SIZES)
4503 205 : && ((m = gfc_match_dupl_check (!c->sizes_list, "sizes"))
4504 : != MATCH_NO))
4505 : {
4506 203 : if (m == MATCH_ERROR)
4507 0 : goto error;
4508 203 : m = match_omp_oacc_expr_list (" (", &c->sizes_list, false, true);
4509 203 : if (m == MATCH_ERROR)
4510 7 : goto error;
4511 196 : if (m == MATCH_YES)
4512 195 : continue;
4513 1 : gfc_error ("Expected %<(%> after %qs at %C", "sizes");
4514 1 : goto error;
4515 : }
4516 : break;
4517 1221 : case 't':
4518 1286 : if ((mask & OMP_CLAUSE_TASK_REDUCTION)
4519 1221 : && gfc_match_omp_clause_reduction (pc, c, openacc,
4520 : allow_derived) == MATCH_YES)
4521 65 : continue;
4522 1228 : if ((mask & OMP_CLAUSE_THREAD_LIMIT)
4523 1156 : && (m = gfc_match_dupl_check (!c->thread_limit, "thread_limit",
4524 : true, &c->thread_limit))
4525 : != MATCH_NO)
4526 : {
4527 72 : if (m == MATCH_ERROR)
4528 0 : goto error;
4529 72 : continue;
4530 : }
4531 1097 : if ((mask & OMP_CLAUSE_THREADS)
4532 1084 : && (m = gfc_match_dupl_check (!c->threads, "threads"))
4533 : != MATCH_NO)
4534 : {
4535 13 : if (m == MATCH_ERROR)
4536 0 : goto error;
4537 13 : c->threads = true;
4538 13 : continue;
4539 : }
4540 1268 : if ((mask & OMP_CLAUSE_TILE)
4541 221 : && !c->tile_list
4542 1292 : && match_omp_oacc_expr_list ("tile (", &c->tile_list,
4543 : true, false) == MATCH_YES)
4544 197 : continue;
4545 874 : if ((mask & OMP_CLAUSE_TO) && (mask & OMP_CLAUSE_LINK))
4546 : {
4547 : /* Declare target: 'to' is an alias for 'enter';
4548 : 'to' is deprecated since 5.2. */
4549 116 : m = gfc_match_omp_to_link ("to (", &c->lists[OMP_LIST_TO]);
4550 116 : if (m == MATCH_ERROR)
4551 0 : goto error;
4552 116 : if (m == MATCH_YES)
4553 : {
4554 116 : gfc_warning (OPT_Wdeprecated_openmp,
4555 : "%<to%> clause with %<declare target%> at %L "
4556 : "deprecated since OpenMP 5.2, use %<enter%>",
4557 : &old_loc);
4558 116 : continue;
4559 : }
4560 : }
4561 1486 : else if ((mask & OMP_CLAUSE_TO)
4562 758 : && gfc_match_motion_var_list ("to (", &c->lists[OMP_LIST_TO],
4563 : &head) == MATCH_YES)
4564 728 : continue;
4565 : break;
4566 1516 : case 'u':
4567 1574 : if ((mask & OMP_CLAUSE_UNIFORM)
4568 1516 : && gfc_match_omp_variable_list ("uniform (",
4569 : &c->lists[OMP_LIST_UNIFORM],
4570 : false) == MATCH_YES)
4571 58 : continue;
4572 1599 : if ((mask & OMP_CLAUSE_UNTIED)
4573 1458 : && (m = gfc_match_dupl_check (!c->untied, "untied")) != MATCH_NO)
4574 : {
4575 141 : if (m == MATCH_ERROR)
4576 0 : goto error;
4577 141 : c->untied = true;
4578 141 : continue;
4579 : }
4580 1561 : if ((mask & OMP_CLAUSE_ATOMIC)
4581 1317 : && (m = gfc_match_dupl_atomic ((c->atomic_op
4582 : == GFC_OMP_ATOMIC_UNSET),
4583 : "update")) != MATCH_NO)
4584 : {
4585 245 : if (m == MATCH_ERROR)
4586 1 : goto error;
4587 244 : c->atomic_op = GFC_OMP_ATOMIC_UPDATE;
4588 244 : continue;
4589 : }
4590 1094 : if ((mask & OMP_CLAUSE_USE)
4591 1072 : && gfc_match_omp_variable_list ("use (",
4592 : &c->lists[OMP_LIST_USE],
4593 : true) == MATCH_YES)
4594 22 : continue;
4595 1110 : if ((mask & OMP_CLAUSE_USE_DEVICE)
4596 1050 : && gfc_match_omp_variable_list ("use_device (",
4597 : &c->lists[OMP_LIST_USE_DEVICE],
4598 : true) == MATCH_YES)
4599 60 : continue;
4600 1153 : if ((mask & OMP_CLAUSE_USE_DEVICE_PTR)
4601 1918 : && gfc_match_omp_variable_list
4602 928 : ("use_device_ptr (",
4603 : &c->lists[OMP_LIST_USE_DEVICE_PTR], false) == MATCH_YES)
4604 163 : continue;
4605 1592 : if ((mask & OMP_CLAUSE_USE_DEVICE_ADDR)
4606 1592 : && gfc_match_omp_variable_list
4607 765 : ("use_device_addr (", &c->lists[OMP_LIST_USE_DEVICE_ADDR],
4608 : false, NULL, NULL, true) == MATCH_YES)
4609 765 : continue;
4610 114 : if ((mask & OMP_CLAUSE_USES_ALLOCATORS)
4611 62 : && (gfc_match ("uses_allocators ( ") == MATCH_YES))
4612 : {
4613 56 : if (gfc_match_omp_clause_uses_allocators (c) != MATCH_YES)
4614 4 : goto error;
4615 52 : continue;
4616 : }
4617 : break;
4618 1570 : case 'v':
4619 : /* VECTOR_LENGTH must be matched before VECTOR, because the latter
4620 : doesn't unconditionally match '('. */
4621 2139 : if ((mask & OMP_CLAUSE_VECTOR_LENGTH)
4622 1570 : && (m = gfc_match_dupl_check (!c->vector_length_expr,
4623 : "vector_length", true,
4624 : &c->vector_length_expr))
4625 : != MATCH_NO)
4626 : {
4627 573 : if (m == MATCH_ERROR)
4628 4 : goto error;
4629 569 : continue;
4630 : }
4631 1989 : if ((mask & OMP_CLAUSE_VECTOR)
4632 997 : && (m = gfc_match_dupl_check (!c->vector, "vector")) != MATCH_NO)
4633 : {
4634 995 : if (m == MATCH_ERROR)
4635 0 : goto error;
4636 995 : c->vector = true;
4637 995 : m = match_oacc_clause_gwv (c, GOMP_DIM_VECTOR);
4638 995 : if (m == MATCH_ERROR)
4639 3 : goto error;
4640 992 : continue;
4641 : }
4642 : break;
4643 1482 : case 'w':
4644 1482 : if ((mask & OMP_CLAUSE_WAIT)
4645 1482 : && gfc_match ("wait") == MATCH_YES)
4646 : {
4647 192 : m = match_omp_oacc_expr_list (" (", &c->wait_list, false, false);
4648 192 : if (m == MATCH_ERROR)
4649 9 : goto error;
4650 183 : else if (m == MATCH_NO)
4651 : {
4652 47 : gfc_expr *expr
4653 47 : = gfc_get_constant_expr (BT_INTEGER,
4654 : gfc_default_integer_kind,
4655 : &gfc_current_locus);
4656 47 : mpz_set_si (expr->value.integer, GOMP_ASYNC_NOVAL);
4657 47 : gfc_expr_list **expr_list = &c->wait_list;
4658 56 : while (*expr_list)
4659 9 : expr_list = &(*expr_list)->next;
4660 47 : *expr_list = gfc_get_expr_list ();
4661 47 : (*expr_list)->expr = expr;
4662 47 : needs_space = true;
4663 : }
4664 183 : continue;
4665 183 : }
4666 1303 : if ((mask & OMP_CLAUSE_WEAK)
4667 1290 : && (m = gfc_match_dupl_check (!c->weak, "weak"))
4668 : != MATCH_NO)
4669 : {
4670 14 : if (m == MATCH_ERROR)
4671 1 : goto error;
4672 13 : c->weak = true;
4673 13 : continue;
4674 : }
4675 2137 : if ((mask & OMP_CLAUSE_WORKER)
4676 1276 : && (m = gfc_match_dupl_check (!c->worker, "worker")) != MATCH_NO)
4677 : {
4678 864 : if (m == MATCH_ERROR)
4679 0 : goto error;
4680 864 : c->worker = true;
4681 864 : m = match_oacc_clause_gwv (c, GOMP_DIM_WORKER);
4682 864 : if (m == MATCH_ERROR)
4683 3 : goto error;
4684 861 : continue;
4685 : }
4686 824 : if ((mask & OMP_CLAUSE_ATOMIC)
4687 412 : && (m = gfc_match_dupl_atomic ((c->atomic_op
4688 : == GFC_OMP_ATOMIC_UNSET),
4689 : "write")) != MATCH_NO)
4690 : {
4691 412 : if (m == MATCH_ERROR)
4692 0 : goto error;
4693 412 : c->atomic_op = GFC_OMP_ATOMIC_WRITE;
4694 412 : continue;
4695 : }
4696 : break;
4697 : }
4698 : break;
4699 46212 : }
4700 :
4701 34525 : end:
4702 34270 : if (error || gfc_match_omp_eos () != MATCH_YES)
4703 : {
4704 531 : if (!gfc_error_flag_test ())
4705 137 : gfc_error ("Failed to match clause at %C");
4706 531 : gfc_free_omp_clauses (c);
4707 531 : return MATCH_ERROR;
4708 : }
4709 :
4710 33994 : *cp = c;
4711 33994 : return MATCH_YES;
4712 :
4713 255 : error:
4714 255 : error = true;
4715 255 : goto end;
4716 : }
4717 :
4718 :
4719 : #define OACC_PARALLEL_CLAUSES \
4720 : (omp_mask (OMP_CLAUSE_IF) | OMP_CLAUSE_ASYNC | OMP_CLAUSE_NUM_GANGS \
4721 : | OMP_CLAUSE_NUM_WORKERS | OMP_CLAUSE_VECTOR_LENGTH | OMP_CLAUSE_REDUCTION \
4722 : | OMP_CLAUSE_COPY | OMP_CLAUSE_COPYIN | OMP_CLAUSE_COPYOUT \
4723 : | OMP_CLAUSE_CREATE | OMP_CLAUSE_NO_CREATE | OMP_CLAUSE_PRESENT \
4724 : | OMP_CLAUSE_DEVICEPTR | OMP_CLAUSE_PRIVATE | OMP_CLAUSE_FIRSTPRIVATE \
4725 : | OMP_CLAUSE_DEFAULT | OMP_CLAUSE_WAIT | OMP_CLAUSE_ATTACH \
4726 : | OMP_CLAUSE_SELF)
4727 : #define OACC_KERNELS_CLAUSES \
4728 : (omp_mask (OMP_CLAUSE_IF) | OMP_CLAUSE_ASYNC | OMP_CLAUSE_NUM_GANGS \
4729 : | OMP_CLAUSE_NUM_WORKERS | OMP_CLAUSE_VECTOR_LENGTH | OMP_CLAUSE_DEVICEPTR \
4730 : | OMP_CLAUSE_COPY | OMP_CLAUSE_COPYIN | OMP_CLAUSE_COPYOUT \
4731 : | OMP_CLAUSE_CREATE | OMP_CLAUSE_NO_CREATE | OMP_CLAUSE_PRESENT \
4732 : | OMP_CLAUSE_DEFAULT | OMP_CLAUSE_WAIT | OMP_CLAUSE_ATTACH \
4733 : | OMP_CLAUSE_SELF)
4734 : #define OACC_SERIAL_CLAUSES \
4735 : (omp_mask (OMP_CLAUSE_IF) | OMP_CLAUSE_ASYNC | OMP_CLAUSE_REDUCTION \
4736 : | OMP_CLAUSE_COPY | OMP_CLAUSE_COPYIN | OMP_CLAUSE_COPYOUT \
4737 : | OMP_CLAUSE_CREATE | OMP_CLAUSE_NO_CREATE | OMP_CLAUSE_PRESENT \
4738 : | OMP_CLAUSE_DEVICEPTR | OMP_CLAUSE_PRIVATE | OMP_CLAUSE_FIRSTPRIVATE \
4739 : | OMP_CLAUSE_DEFAULT | OMP_CLAUSE_WAIT | OMP_CLAUSE_ATTACH \
4740 : | OMP_CLAUSE_SELF)
4741 : #define OACC_DATA_CLAUSES \
4742 : (omp_mask (OMP_CLAUSE_IF) | OMP_CLAUSE_DEVICEPTR | OMP_CLAUSE_COPY \
4743 : | OMP_CLAUSE_COPYIN | OMP_CLAUSE_COPYOUT | OMP_CLAUSE_CREATE \
4744 : | OMP_CLAUSE_NO_CREATE | OMP_CLAUSE_PRESENT | OMP_CLAUSE_ATTACH \
4745 : | OMP_CLAUSE_DEFAULT)
4746 : #define OACC_LOOP_CLAUSES \
4747 : (omp_mask (OMP_CLAUSE_COLLAPSE) | OMP_CLAUSE_GANG | OMP_CLAUSE_WORKER \
4748 : | OMP_CLAUSE_VECTOR | OMP_CLAUSE_SEQ | OMP_CLAUSE_INDEPENDENT \
4749 : | OMP_CLAUSE_PRIVATE | OMP_CLAUSE_REDUCTION | OMP_CLAUSE_AUTO \
4750 : | OMP_CLAUSE_TILE)
4751 : #define OACC_PARALLEL_LOOP_CLAUSES \
4752 : (OACC_LOOP_CLAUSES | OACC_PARALLEL_CLAUSES)
4753 : #define OACC_KERNELS_LOOP_CLAUSES \
4754 : (OACC_LOOP_CLAUSES | OACC_KERNELS_CLAUSES)
4755 : #define OACC_SERIAL_LOOP_CLAUSES \
4756 : (OACC_LOOP_CLAUSES | OACC_SERIAL_CLAUSES)
4757 : #define OACC_HOST_DATA_CLAUSES \
4758 : (omp_mask (OMP_CLAUSE_USE_DEVICE) \
4759 : | OMP_CLAUSE_IF \
4760 : | OMP_CLAUSE_IF_PRESENT)
4761 : #define OACC_DECLARE_CLAUSES \
4762 : (omp_mask (OMP_CLAUSE_COPY) | OMP_CLAUSE_COPYIN | OMP_CLAUSE_COPYOUT \
4763 : | OMP_CLAUSE_CREATE | OMP_CLAUSE_DEVICEPTR | OMP_CLAUSE_DEVICE_RESIDENT \
4764 : | OMP_CLAUSE_PRESENT \
4765 : | OMP_CLAUSE_LINK)
4766 : #define OACC_UPDATE_CLAUSES \
4767 : (omp_mask (OMP_CLAUSE_IF) | OMP_CLAUSE_ASYNC | OMP_CLAUSE_HOST \
4768 : | OMP_CLAUSE_DEVICE | OMP_CLAUSE_WAIT | OMP_CLAUSE_IF_PRESENT \
4769 : | OMP_CLAUSE_SELF)
4770 : #define OACC_ENTER_DATA_CLAUSES \
4771 : (omp_mask (OMP_CLAUSE_IF) | OMP_CLAUSE_ASYNC | OMP_CLAUSE_WAIT \
4772 : | OMP_CLAUSE_COPYIN | OMP_CLAUSE_CREATE | OMP_CLAUSE_ATTACH)
4773 : #define OACC_EXIT_DATA_CLAUSES \
4774 : (omp_mask (OMP_CLAUSE_IF) | OMP_CLAUSE_ASYNC | OMP_CLAUSE_WAIT \
4775 : | OMP_CLAUSE_COPYOUT | OMP_CLAUSE_DELETE | OMP_CLAUSE_FINALIZE \
4776 : | OMP_CLAUSE_DETACH)
4777 : #define OACC_WAIT_CLAUSES \
4778 : omp_mask (OMP_CLAUSE_ASYNC) | OMP_CLAUSE_IF
4779 : #define OACC_ROUTINE_CLAUSES \
4780 : (omp_mask (OMP_CLAUSE_GANG) | OMP_CLAUSE_WORKER | OMP_CLAUSE_VECTOR \
4781 : | OMP_CLAUSE_SEQ \
4782 : | OMP_CLAUSE_NOHOST)
4783 :
4784 :
4785 : static match
4786 11804 : match_acc (gfc_exec_op op, const omp_mask mask)
4787 : {
4788 11804 : gfc_omp_clauses *c;
4789 11804 : if (gfc_match_omp_clauses (&c, mask, false, false, true) != MATCH_YES)
4790 : return MATCH_ERROR;
4791 11599 : new_st.op = op;
4792 11599 : new_st.ext.omp_clauses = c;
4793 11599 : return MATCH_YES;
4794 : }
4795 :
4796 : match
4797 1378 : gfc_match_oacc_parallel_loop (void)
4798 : {
4799 1378 : return match_acc (EXEC_OACC_PARALLEL_LOOP, OACC_PARALLEL_LOOP_CLAUSES);
4800 : }
4801 :
4802 :
4803 : match
4804 2974 : gfc_match_oacc_parallel (void)
4805 : {
4806 2974 : return match_acc (EXEC_OACC_PARALLEL, OACC_PARALLEL_CLAUSES);
4807 : }
4808 :
4809 :
4810 : match
4811 129 : gfc_match_oacc_kernels_loop (void)
4812 : {
4813 129 : return match_acc (EXEC_OACC_KERNELS_LOOP, OACC_KERNELS_LOOP_CLAUSES);
4814 : }
4815 :
4816 :
4817 : match
4818 906 : gfc_match_oacc_kernels (void)
4819 : {
4820 906 : return match_acc (EXEC_OACC_KERNELS, OACC_KERNELS_CLAUSES);
4821 : }
4822 :
4823 :
4824 : match
4825 230 : gfc_match_oacc_serial_loop (void)
4826 : {
4827 230 : return match_acc (EXEC_OACC_SERIAL_LOOP, OACC_SERIAL_LOOP_CLAUSES);
4828 : }
4829 :
4830 :
4831 : match
4832 359 : gfc_match_oacc_serial (void)
4833 : {
4834 359 : return match_acc (EXEC_OACC_SERIAL, OACC_SERIAL_CLAUSES);
4835 : }
4836 :
4837 :
4838 : match
4839 689 : gfc_match_oacc_data (void)
4840 : {
4841 689 : return match_acc (EXEC_OACC_DATA, OACC_DATA_CLAUSES);
4842 : }
4843 :
4844 :
4845 : match
4846 65 : gfc_match_oacc_host_data (void)
4847 : {
4848 65 : return match_acc (EXEC_OACC_HOST_DATA, OACC_HOST_DATA_CLAUSES);
4849 : }
4850 :
4851 :
4852 : match
4853 3585 : gfc_match_oacc_loop (void)
4854 : {
4855 3585 : return match_acc (EXEC_OACC_LOOP, OACC_LOOP_CLAUSES);
4856 : }
4857 :
4858 :
4859 : match
4860 178 : gfc_match_oacc_declare (void)
4861 : {
4862 178 : gfc_omp_clauses *c;
4863 178 : gfc_omp_namelist *n;
4864 178 : gfc_namespace *ns = gfc_current_ns;
4865 178 : gfc_oacc_declare *new_oc;
4866 178 : bool module_var = false;
4867 178 : locus where = gfc_current_locus;
4868 :
4869 178 : if (gfc_match_omp_clauses (&c, OACC_DECLARE_CLAUSES, false, false, true)
4870 : != MATCH_YES)
4871 : return MATCH_ERROR;
4872 :
4873 262 : for (n = c->lists[OMP_LIST_DEVICE_RESIDENT]; n != NULL; n = n->next)
4874 90 : n->sym->attr.oacc_declare_device_resident = 1;
4875 :
4876 192 : for (n = c->lists[OMP_LIST_LINK]; n != NULL; n = n->next)
4877 20 : n->sym->attr.oacc_declare_link = 1;
4878 :
4879 318 : for (n = c->lists[OMP_LIST_MAP]; n != NULL; n = n->next)
4880 : {
4881 156 : gfc_symbol *s = n->sym;
4882 :
4883 156 : if (gfc_current_ns->proc_name
4884 156 : && gfc_current_ns->proc_name->attr.flavor == FL_MODULE)
4885 : {
4886 52 : if (n->u.map.op != OMP_MAP_ALLOC && n->u.map.op != OMP_MAP_TO)
4887 : {
4888 6 : gfc_error ("Invalid clause in module with !$ACC DECLARE at %L",
4889 : &where);
4890 6 : return MATCH_ERROR;
4891 : }
4892 :
4893 : module_var = true;
4894 : }
4895 :
4896 150 : if (s->attr.use_assoc)
4897 : {
4898 0 : gfc_error ("Variable is USE-associated with !$ACC DECLARE at %L",
4899 : &where);
4900 0 : return MATCH_ERROR;
4901 : }
4902 :
4903 150 : if ((s->result == s && s->ns->contained != gfc_current_ns)
4904 150 : || ((s->attr.flavor == FL_UNKNOWN || s->attr.flavor == FL_VARIABLE)
4905 135 : && s->ns != gfc_current_ns))
4906 : {
4907 2 : gfc_error ("Variable %qs shall be declared in the same scoping unit "
4908 : "as !$ACC DECLARE at %L", s->name, &where);
4909 2 : return MATCH_ERROR;
4910 : }
4911 :
4912 148 : if ((s->attr.dimension || s->attr.codimension)
4913 76 : && s->attr.dummy && s->as->type != AS_EXPLICIT)
4914 : {
4915 2 : gfc_error ("Assumed-size dummy array with !$ACC DECLARE at %L",
4916 : &where);
4917 2 : return MATCH_ERROR;
4918 : }
4919 :
4920 146 : switch (n->u.map.op)
4921 : {
4922 49 : case OMP_MAP_FORCE_ALLOC:
4923 49 : case OMP_MAP_ALLOC:
4924 49 : s->attr.oacc_declare_create = 1;
4925 49 : break;
4926 :
4927 63 : case OMP_MAP_FORCE_TO:
4928 63 : case OMP_MAP_TO:
4929 63 : s->attr.oacc_declare_copyin = 1;
4930 63 : break;
4931 :
4932 1 : case OMP_MAP_FORCE_DEVICEPTR:
4933 1 : s->attr.oacc_declare_deviceptr = 1;
4934 1 : break;
4935 :
4936 : default:
4937 : break;
4938 : }
4939 : }
4940 :
4941 162 : new_oc = gfc_get_oacc_declare ();
4942 162 : new_oc->next = ns->oacc_declare;
4943 162 : new_oc->module_var = module_var;
4944 162 : new_oc->clauses = c;
4945 162 : new_oc->loc = gfc_current_locus;
4946 162 : ns->oacc_declare = new_oc;
4947 :
4948 162 : return MATCH_YES;
4949 : }
4950 :
4951 :
4952 : match
4953 760 : gfc_match_oacc_update (void)
4954 : {
4955 760 : gfc_omp_clauses *c;
4956 760 : locus here = gfc_current_locus;
4957 :
4958 760 : if (gfc_match_omp_clauses (&c, OACC_UPDATE_CLAUSES, false, false, true)
4959 : != MATCH_YES)
4960 : return MATCH_ERROR;
4961 :
4962 756 : if (!c->lists[OMP_LIST_MAP])
4963 : {
4964 1 : gfc_error ("%<acc update%> must contain at least one "
4965 : "%<device%> or %<host%> or %<self%> clause at %L", &here);
4966 1 : return MATCH_ERROR;
4967 : }
4968 :
4969 755 : new_st.op = EXEC_OACC_UPDATE;
4970 755 : new_st.ext.omp_clauses = c;
4971 755 : return MATCH_YES;
4972 : }
4973 :
4974 :
4975 : match
4976 877 : gfc_match_oacc_enter_data (void)
4977 : {
4978 877 : return match_acc (EXEC_OACC_ENTER_DATA, OACC_ENTER_DATA_CLAUSES);
4979 : }
4980 :
4981 :
4982 : match
4983 612 : gfc_match_oacc_exit_data (void)
4984 : {
4985 612 : return match_acc (EXEC_OACC_EXIT_DATA, OACC_EXIT_DATA_CLAUSES);
4986 : }
4987 :
4988 :
4989 : match
4990 202 : gfc_match_oacc_wait (void)
4991 : {
4992 202 : gfc_omp_clauses *c = gfc_get_omp_clauses ();
4993 202 : gfc_expr_list *wait_list = NULL, *el;
4994 202 : bool space = true;
4995 202 : match m;
4996 :
4997 202 : m = match_omp_oacc_expr_list (" (", &wait_list, true, false);
4998 202 : if (m == MATCH_ERROR)
4999 : return m;
5000 196 : else if (m == MATCH_YES)
5001 126 : space = false;
5002 :
5003 196 : if (gfc_match_omp_clauses (&c, OACC_WAIT_CLAUSES, space, space, true)
5004 : == MATCH_ERROR)
5005 : return MATCH_ERROR;
5006 :
5007 184 : if (wait_list)
5008 261 : for (el = wait_list; el; el = el->next)
5009 : {
5010 140 : if (el->expr == NULL)
5011 : {
5012 2 : gfc_error ("Invalid argument to !$ACC WAIT at %C");
5013 2 : return MATCH_ERROR;
5014 : }
5015 :
5016 138 : if (!gfc_resolve_expr (el->expr)
5017 138 : || el->expr->ts.type != BT_INTEGER || el->expr->rank != 0)
5018 : {
5019 3 : gfc_error ("WAIT clause at %L requires a scalar INTEGER expression",
5020 3 : &el->expr->where);
5021 :
5022 3 : return MATCH_ERROR;
5023 : }
5024 : }
5025 179 : c->wait_list = wait_list;
5026 179 : new_st.op = EXEC_OACC_WAIT;
5027 179 : new_st.ext.omp_clauses = c;
5028 179 : return MATCH_YES;
5029 : }
5030 :
5031 :
5032 : match
5033 97 : gfc_match_oacc_cache (void)
5034 : {
5035 97 : bool readonly = false;
5036 97 : gfc_omp_clauses *c = gfc_get_omp_clauses ();
5037 : /* The OpenACC cache directive explicitly only allows "array elements or
5038 : subarrays", which we're currently not checking here. Either check this
5039 : after the call of gfc_match_omp_variable_list, or add something like a
5040 : only_sections variant next to its allow_sections parameter. */
5041 97 : match m = gfc_match (" ( ");
5042 97 : if (m != MATCH_YES)
5043 : {
5044 0 : gfc_free_omp_clauses(c);
5045 0 : return m;
5046 : }
5047 :
5048 97 : if (gfc_match ("readonly : ") == MATCH_YES)
5049 8 : readonly = true;
5050 :
5051 97 : gfc_omp_namelist **head = NULL;
5052 97 : m = gfc_match_omp_variable_list ("", &c->lists[OMP_LIST_CACHE], true,
5053 : NULL, &head, true);
5054 97 : if (m != MATCH_YES)
5055 : {
5056 2 : gfc_free_omp_clauses(c);
5057 2 : return m;
5058 : }
5059 :
5060 95 : if (readonly)
5061 24 : for (gfc_omp_namelist *n = *head; n; n = n->next)
5062 16 : n->u.map.readonly = true;
5063 :
5064 95 : if (gfc_current_state() != COMP_DO
5065 56 : && gfc_current_state() != COMP_DO_CONCURRENT)
5066 : {
5067 2 : gfc_error ("ACC CACHE directive must be inside of loop %C");
5068 2 : gfc_free_omp_clauses(c);
5069 2 : return MATCH_ERROR;
5070 : }
5071 :
5072 93 : new_st.op = EXEC_OACC_CACHE;
5073 93 : new_st.ext.omp_clauses = c;
5074 93 : return MATCH_YES;
5075 : }
5076 :
5077 : /* Determine the OpenACC 'routine' directive's level of parallelism. */
5078 :
5079 : static oacc_routine_lop
5080 734 : gfc_oacc_routine_lop (gfc_omp_clauses *clauses)
5081 : {
5082 734 : oacc_routine_lop ret = OACC_ROUTINE_LOP_SEQ;
5083 :
5084 734 : if (clauses)
5085 : {
5086 584 : unsigned n_lop_clauses = 0;
5087 :
5088 584 : if (clauses->gang)
5089 : {
5090 164 : ++n_lop_clauses;
5091 164 : ret = OACC_ROUTINE_LOP_GANG;
5092 : }
5093 584 : if (clauses->worker)
5094 : {
5095 114 : ++n_lop_clauses;
5096 114 : ret = OACC_ROUTINE_LOP_WORKER;
5097 : }
5098 584 : if (clauses->vector)
5099 : {
5100 116 : ++n_lop_clauses;
5101 116 : ret = OACC_ROUTINE_LOP_VECTOR;
5102 : }
5103 584 : if (clauses->seq)
5104 : {
5105 206 : ++n_lop_clauses;
5106 206 : ret = OACC_ROUTINE_LOP_SEQ;
5107 : }
5108 :
5109 584 : if (n_lop_clauses > 1)
5110 47 : ret = OACC_ROUTINE_LOP_ERROR;
5111 : }
5112 :
5113 734 : return ret;
5114 : }
5115 :
5116 : match
5117 698 : gfc_match_oacc_routine (void)
5118 : {
5119 698 : locus old_loc;
5120 698 : match m;
5121 698 : gfc_intrinsic_sym *isym = NULL;
5122 698 : gfc_symbol *sym = NULL;
5123 698 : gfc_omp_clauses *c = NULL;
5124 698 : gfc_oacc_routine_name *n = NULL;
5125 698 : oacc_routine_lop lop = OACC_ROUTINE_LOP_NONE;
5126 698 : bool nohost;
5127 :
5128 698 : old_loc = gfc_current_locus;
5129 :
5130 698 : m = gfc_match (" (");
5131 :
5132 698 : if (gfc_current_ns->proc_name
5133 696 : && gfc_current_ns->proc_name->attr.if_source == IFSRC_IFBODY
5134 90 : && m == MATCH_YES)
5135 : {
5136 3 : gfc_error ("Only the !$ACC ROUTINE form without "
5137 : "list is allowed in interface block at %C");
5138 3 : goto cleanup;
5139 : }
5140 :
5141 608 : if (m == MATCH_YES)
5142 : {
5143 295 : char buffer[GFC_MAX_SYMBOL_LEN + 1];
5144 :
5145 295 : m = gfc_match_name (buffer);
5146 295 : if (m == MATCH_YES)
5147 : {
5148 294 : gfc_symtree *st = NULL;
5149 :
5150 : /* First look for an intrinsic symbol. */
5151 294 : isym = gfc_find_function (buffer);
5152 294 : if (!isym)
5153 294 : isym = gfc_find_subroutine (buffer);
5154 : /* If no intrinsic symbol found, search the current namespace. */
5155 294 : if (!isym)
5156 276 : st = gfc_find_symtree (gfc_current_ns->sym_root, buffer);
5157 276 : if (st)
5158 : {
5159 270 : sym = st->n.sym;
5160 : /* If the name in a 'routine' directive refers to the containing
5161 : subroutine or function, then make sure that we'll later handle
5162 : this accordingly. */
5163 270 : if (gfc_current_ns->proc_name != NULL
5164 270 : && strcmp (sym->name, gfc_current_ns->proc_name->name) == 0)
5165 294 : sym = NULL;
5166 : }
5167 :
5168 294 : if (isym == NULL && st == NULL)
5169 : {
5170 6 : gfc_error ("Invalid NAME %qs in !$ACC ROUTINE ( NAME ) at %C",
5171 : buffer);
5172 6 : gfc_current_locus = old_loc;
5173 9 : return MATCH_ERROR;
5174 : }
5175 : }
5176 : else
5177 : {
5178 1 : gfc_error ("Syntax error in !$ACC ROUTINE ( NAME ) at %C");
5179 1 : gfc_current_locus = old_loc;
5180 1 : return MATCH_ERROR;
5181 : }
5182 :
5183 288 : if (gfc_match_char (')') != MATCH_YES)
5184 : {
5185 2 : gfc_error ("Syntax error in !$ACC ROUTINE ( NAME ) at %C, expecting"
5186 : " %<)%> after NAME");
5187 2 : gfc_current_locus = old_loc;
5188 2 : return MATCH_ERROR;
5189 : }
5190 : }
5191 :
5192 686 : if (gfc_match_omp_eos () != MATCH_YES
5193 686 : && (gfc_match_omp_clauses (&c, OACC_ROUTINE_CLAUSES, false, false, true)
5194 : != MATCH_YES))
5195 : return MATCH_ERROR;
5196 :
5197 683 : lop = gfc_oacc_routine_lop (c);
5198 683 : if (lop == OACC_ROUTINE_LOP_ERROR)
5199 : {
5200 47 : gfc_error ("Multiple loop axes specified for routine at %C");
5201 47 : goto cleanup;
5202 : }
5203 636 : nohost = c ? c->nohost : false;
5204 :
5205 636 : if (isym != NULL)
5206 : {
5207 : /* Diagnose any OpenACC 'routine' directive that doesn't match the
5208 : (implicit) one with a 'seq' clause. */
5209 16 : if (c && (c->gang || c->worker || c->vector))
5210 : {
5211 10 : gfc_error ("Intrinsic symbol specified in !$ACC ROUTINE ( NAME )"
5212 : " at %C marked with incompatible GANG, WORKER, or VECTOR"
5213 : " clause");
5214 10 : goto cleanup;
5215 : }
5216 : /* ..., and no 'nohost' clause. */
5217 6 : if (nohost)
5218 : {
5219 2 : gfc_error ("Intrinsic symbol specified in !$ACC ROUTINE ( NAME )"
5220 : " at %C marked with incompatible NOHOST clause");
5221 2 : goto cleanup;
5222 : }
5223 : }
5224 620 : else if (sym != NULL)
5225 : {
5226 151 : bool add = true;
5227 :
5228 : /* For a repeated OpenACC 'routine' directive, diagnose if it doesn't
5229 : match the first one. */
5230 151 : for (gfc_oacc_routine_name *n_p = gfc_current_ns->oacc_routine_names;
5231 346 : n_p;
5232 195 : n_p = n_p->next)
5233 235 : if (n_p->sym == sym)
5234 : {
5235 51 : add = false;
5236 51 : bool nohost_p = n_p->clauses ? n_p->clauses->nohost : false;
5237 51 : if (lop != gfc_oacc_routine_lop (n_p->clauses)
5238 51 : || nohost != nohost_p)
5239 : {
5240 40 : gfc_error ("!$ACC ROUTINE already applied at %C");
5241 40 : goto cleanup;
5242 : }
5243 : }
5244 :
5245 111 : if (add)
5246 : {
5247 100 : sym->attr.oacc_routine_lop = lop;
5248 100 : sym->attr.oacc_routine_nohost = nohost;
5249 :
5250 100 : n = gfc_get_oacc_routine_name ();
5251 100 : n->sym = sym;
5252 100 : n->clauses = c;
5253 100 : n->next = gfc_current_ns->oacc_routine_names;
5254 100 : n->loc = old_loc;
5255 100 : gfc_current_ns->oacc_routine_names = n;
5256 : }
5257 : }
5258 469 : else if (gfc_current_ns->proc_name)
5259 : {
5260 : /* For a repeated OpenACC 'routine' directive, diagnose if it doesn't
5261 : match the first one. */
5262 468 : oacc_routine_lop lop_p = gfc_current_ns->proc_name->attr.oacc_routine_lop;
5263 468 : bool nohost_p = gfc_current_ns->proc_name->attr.oacc_routine_nohost;
5264 468 : if (lop_p != OACC_ROUTINE_LOP_NONE
5265 86 : && (lop != lop_p
5266 86 : || nohost != nohost_p))
5267 : {
5268 56 : gfc_error ("!$ACC ROUTINE already applied at %C");
5269 56 : goto cleanup;
5270 : }
5271 :
5272 412 : if (!gfc_add_omp_declare_target (&gfc_current_ns->proc_name->attr,
5273 : gfc_current_ns->proc_name->name,
5274 : &old_loc))
5275 1 : goto cleanup;
5276 411 : gfc_current_ns->proc_name->attr.oacc_routine_lop = lop;
5277 411 : gfc_current_ns->proc_name->attr.oacc_routine_nohost = nohost;
5278 : }
5279 : else
5280 : /* Something has gone wrong, possibly a syntax error. */
5281 1 : goto cleanup;
5282 :
5283 526 : if (gfc_pure (NULL) && c && (c->gang || c->worker || c->vector))
5284 : {
5285 6 : gfc_error ("!$ACC ROUTINE with GANG, WORKER, or VECTOR clause is not "
5286 : "permitted in PURE procedure at %C");
5287 6 : goto cleanup;
5288 : }
5289 :
5290 :
5291 520 : if (n)
5292 100 : n->clauses = c;
5293 420 : else if (gfc_current_ns->oacc_routine)
5294 0 : gfc_current_ns->oacc_routine_clauses = c;
5295 :
5296 520 : new_st.op = EXEC_OACC_ROUTINE;
5297 520 : new_st.ext.omp_clauses = c;
5298 520 : return MATCH_YES;
5299 :
5300 166 : cleanup:
5301 166 : gfc_current_locus = old_loc;
5302 166 : return MATCH_ERROR;
5303 : }
5304 :
5305 :
5306 : #define OMP_PARALLEL_CLAUSES \
5307 : (omp_mask (OMP_CLAUSE_PRIVATE) | OMP_CLAUSE_FIRSTPRIVATE \
5308 : | OMP_CLAUSE_SHARED | OMP_CLAUSE_COPYIN | OMP_CLAUSE_REDUCTION \
5309 : | OMP_CLAUSE_IF | OMP_CLAUSE_NUM_THREADS | OMP_CLAUSE_DEFAULT \
5310 : | OMP_CLAUSE_PROC_BIND | OMP_CLAUSE_ALLOCATE)
5311 : #define OMP_DECLARE_SIMD_CLAUSES \
5312 : (omp_mask (OMP_CLAUSE_SIMDLEN) | OMP_CLAUSE_LINEAR \
5313 : | OMP_CLAUSE_UNIFORM | OMP_CLAUSE_ALIGNED | OMP_CLAUSE_INBRANCH \
5314 : | OMP_CLAUSE_NOTINBRANCH)
5315 : #define OMP_DO_CLAUSES \
5316 : (omp_mask (OMP_CLAUSE_PRIVATE) | OMP_CLAUSE_FIRSTPRIVATE \
5317 : | OMP_CLAUSE_LASTPRIVATE | OMP_CLAUSE_REDUCTION \
5318 : | OMP_CLAUSE_SCHEDULE | OMP_CLAUSE_ORDERED | OMP_CLAUSE_COLLAPSE \
5319 : | OMP_CLAUSE_LINEAR | OMP_CLAUSE_ORDER | OMP_CLAUSE_ALLOCATE \
5320 : | OMP_CLAUSE_NOWAIT)
5321 : #define OMP_LOOP_CLAUSES \
5322 : (omp_mask (OMP_CLAUSE_BIND) | OMP_CLAUSE_COLLAPSE | OMP_CLAUSE_ORDER \
5323 : | OMP_CLAUSE_PRIVATE | OMP_CLAUSE_LASTPRIVATE | OMP_CLAUSE_REDUCTION)
5324 :
5325 : #define OMP_SCOPE_CLAUSES \
5326 : (omp_mask (OMP_CLAUSE_PRIVATE) |OMP_CLAUSE_FIRSTPRIVATE \
5327 : | OMP_CLAUSE_REDUCTION | OMP_CLAUSE_ALLOCATE | OMP_CLAUSE_NOWAIT)
5328 : #define OMP_SECTIONS_CLAUSES \
5329 : (omp_mask (OMP_CLAUSE_PRIVATE) | OMP_CLAUSE_FIRSTPRIVATE \
5330 : | OMP_CLAUSE_LASTPRIVATE | OMP_CLAUSE_REDUCTION \
5331 : | OMP_CLAUSE_ALLOCATE | OMP_CLAUSE_NOWAIT)
5332 : #define OMP_SIMD_CLAUSES \
5333 : (omp_mask (OMP_CLAUSE_PRIVATE) | OMP_CLAUSE_LASTPRIVATE \
5334 : | OMP_CLAUSE_REDUCTION | OMP_CLAUSE_COLLAPSE | OMP_CLAUSE_SAFELEN \
5335 : | OMP_CLAUSE_LINEAR | OMP_CLAUSE_ALIGNED | OMP_CLAUSE_SIMDLEN \
5336 : | OMP_CLAUSE_IF | OMP_CLAUSE_ORDER | OMP_CLAUSE_NOTEMPORAL)
5337 : #define OMP_TASK_CLAUSES \
5338 : (omp_mask (OMP_CLAUSE_PRIVATE) | OMP_CLAUSE_FIRSTPRIVATE \
5339 : | OMP_CLAUSE_SHARED | OMP_CLAUSE_IF | OMP_CLAUSE_DEFAULT \
5340 : | OMP_CLAUSE_UNTIED | OMP_CLAUSE_FINAL | OMP_CLAUSE_MERGEABLE \
5341 : | OMP_CLAUSE_DEPEND | OMP_CLAUSE_PRIORITY | OMP_CLAUSE_IN_REDUCTION \
5342 : | OMP_CLAUSE_DETACH | OMP_CLAUSE_AFFINITY | OMP_CLAUSE_ALLOCATE)
5343 : #define OMP_TASKLOOP_CLAUSES \
5344 : (omp_mask (OMP_CLAUSE_PRIVATE) | OMP_CLAUSE_FIRSTPRIVATE \
5345 : | OMP_CLAUSE_LASTPRIVATE | OMP_CLAUSE_SHARED | OMP_CLAUSE_IF \
5346 : | OMP_CLAUSE_DEFAULT | OMP_CLAUSE_UNTIED | OMP_CLAUSE_FINAL \
5347 : | OMP_CLAUSE_MERGEABLE | OMP_CLAUSE_PRIORITY | OMP_CLAUSE_GRAINSIZE \
5348 : | OMP_CLAUSE_NUM_TASKS | OMP_CLAUSE_COLLAPSE | OMP_CLAUSE_NOGROUP \
5349 : | OMP_CLAUSE_REDUCTION | OMP_CLAUSE_IN_REDUCTION | OMP_CLAUSE_ALLOCATE)
5350 : #define OMP_TASKGROUP_CLAUSES \
5351 : (omp_mask (OMP_CLAUSE_TASK_REDUCTION) | OMP_CLAUSE_ALLOCATE)
5352 : #define OMP_TARGET_CLAUSES \
5353 : (omp_mask (OMP_CLAUSE_DEVICE) | OMP_CLAUSE_MAP | OMP_CLAUSE_IF \
5354 : | OMP_CLAUSE_DEPEND | OMP_CLAUSE_NOWAIT | OMP_CLAUSE_PRIVATE \
5355 : | OMP_CLAUSE_FIRSTPRIVATE | OMP_CLAUSE_DEFAULTMAP \
5356 : | OMP_CLAUSE_IS_DEVICE_PTR | OMP_CLAUSE_IN_REDUCTION \
5357 : | OMP_CLAUSE_THREAD_LIMIT | OMP_CLAUSE_ALLOCATE \
5358 : | OMP_CLAUSE_HAS_DEVICE_ADDR | OMP_CLAUSE_USES_ALLOCATORS \
5359 : | OMP_CLAUSE_DYN_GROUPPRIVATE | OMP_CLAUSE_DEVICE_TYPE)
5360 : #define OMP_TARGET_DATA_CLAUSES \
5361 : (omp_mask (OMP_CLAUSE_DEVICE) | OMP_CLAUSE_MAP | OMP_CLAUSE_IF \
5362 : | OMP_CLAUSE_USE_DEVICE_PTR | OMP_CLAUSE_USE_DEVICE_ADDR)
5363 : #define OMP_TARGET_ENTER_DATA_CLAUSES \
5364 : (omp_mask (OMP_CLAUSE_DEVICE) | OMP_CLAUSE_MAP | OMP_CLAUSE_IF \
5365 : | OMP_CLAUSE_DEPEND | OMP_CLAUSE_NOWAIT)
5366 : #define OMP_TARGET_EXIT_DATA_CLAUSES \
5367 : (omp_mask (OMP_CLAUSE_DEVICE) | OMP_CLAUSE_MAP | OMP_CLAUSE_IF \
5368 : | OMP_CLAUSE_DEPEND | OMP_CLAUSE_NOWAIT)
5369 : #define OMP_TARGET_UPDATE_CLAUSES \
5370 : (omp_mask (OMP_CLAUSE_DEVICE) | OMP_CLAUSE_IF | OMP_CLAUSE_TO \
5371 : | OMP_CLAUSE_FROM | OMP_CLAUSE_DEPEND | OMP_CLAUSE_NOWAIT)
5372 : #define OMP_TEAMS_CLAUSES \
5373 : (omp_mask (OMP_CLAUSE_NUM_TEAMS) | OMP_CLAUSE_THREAD_LIMIT \
5374 : | OMP_CLAUSE_DEFAULT | OMP_CLAUSE_PRIVATE | OMP_CLAUSE_FIRSTPRIVATE \
5375 : | OMP_CLAUSE_SHARED | OMP_CLAUSE_REDUCTION | OMP_CLAUSE_ALLOCATE)
5376 : #define OMP_DISTRIBUTE_CLAUSES \
5377 : (omp_mask (OMP_CLAUSE_PRIVATE) | OMP_CLAUSE_FIRSTPRIVATE \
5378 : | OMP_CLAUSE_LASTPRIVATE | OMP_CLAUSE_COLLAPSE | OMP_CLAUSE_DIST_SCHEDULE \
5379 : | OMP_CLAUSE_ORDER | OMP_CLAUSE_ALLOCATE)
5380 : #define OMP_SINGLE_CLAUSES \
5381 : (omp_mask (OMP_CLAUSE_PRIVATE) | OMP_CLAUSE_FIRSTPRIVATE \
5382 : | OMP_CLAUSE_ALLOCATE | OMP_CLAUSE_NOWAIT | OMP_CLAUSE_COPYPRIVATE)
5383 : #define OMP_ORDERED_CLAUSES \
5384 : (omp_mask (OMP_CLAUSE_THREADS) | OMP_CLAUSE_SIMD)
5385 : #define OMP_DECLARE_TARGET_CLAUSES \
5386 : (omp_mask (OMP_CLAUSE_ENTER) | OMP_CLAUSE_LINK | OMP_CLAUSE_DEVICE_TYPE \
5387 : | OMP_CLAUSE_TO | OMP_CLAUSE_INDIRECT | OMP_CLAUSE_LOCAL)
5388 : #define OMP_ATOMIC_CLAUSES \
5389 : (omp_mask (OMP_CLAUSE_ATOMIC) | OMP_CLAUSE_CAPTURE | OMP_CLAUSE_HINT \
5390 : | OMP_CLAUSE_MEMORDER | OMP_CLAUSE_COMPARE | OMP_CLAUSE_FAIL \
5391 : | OMP_CLAUSE_WEAK)
5392 : #define OMP_MASKED_CLAUSES \
5393 : (omp_mask (OMP_CLAUSE_FILTER))
5394 : #define OMP_ERROR_CLAUSES \
5395 : (omp_mask (OMP_CLAUSE_AT) | OMP_CLAUSE_MESSAGE | OMP_CLAUSE_SEVERITY)
5396 : #define OMP_WORKSHARE_CLAUSES \
5397 : omp_mask (OMP_CLAUSE_NOWAIT)
5398 : #define OMP_UNROLL_CLAUSES \
5399 : (omp_mask (OMP_CLAUSE_FULL) | OMP_CLAUSE_PARTIAL)
5400 : #define OMP_TILE_CLAUSES \
5401 : (omp_mask (OMP_CLAUSE_SIZES))
5402 : #define OMP_ALLOCATORS_CLAUSES \
5403 : omp_mask (OMP_CLAUSE_ALLOCATE)
5404 : #define OMP_INTEROP_CLAUSES \
5405 : (omp_mask (OMP_CLAUSE_DEPEND) | OMP_CLAUSE_NOWAIT | OMP_CLAUSE_DEVICE \
5406 : | OMP_CLAUSE_INIT | OMP_CLAUSE_DESTROY | OMP_CLAUSE_USE)
5407 : #define OMP_DISPATCH_CLAUSES \
5408 : (omp_mask (OMP_CLAUSE_DEVICE) | OMP_CLAUSE_DEPEND | OMP_CLAUSE_NOVARIANTS \
5409 : | OMP_CLAUSE_NOCONTEXT | OMP_CLAUSE_IS_DEVICE_PTR | OMP_CLAUSE_NOWAIT \
5410 : | OMP_CLAUSE_HAS_DEVICE_ADDR | OMP_CLAUSE_INTEROP)
5411 :
5412 :
5413 : static match
5414 17183 : match_omp (gfc_exec_op op, const omp_mask mask)
5415 : {
5416 17183 : gfc_omp_clauses *c;
5417 17183 : if (gfc_match_omp_clauses (&c, mask, true, true, false,
5418 : op == EXEC_OMP_TARGET) != MATCH_YES)
5419 : return MATCH_ERROR;
5420 16926 : new_st.op = op;
5421 16926 : new_st.ext.omp_clauses = c;
5422 16926 : return MATCH_YES;
5423 : }
5424 :
5425 : /* Handles both declarative and (deprecated) executable ALLOCATE directive;
5426 : accepts optional list (for executable) and common blocks.
5427 : If no variables have been provided, the single omp namelist has sym == NULL.
5428 :
5429 : Note that the executable ALLOCATE directive permits structure elements only
5430 : in OpenMP 5.0 and 5.1 but not longer in 5.2. See also the comment on the
5431 : 'omp allocators' directive below. The accidental change was reverted for
5432 : OpenMP TR12, permitting them again. See also gfc_match_omp_allocators.
5433 :
5434 : Hence, structure elements are rejected for now, also to make resolving
5435 : OMP_LIST_ALLOCATE simpler (check for duplicates, same symbol in
5436 : Fortran allocate stmt). TODO: Permit structure elements. */
5437 :
5438 : match
5439 274 : gfc_match_omp_allocate (void)
5440 : {
5441 274 : match m;
5442 274 : bool first = true;
5443 274 : gfc_omp_namelist *vars = NULL;
5444 274 : gfc_expr *align = NULL;
5445 274 : gfc_expr *allocator = NULL;
5446 274 : locus loc = gfc_current_locus;
5447 :
5448 274 : m = gfc_match_omp_variable_list (" (", &vars, true, NULL, NULL, true, true,
5449 : NULL, true);
5450 :
5451 274 : if (m == MATCH_ERROR)
5452 : return m;
5453 :
5454 502 : while (true)
5455 : {
5456 502 : gfc_gobble_whitespace ();
5457 502 : if (gfc_match_omp_eos () == MATCH_YES)
5458 : break;
5459 234 : if (!first)
5460 28 : gfc_match (", ");
5461 234 : first = false;
5462 234 : if ((m = gfc_match_dupl_check (!align, "align", true, &align))
5463 : != MATCH_NO)
5464 : {
5465 62 : if (m == MATCH_ERROR)
5466 1 : goto error;
5467 61 : continue;
5468 : }
5469 172 : if ((m = gfc_match_dupl_check (!allocator, "allocator",
5470 : true, &allocator)) != MATCH_NO)
5471 : {
5472 171 : if (m == MATCH_ERROR)
5473 1 : goto error;
5474 170 : continue;
5475 : }
5476 1 : gfc_error ("Expected ALIGN or ALLOCATOR clause at %C");
5477 1 : return MATCH_ERROR;
5478 : }
5479 541 : for (gfc_omp_namelist *n = vars; n; n = n->next)
5480 276 : if (n->expr)
5481 : {
5482 3 : if ((n->expr->ref && n->expr->ref->type == REF_COMPONENT)
5483 3 : || (n->expr->ref->next && n->expr->ref->type == REF_COMPONENT))
5484 1 : gfc_error ("Sorry, structure-element list item at %L in ALLOCATE "
5485 : "directive is not yet supported", &n->expr->where);
5486 : else
5487 2 : gfc_error ("Unexpected expression as list item at %L in ALLOCATE "
5488 : "directive", &n->expr->where);
5489 :
5490 3 : gfc_free_omp_namelist (vars, OMP_LIST_ALLOCATE);
5491 3 : goto error;
5492 : }
5493 :
5494 265 : new_st.op = EXEC_OMP_ALLOCATE;
5495 265 : new_st.ext.omp_clauses = gfc_get_omp_clauses ();
5496 265 : if (vars == NULL)
5497 : {
5498 27 : vars = gfc_get_omp_namelist ();
5499 27 : vars->where = loc;
5500 27 : vars->u.align = align;
5501 27 : vars->u2.allocator = allocator;
5502 27 : new_st.ext.omp_clauses->lists[OMP_LIST_ALLOCATE] = vars;
5503 : }
5504 : else
5505 : {
5506 238 : new_st.ext.omp_clauses->lists[OMP_LIST_ALLOCATE] = vars;
5507 511 : for (; vars; vars = vars->next)
5508 : {
5509 273 : vars->u.align = (align) ? gfc_copy_expr (align) : NULL;
5510 273 : vars->u2.allocator = allocator;
5511 : }
5512 238 : gfc_free_expr (align);
5513 : }
5514 : return MATCH_YES;
5515 :
5516 5 : error:
5517 5 : gfc_free_expr (align);
5518 5 : gfc_free_expr (allocator);
5519 5 : return MATCH_ERROR;
5520 : }
5521 :
5522 : /* In line with OpenMP 5.2 derived-type components are rejected.
5523 : See also comment before gfc_match_omp_allocate. */
5524 :
5525 : match
5526 26 : gfc_match_omp_allocators (void)
5527 : {
5528 26 : return match_omp (EXEC_OMP_ALLOCATORS, OMP_ALLOCATORS_CLAUSES);
5529 : }
5530 :
5531 :
5532 : match
5533 23 : gfc_match_omp_assume (void)
5534 : {
5535 23 : gfc_omp_clauses *c;
5536 23 : locus loc = gfc_current_locus;
5537 23 : if ((gfc_match_omp_clauses (&c, omp_mask (OMP_CLAUSE_ASSUMPTIONS))
5538 : != MATCH_YES)
5539 23 : || (omp_verify_merge_absent_contains (ST_OMP_ASSUME, c->assume, NULL,
5540 : &loc) != MATCH_YES))
5541 7 : return MATCH_ERROR;
5542 16 : new_st.op = EXEC_OMP_ASSUME;
5543 16 : new_st.ext.omp_clauses = c;
5544 16 : return MATCH_YES;
5545 : }
5546 :
5547 :
5548 : match
5549 28 : gfc_match_omp_assumes (void)
5550 : {
5551 28 : gfc_omp_clauses *c;
5552 28 : locus loc = gfc_current_locus;
5553 28 : if (!gfc_current_ns->proc_name
5554 27 : || (gfc_current_ns->proc_name->attr.flavor != FL_MODULE
5555 23 : && !gfc_current_ns->proc_name->attr.subroutine
5556 10 : && !gfc_current_ns->proc_name->attr.function))
5557 : {
5558 2 : gfc_error ("!$OMP ASSUMES at %C must be in the specification part of a "
5559 : "subprogram or module");
5560 2 : return MATCH_ERROR;
5561 : }
5562 26 : if ((gfc_match_omp_clauses (&c, omp_mask (OMP_CLAUSE_ASSUMPTIONS))
5563 : != MATCH_YES)
5564 50 : || (omp_verify_merge_absent_contains (ST_OMP_ASSUMES, c->assume,
5565 24 : gfc_current_ns->omp_assumes, &loc)
5566 : != MATCH_YES))
5567 5 : return MATCH_ERROR;
5568 21 : if (gfc_current_ns->omp_assumes == NULL)
5569 : {
5570 19 : gfc_current_ns->omp_assumes = c->assume;
5571 19 : c->assume = NULL;
5572 : }
5573 2 : else if (gfc_current_ns->omp_assumes && c->assume)
5574 : {
5575 2 : gfc_current_ns->omp_assumes->no_openmp |= c->assume->no_openmp;
5576 2 : gfc_current_ns->omp_assumes->no_openmp_routines
5577 2 : |= c->assume->no_openmp_routines;
5578 2 : gfc_current_ns->omp_assumes->no_openmp_constructs
5579 2 : |= c->assume->no_openmp_constructs;
5580 2 : gfc_current_ns->omp_assumes->no_parallelism |= c->assume->no_parallelism;
5581 2 : if (gfc_current_ns->omp_assumes->holds && c->assume->holds)
5582 : {
5583 : gfc_expr_list *el = gfc_current_ns->omp_assumes->holds;
5584 1 : for ( ; el->next ; el = el->next)
5585 : ;
5586 1 : el->next = c->assume->holds;
5587 1 : }
5588 1 : else if (c->assume->holds)
5589 0 : gfc_current_ns->omp_assumes->holds = c->assume->holds;
5590 2 : c->assume->holds = NULL;
5591 : }
5592 21 : gfc_free_omp_clauses (c);
5593 21 : return MATCH_YES;
5594 : }
5595 :
5596 :
5597 : match
5598 162 : gfc_match_omp_critical (void)
5599 : {
5600 162 : char n[GFC_MAX_SYMBOL_LEN+1];
5601 162 : gfc_omp_clauses *c = NULL;
5602 :
5603 162 : if (gfc_match (" ( %n )", n) != MATCH_YES)
5604 115 : n[0] = '\0';
5605 :
5606 162 : if (gfc_match_omp_clauses (&c, omp_mask (OMP_CLAUSE_HINT),
5607 162 : /* first = */ n[0] == '\0') != MATCH_YES)
5608 : return MATCH_ERROR;
5609 :
5610 160 : new_st.op = EXEC_OMP_CRITICAL;
5611 160 : new_st.ext.omp_clauses = c;
5612 160 : if (n[0])
5613 47 : c->critical_name = xstrdup (n);
5614 : return MATCH_YES;
5615 : }
5616 :
5617 :
5618 : match
5619 160 : gfc_match_omp_end_critical (void)
5620 : {
5621 160 : char n[GFC_MAX_SYMBOL_LEN+1];
5622 :
5623 160 : if (gfc_match (" ( %n )", n) != MATCH_YES)
5624 113 : n[0] = '\0';
5625 160 : if (gfc_match_omp_eos () != MATCH_YES)
5626 : {
5627 1 : gfc_error ("Unexpected junk after $OMP CRITICAL statement at %C");
5628 1 : return MATCH_ERROR;
5629 : }
5630 :
5631 159 : new_st.op = EXEC_OMP_END_CRITICAL;
5632 159 : new_st.ext.omp_name = n[0] ? xstrdup (n) : NULL;
5633 159 : return MATCH_YES;
5634 : }
5635 :
5636 : /* depobj(depobj) depend(dep-type:loc)|destroy|update(dep-type)
5637 : dep-type = in/out/inout/mutexinoutset/depobj/source/sink
5638 : depend: !source, !sink
5639 : update: !source, !sink, !depobj
5640 : locator = exactly one list item .*/
5641 : match
5642 125 : gfc_match_omp_depobj (void)
5643 : {
5644 125 : gfc_omp_clauses *c = NULL;
5645 125 : gfc_expr *depobj;
5646 :
5647 125 : if (gfc_match (" ( %v ) ", &depobj) != MATCH_YES)
5648 : {
5649 2 : gfc_error ("Expected %<( depobj )%> at %C");
5650 2 : return MATCH_ERROR;
5651 : }
5652 123 : if (gfc_match ("update ( ") == MATCH_YES)
5653 : {
5654 12 : c = gfc_get_omp_clauses ();
5655 12 : if (gfc_match ("inoutset )") == MATCH_YES)
5656 2 : c->depobj_update = OMP_DEPEND_INOUTSET;
5657 10 : else if (gfc_match ("inout )") == MATCH_YES)
5658 1 : c->depobj_update = OMP_DEPEND_INOUT;
5659 9 : else if (gfc_match ("in )") == MATCH_YES)
5660 2 : c->depobj_update = OMP_DEPEND_IN;
5661 7 : else if (gfc_match ("out )") == MATCH_YES)
5662 2 : c->depobj_update = OMP_DEPEND_OUT;
5663 5 : else if (gfc_match ("mutexinoutset )") == MATCH_YES)
5664 2 : c->depobj_update = OMP_DEPEND_MUTEXINOUTSET;
5665 : else
5666 : {
5667 3 : gfc_error ("Expected IN, OUT, INOUT, INOUTSET or MUTEXINOUTSET "
5668 : "followed by %<)%> at %C");
5669 3 : goto error;
5670 : }
5671 : }
5672 111 : else if (gfc_match ("destroy ") == MATCH_YES)
5673 : {
5674 16 : gfc_expr *destroyobj = NULL;
5675 16 : c = gfc_get_omp_clauses ();
5676 16 : c->destroy = true;
5677 :
5678 16 : if (gfc_match (" ( %v ) ", &destroyobj) == MATCH_YES)
5679 : {
5680 3 : if (destroyobj->symtree != depobj->symtree)
5681 2 : gfc_warning (OPT_Wopenmp, "The same depend object should be used as"
5682 : " DEPOBJ argument at %L and as DESTROY argument at %L",
5683 : &depobj->where, &destroyobj->where);
5684 3 : gfc_free_expr (destroyobj);
5685 : }
5686 : }
5687 95 : else if (gfc_match_omp_clauses (&c, omp_mask (OMP_CLAUSE_DEPEND), true, false)
5688 : != MATCH_YES)
5689 2 : goto error;
5690 :
5691 118 : if (c->depobj_update == OMP_DEPEND_UNSET && !c->destroy)
5692 : {
5693 93 : if (!c->doacross_source && !c->lists[OMP_LIST_DEPEND])
5694 : {
5695 1 : gfc_error ("Expected DEPEND, UPDATE, or DESTROY clause at %C");
5696 1 : goto error;
5697 : }
5698 92 : if (c->lists[OMP_LIST_DEPEND]->u.depend_doacross_op == OMP_DEPEND_DEPOBJ)
5699 : {
5700 1 : gfc_error ("DEPEND clause at %L of OMP DEPOBJ construct shall not "
5701 : "have dependence-type DEPOBJ",
5702 : c->lists[OMP_LIST_DEPEND]
5703 : ? &c->lists[OMP_LIST_DEPEND]->where : &gfc_current_locus);
5704 1 : goto error;
5705 : }
5706 91 : if (c->lists[OMP_LIST_DEPEND]->next)
5707 : {
5708 1 : gfc_error ("DEPEND clause at %L of OMP DEPOBJ construct shall have "
5709 : "only a single locator",
5710 : &c->lists[OMP_LIST_DEPEND]->next->where);
5711 1 : goto error;
5712 : }
5713 : }
5714 :
5715 115 : c->depobj = depobj;
5716 115 : new_st.op = EXEC_OMP_DEPOBJ;
5717 115 : new_st.ext.omp_clauses = c;
5718 115 : return MATCH_YES;
5719 :
5720 8 : error:
5721 8 : gfc_free_expr (depobj);
5722 8 : gfc_free_omp_clauses (c);
5723 8 : return MATCH_ERROR;
5724 : }
5725 :
5726 : match
5727 160 : gfc_match_omp_dispatch (void)
5728 : {
5729 160 : return match_omp (EXEC_OMP_DISPATCH, OMP_DISPATCH_CLAUSES);
5730 : }
5731 :
5732 : match
5733 57 : gfc_match_omp_distribute (void)
5734 : {
5735 57 : return match_omp (EXEC_OMP_DISTRIBUTE, OMP_DISTRIBUTE_CLAUSES);
5736 : }
5737 :
5738 :
5739 : match
5740 44 : gfc_match_omp_distribute_parallel_do (void)
5741 : {
5742 44 : return match_omp (EXEC_OMP_DISTRIBUTE_PARALLEL_DO,
5743 44 : (OMP_DISTRIBUTE_CLAUSES | OMP_PARALLEL_CLAUSES
5744 44 : | OMP_DO_CLAUSES)
5745 44 : & ~(omp_mask (OMP_CLAUSE_ORDERED)
5746 44 : | OMP_CLAUSE_LINEAR | OMP_CLAUSE_NOWAIT));
5747 : }
5748 :
5749 :
5750 : match
5751 34 : gfc_match_omp_distribute_parallel_do_simd (void)
5752 : {
5753 34 : return match_omp (EXEC_OMP_DISTRIBUTE_PARALLEL_DO_SIMD,
5754 34 : (OMP_DISTRIBUTE_CLAUSES | OMP_PARALLEL_CLAUSES
5755 34 : | OMP_DO_CLAUSES | OMP_SIMD_CLAUSES)
5756 34 : & ~(omp_mask (OMP_CLAUSE_ORDERED) | OMP_CLAUSE_NOWAIT));
5757 : }
5758 :
5759 :
5760 : match
5761 52 : gfc_match_omp_distribute_simd (void)
5762 : {
5763 52 : return match_omp (EXEC_OMP_DISTRIBUTE_SIMD,
5764 52 : OMP_DISTRIBUTE_CLAUSES | OMP_SIMD_CLAUSES);
5765 : }
5766 :
5767 :
5768 : match
5769 1252 : gfc_match_omp_do (void)
5770 : {
5771 1252 : return match_omp (EXEC_OMP_DO, OMP_DO_CLAUSES);
5772 : }
5773 :
5774 :
5775 : match
5776 137 : gfc_match_omp_do_simd (void)
5777 : {
5778 137 : return match_omp (EXEC_OMP_DO_SIMD, OMP_DO_CLAUSES | OMP_SIMD_CLAUSES);
5779 : }
5780 :
5781 :
5782 : match
5783 70 : gfc_match_omp_loop (void)
5784 : {
5785 70 : return match_omp (EXEC_OMP_LOOP, OMP_LOOP_CLAUSES);
5786 : }
5787 :
5788 :
5789 : match
5790 35 : gfc_match_omp_teams_loop (void)
5791 : {
5792 35 : return match_omp (EXEC_OMP_TEAMS_LOOP, OMP_TEAMS_CLAUSES | OMP_LOOP_CLAUSES);
5793 : }
5794 :
5795 :
5796 : match
5797 18 : gfc_match_omp_target_teams_loop (void)
5798 : {
5799 18 : return match_omp (EXEC_OMP_TARGET_TEAMS_LOOP,
5800 18 : OMP_TARGET_CLAUSES | OMP_TEAMS_CLAUSES | OMP_LOOP_CLAUSES);
5801 : }
5802 :
5803 :
5804 : match
5805 31 : gfc_match_omp_parallel_loop (void)
5806 : {
5807 31 : return match_omp (EXEC_OMP_PARALLEL_LOOP,
5808 31 : OMP_PARALLEL_CLAUSES | OMP_LOOP_CLAUSES);
5809 : }
5810 :
5811 :
5812 : match
5813 16 : gfc_match_omp_target_parallel_loop (void)
5814 : {
5815 16 : return match_omp (EXEC_OMP_TARGET_PARALLEL_LOOP,
5816 16 : (OMP_TARGET_CLAUSES | OMP_PARALLEL_CLAUSES
5817 16 : | OMP_LOOP_CLAUSES));
5818 : }
5819 :
5820 :
5821 : match
5822 101 : gfc_match_omp_error (void)
5823 : {
5824 101 : locus loc = gfc_current_locus;
5825 101 : match m = match_omp (EXEC_OMP_ERROR, OMP_ERROR_CLAUSES);
5826 101 : if (m != MATCH_YES)
5827 : return m;
5828 :
5829 82 : gfc_omp_clauses *c = new_st.ext.omp_clauses;
5830 82 : if (c->severity == OMP_SEVERITY_UNSET)
5831 45 : c->severity = OMP_SEVERITY_FATAL;
5832 82 : if (new_st.ext.omp_clauses->at == OMP_AT_EXECUTION)
5833 : return MATCH_YES;
5834 37 : if (c->message
5835 37 : && (!gfc_resolve_expr (c->message)
5836 16 : || c->message->ts.type != BT_CHARACTER
5837 14 : || c->message->ts.kind != gfc_default_character_kind
5838 13 : || c->message->rank != 0))
5839 : {
5840 4 : gfc_error ("MESSAGE clause at %L requires a scalar default-kind "
5841 : "CHARACTER expression",
5842 4 : &new_st.ext.omp_clauses->message->where);
5843 4 : return MATCH_ERROR;
5844 : }
5845 33 : if (c->message && !gfc_is_constant_expr (c->message))
5846 : {
5847 2 : gfc_error ("Constant character expression required in MESSAGE clause "
5848 2 : "at %L", &new_st.ext.omp_clauses->message->where);
5849 2 : return MATCH_ERROR;
5850 : }
5851 31 : if (c->message)
5852 : {
5853 10 : const char *msg = G_("$OMP ERROR encountered at %L: %s");
5854 10 : gcc_assert (c->message->expr_type == EXPR_CONSTANT);
5855 10 : gfc_charlen_t slen = c->message->value.character.length;
5856 10 : int i = gfc_validate_kind (BT_CHARACTER, gfc_default_character_kind,
5857 : false);
5858 10 : size_t size = slen * gfc_character_kinds[i].bit_size / 8;
5859 10 : unsigned char *s = XCNEWVAR (unsigned char, size + 1);
5860 10 : gfc_encode_character (gfc_default_character_kind, slen,
5861 10 : c->message->value.character.string,
5862 : (unsigned char *) s, size);
5863 10 : s[size] = '\0';
5864 10 : if (c->severity == OMP_SEVERITY_WARNING)
5865 6 : gfc_warning_now (0, msg, &loc, s);
5866 : else
5867 4 : gfc_error_now (msg, &loc, s);
5868 10 : free (s);
5869 : }
5870 : else
5871 : {
5872 21 : const char *msg = G_("$OMP ERROR encountered at %L");
5873 21 : if (c->severity == OMP_SEVERITY_WARNING)
5874 7 : gfc_warning_now (0, msg, &loc);
5875 : else
5876 14 : gfc_error_now (msg, &loc);
5877 : }
5878 : return MATCH_YES;
5879 : }
5880 :
5881 : match
5882 86 : gfc_match_omp_flush (void)
5883 : {
5884 86 : gfc_omp_namelist *list = NULL;
5885 86 : gfc_omp_clauses *c = NULL;
5886 86 : gfc_gobble_whitespace ();
5887 86 : enum gfc_omp_memorder mo = OMP_MEMORDER_UNSET;
5888 86 : if (gfc_match_omp_eos () == MATCH_NO && gfc_peek_ascii_char () != '(')
5889 : {
5890 14 : if (gfc_match ("seq_cst") == MATCH_YES)
5891 : mo = OMP_MEMORDER_SEQ_CST;
5892 11 : else if (gfc_match ("acq_rel") == MATCH_YES)
5893 : mo = OMP_MEMORDER_ACQ_REL;
5894 8 : else if (gfc_match ("release") == MATCH_YES)
5895 : mo = OMP_MEMORDER_RELEASE;
5896 5 : else if (gfc_match ("acquire") == MATCH_YES)
5897 : mo = OMP_MEMORDER_ACQUIRE;
5898 : else
5899 : {
5900 2 : gfc_error ("Expected SEQ_CST, AQC_REL, RELEASE, or ACQUIRE at %C");
5901 2 : return MATCH_ERROR;
5902 : }
5903 12 : c = gfc_get_omp_clauses ();
5904 12 : c->memorder = mo;
5905 : }
5906 84 : gfc_match_omp_variable_list (" (", &list, true);
5907 84 : if (list && mo != OMP_MEMORDER_UNSET)
5908 : {
5909 4 : gfc_error ("List specified together with memory order clause in FLUSH "
5910 : "directive at %C");
5911 4 : gfc_free_omp_namelist (list, OMP_LIST_NONE);
5912 4 : gfc_free_omp_clauses (c);
5913 4 : return MATCH_ERROR;
5914 : }
5915 80 : if (gfc_match_omp_eos () != MATCH_YES)
5916 : {
5917 0 : gfc_error ("Unexpected junk after $OMP FLUSH statement at %C");
5918 0 : gfc_free_omp_namelist (list, OMP_LIST_NONE);
5919 0 : gfc_free_omp_clauses (c);
5920 0 : return MATCH_ERROR;
5921 : }
5922 80 : new_st.op = EXEC_OMP_FLUSH;
5923 80 : new_st.ext.omp_namelist = list;
5924 80 : new_st.ext.omp_clauses = c;
5925 80 : return MATCH_YES;
5926 : }
5927 :
5928 :
5929 : match
5930 188 : gfc_match_omp_declare_simd (void)
5931 : {
5932 188 : locus where = gfc_current_locus;
5933 188 : gfc_symbol *proc_name;
5934 188 : gfc_omp_clauses *c;
5935 188 : gfc_omp_declare_simd *ods;
5936 188 : bool needs_space = false;
5937 :
5938 188 : switch (gfc_match (" ( "))
5939 : {
5940 144 : case MATCH_YES:
5941 144 : if (gfc_match_symbol (&proc_name, /* host assoc = */ true) != MATCH_YES
5942 144 : || gfc_match (" ) ") != MATCH_YES)
5943 0 : return MATCH_ERROR;
5944 : break;
5945 44 : case MATCH_NO: proc_name = NULL; needs_space = true; break;
5946 : case MATCH_ERROR: return MATCH_ERROR;
5947 : }
5948 :
5949 188 : if (gfc_match_omp_clauses (&c, OMP_DECLARE_SIMD_CLAUSES, true,
5950 : needs_space) != MATCH_YES)
5951 : return MATCH_ERROR;
5952 :
5953 183 : if (gfc_current_ns->is_block_data)
5954 : {
5955 1 : gfc_free_omp_clauses (c);
5956 1 : return MATCH_YES;
5957 : }
5958 :
5959 182 : ods = gfc_get_omp_declare_simd ();
5960 182 : ods->where = where;
5961 182 : ods->proc_name = proc_name;
5962 182 : ods->clauses = c;
5963 182 : ods->next = gfc_current_ns->omp_declare_simd;
5964 182 : gfc_current_ns->omp_declare_simd = ods;
5965 182 : return MATCH_YES;
5966 : }
5967 :
5968 :
5969 : /* Find a matching "!$omp declare mapper" for typespec TS in symtree ST. */
5970 :
5971 : gfc_omp_udm *
5972 29 : gfc_omp_udm_find (gfc_symtree *st, gfc_typespec *ts)
5973 : {
5974 29 : gfc_omp_udm *omp_udm;
5975 :
5976 29 : if (st == NULL)
5977 : return NULL;
5978 :
5979 14 : gfc_symbol *dt = (ts->type == BT_CLASS
5980 0 : ? CLASS_DATA (ts->u.derived)->ts.u.derived
5981 : : ts->u.derived);
5982 15 : for (omp_udm = st->n.omp_udm; omp_udm; omp_udm = omp_udm->next)
5983 : {
5984 5 : if (dt == omp_udm->ts.u.derived)
5985 : return omp_udm;
5986 : /* Special case for comparing derived types across namespaces. If the
5987 : true names and module names are the same and the module name is
5988 : nonnull, then they are equal. */
5989 1 : if (dt->module && omp_udm->ts.u.derived->module
5990 1 : && strcmp (dt->name, omp_udm->ts.u.derived->name) == 0
5991 1 : && strcmp (dt->module, omp_udm->ts.u.derived->module) == 0)
5992 : return omp_udm;
5993 : }
5994 :
5995 : return NULL;
5996 : }
5997 :
5998 :
5999 : /* Match !$omp declare mapper([ mapper-identifier : ] type :: var) clauses-list */
6000 :
6001 : match
6002 27 : gfc_match_omp_declare_mapper (void)
6003 : {
6004 27 : match m;
6005 27 : gfc_typespec ts;
6006 27 : char mapper_id[GFC_MAX_SYMBOL_LEN + 1];
6007 27 : char var[GFC_MAX_SYMBOL_LEN + 1];
6008 27 : gfc_namespace *mapper_ns = NULL;
6009 27 : gfc_symtree *var_st;
6010 27 : gfc_symtree *st;
6011 27 : gfc_omp_udm *omp_udm = NULL, *prev_udm = NULL;
6012 27 : locus where = gfc_current_locus;
6013 :
6014 27 : if (gfc_match_char ('(') != MATCH_YES)
6015 : {
6016 1 : gfc_error ("Expected %<(%> at %C");
6017 1 : return MATCH_ERROR;
6018 : }
6019 :
6020 26 : locus old_locus = gfc_current_locus;
6021 :
6022 26 : m = gfc_match (" %n : ", mapper_id);
6023 :
6024 26 : if (m == MATCH_ERROR)
6025 : return MATCH_ERROR;
6026 :
6027 : /* As a special case, a mapper named "default" and an unnamed mapper are
6028 : both the default mapper for a given type. */
6029 26 : if (strcmp (mapper_id, "default") == 0)
6030 0 : mapper_id[0] = '\0';
6031 :
6032 26 : if (gfc_peek_ascii_char () == ':')
6033 : {
6034 : /* If we see '::', the user did not name the mapper, and instead we just
6035 : saw the type. So backtrack and try parsing as a type instead. */
6036 14 : mapper_id[0] = '\0';
6037 14 : gfc_current_locus = old_locus;
6038 : }
6039 26 : old_locus = gfc_current_locus;
6040 :
6041 26 : m = gfc_match_type_spec (&ts);
6042 26 : if (m != MATCH_YES)
6043 : {
6044 4 : gfc_error ("Expected either a type name at %L or a map-type "
6045 : "identifier, a colon, or a type name", &old_locus);
6046 4 : return MATCH_ERROR;
6047 : }
6048 :
6049 22 : if (ts.type != BT_DERIVED)
6050 : {
6051 1 : gfc_error ("!$OMP DECLARE MAPPER with non-derived type at %L", &old_locus);
6052 1 : return MATCH_ERROR;
6053 : }
6054 :
6055 21 : if (gfc_match (" :: ") != MATCH_YES)
6056 : {
6057 0 : gfc_error ("Expected %<::%> at %C");
6058 0 : return MATCH_ERROR;
6059 : }
6060 :
6061 21 : if (gfc_match_name (var) != MATCH_YES)
6062 : {
6063 1 : gfc_error ("Expected variable name at %C");
6064 1 : return MATCH_ERROR;
6065 : }
6066 :
6067 20 : if (gfc_match_char (')') != MATCH_YES)
6068 : {
6069 2 : gfc_error ("Expected %<)%> at %C");
6070 2 : return MATCH_ERROR;
6071 : }
6072 :
6073 18 : st = gfc_find_symtree (gfc_current_ns->omp_udm_root, mapper_id);
6074 :
6075 : /* Now we need to set up a new namespace, and create a new sym_tree for our
6076 : dummy variable so we can use it in the following list of mapping
6077 : clauses. */
6078 :
6079 18 : gfc_current_ns = mapper_ns = gfc_get_namespace (gfc_current_ns, 1);
6080 18 : mapper_ns->proc_name = mapper_ns->parent->proc_name;
6081 18 : mapper_ns->omp_udm_ns = 1;
6082 :
6083 18 : gfc_get_sym_tree (var, mapper_ns, &var_st, false);
6084 18 : var_st->n.sym->ts = ts;
6085 18 : var_st->n.sym->attr.omp_udm_artificial_var = 1;
6086 18 : var_st->n.sym->attr.flavor = FL_VARIABLE;
6087 18 : gfc_commit_symbols ();
6088 :
6089 18 : gfc_omp_clauses *clauses = NULL;
6090 :
6091 18 : m = gfc_match_omp_clauses (&clauses, omp_mask (OMP_CLAUSE_MAP), true, true,
6092 : false, false, OMP_MAP_UNSET);
6093 18 : if (m != MATCH_YES)
6094 1 : goto failure;
6095 :
6096 17 : omp_udm = gfc_get_omp_udm ();
6097 17 : omp_udm->next = NULL;
6098 17 : omp_udm->where = where;
6099 17 : omp_udm->mapper_id = gfc_get_string ("%s", mapper_id);
6100 17 : omp_udm->ts = ts;
6101 17 : omp_udm->var_sym = var_st->n.sym;
6102 17 : omp_udm->mapper_ns = mapper_ns;
6103 17 : omp_udm->clauses = clauses;
6104 :
6105 17 : gfc_current_ns = mapper_ns->parent;
6106 :
6107 17 : prev_udm = gfc_omp_udm_find (st, &ts);
6108 17 : if (prev_udm)
6109 : {
6110 2 : if (mapper_id[0])
6111 1 : gfc_error ("Redefinition of !$OMP DECLARE MAPPER at %L for type %qs with id %qs",
6112 : &where, gfc_typename (&ts), mapper_id);
6113 : else
6114 1 : gfc_error ("Redefinition of !$OMP DECLARE MAPPER at %L for type %qs",
6115 : &where, gfc_typename (&ts));
6116 2 : inform (gfc_get_location (&prev_udm->where),
6117 : "Previous !$OMP DECLARE MAPPER here");
6118 2 : return MATCH_ERROR;
6119 : }
6120 15 : else if (st)
6121 : {
6122 0 : omp_udm->next = st->n.omp_udm;
6123 0 : st->n.omp_udm = omp_udm;
6124 : }
6125 : else
6126 : {
6127 15 : st = gfc_new_symtree (&gfc_current_ns->omp_udm_root, mapper_id);
6128 15 : st->n.omp_udm = omp_udm;
6129 : }
6130 :
6131 : return MATCH_YES;
6132 :
6133 1 : failure:
6134 1 : if (mapper_ns)
6135 1 : gfc_current_ns = mapper_ns->parent;
6136 1 : gfc_free_omp_udm (omp_udm);
6137 :
6138 1 : return MATCH_ERROR;
6139 : }
6140 :
6141 : /* For 'declare reduction', matches either the combiner or initializer
6142 : expression, either can be an assignment of 'omp_sym1 = ...'
6143 : or a subroutine call, i.e. 'subroutine-name(argument-list)'. */
6144 :
6145 : static bool
6146 922 : match_udr_expr (gfc_symtree *omp_sym1, gfc_symtree *omp_sym2)
6147 : {
6148 922 : match m;
6149 922 : locus old_loc = gfc_current_locus;
6150 922 : char sname[GFC_MAX_SYMBOL_LEN + 1];
6151 922 : gfc_symbol *sym;
6152 922 : gfc_namespace *ns = gfc_current_ns;
6153 922 : gfc_expr *lvalue = NULL, *rvalue = NULL;
6154 922 : gfc_symtree *st;
6155 922 : gfc_actual_arglist *arglist;
6156 :
6157 922 : m = gfc_match (" %v =", &lvalue);
6158 922 : if (m != MATCH_YES)
6159 210 : gfc_current_locus = old_loc;
6160 : else
6161 : {
6162 712 : m = gfc_match (" %e )", &rvalue);
6163 712 : if (m == MATCH_YES)
6164 : {
6165 702 : ns->code = gfc_get_code (EXEC_ASSIGN);
6166 702 : ns->code->expr1 = lvalue;
6167 702 : ns->code->expr2 = rvalue;
6168 702 : ns->code->loc = old_loc;
6169 702 : return true;
6170 : }
6171 :
6172 10 : gfc_current_locus = old_loc;
6173 10 : gfc_free_expr (lvalue);
6174 : }
6175 :
6176 220 : m = gfc_match (" %n", sname);
6177 220 : if (m != MATCH_YES)
6178 4 : goto syntax;
6179 :
6180 216 : if (strcmp (sname, omp_sym1->name) == 0
6181 203 : || strcmp (sname, omp_sym2->name) == 0)
6182 14 : goto syntax;
6183 :
6184 202 : gfc_current_ns = ns->parent;
6185 202 : if (gfc_get_ha_sym_tree (sname, &st))
6186 0 : goto syntax;
6187 :
6188 202 : sym = st->n.sym;
6189 202 : if (sym->attr.flavor != FL_PROCEDURE
6190 74 : && sym->attr.flavor != FL_UNKNOWN)
6191 1 : goto syntax;
6192 :
6193 201 : if (!sym->attr.generic
6194 191 : && !sym->attr.subroutine
6195 73 : && !sym->attr.function)
6196 : {
6197 73 : if (!(sym->attr.external && !sym->attr.referenced))
6198 : {
6199 : /* ...create a symbol in this scope... */
6200 73 : if (sym->ns != gfc_current_ns
6201 73 : && gfc_get_sym_tree (sname, NULL, &st, false) == 1)
6202 0 : goto syntax;
6203 :
6204 73 : if (sym != st->n.sym)
6205 73 : sym = st->n.sym;
6206 : }
6207 :
6208 : /* ...and then to try to make the symbol into a subroutine. */
6209 73 : if (!gfc_add_subroutine (&sym->attr, sym->name, NULL))
6210 0 : goto syntax;
6211 : }
6212 :
6213 201 : gfc_set_sym_referenced (sym);
6214 201 : gfc_gobble_whitespace ();
6215 201 : if (gfc_peek_ascii_char () != '(')
6216 6 : goto syntax;
6217 :
6218 195 : gfc_current_ns = ns;
6219 195 : m = gfc_match_actual_arglist (1, &arglist);
6220 195 : if (m != MATCH_YES)
6221 0 : goto syntax;
6222 :
6223 195 : if (gfc_match_char (')') != MATCH_YES)
6224 0 : goto syntax;
6225 :
6226 195 : gfc_clear_error ();
6227 195 : ns->code = gfc_get_code (EXEC_CALL);
6228 195 : ns->code->symtree = st;
6229 195 : ns->code->ext.actual = arglist;
6230 195 : ns->code->loc = old_loc;
6231 195 : return true;
6232 25 : syntax:
6233 25 : gfc_clear_error ();
6234 25 : gfc_error ("Expected either %<%s = expr%> or %<subroutine-name(argument-list)"
6235 : "%> followed by %<)%> at %L", omp_sym1->name, &old_loc);
6236 25 : return false;
6237 : }
6238 :
6239 : static bool
6240 1203 : gfc_omp_udr_predef (gfc_omp_reduction_op rop, const char *name,
6241 : gfc_typespec *ts, const char **n)
6242 : {
6243 1203 : if (!gfc_numeric_ts (ts) && ts->type != BT_LOGICAL)
6244 : return false;
6245 :
6246 673 : switch (rop)
6247 : {
6248 19 : case OMP_REDUCTION_PLUS:
6249 19 : case OMP_REDUCTION_MINUS:
6250 19 : case OMP_REDUCTION_TIMES:
6251 19 : return ts->type != BT_LOGICAL;
6252 12 : case OMP_REDUCTION_AND:
6253 12 : case OMP_REDUCTION_OR:
6254 12 : case OMP_REDUCTION_EQV:
6255 12 : case OMP_REDUCTION_NEQV:
6256 12 : return ts->type == BT_LOGICAL;
6257 641 : case OMP_REDUCTION_USER:
6258 641 : if (name[0] != '.' && (ts->type == BT_INTEGER || ts->type == BT_REAL))
6259 : {
6260 569 : gfc_symbol *sym;
6261 :
6262 569 : gfc_find_symbol (name, NULL, 1, &sym);
6263 569 : if (sym != NULL)
6264 : {
6265 93 : if (sym->attr.intrinsic)
6266 0 : *n = sym->name;
6267 93 : else if ((sym->attr.flavor != FL_UNKNOWN
6268 81 : && sym->attr.flavor != FL_PROCEDURE)
6269 69 : || sym->attr.external
6270 54 : || sym->attr.generic
6271 54 : || sym->attr.entry
6272 54 : || sym->attr.result
6273 54 : || sym->attr.dummy
6274 54 : || sym->attr.subroutine
6275 50 : || sym->attr.pointer
6276 50 : || sym->attr.target
6277 50 : || sym->attr.cray_pointer
6278 50 : || sym->attr.cray_pointee
6279 50 : || (sym->attr.proc != PROC_UNKNOWN
6280 0 : && sym->attr.proc != PROC_INTRINSIC)
6281 50 : || sym->attr.if_source != IFSRC_UNKNOWN
6282 50 : || sym == sym->ns->proc_name)
6283 43 : *n = NULL;
6284 : else
6285 50 : *n = sym->name;
6286 : }
6287 : else
6288 476 : *n = name;
6289 569 : if (*n
6290 526 : && (strcmp (*n, "max") == 0 || strcmp (*n, "min") == 0))
6291 56 : return true;
6292 531 : else if (*n
6293 488 : && ts->type == BT_INTEGER
6294 402 : && (strcmp (*n, "iand") == 0
6295 396 : || strcmp (*n, "ior") == 0
6296 390 : || strcmp (*n, "ieor") == 0))
6297 : return true;
6298 : }
6299 : break;
6300 : default:
6301 : break;
6302 : }
6303 : return false;
6304 : }
6305 :
6306 : gfc_omp_udr *
6307 666 : gfc_omp_udr_find (gfc_symtree *st, gfc_typespec *ts)
6308 : {
6309 666 : gfc_omp_udr *omp_udr;
6310 :
6311 666 : if (st == NULL)
6312 : return NULL;
6313 :
6314 112 : gfc_symbol *dt = NULL;
6315 112 : if (ts->type == BT_DERIVED || ts->type == BT_CLASS)
6316 25 : dt = (ts->type == BT_CLASS
6317 0 : ? CLASS_DATA (ts->u.derived)->ts.u.derived : ts->u.derived);
6318 260 : for (omp_udr = st->n.omp_udr; omp_udr; omp_udr = omp_udr->next)
6319 161 : if (omp_udr->ts.type == ts->type
6320 91 : || (dt && omp_udr->ts.type == BT_DERIVED))
6321 : {
6322 70 : if (dt && omp_udr->ts.type == BT_DERIVED)
6323 : {
6324 15 : gfc_symbol *dtu = omp_udr->ts.u.derived;
6325 15 : if (dt == dtu)
6326 : return omp_udr;
6327 : /* Special case for comparing derived types across namespaces. If
6328 : the true names and module names are the same and the module name
6329 : is nonnull, then they are equal. */
6330 7 : if (dt->module && dtu->module
6331 1 : && strcmp (dt->name, dtu->name) == 0
6332 1 : && strcmp (dt->module, dtu->module) == 0)
6333 : return omp_udr;
6334 : }
6335 55 : else if (omp_udr->ts.kind == ts->kind)
6336 : {
6337 20 : if (omp_udr->ts.type == BT_CHARACTER)
6338 : {
6339 17 : if (omp_udr->ts.u.cl->length == NULL
6340 15 : || ts->u.cl->length == NULL)
6341 : return omp_udr;
6342 15 : if (omp_udr->ts.u.cl->length->expr_type != EXPR_CONSTANT)
6343 : return omp_udr;
6344 15 : if (ts->u.cl->length->expr_type != EXPR_CONSTANT)
6345 : return omp_udr;
6346 15 : if (omp_udr->ts.u.cl->length->ts.type != BT_INTEGER)
6347 : return omp_udr;
6348 15 : if (ts->u.cl->length->ts.type != BT_INTEGER)
6349 : return omp_udr;
6350 15 : if (gfc_compare_expr (omp_udr->ts.u.cl->length,
6351 : ts->u.cl->length, INTRINSIC_EQ) != 0)
6352 15 : continue;
6353 : }
6354 3 : return omp_udr;
6355 : }
6356 : }
6357 : return NULL;
6358 : }
6359 :
6360 : match
6361 587 : gfc_match_omp_declare_reduction (void)
6362 : {
6363 587 : match m;
6364 587 : gfc_intrinsic_op op;
6365 587 : char name[GFC_MAX_SYMBOL_LEN + 3];
6366 587 : auto_vec<gfc_typespec, 5> tss;
6367 587 : gfc_typespec ts;
6368 587 : unsigned int i;
6369 587 : gfc_symtree *st;
6370 587 : locus where = gfc_current_locus;
6371 587 : locus end_loc = gfc_current_locus;
6372 587 : bool end_loc_set = false;
6373 587 : gfc_omp_reduction_op rop = OMP_REDUCTION_NONE;
6374 :
6375 587 : if (gfc_match_char ('(') != MATCH_YES)
6376 : {
6377 4 : gfc_error ("Expected %<(%> at %C");
6378 4 : return MATCH_ERROR;
6379 : }
6380 :
6381 583 : m = gfc_match (" %o : ", &op);
6382 583 : if (m == MATCH_ERROR)
6383 : return MATCH_ERROR;
6384 583 : if (m == MATCH_YES)
6385 : {
6386 142 : snprintf (name, sizeof name, "operator %s", gfc_op2string (op));
6387 142 : rop = (gfc_omp_reduction_op) op;
6388 : }
6389 : else
6390 : {
6391 441 : m = gfc_match_defined_op_name (name + 1, 1);
6392 441 : if (m == MATCH_ERROR)
6393 : return MATCH_ERROR;
6394 440 : if (m == MATCH_YES)
6395 : {
6396 41 : name[0] = '.';
6397 41 : strcat (name, ".");
6398 41 : if (gfc_match (" : ") != MATCH_YES)
6399 : {
6400 0 : gfc_error ("Expected %<:%> at %C");
6401 0 : return MATCH_ERROR;
6402 : }
6403 : }
6404 : else
6405 : {
6406 399 : if (gfc_match (" %n : ", name) != MATCH_YES)
6407 : {
6408 4 : gfc_error ("Expected an identfifier or operator as reduction "
6409 : "identifier followed by a colon at %C");
6410 4 : return MATCH_ERROR;
6411 : }
6412 : }
6413 : rop = OMP_REDUCTION_USER;
6414 : }
6415 :
6416 578 : m = gfc_match_type_spec (&ts);
6417 578 : if (m != MATCH_YES)
6418 : {
6419 4 : gfc_error ("Expected type spec at %C");
6420 4 : return MATCH_ERROR;
6421 : }
6422 : /* Treat len=: the same as len=*. */
6423 574 : if (ts.type == BT_CHARACTER)
6424 61 : ts.deferred = false;
6425 574 : tss.safe_push (ts);
6426 :
6427 1189 : while (gfc_match_char (',') == MATCH_YES)
6428 : {
6429 42 : m = gfc_match_type_spec (&ts);
6430 42 : if (m != MATCH_YES)
6431 : {
6432 1 : gfc_error ("Expected type spec at %C");
6433 1 : return MATCH_ERROR;
6434 : }
6435 41 : tss.safe_push (ts);
6436 : }
6437 573 : if (gfc_match_char (':') != MATCH_YES)
6438 : {
6439 6 : gfc_error ("Expected %<:%> or %<,%> at %C");
6440 6 : return MATCH_ERROR;
6441 : }
6442 :
6443 567 : st = gfc_find_symtree (gfc_current_ns->omp_udr_root, name);
6444 1111 : for (i = 0; i < tss.length (); i++)
6445 : {
6446 603 : gfc_symtree *omp_out, *omp_in;
6447 603 : gfc_symtree *omp_priv = NULL, *omp_orig = NULL;
6448 603 : gfc_namespace *combiner_ns, *initializer_ns = NULL;
6449 603 : gfc_omp_udr *prev_udr, *omp_udr;
6450 603 : const char *predef_name = NULL;
6451 :
6452 603 : omp_udr = gfc_get_omp_udr ();
6453 603 : omp_udr->name = gfc_get_string ("%s", name);
6454 603 : omp_udr->rop = rop;
6455 603 : omp_udr->ts = tss[i];
6456 603 : omp_udr->where = where;
6457 :
6458 603 : gfc_current_ns = combiner_ns = gfc_get_namespace (gfc_current_ns, 1);
6459 603 : combiner_ns->proc_name = combiner_ns->parent->proc_name;
6460 :
6461 603 : gfc_get_sym_tree ("omp_out", combiner_ns, &omp_out, false);
6462 603 : gfc_get_sym_tree ("omp_in", combiner_ns, &omp_in, false);
6463 603 : combiner_ns->omp_udr_ns = 1;
6464 603 : omp_out->n.sym->ts = tss[i];
6465 603 : omp_in->n.sym->ts = tss[i];
6466 603 : omp_out->n.sym->attr.omp_udr_artificial_var = 1;
6467 603 : omp_in->n.sym->attr.omp_udr_artificial_var = 1;
6468 603 : omp_out->n.sym->attr.flavor = FL_VARIABLE;
6469 603 : omp_in->n.sym->attr.flavor = FL_VARIABLE;
6470 603 : gfc_commit_symbols ();
6471 603 : omp_udr->combiner_ns = combiner_ns;
6472 603 : omp_udr->omp_out = omp_out->n.sym;
6473 603 : omp_udr->omp_in = omp_in->n.sym;
6474 :
6475 603 : locus old_loc = gfc_current_locus;
6476 :
6477 603 : if (!match_udr_expr (omp_out, omp_in))
6478 : {
6479 19 : syntax:
6480 59 : gfc_current_ns = combiner_ns->parent;
6481 59 : gfc_undo_symbols ();
6482 59 : gfc_free_omp_udr (omp_udr);
6483 59 : return MATCH_ERROR;
6484 : }
6485 :
6486 584 : if (gfc_match (" initializer ( ") == MATCH_YES)
6487 : {
6488 319 : gfc_current_ns = combiner_ns->parent;
6489 319 : initializer_ns = gfc_get_namespace (gfc_current_ns, 1);
6490 319 : gfc_current_ns = initializer_ns;
6491 319 : initializer_ns->proc_name = initializer_ns->parent->proc_name;
6492 :
6493 319 : gfc_get_sym_tree ("omp_priv", initializer_ns, &omp_priv, false);
6494 319 : gfc_get_sym_tree ("omp_orig", initializer_ns, &omp_orig, false);
6495 319 : initializer_ns->omp_udr_ns = 1;
6496 319 : omp_priv->n.sym->ts = tss[i];
6497 319 : omp_orig->n.sym->ts = tss[i];
6498 319 : omp_priv->n.sym->attr.omp_udr_artificial_var = 1;
6499 319 : omp_orig->n.sym->attr.omp_udr_artificial_var = 1;
6500 319 : omp_priv->n.sym->attr.flavor = FL_VARIABLE;
6501 319 : omp_orig->n.sym->attr.flavor = FL_VARIABLE;
6502 319 : gfc_commit_symbols ();
6503 319 : omp_udr->initializer_ns = initializer_ns;
6504 319 : omp_udr->omp_priv = omp_priv->n.sym;
6505 319 : omp_udr->omp_orig = omp_orig->n.sym;
6506 :
6507 319 : if (!match_udr_expr (omp_priv, omp_orig))
6508 6 : goto syntax;
6509 : }
6510 :
6511 578 : gfc_current_ns = combiner_ns->parent;
6512 578 : if (!end_loc_set)
6513 : {
6514 542 : end_loc_set = true;
6515 542 : end_loc = gfc_current_locus;
6516 : }
6517 578 : gfc_current_locus = old_loc;
6518 :
6519 578 : prev_udr = gfc_omp_udr_find (st, &tss[i]);
6520 578 : if (gfc_omp_udr_predef (rop, name, &tss[i], &predef_name)
6521 : /* Don't error on !$omp declare reduction (min : integer : ...)
6522 : just yet, there could be integer :: min afterwards,
6523 : making it valid. When the UDR is resolved, we'll get
6524 : to it again. */
6525 578 : && (rop != OMP_REDUCTION_USER || name[0] == '.'))
6526 : {
6527 27 : if (predef_name)
6528 0 : gfc_error_now ("Redefinition of predefined %qs in "
6529 : "!$OMP DECLARE REDUCTION at %L",
6530 : predef_name, &where);
6531 : else
6532 27 : gfc_error_now ("Redefinition of predefined %qs in "
6533 : "!$OMP DECLARE REDUCTION at %L", name, &where);
6534 27 : goto syntax;
6535 : }
6536 551 : else if (prev_udr)
6537 : {
6538 7 : gfc_error_now ("Redefinition of %qs in !$OMP DECLARE REDUCTION at %L",
6539 : name, &where);
6540 7 : inform (gfc_get_location (&prev_udr->where),
6541 : "Previous !$OMP DECLARE REDUCTION");
6542 7 : goto syntax;
6543 : }
6544 544 : else if (st)
6545 : {
6546 98 : omp_udr->next = st->n.omp_udr;
6547 98 : st->n.omp_udr = omp_udr;
6548 : }
6549 : else
6550 : {
6551 446 : st = gfc_new_symtree (&gfc_current_ns->omp_udr_root, name);
6552 446 : st->n.omp_udr = omp_udr;
6553 : }
6554 : }
6555 :
6556 508 : if (end_loc_set)
6557 : {
6558 508 : gfc_current_locus = end_loc;
6559 508 : if (gfc_match_omp_eos () != MATCH_YES)
6560 : {
6561 4 : gfc_error ("Unexpected junk at %C");
6562 4 : return MATCH_ERROR;
6563 : }
6564 : return MATCH_YES;
6565 : }
6566 : return MATCH_ERROR;
6567 587 : }
6568 :
6569 :
6570 : match
6571 472 : gfc_match_omp_declare_target (void)
6572 : {
6573 472 : locus old_loc;
6574 472 : match m;
6575 472 : gfc_omp_clauses *c = NULL;
6576 472 : enum gfc_omp_list_type list;
6577 472 : gfc_omp_namelist *n;
6578 472 : gfc_symbol *s;
6579 :
6580 472 : old_loc = gfc_current_locus;
6581 :
6582 472 : if (gfc_current_ns->proc_name
6583 472 : && gfc_match_omp_eos () == MATCH_YES)
6584 : {
6585 138 : if (!gfc_add_omp_declare_target (&gfc_current_ns->proc_name->attr,
6586 138 : gfc_current_ns->proc_name->name,
6587 : &old_loc))
6588 0 : goto cleanup;
6589 : return MATCH_YES;
6590 : }
6591 :
6592 334 : if (gfc_current_ns->proc_name
6593 334 : && gfc_current_ns->proc_name->attr.if_source == IFSRC_IFBODY)
6594 : {
6595 2 : gfc_error ("Only the !$OMP DECLARE TARGET form without "
6596 : "clauses is allowed in interface block at %C");
6597 2 : goto cleanup;
6598 : }
6599 :
6600 332 : m = gfc_match (" (");
6601 332 : if (m == MATCH_YES)
6602 : {
6603 86 : c = gfc_get_omp_clauses ();
6604 86 : gfc_current_locus = old_loc;
6605 86 : m = gfc_match_omp_to_link (" (", &c->lists[OMP_LIST_ENTER]);
6606 86 : if (m != MATCH_YES)
6607 0 : goto syntax;
6608 86 : if (gfc_match_omp_eos () != MATCH_YES)
6609 : {
6610 0 : gfc_error ("Unexpected junk after !$OMP DECLARE TARGET at %C");
6611 0 : goto cleanup;
6612 : }
6613 : }
6614 246 : else if (gfc_match_omp_clauses (&c, OMP_DECLARE_TARGET_CLAUSES) != MATCH_YES)
6615 : return MATCH_ERROR;
6616 :
6617 326 : gfc_buffer_error (false);
6618 :
6619 326 : static const enum gfc_omp_list_type to_enter_link_lists[]
6620 : = { OMP_LIST_TO, OMP_LIST_ENTER, OMP_LIST_LINK, OMP_LIST_LOCAL };
6621 1630 : for (size_t listn = 0; listn < ARRAY_SIZE (to_enter_link_lists)
6622 1630 : && (list = to_enter_link_lists[listn], true); ++listn)
6623 1849 : for (n = c->lists[list]; n; n = n->next)
6624 545 : if (n->sym)
6625 504 : n->sym->mark = 0;
6626 41 : else if (n->u.common->head)
6627 41 : n->u.common->head->mark = 0;
6628 :
6629 326 : if (c->device_type == OMP_DEVICE_TYPE_UNSET)
6630 258 : c->device_type = OMP_DEVICE_TYPE_ANY;
6631 1304 : for (size_t listn = 0; listn < ARRAY_SIZE (to_enter_link_lists)
6632 1630 : && (list = to_enter_link_lists[listn], true); ++listn)
6633 1849 : for (n = c->lists[list]; n; n = n->next)
6634 545 : if (n->sym)
6635 : {
6636 504 : if (n->sym->attr.in_common)
6637 1 : gfc_error_now ("OMP DECLARE TARGET variable at %L is an "
6638 : "element of a COMMON block", &n->where);
6639 503 : else if (n->sym->attr.omp_groupprivate && list != OMP_LIST_LOCAL)
6640 12 : gfc_error_now ("List item %qs at %L not appear in the %qs clause "
6641 : "as it was previously specified in a GROUPPRIVATE "
6642 : "directive", n->sym->name, &n->where,
6643 : list == OMP_LIST_LINK
6644 5 : ? "link" : list == OMP_LIST_TO ? "to" : "enter");
6645 496 : else if (n->sym->mark)
6646 9 : gfc_error_now ("Variable at %L mentioned multiple times in "
6647 : "clauses of the same OMP DECLARE TARGET directive",
6648 : &n->where);
6649 487 : else if ((n->sym->attr.omp_declare_target_link
6650 482 : || n->sym->attr.omp_declare_target_local)
6651 : && list != OMP_LIST_LINK
6652 7 : && list != OMP_LIST_LOCAL)
6653 1 : gfc_error_now ("OMP DECLARE TARGET variable at %L previously "
6654 : "mentioned in %s clause and later in %s clause",
6655 : &n->where,
6656 : n->sym->attr.omp_declare_target_link ? "LINK"
6657 : : "LOCAL",
6658 : list == OMP_LIST_TO ? "TO" : "ENTER");
6659 486 : else if (n->sym->attr.omp_declare_target
6660 14 : && (list == OMP_LIST_LINK || list == OMP_LIST_LOCAL))
6661 1 : gfc_error_now ("OMP DECLARE TARGET variable at %L previously "
6662 : "mentioned in TO or ENTER clause and later in "
6663 : "%s clause", &n->where,
6664 : list == OMP_LIST_LINK ? "LINK" : "LOCAL");
6665 : else
6666 : {
6667 485 : if (list == OMP_LIST_TO || list == OMP_LIST_ENTER)
6668 446 : gfc_add_omp_declare_target (&n->sym->attr, n->sym->name,
6669 : &n->sym->declared_at);
6670 485 : if (list == OMP_LIST_LINK)
6671 30 : gfc_add_omp_declare_target_link (&n->sym->attr, n->sym->name,
6672 30 : &n->sym->declared_at);
6673 485 : if (list == OMP_LIST_LOCAL)
6674 9 : gfc_add_omp_declare_target_local (&n->sym->attr, n->sym->name,
6675 9 : &n->sym->declared_at);
6676 : }
6677 504 : if (n->sym->attr.omp_device_type != OMP_DEVICE_TYPE_UNSET
6678 36 : && n->sym->attr.omp_device_type != c->device_type)
6679 : {
6680 12 : const char *dt = "any";
6681 12 : if (n->sym->attr.omp_device_type == OMP_DEVICE_TYPE_NOHOST)
6682 : dt = "nohost";
6683 8 : else if (n->sym->attr.omp_device_type == OMP_DEVICE_TYPE_HOST)
6684 4 : dt = "host";
6685 12 : if (n->sym->attr.omp_groupprivate)
6686 1 : gfc_error_now ("List item %qs at %L set in previous OMP "
6687 : "GROUPPRIVATE directive to the different "
6688 : "DEVICE_TYPE %qs", n->sym->name, &n->where, dt);
6689 : else
6690 11 : gfc_error_now ("List item %qs at %L set in previous OMP "
6691 : "DECLARE TARGET directive to the different "
6692 : "DEVICE_TYPE %qs", n->sym->name, &n->where, dt);
6693 : }
6694 504 : n->sym->attr.omp_device_type = c->device_type;
6695 504 : if (c->indirect && c->device_type != OMP_DEVICE_TYPE_ANY)
6696 : {
6697 1 : gfc_error_now ("DEVICE_TYPE must be ANY when used with INDIRECT "
6698 : "at %L", &n->where);
6699 1 : c->indirect = 0;
6700 : }
6701 504 : n->sym->attr.omp_declare_target_indirect = c->indirect;
6702 504 : if (list == OMP_LIST_LINK && c->device_type == OMP_DEVICE_TYPE_NOHOST)
6703 3 : gfc_error_now ("List item %qs at %L set with NOHOST specified may "
6704 : "not appear in a LINK clause", n->sym->name,
6705 : &n->where);
6706 504 : n->sym->mark = 1;
6707 : }
6708 : else /* common block */
6709 : {
6710 41 : if (n->u.common->omp_groupprivate && list != OMP_LIST_LOCAL)
6711 7 : gfc_error_now ("Common block %</%s/%> at %L not appear in the %qs "
6712 : "clause as it was previously specified in a "
6713 : "GROUPPRIVATE directive",
6714 7 : n->u.common->name, &n->where,
6715 : list == OMP_LIST_LINK
6716 5 : ? "link" : list == OMP_LIST_TO ? "to" : "enter");
6717 34 : else if (n->u.common->head && n->u.common->head->mark)
6718 4 : gfc_error_now ("Common block %</%s/%> at %L mentioned multiple "
6719 : "times in clauses of the same OMP DECLARE TARGET "
6720 4 : "directive", n->u.common->name, &n->where);
6721 30 : else if ((n->u.common->omp_declare_target_link
6722 26 : || n->u.common->omp_declare_target_local)
6723 : && list != OMP_LIST_LINK
6724 6 : && list != OMP_LIST_LOCAL)
6725 2 : gfc_error_now ("Common block %</%s/%> at %L previously mentioned "
6726 : "in %s clause and later in %s clause",
6727 1 : n->u.common->name, &n->where,
6728 : n->u.common->omp_declare_target_link ? "LINK"
6729 : : "LOCAL",
6730 : list == OMP_LIST_TO ? "TO" : "ENTER");
6731 29 : else if (n->u.common->omp_declare_target
6732 4 : && (list == OMP_LIST_LINK || list == OMP_LIST_LOCAL))
6733 1 : gfc_error_now ("Common block %</%s/%> at %L previously mentioned "
6734 : "in TO or ENTER clause and later in %s clause",
6735 1 : n->u.common->name, &n->where,
6736 : list == OMP_LIST_LINK ? "LINK" : "LOCAL");
6737 41 : if (n->u.common->omp_device_type != OMP_DEVICE_TYPE_UNSET
6738 21 : && n->u.common->omp_device_type != c->device_type)
6739 : {
6740 1 : const char *dt = "any";
6741 1 : if (n->u.common->omp_device_type == OMP_DEVICE_TYPE_NOHOST)
6742 : dt = "nohost";
6743 0 : else if (n->u.common->omp_device_type == OMP_DEVICE_TYPE_HOST)
6744 0 : dt = "host";
6745 1 : if (n->u.common->omp_groupprivate)
6746 1 : gfc_error_now ("Common block %</%s/%> at %L set in previous OMP "
6747 : "GROUPPRIVATE directive to the different "
6748 1 : "DEVICE_TYPE %qs", n->u.common->name, &n->where,
6749 : dt);
6750 : else
6751 0 : gfc_error_now ("Common block %</%s/%> at %L set in previous OMP "
6752 : "DECLARE TARGET directive to the different "
6753 0 : "DEVICE_TYPE %qs", n->u.common->name, &n->where,
6754 : dt);
6755 : }
6756 41 : n->u.common->omp_device_type = c->device_type;
6757 :
6758 41 : if (c->indirect && c->device_type != OMP_DEVICE_TYPE_ANY)
6759 : {
6760 0 : gfc_error_now ("DEVICE_TYPE must be ANY when used with INDIRECT "
6761 : "at %L", &n->where);
6762 0 : c->indirect = 0;
6763 : }
6764 41 : if (list == OMP_LIST_LINK && c->device_type == OMP_DEVICE_TYPE_NOHOST)
6765 1 : gfc_error_now ("Common block %</%s/%> at %L set with NOHOST "
6766 : "specified may not appear in a LINK clause",
6767 1 : n->u.common->name, &n->where);
6768 :
6769 41 : if (list == OMP_LIST_TO || list == OMP_LIST_ENTER)
6770 21 : n->u.common->omp_declare_target = 1;
6771 41 : if (list == OMP_LIST_LINK)
6772 15 : n->u.common->omp_declare_target_link = 1;
6773 41 : if (list == OMP_LIST_LOCAL)
6774 5 : n->u.common->omp_declare_target_local = 1;
6775 :
6776 110 : for (s = n->u.common->head; s; s = s->common_next)
6777 : {
6778 69 : s->mark = 1;
6779 69 : if (list == OMP_LIST_TO || list == OMP_LIST_ENTER)
6780 33 : gfc_add_omp_declare_target (&s->attr, s->name, &n->where);
6781 69 : if (list == OMP_LIST_LINK)
6782 31 : gfc_add_omp_declare_target_link (&s->attr, s->name, &n->where);
6783 69 : if (list == OMP_LIST_LOCAL)
6784 5 : gfc_add_omp_declare_target_local (&s->attr, s->name, &n->where);
6785 69 : s->attr.omp_device_type = c->device_type;
6786 69 : s->attr.omp_declare_target_indirect = c->indirect;
6787 : }
6788 : }
6789 326 : if ((c->device_type || c->indirect)
6790 326 : && !c->lists[OMP_LIST_ENTER]
6791 151 : && !c->lists[OMP_LIST_TO]
6792 47 : && !c->lists[OMP_LIST_LINK]
6793 10 : && !c->lists[OMP_LIST_LOCAL])
6794 2 : gfc_warning_now (OPT_Wopenmp,
6795 : "OMP DECLARE TARGET directive at %L with only "
6796 : "DEVICE_TYPE or INDIRECT clauses is ignored",
6797 : &old_loc);
6798 :
6799 326 : gfc_buffer_error (true);
6800 :
6801 326 : if (c)
6802 326 : gfc_free_omp_clauses (c);
6803 326 : return MATCH_YES;
6804 :
6805 0 : syntax:
6806 0 : gfc_error ("Syntax error in !$OMP DECLARE TARGET list at %C");
6807 :
6808 2 : cleanup:
6809 2 : gfc_current_locus = old_loc;
6810 2 : if (c)
6811 0 : gfc_free_omp_clauses (c);
6812 : return MATCH_ERROR;
6813 : }
6814 :
6815 : /* Skip over and ignore trait-property-extensions.
6816 :
6817 : trait-property-extension :
6818 : trait-property-name
6819 : identifier (trait-property-extension[, trait-property-extension[, ...]])
6820 : constant integer expression
6821 : */
6822 :
6823 : static match gfc_ignore_trait_property_extension_list (void);
6824 :
6825 : static match
6826 7 : gfc_ignore_trait_property_extension (void)
6827 : {
6828 7 : char buf[GFC_MAX_SYMBOL_LEN + 1];
6829 7 : gfc_expr *expr;
6830 :
6831 : /* Identifier form of trait-property name, possibly followed by
6832 : a list of (recursive) trait-property-extensions. */
6833 7 : if (gfc_match_name (buf) == MATCH_YES)
6834 : {
6835 0 : if (gfc_match (" (") == MATCH_YES)
6836 0 : return gfc_ignore_trait_property_extension_list ();
6837 : return MATCH_YES;
6838 : }
6839 :
6840 : /* Literal constant. */
6841 7 : if (gfc_match_literal_constant (&expr, 0) == MATCH_YES)
6842 : return MATCH_YES;
6843 :
6844 : /* FIXME: constant integer expressions. */
6845 0 : gfc_error ("Expected trait-property-extension at %C");
6846 0 : return MATCH_ERROR;
6847 : }
6848 :
6849 : static match
6850 5 : gfc_ignore_trait_property_extension_list (void)
6851 : {
6852 9 : while (1)
6853 : {
6854 7 : if (gfc_ignore_trait_property_extension () != MATCH_YES)
6855 : return MATCH_ERROR;
6856 7 : if (gfc_match (" ,") == MATCH_YES)
6857 2 : continue;
6858 5 : if (gfc_match (" )") == MATCH_YES)
6859 : return MATCH_YES;
6860 0 : gfc_error ("expected %<)%> at %C");
6861 0 : return MATCH_ERROR;
6862 : }
6863 : }
6864 :
6865 :
6866 : match
6867 110 : gfc_match_omp_interop (void)
6868 : {
6869 110 : return match_omp (EXEC_OMP_INTEROP, OMP_INTEROP_CLAUSES);
6870 : }
6871 :
6872 :
6873 : /* OpenMP 5.0:
6874 :
6875 : trait-selector:
6876 : trait-selector-name[([trait-score:]trait-property[,trait-property[,...]])]
6877 :
6878 : trait-score:
6879 : score(score-expression) */
6880 :
6881 : static match
6882 637 : gfc_match_omp_context_selector (gfc_omp_set_selector *oss)
6883 : {
6884 775 : do
6885 : {
6886 775 : char selector[GFC_MAX_SYMBOL_LEN + 1];
6887 :
6888 775 : if (gfc_match_name (selector) != MATCH_YES)
6889 : {
6890 2 : gfc_error ("expected trait selector name at %C");
6891 39 : return MATCH_ERROR;
6892 : }
6893 :
6894 773 : gfc_omp_selector *os = gfc_get_omp_selector ();
6895 773 : if (oss->code == OMP_TRAIT_SET_CONSTRUCT
6896 335 : && !strcmp (selector, "do"))
6897 48 : os->code = OMP_TRAIT_CONSTRUCT_FOR;
6898 725 : else if (oss->code == OMP_TRAIT_SET_CONSTRUCT
6899 287 : && !strcmp (selector, "for"))
6900 1 : os->code = OMP_TRAIT_INVALID;
6901 : else
6902 724 : os->code = omp_lookup_ts_code (oss->code, selector);
6903 773 : os->next = oss->trait_selectors;
6904 773 : oss->trait_selectors = os;
6905 :
6906 773 : if (os->code == OMP_TRAIT_INVALID)
6907 : {
6908 18 : gfc_warning (OPT_Wopenmp,
6909 : "unknown selector %qs for context selector set %qs "
6910 : "at %C",
6911 18 : selector, omp_tss_map[oss->code]);
6912 18 : if (gfc_match (" (") == MATCH_YES
6913 18 : && gfc_ignore_trait_property_extension_list () != MATCH_YES)
6914 : return MATCH_ERROR;
6915 18 : if (gfc_match (" ,") == MATCH_YES)
6916 1 : continue;
6917 598 : break;
6918 : }
6919 :
6920 755 : enum omp_tp_type property_kind = omp_ts_map[os->code].tp_type;
6921 755 : bool allow_score = omp_ts_map[os->code].allow_score;
6922 :
6923 755 : if (gfc_match (" (") == MATCH_YES)
6924 : {
6925 431 : if (property_kind == OMP_TRAIT_PROPERTY_NONE)
6926 : {
6927 6 : gfc_error ("selector %qs does not accept any properties at %C",
6928 : selector);
6929 6 : return MATCH_ERROR;
6930 : }
6931 :
6932 425 : if (gfc_match (" score") == MATCH_YES)
6933 : {
6934 63 : if (!allow_score)
6935 : {
6936 10 : gfc_error ("%<score%> cannot be specified in traits "
6937 : "in the %qs trait-selector-set at %C",
6938 10 : omp_tss_map[oss->code]);
6939 10 : return MATCH_ERROR;
6940 : }
6941 53 : if (gfc_match (" (") != MATCH_YES)
6942 : {
6943 0 : gfc_error ("expected %<(%> at %C");
6944 0 : return MATCH_ERROR;
6945 : }
6946 53 : if (gfc_match_expr (&os->score) != MATCH_YES)
6947 : return MATCH_ERROR;
6948 :
6949 52 : if (gfc_match (" )") != MATCH_YES)
6950 : {
6951 0 : gfc_error ("expected %<)%> at %C");
6952 0 : return MATCH_ERROR;
6953 : }
6954 :
6955 52 : if (gfc_match (" :") != MATCH_YES)
6956 : {
6957 0 : gfc_error ("expected : at %C");
6958 0 : return MATCH_ERROR;
6959 : }
6960 : }
6961 :
6962 414 : gfc_omp_trait_property *otp = gfc_get_omp_trait_property ();
6963 414 : otp->property_kind = property_kind;
6964 414 : otp->next = os->properties;
6965 414 : os->properties = otp;
6966 :
6967 414 : switch (property_kind)
6968 : {
6969 25 : case OMP_TRAIT_PROPERTY_ID:
6970 25 : {
6971 25 : char buf[GFC_MAX_SYMBOL_LEN + 1];
6972 25 : if (gfc_match_name (buf) == MATCH_YES)
6973 : {
6974 24 : otp->name = XNEWVEC (char, strlen (buf) + 1);
6975 24 : strcpy (otp->name, buf);
6976 : }
6977 : else
6978 : {
6979 1 : gfc_error ("expected identifier at %C");
6980 1 : free (otp);
6981 1 : os->properties = nullptr;
6982 1 : return MATCH_ERROR;
6983 : }
6984 : }
6985 24 : break;
6986 290 : case OMP_TRAIT_PROPERTY_NAME_LIST:
6987 343 : do
6988 : {
6989 290 : char buf[GFC_MAX_SYMBOL_LEN + 1];
6990 290 : if (gfc_match_name (buf) == MATCH_YES)
6991 : {
6992 170 : otp->name = XNEWVEC (char, strlen (buf) + 1);
6993 170 : strcpy (otp->name, buf);
6994 170 : otp->is_name = true;
6995 : }
6996 120 : else if (gfc_match_literal_constant (&otp->expr, 0)
6997 : != MATCH_YES
6998 120 : || otp->expr->ts.type != BT_CHARACTER)
6999 : {
7000 5 : gfc_error ("expected identifier or string literal "
7001 : "at %C");
7002 5 : free (otp);
7003 5 : os->properties = nullptr;
7004 5 : return MATCH_ERROR;
7005 : }
7006 :
7007 285 : if (gfc_match (" ,") == MATCH_YES)
7008 : {
7009 53 : otp = gfc_get_omp_trait_property ();
7010 53 : otp->property_kind = property_kind;
7011 53 : otp->next = os->properties;
7012 53 : os->properties = otp;
7013 : }
7014 : else
7015 : break;
7016 53 : }
7017 : while (1);
7018 232 : break;
7019 137 : case OMP_TRAIT_PROPERTY_DEV_NUM_EXPR:
7020 137 : case OMP_TRAIT_PROPERTY_BOOL_EXPR:
7021 137 : if (gfc_match_expr (&otp->expr) != MATCH_YES)
7022 : {
7023 3 : gfc_error ("expected expression at %C");
7024 3 : free (otp);
7025 3 : os->properties = nullptr;
7026 3 : return MATCH_ERROR;
7027 : }
7028 : break;
7029 15 : case OMP_TRAIT_PROPERTY_CLAUSE_LIST:
7030 15 : {
7031 15 : if (os->code == OMP_TRAIT_CONSTRUCT_SIMD)
7032 : {
7033 15 : gfc_matching_omp_context_selector = true;
7034 15 : if (gfc_match_omp_clauses (&otp->clauses,
7035 15 : OMP_DECLARE_SIMD_CLAUSES,
7036 : true, false, false)
7037 : != MATCH_YES)
7038 : {
7039 1 : gfc_matching_omp_context_selector = false;
7040 1 : gfc_error ("expected simd clause at %C");
7041 1 : return MATCH_ERROR;
7042 : }
7043 14 : gfc_matching_omp_context_selector = false;
7044 : }
7045 0 : else if (os->code == OMP_TRAIT_IMPLEMENTATION_REQUIRES)
7046 : {
7047 : /* FIXME: The "requires" selector was added in OpenMP 5.1.
7048 : Currently only the now-deprecated syntax
7049 : from OpenMP 5.0 is supported.
7050 : TODO: When implementing, update modules.cc as well. */
7051 0 : sorry_at (gfc_get_location (&gfc_current_locus),
7052 : "%<requires%> selector is not supported yet");
7053 0 : return MATCH_ERROR;
7054 : }
7055 : else
7056 0 : gcc_unreachable ();
7057 14 : break;
7058 : }
7059 0 : default:
7060 0 : gcc_unreachable ();
7061 : }
7062 :
7063 404 : if (gfc_match (" )") != MATCH_YES)
7064 : {
7065 2 : gfc_error ("expected %<)%> at %C");
7066 2 : return MATCH_ERROR;
7067 : }
7068 : }
7069 324 : else if (property_kind != OMP_TRAIT_PROPERTY_NONE
7070 324 : && property_kind != OMP_TRAIT_PROPERTY_CLAUSE_LIST
7071 8 : && property_kind != OMP_TRAIT_PROPERTY_EXTENSION)
7072 : {
7073 8 : if (gfc_match (" (") != MATCH_YES)
7074 : {
7075 8 : gfc_error ("expected %<(%> at %C");
7076 8 : return MATCH_ERROR;
7077 : }
7078 : }
7079 :
7080 718 : if (gfc_match (" ,") != MATCH_YES)
7081 : break;
7082 : }
7083 : while (1);
7084 :
7085 598 : return MATCH_YES;
7086 : }
7087 :
7088 : /* OpenMP 5.0:
7089 :
7090 : trait-set-selector[,trait-set-selector[,...]]
7091 :
7092 : trait-set-selector:
7093 : trait-set-selector-name = { trait-selector[, trait-selector[, ...]] }
7094 :
7095 : trait-set-selector-name:
7096 : constructor
7097 : device
7098 : implementation
7099 : user */
7100 :
7101 : static match
7102 577 : gfc_match_omp_context_selector_specification (gfc_omp_set_selector **oss_head)
7103 : {
7104 713 : do
7105 : {
7106 645 : match m;
7107 645 : char buf[GFC_MAX_SYMBOL_LEN + 1];
7108 645 : enum omp_tss_code set = OMP_TRAIT_SET_INVALID;
7109 :
7110 645 : m = gfc_match_name (buf);
7111 645 : if (m == MATCH_YES)
7112 643 : set = omp_lookup_tss_code (buf);
7113 :
7114 643 : if (set == OMP_TRAIT_SET_INVALID)
7115 : {
7116 5 : gfc_error ("expected context selector set name at %C");
7117 47 : return MATCH_ERROR;
7118 : }
7119 :
7120 640 : m = gfc_match (" =");
7121 640 : if (m != MATCH_YES)
7122 : {
7123 1 : gfc_error ("expected %<=%> at %C");
7124 1 : return MATCH_ERROR;
7125 : }
7126 :
7127 639 : m = gfc_match (" {");
7128 639 : if (m != MATCH_YES)
7129 : {
7130 2 : gfc_error ("expected %<{%> at %C");
7131 2 : return MATCH_ERROR;
7132 : }
7133 :
7134 637 : gfc_omp_set_selector *oss = gfc_get_omp_set_selector ();
7135 637 : oss->next = *oss_head;
7136 637 : oss->code = set;
7137 637 : *oss_head = oss;
7138 :
7139 637 : if (gfc_match_omp_context_selector (oss) != MATCH_YES)
7140 : return MATCH_ERROR;
7141 :
7142 598 : m = gfc_match (" }");
7143 598 : if (m != MATCH_YES)
7144 : {
7145 0 : gfc_error ("expected %<}%> at %C");
7146 0 : return MATCH_ERROR;
7147 : }
7148 :
7149 598 : m = gfc_match (" ,");
7150 598 : if (m != MATCH_YES)
7151 : break;
7152 68 : }
7153 : while (1);
7154 :
7155 530 : return MATCH_YES;
7156 : }
7157 :
7158 :
7159 : match
7160 419 : gfc_match_omp_declare_variant (void)
7161 : {
7162 419 : char buf[GFC_MAX_SYMBOL_LEN + 1];
7163 :
7164 419 : if (gfc_match (" (") != MATCH_YES)
7165 : {
7166 2 : gfc_error ("expected %<(%> at %C");
7167 2 : return MATCH_ERROR;
7168 : }
7169 :
7170 417 : gfc_symtree *base_proc_st, *variant_proc_st;
7171 417 : if (gfc_match_name (buf) != MATCH_YES)
7172 : {
7173 2 : gfc_error ("expected name at %C");
7174 2 : return MATCH_ERROR;
7175 : }
7176 :
7177 415 : if (gfc_get_ha_sym_tree (buf, &base_proc_st))
7178 : return MATCH_ERROR;
7179 :
7180 415 : if (gfc_match (" :") == MATCH_YES)
7181 : {
7182 16 : if (gfc_match_name (buf) != MATCH_YES)
7183 : {
7184 0 : gfc_error ("expected variant name at %C");
7185 0 : return MATCH_ERROR;
7186 : }
7187 :
7188 16 : if (gfc_get_ha_sym_tree (buf, &variant_proc_st))
7189 : return MATCH_ERROR;
7190 : }
7191 : else
7192 : {
7193 : /* Base procedure not specified. */
7194 399 : variant_proc_st = base_proc_st;
7195 399 : base_proc_st = NULL;
7196 : }
7197 :
7198 415 : gfc_omp_declare_variant *odv;
7199 415 : odv = gfc_get_omp_declare_variant ();
7200 415 : odv->where = gfc_current_locus;
7201 415 : odv->variant_proc_symtree = variant_proc_st;
7202 415 : odv->adjust_args_list = NULL;
7203 415 : odv->base_proc_symtree = base_proc_st;
7204 415 : odv->next = NULL;
7205 415 : odv->error_p = false;
7206 :
7207 : /* Add the new declare variant to the end of the list. */
7208 415 : gfc_omp_declare_variant **prev_next = &gfc_current_ns->omp_declare_variant;
7209 555 : while (*prev_next)
7210 140 : prev_next = &((*prev_next)->next);
7211 415 : *prev_next = odv;
7212 :
7213 415 : if (gfc_match (" )") != MATCH_YES)
7214 : {
7215 1 : gfc_error ("expected %<)%> at %C");
7216 1 : return MATCH_ERROR;
7217 : }
7218 :
7219 414 : bool has_match = false, has_adjust_args = false, has_append_args = false;
7220 414 : bool error_p = false;
7221 414 : locus adjust_args_loc;
7222 414 : locus append_args_loc;
7223 :
7224 414 : gfc_gobble_whitespace ();
7225 414 : gfc_match_char (',');
7226 632 : for (;;)
7227 : {
7228 523 : gfc_gobble_whitespace ();
7229 :
7230 523 : enum clause
7231 : {
7232 : clause_match,
7233 : clause_adjust_args,
7234 : clause_append_args
7235 : } ccode;
7236 :
7237 523 : if (gfc_match ("match") == MATCH_YES)
7238 : ccode = clause_match;
7239 119 : else if (gfc_match ("adjust_args") == MATCH_YES)
7240 : {
7241 517 : ccode = clause_adjust_args;
7242 : adjust_args_loc = gfc_current_locus;
7243 : }
7244 38 : else if (gfc_match ("append_args") == MATCH_YES)
7245 : {
7246 517 : ccode = clause_append_args;
7247 : append_args_loc = gfc_current_locus;
7248 : }
7249 : else
7250 : {
7251 : error_p = true;
7252 : break;
7253 : }
7254 :
7255 517 : if (gfc_match (" ( ") != MATCH_YES)
7256 : {
7257 1 : gfc_error ("expected %<(%> at %C");
7258 1 : return MATCH_ERROR;
7259 : }
7260 :
7261 516 : if (ccode == clause_match)
7262 : {
7263 403 : if (has_match)
7264 : {
7265 1 : gfc_error ("%qs clause at %L specified more than once",
7266 : "match", &gfc_current_locus);
7267 1 : return MATCH_ERROR;
7268 : }
7269 402 : has_match = true;
7270 402 : if (gfc_match_omp_context_selector_specification (&odv->set_selectors)
7271 : != MATCH_YES)
7272 : return MATCH_ERROR;
7273 362 : if (gfc_match (" )") != MATCH_YES)
7274 : {
7275 0 : gfc_error ("expected %<)%> at %C");
7276 0 : return MATCH_ERROR;
7277 : }
7278 : }
7279 113 : else if (ccode == clause_adjust_args)
7280 : {
7281 81 : has_adjust_args = true;
7282 81 : bool need_device_ptr_p = false;
7283 81 : bool need_device_addr_p = false;
7284 81 : if (gfc_match ("nothing ") == MATCH_YES)
7285 : ;
7286 58 : else if (gfc_match ("need_device_ptr ") == MATCH_YES)
7287 : need_device_ptr_p = true;
7288 9 : else if (gfc_match ("need_device_addr ") == MATCH_YES)
7289 : need_device_addr_p = true;
7290 : else
7291 : {
7292 2 : gfc_error ("expected %<nothing%>, %<need_device_ptr%> or "
7293 : "%<need_device_addr%> at %C");
7294 2 : return MATCH_ERROR;
7295 : }
7296 79 : if (gfc_match (": ") != MATCH_YES)
7297 : {
7298 1 : gfc_error ("expected %<:%> at %C");
7299 1 : return MATCH_ERROR;
7300 : }
7301 : gfc_omp_namelist *tail = NULL;
7302 : bool need_range = false, have_range = false;
7303 125 : while (true)
7304 : {
7305 125 : gfc_omp_namelist *p = gfc_get_omp_namelist ();
7306 125 : p->where = gfc_current_locus;
7307 125 : p->u.adj_args.need_ptr = need_device_ptr_p;
7308 125 : p->u.adj_args.need_addr = need_device_addr_p;
7309 125 : if (tail)
7310 : {
7311 47 : tail->next = p;
7312 47 : tail = tail->next;
7313 : }
7314 : else
7315 : {
7316 78 : gfc_omp_namelist **q = &odv->adjust_args_list;
7317 78 : if (*q)
7318 : {
7319 50 : for (; (*q)->next; q = &(*q)->next)
7320 : ;
7321 28 : (*q)->next = p;
7322 : }
7323 : else
7324 50 : *q = p;
7325 : tail = p;
7326 : }
7327 125 : if (gfc_match (": ") == MATCH_YES)
7328 : {
7329 2 : if (have_range)
7330 : {
7331 0 : gfc_error ("unexpected %<:%> at %C");
7332 2 : return MATCH_ERROR;
7333 : }
7334 2 : p->u.adj_args.range_start = have_range = true;
7335 2 : need_range = false;
7336 49 : continue;
7337 : }
7338 123 : if (have_range && gfc_match (", ") == MATCH_YES)
7339 : {
7340 1 : have_range = false;
7341 1 : continue;
7342 : }
7343 122 : if (have_range && gfc_match (") ") == MATCH_YES)
7344 : break;
7345 121 : locus saved_loc = gfc_current_locus;
7346 :
7347 : /* Without ranges, only arg names or integer literals permitted;
7348 : handle literals here as gfc_match_expr simplifies the expr. */
7349 121 : if (gfc_match_literal_constant (&p->expr, true) == MATCH_YES)
7350 : {
7351 17 : gfc_gobble_whitespace ();
7352 17 : char c = gfc_peek_ascii_char ();
7353 17 : if (c != ')' && c != ',' && c != ':')
7354 : {
7355 1 : gfc_free_expr (p->expr);
7356 1 : p->expr = NULL;
7357 1 : gfc_current_locus = saved_loc;
7358 : }
7359 : }
7360 121 : if (!p->expr && gfc_match ("omp_num_args") == MATCH_YES)
7361 : {
7362 6 : if (!have_range)
7363 3 : p->u.adj_args.range_start = need_range = true;
7364 : else
7365 : need_range = false;
7366 :
7367 6 : locus saved_loc2 = gfc_current_locus;
7368 6 : gfc_gobble_whitespace ();
7369 6 : char c = gfc_peek_ascii_char ();
7370 6 : if (c == '+' || c == '-')
7371 : {
7372 5 : if (gfc_match ("+ %e", &p->expr) == MATCH_YES)
7373 1 : p->u.adj_args.omp_num_args_plus = true;
7374 4 : else if (gfc_match ("- %e", &p->expr) == MATCH_YES)
7375 4 : p->u.adj_args.omp_num_args_minus = true;
7376 0 : else if (!gfc_error_check ())
7377 : {
7378 0 : gfc_error ("expected constant integer expression "
7379 : "at %C");
7380 0 : p->u.adj_args.error_p = true;
7381 0 : return MATCH_ERROR;
7382 : }
7383 5 : p->where = gfc_get_location_range (&saved_loc, 1,
7384 : &saved_loc, 1,
7385 : &gfc_current_locus);
7386 : }
7387 : else
7388 : {
7389 1 : p->where = gfc_get_location_range (&saved_loc, 1,
7390 : &saved_loc, 1,
7391 : &saved_loc2);
7392 1 : p->u.adj_args.omp_num_args_plus = true;
7393 : }
7394 : }
7395 115 : else if (!p->expr)
7396 : {
7397 99 : match m = gfc_match_expr (&p->expr);
7398 99 : if (m != MATCH_YES)
7399 : {
7400 1 : gfc_error ("expected dummy parameter name, "
7401 : "%<omp_num_args%> or constant positive integer"
7402 : " at %C");
7403 1 : p->u.adj_args.error_p = true;
7404 1 : return MATCH_ERROR;
7405 : }
7406 98 : if (p->expr->expr_type == EXPR_CONSTANT && !have_range)
7407 98 : need_range = true; /* Constant expr but not literal. */
7408 98 : p->where = p->expr->where;
7409 : }
7410 : else
7411 16 : p->where = p->expr->where;
7412 120 : gfc_gobble_whitespace ();
7413 120 : match m = gfc_match (": ");
7414 120 : if (need_range && m != MATCH_YES)
7415 : {
7416 1 : gfc_error ("expected %<:%> at %C");
7417 1 : return MATCH_ERROR;
7418 : }
7419 119 : if (m == MATCH_YES)
7420 : {
7421 6 : p->u.adj_args.range_start = have_range = true;
7422 6 : need_range = false;
7423 6 : continue;
7424 : }
7425 113 : need_range = have_range = false;
7426 113 : if (gfc_match (", ") == MATCH_YES)
7427 38 : continue;
7428 75 : if (gfc_match (") ") == MATCH_YES)
7429 : break;
7430 : }
7431 : }
7432 32 : else if (ccode == clause_append_args)
7433 : {
7434 32 : if (has_append_args)
7435 : {
7436 1 : gfc_error ("%qs clause at %L specified more than once",
7437 : "append_args", &gfc_current_locus);
7438 1 : return MATCH_ERROR;
7439 : }
7440 56 : has_append_args = true;
7441 : gfc_omp_namelist *append_args_last = NULL;
7442 81 : do
7443 : {
7444 56 : gfc_gobble_whitespace ();
7445 56 : if (gfc_match ("interop ") != MATCH_YES)
7446 : {
7447 0 : gfc_error ("expected %<interop%> at %C");
7448 3 : return MATCH_ERROR;
7449 : }
7450 56 : if (gfc_match ("( ") != MATCH_YES)
7451 : {
7452 0 : gfc_error ("expected %<(%> at %C");
7453 0 : return MATCH_ERROR;
7454 : }
7455 :
7456 56 : bool target, targetsync;
7457 56 : char *type_str = NULL;
7458 56 : int type_str_len;
7459 56 : locus loc = gfc_current_locus;
7460 56 : if (gfc_parser_omp_clause_init_modifiers (target, targetsync,
7461 : &type_str, type_str_len,
7462 : false) == MATCH_ERROR)
7463 : return MATCH_ERROR;
7464 :
7465 54 : gfc_omp_namelist *n = gfc_get_omp_namelist();
7466 54 : n->where = loc;
7467 54 : n->u.init.target = target;
7468 54 : n->u.init.targetsync = targetsync;
7469 54 : n->u.init.len = type_str_len;
7470 54 : n->u2.init_interop = type_str;
7471 54 : if (odv->append_args_list)
7472 : {
7473 25 : append_args_last->next = n;
7474 25 : append_args_last = n;
7475 : }
7476 : else
7477 29 : append_args_last = odv->append_args_list = n;
7478 :
7479 54 : gfc_gobble_whitespace ();
7480 54 : if (gfc_match_char (',') == MATCH_YES)
7481 25 : continue;
7482 29 : if (gfc_match_char (')') == MATCH_YES)
7483 : break;
7484 1 : gfc_error ("Expected %<,%> or %<)%> at %C");
7485 1 : return MATCH_ERROR;
7486 : }
7487 : while (true);
7488 : }
7489 466 : gfc_gobble_whitespace ();
7490 466 : if (gfc_match_omp_eos () == MATCH_YES)
7491 : break;
7492 109 : gfc_match_char (',');
7493 109 : }
7494 :
7495 363 : if (error_p || (!has_match && !has_adjust_args && !has_append_args))
7496 : {
7497 6 : gfc_error ("expected %<match%>, %<adjust_args%> or %<append_args%> at %C");
7498 6 : return MATCH_ERROR;
7499 : }
7500 :
7501 357 : if (!has_match)
7502 : {
7503 3 : gfc_error ("expected %<match%> clause at %C");
7504 3 : return MATCH_ERROR;
7505 : }
7506 :
7507 : return MATCH_YES;
7508 : }
7509 :
7510 :
7511 : static match
7512 160 : match_omp_metadirective (bool begin_p)
7513 : {
7514 160 : locus old_loc = gfc_current_locus;
7515 160 : gfc_omp_variant *variants_head;
7516 160 : gfc_omp_variant **next_variant = &variants_head;
7517 160 : bool default_seen = false;
7518 :
7519 : /* Parse the context selectors. */
7520 656 : for (;;)
7521 : {
7522 408 : bool default_p = false;
7523 408 : gfc_omp_set_selector *selectors = NULL;
7524 :
7525 408 : gfc_gobble_whitespace ();
7526 408 : if (gfc_match_eos () == MATCH_YES)
7527 : break;
7528 266 : gfc_match_char (',');
7529 266 : gfc_gobble_whitespace ();
7530 :
7531 266 : locus variant_locus = gfc_current_locus;
7532 :
7533 266 : if (gfc_match ("default ( ") == MATCH_YES)
7534 : {
7535 82 : default_p = true;
7536 82 : gfc_warning (OPT_Wdeprecated_openmp,
7537 : "%<default%> clause with metadirective at %L "
7538 : "deprecated since OpenMP 5.2", &variant_locus);
7539 : }
7540 184 : else if (gfc_match ("otherwise ( ") == MATCH_YES)
7541 : default_p = true;
7542 177 : else if (gfc_match ("when ( ") != MATCH_YES)
7543 : {
7544 1 : gfc_error ("expected %<when%>, %<otherwise%>, or %<default%> at %C");
7545 1 : gfc_current_locus = old_loc;
7546 18 : return MATCH_ERROR;
7547 : }
7548 89 : if (default_p && default_seen)
7549 : {
7550 3 : gfc_error ("too many %<otherwise%> or %<default%> clauses "
7551 : "in %<metadirective%> at %C");
7552 3 : gfc_current_locus = old_loc;
7553 3 : return MATCH_ERROR;
7554 : }
7555 262 : else if (default_seen)
7556 : {
7557 1 : gfc_error ("%<otherwise%> or %<default%> clause "
7558 : "must appear last in %<metadirective%> at %C");
7559 1 : gfc_current_locus = old_loc;
7560 1 : return MATCH_ERROR;
7561 : }
7562 :
7563 261 : if (!default_p)
7564 : {
7565 175 : if (gfc_match_omp_context_selector_specification (&selectors)
7566 : != MATCH_YES)
7567 : return MATCH_ERROR;
7568 :
7569 168 : if (gfc_match (" : ") != MATCH_YES)
7570 : {
7571 1 : gfc_error ("expected %<:%> at %C");
7572 1 : gfc_current_locus = old_loc;
7573 1 : return MATCH_ERROR;
7574 : }
7575 :
7576 167 : gfc_commit_symbols ();
7577 : }
7578 :
7579 253 : gfc_matching_omp_context_selector = true;
7580 253 : gfc_statement directive = match_omp_directive ();
7581 253 : gfc_matching_omp_context_selector = false;
7582 :
7583 253 : if (is_omp_declarative_stmt (directive))
7584 0 : sorry_at (gfc_get_location (&gfc_current_locus),
7585 : "declarative directive variants are not supported");
7586 :
7587 253 : if (gfc_error_flag_test ())
7588 : {
7589 2 : gfc_current_locus = old_loc;
7590 2 : return MATCH_ERROR;
7591 : }
7592 :
7593 251 : if (gfc_match (" )") != MATCH_YES)
7594 : {
7595 0 : gfc_error ("Expected %<)%> at %C");
7596 0 : gfc_current_locus = old_loc;
7597 0 : return MATCH_ERROR;
7598 : }
7599 :
7600 251 : gfc_commit_symbols ();
7601 :
7602 251 : if (begin_p
7603 251 : && directive != ST_NONE
7604 251 : && gfc_omp_end_stmt (directive) == ST_NONE)
7605 : {
7606 3 : gfc_error ("variant directive used in OMP BEGIN METADIRECTIVE "
7607 : "at %C must have a corresponding end directive");
7608 3 : gfc_current_locus = old_loc;
7609 3 : return MATCH_ERROR;
7610 : }
7611 :
7612 248 : if (default_p)
7613 : default_seen = true;
7614 :
7615 248 : gfc_omp_variant *omv = gfc_get_omp_variant ();
7616 248 : omv->selectors = selectors;
7617 248 : omv->stmt = directive;
7618 248 : omv->where = variant_locus;
7619 :
7620 248 : if (directive == ST_NONE)
7621 : {
7622 : /* The directive was a 'nothing' directive. */
7623 15 : omv->code = gfc_get_code (EXEC_CONTINUE);
7624 15 : omv->code->ext.omp_clauses = NULL;
7625 : }
7626 : else
7627 : {
7628 233 : omv->code = gfc_get_code (new_st.op);
7629 233 : omv->code->ext.omp_clauses = new_st.ext.omp_clauses;
7630 : /* Prevent the OpenMP clauses from being freed via NEW_ST. */
7631 233 : new_st.ext.omp_clauses = NULL;
7632 : }
7633 :
7634 248 : *next_variant = omv;
7635 248 : next_variant = &omv->next;
7636 248 : }
7637 :
7638 142 : if (gfc_match_omp_eos () != MATCH_YES)
7639 : {
7640 0 : gfc_error ("Unexpected junk after OMP METADIRECTIVE at %C");
7641 0 : gfc_current_locus = old_loc;
7642 0 : return MATCH_ERROR;
7643 : }
7644 :
7645 : /* Add a 'default (nothing)' clause if no default is explicitly given. */
7646 142 : if (!default_seen)
7647 : {
7648 65 : gfc_omp_variant *omv = gfc_get_omp_variant ();
7649 65 : omv->stmt = ST_NONE;
7650 65 : omv->code = gfc_get_code (EXEC_CONTINUE);
7651 65 : omv->code->ext.omp_clauses = NULL;
7652 65 : omv->where = old_loc;
7653 65 : omv->selectors = NULL;
7654 :
7655 65 : *next_variant = omv;
7656 65 : next_variant = &omv->next;
7657 : }
7658 :
7659 142 : new_st.op = EXEC_OMP_METADIRECTIVE;
7660 142 : new_st.ext.omp_variants = variants_head;
7661 :
7662 142 : return MATCH_YES;
7663 : }
7664 :
7665 : match
7666 43 : gfc_match_omp_begin_metadirective (void)
7667 : {
7668 43 : return match_omp_metadirective (true);
7669 : }
7670 :
7671 : match
7672 117 : gfc_match_omp_metadirective (void)
7673 : {
7674 117 : return match_omp_metadirective (false);
7675 : }
7676 :
7677 : /* Match 'omp threadprivate' or 'omp groupprivate'. */
7678 : static match
7679 259 : gfc_match_omp_thread_group_private (bool is_groupprivate)
7680 : {
7681 259 : locus old_loc;
7682 259 : char n[GFC_MAX_SYMBOL_LEN+1];
7683 259 : gfc_symbol *sym;
7684 259 : match m;
7685 259 : gfc_symtree *st;
7686 259 : struct sym_loc_t { gfc_symbol *sym; gfc_common_head *com; locus loc; };
7687 259 : auto_vec<sym_loc_t> syms;
7688 :
7689 259 : old_loc = gfc_current_locus;
7690 :
7691 259 : m = gfc_match (" ( ");
7692 259 : if (m != MATCH_YES)
7693 : return m;
7694 :
7695 369 : for (;;)
7696 : {
7697 314 : locus sym_loc = gfc_current_locus;
7698 314 : m = gfc_match_symbol (&sym, 0);
7699 314 : switch (m)
7700 : {
7701 209 : case MATCH_YES:
7702 209 : if (sym->attr.in_common)
7703 0 : gfc_error_now ("%qs variable at %L is an element of a COMMON block",
7704 : is_groupprivate ? "groupprivate" : "threadprivate",
7705 : &sym_loc);
7706 209 : else if (!is_groupprivate
7707 209 : && !gfc_add_threadprivate (&sym->attr, sym->name, &sym_loc))
7708 16 : goto cleanup;
7709 207 : else if (is_groupprivate)
7710 : {
7711 30 : if (!gfc_add_omp_groupprivate (&sym->attr, sym->name, &sym_loc))
7712 4 : goto cleanup;
7713 26 : syms.safe_push ({sym, nullptr, sym_loc});
7714 : }
7715 203 : goto next_item;
7716 : case MATCH_NO:
7717 : break;
7718 0 : case MATCH_ERROR:
7719 0 : goto cleanup;
7720 : }
7721 :
7722 105 : m = gfc_match (" / %n /", n);
7723 105 : if (m == MATCH_ERROR)
7724 0 : goto cleanup;
7725 105 : if (m == MATCH_NO || n[0] == '\0')
7726 0 : goto syntax;
7727 :
7728 105 : st = gfc_find_symtree (gfc_current_ns->common_root, n);
7729 105 : if (st == NULL)
7730 : {
7731 2 : gfc_error ("COMMON block /%s/ not found at %L", n, &sym_loc);
7732 2 : goto cleanup;
7733 : }
7734 103 : syms.safe_push ({nullptr, st->n.common, sym_loc});
7735 103 : if (is_groupprivate)
7736 30 : st->n.common->omp_groupprivate = 1;
7737 : else
7738 73 : st->n.common->threadprivate = 1;
7739 236 : for (sym = st->n.common->head; sym; sym = sym->common_next)
7740 141 : if (!is_groupprivate
7741 141 : && !gfc_add_threadprivate (&sym->attr, sym->name, &sym_loc))
7742 3 : goto cleanup;
7743 138 : else if (is_groupprivate
7744 138 : && !gfc_add_omp_groupprivate (&sym->attr, sym->name, &sym_loc))
7745 5 : goto cleanup;
7746 :
7747 95 : next_item:
7748 298 : if (gfc_match_char (')') == MATCH_YES)
7749 : break;
7750 55 : if (gfc_match_char (',') != MATCH_YES)
7751 0 : goto syntax;
7752 55 : }
7753 :
7754 243 : if (is_groupprivate)
7755 : {
7756 39 : gfc_omp_clauses *c;
7757 39 : m = gfc_match_omp_clauses (&c, omp_mask (OMP_CLAUSE_DEVICE_TYPE));
7758 39 : if (m == MATCH_ERROR)
7759 0 : return MATCH_ERROR;
7760 :
7761 39 : if (c->device_type == OMP_DEVICE_TYPE_UNSET)
7762 19 : c->device_type = OMP_DEVICE_TYPE_ANY;
7763 :
7764 86 : for (size_t i = 0; i < syms.length (); i++)
7765 47 : if (syms[i].sym)
7766 : {
7767 24 : sym_loc_t &n = syms[i];
7768 24 : if (n.sym->attr.in_common)
7769 0 : gfc_error_now ("Variable %qs at %L is an element of a COMMON "
7770 : "block", n.sym->name, &n.loc);
7771 24 : else if (n.sym->attr.omp_declare_target
7772 23 : || n.sym->attr.omp_declare_target_link)
7773 2 : gfc_error_now ("List item %qs at %L implies OMP DECLARE TARGET "
7774 : "with the LOCAL clause, but it has been specified"
7775 : " with a different clause before",
7776 : n.sym->name, &n.loc);
7777 24 : if (n.sym->attr.omp_device_type != OMP_DEVICE_TYPE_UNSET
7778 5 : && n.sym->attr.omp_device_type != c->device_type)
7779 : {
7780 2 : const char *dt = "any";
7781 2 : if (n.sym->attr.omp_device_type == OMP_DEVICE_TYPE_HOST)
7782 : dt = "host";
7783 0 : else if (n.sym->attr.omp_device_type == OMP_DEVICE_TYPE_NOHOST)
7784 0 : dt = "nohost";
7785 2 : gfc_error_now ("List item %qs at %L set in previous OMP DECLARE "
7786 : "TARGET directive to the different DEVICE_TYPE %qs",
7787 : n.sym->name, &n.loc, dt);
7788 : }
7789 24 : gfc_add_omp_declare_target_local (&n.sym->attr, n.sym->name,
7790 : &n.loc);
7791 24 : n.sym->attr.omp_device_type = c->device_type;
7792 : }
7793 : else /* Common block. */
7794 : {
7795 23 : sym_loc_t &n = syms[i];
7796 23 : if (n.com->omp_declare_target
7797 22 : || n.com->omp_declare_target_link)
7798 2 : gfc_error_now ("List item %</%s/%> at %L implies OMP DECLARE "
7799 : "TARGET with the LOCAL clause, but it has been "
7800 : "specified with a different clause before",
7801 2 : n.com->name, &n.loc);
7802 23 : if (n.com->omp_device_type != OMP_DEVICE_TYPE_UNSET
7803 5 : && n.com->omp_device_type != c->device_type)
7804 : {
7805 2 : const char *dt = "any";
7806 2 : if (n.com->omp_device_type == OMP_DEVICE_TYPE_HOST)
7807 : dt = "host";
7808 0 : else if (n.com->omp_device_type == OMP_DEVICE_TYPE_NOHOST)
7809 0 : dt = "nohost";
7810 2 : gfc_error_now ("List item %qs at %L set in previous OMP DECLARE"
7811 : " TARGET directive to the different DEVICE_TYPE "
7812 2 : "%qs", n.com->name, &n.loc, dt);
7813 : }
7814 23 : n.com->omp_declare_target_local = 1;
7815 23 : n.com->omp_device_type = c->device_type;
7816 46 : for (gfc_symbol *s = n.com->head; s; s = s->common_next)
7817 : {
7818 23 : gfc_add_omp_declare_target_local (&s->attr, s->name, &n.loc);
7819 23 : s->attr.omp_device_type = c->device_type;
7820 : }
7821 : }
7822 39 : free (c);
7823 : }
7824 :
7825 243 : if (gfc_match_omp_eos () != MATCH_YES)
7826 : {
7827 0 : gfc_error ("Unexpected junk after OMP %s at %C",
7828 : is_groupprivate ? "GROUPPRIVATE" : "THREADPRIVATE");
7829 0 : goto cleanup;
7830 : }
7831 :
7832 : return MATCH_YES;
7833 :
7834 0 : syntax:
7835 0 : gfc_error ("Syntax error in !$OMP %s list at %C",
7836 : is_groupprivate ? "GROUPPRIVATE" : "THREADPRIVATE");
7837 :
7838 16 : cleanup:
7839 16 : gfc_current_locus = old_loc;
7840 16 : return MATCH_ERROR;
7841 259 : }
7842 :
7843 :
7844 : match
7845 48 : gfc_match_omp_groupprivate (void)
7846 : {
7847 48 : return gfc_match_omp_thread_group_private (true);
7848 : }
7849 :
7850 :
7851 : match
7852 211 : gfc_match_omp_threadprivate (void)
7853 : {
7854 211 : return gfc_match_omp_thread_group_private (false);
7855 : }
7856 :
7857 :
7858 : match
7859 2157 : gfc_match_omp_parallel (void)
7860 : {
7861 2157 : return match_omp (EXEC_OMP_PARALLEL, OMP_PARALLEL_CLAUSES);
7862 : }
7863 :
7864 :
7865 : match
7866 1202 : gfc_match_omp_parallel_do (void)
7867 : {
7868 1202 : return match_omp (EXEC_OMP_PARALLEL_DO,
7869 1202 : (OMP_PARALLEL_CLAUSES | OMP_DO_CLAUSES)
7870 1202 : & ~(omp_mask (OMP_CLAUSE_NOWAIT)));
7871 : }
7872 :
7873 :
7874 : match
7875 298 : gfc_match_omp_parallel_do_simd (void)
7876 : {
7877 298 : return match_omp (EXEC_OMP_PARALLEL_DO_SIMD,
7878 298 : (OMP_PARALLEL_CLAUSES | OMP_DO_CLAUSES | OMP_SIMD_CLAUSES)
7879 298 : & ~(omp_mask (OMP_CLAUSE_NOWAIT)));
7880 : }
7881 :
7882 :
7883 : match
7884 14 : gfc_match_omp_parallel_masked (void)
7885 : {
7886 14 : return match_omp (EXEC_OMP_PARALLEL_MASKED,
7887 14 : OMP_PARALLEL_CLAUSES | OMP_MASKED_CLAUSES);
7888 : }
7889 :
7890 : match
7891 10 : gfc_match_omp_parallel_masked_taskloop (void)
7892 : {
7893 10 : return match_omp (EXEC_OMP_PARALLEL_MASKED_TASKLOOP,
7894 10 : (OMP_PARALLEL_CLAUSES | OMP_MASKED_CLAUSES
7895 10 : | OMP_TASKLOOP_CLAUSES)
7896 10 : & ~(omp_mask (OMP_CLAUSE_IN_REDUCTION)));
7897 : }
7898 :
7899 : match
7900 13 : gfc_match_omp_parallel_masked_taskloop_simd (void)
7901 : {
7902 13 : return match_omp (EXEC_OMP_PARALLEL_MASKED_TASKLOOP_SIMD,
7903 13 : (OMP_PARALLEL_CLAUSES | OMP_MASKED_CLAUSES
7904 13 : | OMP_TASKLOOP_CLAUSES | OMP_SIMD_CLAUSES)
7905 13 : & ~(omp_mask (OMP_CLAUSE_IN_REDUCTION)));
7906 : }
7907 :
7908 : match
7909 14 : gfc_match_omp_parallel_master (void)
7910 : {
7911 14 : gfc_warning (OPT_Wdeprecated_openmp,
7912 : "%<master%> construct at %C deprecated since OpenMP 5.1, use "
7913 : "%<masked%>");
7914 14 : return match_omp (EXEC_OMP_PARALLEL_MASTER, OMP_PARALLEL_CLAUSES);
7915 : }
7916 :
7917 : match
7918 15 : gfc_match_omp_parallel_master_taskloop (void)
7919 : {
7920 15 : gfc_warning (OPT_Wdeprecated_openmp,
7921 : "%<master%> construct at %C deprecated since OpenMP 5.1, "
7922 : "use %<masked%>");
7923 15 : return match_omp (EXEC_OMP_PARALLEL_MASTER_TASKLOOP,
7924 15 : (OMP_PARALLEL_CLAUSES | OMP_TASKLOOP_CLAUSES)
7925 15 : & ~(omp_mask (OMP_CLAUSE_IN_REDUCTION)));
7926 : }
7927 :
7928 : match
7929 21 : gfc_match_omp_parallel_master_taskloop_simd (void)
7930 : {
7931 21 : gfc_warning (OPT_Wdeprecated_openmp,
7932 : "%<master%> construct at %C deprecated since OpenMP 5.1, "
7933 : "use %<masked%>");
7934 21 : return match_omp (EXEC_OMP_PARALLEL_MASTER_TASKLOOP_SIMD,
7935 21 : (OMP_PARALLEL_CLAUSES | OMP_TASKLOOP_CLAUSES
7936 21 : | OMP_SIMD_CLAUSES)
7937 21 : & ~(omp_mask (OMP_CLAUSE_IN_REDUCTION)));
7938 : }
7939 :
7940 : match
7941 59 : gfc_match_omp_parallel_sections (void)
7942 : {
7943 59 : return match_omp (EXEC_OMP_PARALLEL_SECTIONS,
7944 59 : (OMP_PARALLEL_CLAUSES | OMP_SECTIONS_CLAUSES)
7945 59 : & ~(omp_mask (OMP_CLAUSE_NOWAIT)));
7946 : }
7947 :
7948 :
7949 : match
7950 56 : gfc_match_omp_parallel_workshare (void)
7951 : {
7952 56 : return match_omp (EXEC_OMP_PARALLEL_WORKSHARE, OMP_PARALLEL_CLAUSES);
7953 : }
7954 :
7955 : void
7956 49445 : gfc_check_omp_requires (gfc_namespace *ns, int ref_omp_requires)
7957 : {
7958 49445 : const char *msg = G_("Program unit at %L has OpenMP device "
7959 : "constructs/routines but does not set !$OMP REQUIRES %s "
7960 : "but other program units do");
7961 49445 : if (ns->omp_target_seen
7962 1284 : && (ns->omp_requires & OMP_REQ_TARGET_MASK)
7963 1284 : != (ref_omp_requires & OMP_REQ_TARGET_MASK))
7964 : {
7965 6 : gcc_assert (ns->proc_name);
7966 6 : if ((ref_omp_requires & OMP_REQ_REVERSE_OFFLOAD)
7967 5 : && !(ns->omp_requires & OMP_REQ_REVERSE_OFFLOAD))
7968 4 : gfc_error (msg, &ns->proc_name->declared_at, "REVERSE_OFFLOAD");
7969 6 : if ((ref_omp_requires & OMP_REQ_UNIFIED_ADDRESS)
7970 1 : && !(ns->omp_requires & OMP_REQ_UNIFIED_ADDRESS))
7971 1 : gfc_error (msg, &ns->proc_name->declared_at, "UNIFIED_ADDRESS");
7972 6 : if ((ref_omp_requires & OMP_REQ_UNIFIED_SHARED_MEMORY)
7973 4 : && !(ns->omp_requires & OMP_REQ_UNIFIED_SHARED_MEMORY))
7974 2 : gfc_error (msg, &ns->proc_name->declared_at, "UNIFIED_SHARED_MEMORY");
7975 6 : if ((ref_omp_requires & OMP_REQ_SELF_MAPS)
7976 1 : && !(ns->omp_requires & OMP_REQ_UNIFIED_SHARED_MEMORY))
7977 1 : gfc_error (msg, &ns->proc_name->declared_at, "SELF_MAPS");
7978 : }
7979 49445 : }
7980 :
7981 : bool
7982 126 : gfc_omp_requires_add_clause (gfc_omp_requires_kind clause,
7983 : const char *clause_name, locus *loc,
7984 : const char *module_name)
7985 : {
7986 126 : gfc_namespace *prog_unit = gfc_current_ns;
7987 150 : while (prog_unit->parent)
7988 : {
7989 26 : if (gfc_state_stack->previous
7990 26 : && gfc_state_stack->previous->state == COMP_INTERFACE)
7991 : break;
7992 : /* A submodule namespace may have its parent set to the ancestor module
7993 : for host-association purposes. Do not escape the submodule boundary:
7994 : the submodule itself is the program unit for OMP REQUIRES purposes. */
7995 25 : if (prog_unit->proc_name
7996 25 : && prog_unit->proc_name->attr.flavor == FL_MODULE)
7997 : break;
7998 : prog_unit = prog_unit->parent;
7999 : }
8000 :
8001 : /* Requires added after use. */
8002 126 : if (prog_unit->omp_target_seen
8003 24 : && (clause & OMP_REQ_TARGET_MASK)
8004 24 : && !(prog_unit->omp_requires & clause))
8005 : {
8006 0 : if (module_name)
8007 0 : gfc_error ("!$OMP REQUIRES clause %qs specified via module %qs use "
8008 : "at %L comes after using a device construct/routine",
8009 : clause_name, module_name, loc);
8010 : else
8011 0 : gfc_error ("!$OMP REQUIRES clause %qs specified at %L comes after "
8012 : "using a device construct/routine", clause_name, loc);
8013 0 : return false;
8014 : }
8015 :
8016 : /* Overriding atomic_default_mem_order clause value. */
8017 126 : if ((clause & OMP_REQ_ATOMIC_MEM_ORDER_MASK)
8018 34 : && (prog_unit->omp_requires & OMP_REQ_ATOMIC_MEM_ORDER_MASK)
8019 6 : && (prog_unit->omp_requires & OMP_REQ_ATOMIC_MEM_ORDER_MASK)
8020 6 : != (int) clause)
8021 : {
8022 3 : const char *other;
8023 3 : switch (prog_unit->omp_requires & OMP_REQ_ATOMIC_MEM_ORDER_MASK)
8024 : {
8025 : case OMP_REQ_ATOMIC_MEM_ORDER_SEQ_CST: other = "seq_cst"; break;
8026 0 : case OMP_REQ_ATOMIC_MEM_ORDER_ACQ_REL: other = "acq_rel"; break;
8027 1 : case OMP_REQ_ATOMIC_MEM_ORDER_ACQUIRE: other = "acquire"; break;
8028 1 : case OMP_REQ_ATOMIC_MEM_ORDER_RELAXED: other = "relaxed"; break;
8029 0 : case OMP_REQ_ATOMIC_MEM_ORDER_RELEASE: other = "release"; break;
8030 0 : default: gcc_unreachable ();
8031 : }
8032 :
8033 3 : if (module_name)
8034 0 : gfc_error ("!$OMP REQUIRES clause %<atomic_default_mem_order(%s)%> "
8035 : "specified via module %qs use at %L overrides a previous "
8036 : "%<atomic_default_mem_order(%s)%> (which might be through "
8037 : "using a module)", clause_name, module_name, loc, other);
8038 : else
8039 3 : gfc_error ("!$OMP REQUIRES clause %<atomic_default_mem_order(%s)%> "
8040 : "specified at %L overrides a previous "
8041 : "%<atomic_default_mem_order(%s)%> (which might be through "
8042 : "using a module)", clause_name, loc, other);
8043 3 : return false;
8044 : }
8045 :
8046 : /* Requires via module not at program-unit level and not repeating clause. */
8047 123 : if (prog_unit != gfc_current_ns && !(prog_unit->omp_requires & clause))
8048 : {
8049 0 : if (clause & OMP_REQ_ATOMIC_MEM_ORDER_MASK)
8050 0 : gfc_error ("!$OMP REQUIRES clause %<atomic_default_mem_order(%s)%> "
8051 : "specified via module %qs use at %L but same clause is "
8052 : "not specified for the program unit", clause_name,
8053 : module_name, loc);
8054 : else
8055 0 : gfc_error ("!$OMP REQUIRES clause %qs specified via module %qs use at "
8056 : "%L but same clause is not specified for the program unit",
8057 : clause_name, module_name, loc);
8058 0 : return false;
8059 : }
8060 :
8061 123 : if (!gfc_state_stack->previous
8062 115 : || gfc_state_stack->previous->state != COMP_INTERFACE)
8063 122 : prog_unit->omp_requires |= clause;
8064 : return true;
8065 : }
8066 :
8067 : match
8068 98 : gfc_match_omp_requires (void)
8069 : {
8070 98 : static const char *clauses[] = {"reverse_offload",
8071 : "unified_address",
8072 : "unified_shared_memory",
8073 : "self_maps",
8074 : "dynamic_allocators",
8075 : "atomic_default"};
8076 98 : const char *clause = NULL;
8077 98 : int requires_clauses = 0;
8078 98 : bool first = true;
8079 98 : locus old_loc;
8080 :
8081 : /* A submodule's namespace may have its parent pointer set to the ancestor
8082 : module namespace for host-association purposes. The submodule spec part
8083 : is still a valid program-unit spec part for OMP REQUIRES. Only reject
8084 : the directive when we are genuinely nested inside a procedure. */
8085 98 : if (gfc_current_ns->parent
8086 8 : && !(gfc_current_ns->proc_name
8087 8 : && gfc_current_ns->proc_name->attr.flavor == FL_MODULE)
8088 7 : && (!gfc_state_stack->previous
8089 7 : || gfc_state_stack->previous->state != COMP_INTERFACE))
8090 : {
8091 6 : gfc_error ("!$OMP REQUIRES at %C must appear in the specification part "
8092 : "of a program unit");
8093 6 : return MATCH_ERROR;
8094 : }
8095 :
8096 276 : while (true)
8097 : {
8098 184 : old_loc = gfc_current_locus;
8099 184 : gfc_omp_requires_kind requires_clause;
8100 92 : if ((first || gfc_match_char (',') != MATCH_YES)
8101 184 : && (first && gfc_match_space () != MATCH_YES))
8102 0 : goto error;
8103 184 : first = false;
8104 184 : gfc_gobble_whitespace ();
8105 184 : old_loc = gfc_current_locus;
8106 :
8107 184 : if (gfc_match_omp_eos () != MATCH_NO)
8108 : break;
8109 103 : if (gfc_match (clauses[0]) == MATCH_YES)
8110 : {
8111 34 : clause = clauses[0];
8112 34 : requires_clause = OMP_REQ_REVERSE_OFFLOAD;
8113 34 : if (requires_clauses & OMP_REQ_REVERSE_OFFLOAD)
8114 1 : goto duplicate_clause;
8115 : }
8116 69 : else if (gfc_match (clauses[1]) == MATCH_YES)
8117 : {
8118 9 : clause = clauses[1];
8119 9 : requires_clause = OMP_REQ_UNIFIED_ADDRESS;
8120 9 : if (requires_clauses & OMP_REQ_UNIFIED_ADDRESS)
8121 1 : goto duplicate_clause;
8122 : }
8123 60 : else if (gfc_match (clauses[2]) == MATCH_YES)
8124 : {
8125 14 : clause = clauses[2];
8126 14 : requires_clause = OMP_REQ_UNIFIED_SHARED_MEMORY;
8127 14 : if (requires_clauses & OMP_REQ_UNIFIED_SHARED_MEMORY)
8128 1 : goto duplicate_clause;
8129 : }
8130 46 : else if (gfc_match (clauses[3]) == MATCH_YES)
8131 : {
8132 7 : clause = clauses[3];
8133 7 : requires_clause = OMP_REQ_SELF_MAPS;
8134 7 : if (requires_clauses & OMP_REQ_SELF_MAPS)
8135 0 : goto duplicate_clause;
8136 : }
8137 39 : else if (gfc_match (clauses[4]) == MATCH_YES)
8138 : {
8139 7 : clause = clauses[4];
8140 7 : requires_clause = OMP_REQ_DYNAMIC_ALLOCATORS;
8141 7 : if (requires_clauses & OMP_REQ_DYNAMIC_ALLOCATORS)
8142 1 : goto duplicate_clause;
8143 : }
8144 32 : else if (gfc_match ("atomic_default_mem_order (") == MATCH_YES)
8145 : {
8146 31 : clause = clauses[5];
8147 31 : if (requires_clauses & OMP_REQ_ATOMIC_MEM_ORDER_MASK)
8148 1 : goto duplicate_clause;
8149 30 : if (gfc_match (" seq_cst )") == MATCH_YES)
8150 : {
8151 : clause = "seq_cst";
8152 : requires_clause = OMP_REQ_ATOMIC_MEM_ORDER_SEQ_CST;
8153 : }
8154 18 : else if (gfc_match (" acq_rel )") == MATCH_YES)
8155 : {
8156 : clause = "acq_rel";
8157 : requires_clause = OMP_REQ_ATOMIC_MEM_ORDER_ACQ_REL;
8158 : }
8159 12 : else if (gfc_match (" acquire )") == MATCH_YES)
8160 : {
8161 : clause = "acquire";
8162 : requires_clause = OMP_REQ_ATOMIC_MEM_ORDER_ACQUIRE;
8163 : }
8164 9 : else if (gfc_match (" relaxed )") == MATCH_YES)
8165 : {
8166 : clause = "relaxed";
8167 : requires_clause = OMP_REQ_ATOMIC_MEM_ORDER_RELAXED;
8168 : }
8169 5 : else if (gfc_match (" release )") == MATCH_YES)
8170 : {
8171 : clause = "release";
8172 : requires_clause = OMP_REQ_ATOMIC_MEM_ORDER_RELEASE;
8173 : }
8174 : else
8175 : {
8176 2 : gfc_error ("Expected ACQ_REL, ACQUIRE, RELAXED, RELEASE or "
8177 : "SEQ_CST for ATOMIC_DEFAULT_MEM_ORDER clause at %C");
8178 2 : goto error;
8179 : }
8180 : }
8181 : else
8182 1 : goto error;
8183 :
8184 95 : if (!gfc_omp_requires_add_clause (requires_clause, clause, &old_loc, NULL))
8185 3 : goto error;
8186 92 : requires_clauses |= requires_clause;
8187 92 : }
8188 :
8189 81 : if (requires_clauses == 0)
8190 : {
8191 1 : if (!gfc_error_flag_test ())
8192 1 : gfc_error ("Clause expected at %C");
8193 1 : goto error;
8194 : }
8195 : return MATCH_YES;
8196 :
8197 5 : duplicate_clause:
8198 5 : gfc_error ("%qs clause at %L specified more than once", clause, &old_loc);
8199 12 : error:
8200 12 : if (!gfc_error_flag_test ())
8201 1 : gfc_error ("Expected UNIFIED_ADDRESS, UNIFIED_SHARED_MEMORY, SELF_MAPS, "
8202 : "DYNAMIC_ALLOCATORS, REVERSE_OFFLOAD, or "
8203 : "ATOMIC_DEFAULT_MEM_ORDER clause at %L", &old_loc);
8204 : return MATCH_ERROR;
8205 : }
8206 :
8207 :
8208 : match
8209 51 : gfc_match_omp_scan (void)
8210 : {
8211 51 : bool incl;
8212 51 : gfc_omp_clauses *c = gfc_get_omp_clauses ();
8213 51 : gfc_gobble_whitespace ();
8214 51 : if ((incl = (gfc_match ("inclusive") == MATCH_YES))
8215 51 : || gfc_match ("exclusive") == MATCH_YES)
8216 : {
8217 70 : if (gfc_match_omp_variable_list (" (", &c->lists[incl ? OMP_LIST_SCAN_IN
8218 : : OMP_LIST_SCAN_EX],
8219 : false) != MATCH_YES)
8220 : {
8221 0 : gfc_free_omp_clauses (c);
8222 0 : return MATCH_ERROR;
8223 : }
8224 : }
8225 : else
8226 : {
8227 1 : gfc_error ("Expected INCLUSIVE or EXCLUSIVE clause at %C");
8228 1 : gfc_free_omp_clauses (c);
8229 1 : return MATCH_ERROR;
8230 : }
8231 50 : if (gfc_match_omp_eos () != MATCH_YES)
8232 : {
8233 1 : gfc_error ("Unexpected junk after !$OMP SCAN at %C");
8234 1 : gfc_free_omp_clauses (c);
8235 1 : return MATCH_ERROR;
8236 : }
8237 :
8238 49 : new_st.op = EXEC_OMP_SCAN;
8239 49 : new_st.ext.omp_clauses = c;
8240 49 : return MATCH_YES;
8241 : }
8242 :
8243 :
8244 : match
8245 58 : gfc_match_omp_scope (void)
8246 : {
8247 58 : return match_omp (EXEC_OMP_SCOPE, OMP_SCOPE_CLAUSES);
8248 : }
8249 :
8250 :
8251 : match
8252 82 : gfc_match_omp_sections (void)
8253 : {
8254 82 : return match_omp (EXEC_OMP_SECTIONS, OMP_SECTIONS_CLAUSES);
8255 : }
8256 :
8257 :
8258 : match
8259 782 : gfc_match_omp_simd (void)
8260 : {
8261 782 : return match_omp (EXEC_OMP_SIMD, OMP_SIMD_CLAUSES);
8262 : }
8263 :
8264 :
8265 : match
8266 570 : gfc_match_omp_single (void)
8267 : {
8268 570 : return match_omp (EXEC_OMP_SINGLE, OMP_SINGLE_CLAUSES);
8269 : }
8270 :
8271 :
8272 : match
8273 2224 : gfc_match_omp_target (void)
8274 : {
8275 2224 : return match_omp (EXEC_OMP_TARGET, OMP_TARGET_CLAUSES);
8276 : }
8277 :
8278 :
8279 : match
8280 1399 : gfc_match_omp_target_data (void)
8281 : {
8282 1399 : return match_omp (EXEC_OMP_TARGET_DATA, OMP_TARGET_DATA_CLAUSES);
8283 : }
8284 :
8285 :
8286 : match
8287 467 : gfc_match_omp_target_enter_data (void)
8288 : {
8289 467 : return match_omp (EXEC_OMP_TARGET_ENTER_DATA, OMP_TARGET_ENTER_DATA_CLAUSES);
8290 : }
8291 :
8292 :
8293 : match
8294 365 : gfc_match_omp_target_exit_data (void)
8295 : {
8296 365 : return match_omp (EXEC_OMP_TARGET_EXIT_DATA, OMP_TARGET_EXIT_DATA_CLAUSES);
8297 : }
8298 :
8299 :
8300 : match
8301 25 : gfc_match_omp_target_parallel (void)
8302 : {
8303 25 : return match_omp (EXEC_OMP_TARGET_PARALLEL,
8304 25 : (OMP_TARGET_CLAUSES | OMP_PARALLEL_CLAUSES)
8305 25 : & ~(omp_mask (OMP_CLAUSE_COPYIN)));
8306 : }
8307 :
8308 :
8309 : match
8310 81 : gfc_match_omp_target_parallel_do (void)
8311 : {
8312 81 : return match_omp (EXEC_OMP_TARGET_PARALLEL_DO,
8313 81 : (OMP_TARGET_CLAUSES | OMP_PARALLEL_CLAUSES
8314 81 : | OMP_DO_CLAUSES) & ~(omp_mask (OMP_CLAUSE_COPYIN)));
8315 : }
8316 :
8317 :
8318 : match
8319 19 : gfc_match_omp_target_parallel_do_simd (void)
8320 : {
8321 19 : return match_omp (EXEC_OMP_TARGET_PARALLEL_DO_SIMD,
8322 19 : (OMP_TARGET_CLAUSES | OMP_PARALLEL_CLAUSES | OMP_DO_CLAUSES
8323 19 : | OMP_SIMD_CLAUSES) & ~(omp_mask (OMP_CLAUSE_COPYIN)));
8324 : }
8325 :
8326 :
8327 : match
8328 34 : gfc_match_omp_target_simd (void)
8329 : {
8330 34 : return match_omp (EXEC_OMP_TARGET_SIMD,
8331 34 : OMP_TARGET_CLAUSES | OMP_SIMD_CLAUSES);
8332 : }
8333 :
8334 :
8335 : match
8336 72 : gfc_match_omp_target_teams (void)
8337 : {
8338 72 : return match_omp (EXEC_OMP_TARGET_TEAMS,
8339 72 : OMP_TARGET_CLAUSES | OMP_TEAMS_CLAUSES);
8340 : }
8341 :
8342 :
8343 : match
8344 19 : gfc_match_omp_target_teams_distribute (void)
8345 : {
8346 19 : return match_omp (EXEC_OMP_TARGET_TEAMS_DISTRIBUTE,
8347 19 : OMP_TARGET_CLAUSES | OMP_TEAMS_CLAUSES
8348 19 : | OMP_DISTRIBUTE_CLAUSES);
8349 : }
8350 :
8351 :
8352 : match
8353 64 : gfc_match_omp_target_teams_distribute_parallel_do (void)
8354 : {
8355 64 : return match_omp (EXEC_OMP_TARGET_TEAMS_DISTRIBUTE_PARALLEL_DO,
8356 64 : (OMP_TARGET_CLAUSES | OMP_TEAMS_CLAUSES
8357 64 : | OMP_DISTRIBUTE_CLAUSES | OMP_PARALLEL_CLAUSES
8358 64 : | OMP_DO_CLAUSES)
8359 64 : & ~(omp_mask (OMP_CLAUSE_ORDERED))
8360 64 : & ~(omp_mask (OMP_CLAUSE_LINEAR)));
8361 : }
8362 :
8363 :
8364 : match
8365 35 : gfc_match_omp_target_teams_distribute_parallel_do_simd (void)
8366 : {
8367 35 : return match_omp (EXEC_OMP_TARGET_TEAMS_DISTRIBUTE_PARALLEL_DO_SIMD,
8368 35 : (OMP_TARGET_CLAUSES | OMP_TEAMS_CLAUSES
8369 35 : | OMP_DISTRIBUTE_CLAUSES | OMP_PARALLEL_CLAUSES
8370 35 : | OMP_DO_CLAUSES | OMP_SIMD_CLAUSES)
8371 35 : & ~(omp_mask (OMP_CLAUSE_ORDERED)));
8372 : }
8373 :
8374 :
8375 : match
8376 21 : gfc_match_omp_target_teams_distribute_simd (void)
8377 : {
8378 21 : return match_omp (EXEC_OMP_TARGET_TEAMS_DISTRIBUTE_SIMD,
8379 21 : OMP_TARGET_CLAUSES | OMP_TEAMS_CLAUSES
8380 21 : | OMP_DISTRIBUTE_CLAUSES | OMP_SIMD_CLAUSES);
8381 : }
8382 :
8383 :
8384 : match
8385 1724 : gfc_match_omp_target_update (void)
8386 : {
8387 1724 : return match_omp (EXEC_OMP_TARGET_UPDATE, OMP_TARGET_UPDATE_CLAUSES);
8388 : }
8389 :
8390 :
8391 : match
8392 1182 : gfc_match_omp_task (void)
8393 : {
8394 1182 : return match_omp (EXEC_OMP_TASK, OMP_TASK_CLAUSES);
8395 : }
8396 :
8397 :
8398 : match
8399 72 : gfc_match_omp_taskloop (void)
8400 : {
8401 72 : return match_omp (EXEC_OMP_TASKLOOP, OMP_TASKLOOP_CLAUSES);
8402 : }
8403 :
8404 :
8405 : match
8406 40 : gfc_match_omp_taskloop_simd (void)
8407 : {
8408 40 : return match_omp (EXEC_OMP_TASKLOOP_SIMD,
8409 40 : OMP_TASKLOOP_CLAUSES | OMP_SIMD_CLAUSES);
8410 : }
8411 :
8412 :
8413 : match
8414 147 : gfc_match_omp_taskwait (void)
8415 : {
8416 147 : if (gfc_match_omp_eos () == MATCH_YES)
8417 : {
8418 133 : new_st.op = EXEC_OMP_TASKWAIT;
8419 133 : new_st.ext.omp_clauses = NULL;
8420 133 : return MATCH_YES;
8421 : }
8422 14 : return match_omp (EXEC_OMP_TASKWAIT,
8423 14 : omp_mask (OMP_CLAUSE_DEPEND) | OMP_CLAUSE_NOWAIT);
8424 : }
8425 :
8426 :
8427 : match
8428 10 : gfc_match_omp_taskyield (void)
8429 : {
8430 10 : if (gfc_match_omp_eos () != MATCH_YES)
8431 : {
8432 0 : gfc_error ("Unexpected junk after TASKYIELD clause at %C");
8433 0 : return MATCH_ERROR;
8434 : }
8435 10 : new_st.op = EXEC_OMP_TASKYIELD;
8436 10 : new_st.ext.omp_clauses = NULL;
8437 10 : return MATCH_YES;
8438 : }
8439 :
8440 :
8441 : match
8442 150 : gfc_match_omp_teams (void)
8443 : {
8444 150 : return match_omp (EXEC_OMP_TEAMS, OMP_TEAMS_CLAUSES);
8445 : }
8446 :
8447 :
8448 : match
8449 22 : gfc_match_omp_teams_distribute (void)
8450 : {
8451 22 : return match_omp (EXEC_OMP_TEAMS_DISTRIBUTE,
8452 22 : OMP_TEAMS_CLAUSES | OMP_DISTRIBUTE_CLAUSES);
8453 : }
8454 :
8455 :
8456 : match
8457 39 : gfc_match_omp_teams_distribute_parallel_do (void)
8458 : {
8459 39 : return match_omp (EXEC_OMP_TEAMS_DISTRIBUTE_PARALLEL_DO,
8460 39 : (OMP_TEAMS_CLAUSES | OMP_DISTRIBUTE_CLAUSES
8461 39 : | OMP_PARALLEL_CLAUSES | OMP_DO_CLAUSES)
8462 39 : & ~(omp_mask (OMP_CLAUSE_ORDERED)
8463 39 : | OMP_CLAUSE_LINEAR | OMP_CLAUSE_NOWAIT));
8464 : }
8465 :
8466 :
8467 : match
8468 62 : gfc_match_omp_teams_distribute_parallel_do_simd (void)
8469 : {
8470 62 : return match_omp (EXEC_OMP_TEAMS_DISTRIBUTE_PARALLEL_DO_SIMD,
8471 62 : (OMP_TEAMS_CLAUSES | OMP_DISTRIBUTE_CLAUSES
8472 62 : | OMP_PARALLEL_CLAUSES | OMP_DO_CLAUSES
8473 62 : | OMP_SIMD_CLAUSES)
8474 62 : & ~(omp_mask (OMP_CLAUSE_ORDERED) | OMP_CLAUSE_NOWAIT));
8475 : }
8476 :
8477 :
8478 : match
8479 44 : gfc_match_omp_teams_distribute_simd (void)
8480 : {
8481 44 : return match_omp (EXEC_OMP_TEAMS_DISTRIBUTE_SIMD,
8482 44 : OMP_TEAMS_CLAUSES | OMP_DISTRIBUTE_CLAUSES
8483 44 : | OMP_SIMD_CLAUSES);
8484 : }
8485 :
8486 : match
8487 203 : gfc_match_omp_tile (void)
8488 : {
8489 203 : return match_omp (EXEC_OMP_TILE, OMP_TILE_CLAUSES);
8490 : }
8491 :
8492 : match
8493 415 : gfc_match_omp_unroll (void)
8494 : {
8495 415 : return match_omp (EXEC_OMP_UNROLL, OMP_UNROLL_CLAUSES);
8496 : }
8497 :
8498 : match
8499 39 : gfc_match_omp_workshare (void)
8500 : {
8501 39 : return match_omp (EXEC_OMP_WORKSHARE, OMP_WORKSHARE_CLAUSES);
8502 : }
8503 :
8504 :
8505 : match
8506 55 : gfc_match_omp_masked (void)
8507 : {
8508 55 : return match_omp (EXEC_OMP_MASKED, OMP_MASKED_CLAUSES);
8509 : }
8510 :
8511 : match
8512 10 : gfc_match_omp_masked_taskloop (void)
8513 : {
8514 10 : return match_omp (EXEC_OMP_MASKED_TASKLOOP,
8515 10 : OMP_MASKED_CLAUSES | OMP_TASKLOOP_CLAUSES);
8516 : }
8517 :
8518 : match
8519 16 : gfc_match_omp_masked_taskloop_simd (void)
8520 : {
8521 16 : return match_omp (EXEC_OMP_MASKED_TASKLOOP_SIMD,
8522 16 : (OMP_MASKED_CLAUSES | OMP_TASKLOOP_CLAUSES
8523 16 : | OMP_SIMD_CLAUSES));
8524 : }
8525 :
8526 : match
8527 111 : gfc_match_omp_master (void)
8528 : {
8529 111 : gfc_warning (OPT_Wdeprecated_openmp,
8530 : "%<master%> construct at %C deprecated since OpenMP 5.1, "
8531 : "use %<masked%>");
8532 111 : if (gfc_match_omp_eos () != MATCH_YES)
8533 : {
8534 1 : gfc_error ("Unexpected junk after $OMP MASTER statement at %C");
8535 1 : return MATCH_ERROR;
8536 : }
8537 110 : new_st.op = EXEC_OMP_MASTER;
8538 110 : new_st.ext.omp_clauses = NULL;
8539 110 : return MATCH_YES;
8540 : }
8541 :
8542 : match
8543 16 : gfc_match_omp_master_taskloop (void)
8544 : {
8545 16 : gfc_warning (OPT_Wdeprecated_openmp,
8546 : "%<master%> construct at %C deprecated since OpenMP 5.1, "
8547 : "use %<masked%>");
8548 16 : return match_omp (EXEC_OMP_MASTER_TASKLOOP, OMP_TASKLOOP_CLAUSES);
8549 : }
8550 :
8551 : match
8552 21 : gfc_match_omp_master_taskloop_simd (void)
8553 : {
8554 21 : gfc_warning (OPT_Wdeprecated_openmp,
8555 : "%<master%> construct at %C deprecated since OpenMP 5.1, use "
8556 : "%<masked%>");
8557 21 : return match_omp (EXEC_OMP_MASTER_TASKLOOP_SIMD,
8558 21 : OMP_TASKLOOP_CLAUSES | OMP_SIMD_CLAUSES);
8559 : }
8560 :
8561 : match
8562 235 : gfc_match_omp_ordered (void)
8563 : {
8564 235 : return match_omp (EXEC_OMP_ORDERED, OMP_ORDERED_CLAUSES);
8565 : }
8566 :
8567 : match
8568 24 : gfc_match_omp_nothing (void)
8569 : {
8570 24 : if (gfc_match_omp_eos () != MATCH_YES)
8571 : {
8572 1 : gfc_error ("Unexpected junk after $OMP NOTHING statement at %C");
8573 1 : return MATCH_ERROR;
8574 : }
8575 : /* Will use ST_NONE; therefore, no EXEC_OMP_ is needed. */
8576 : return MATCH_YES;
8577 : }
8578 :
8579 : match
8580 317 : gfc_match_omp_ordered_depend (void)
8581 : {
8582 317 : return match_omp (EXEC_OMP_ORDERED, omp_mask (OMP_CLAUSE_DOACROSS));
8583 : }
8584 :
8585 :
8586 : /* omp atomic [clause-list]
8587 : - atomic-clause: read | write | update
8588 : - capture
8589 : - memory-order-clause: seq_cst | acq_rel | release | acquire | relaxed
8590 : - hint(hint-expr)
8591 : - OpenMP 5.1: compare | fail (seq_cst | acquire | relaxed ) | weak
8592 : */
8593 :
8594 : match
8595 2171 : gfc_match_omp_atomic (void)
8596 : {
8597 2171 : gfc_omp_clauses *c;
8598 2171 : locus loc = gfc_current_locus;
8599 :
8600 2171 : if (gfc_match_omp_clauses (&c, OMP_ATOMIC_CLAUSES, true, true) != MATCH_YES)
8601 : return MATCH_ERROR;
8602 :
8603 2153 : if (c->atomic_op == GFC_OMP_ATOMIC_UNSET)
8604 1011 : c->atomic_op = GFC_OMP_ATOMIC_UPDATE;
8605 :
8606 2153 : if (c->capture && c->atomic_op != GFC_OMP_ATOMIC_UPDATE)
8607 3 : gfc_error ("!$OMP ATOMIC at %L with %s clause is incompatible with "
8608 : "READ or WRITE", &loc, "CAPTURE");
8609 2153 : if (c->compare && c->atomic_op != GFC_OMP_ATOMIC_UPDATE)
8610 3 : gfc_error ("!$OMP ATOMIC at %L with %s clause is incompatible with "
8611 : "READ or WRITE", &loc, "COMPARE");
8612 2153 : if (c->fail != OMP_MEMORDER_UNSET && c->atomic_op != GFC_OMP_ATOMIC_UPDATE)
8613 2 : gfc_error ("!$OMP ATOMIC at %L with %s clause is incompatible with "
8614 : "READ or WRITE", &loc, "FAIL");
8615 2153 : if (c->weak && !c->compare)
8616 : {
8617 5 : gfc_error ("!$OMP ATOMIC at %L with %s clause requires %s clause", &loc,
8618 : "WEAK", "COMPARE");
8619 5 : c->weak = false;
8620 : }
8621 :
8622 2153 : if (c->memorder == OMP_MEMORDER_UNSET)
8623 : {
8624 1969 : gfc_namespace *prog_unit = gfc_current_ns;
8625 1969 : while (prog_unit->parent
8626 2525 : && !(prog_unit->proc_name
8627 556 : && prog_unit->proc_name->attr.flavor == FL_MODULE))
8628 : prog_unit = prog_unit->parent;
8629 1969 : switch (prog_unit->omp_requires & OMP_REQ_ATOMIC_MEM_ORDER_MASK)
8630 : {
8631 1936 : case 0:
8632 1936 : case OMP_REQ_ATOMIC_MEM_ORDER_RELAXED:
8633 1936 : c->memorder = OMP_MEMORDER_RELAXED;
8634 1936 : break;
8635 7 : case OMP_REQ_ATOMIC_MEM_ORDER_SEQ_CST:
8636 7 : c->memorder = OMP_MEMORDER_SEQ_CST;
8637 7 : break;
8638 16 : case OMP_REQ_ATOMIC_MEM_ORDER_ACQ_REL:
8639 16 : if (c->capture)
8640 5 : c->memorder = OMP_MEMORDER_ACQ_REL;
8641 11 : else if (c->atomic_op == GFC_OMP_ATOMIC_READ)
8642 3 : c->memorder = OMP_MEMORDER_ACQUIRE;
8643 : else
8644 8 : c->memorder = OMP_MEMORDER_RELEASE;
8645 : break;
8646 5 : case OMP_REQ_ATOMIC_MEM_ORDER_ACQUIRE:
8647 5 : if (c->atomic_op == GFC_OMP_ATOMIC_WRITE)
8648 : {
8649 1 : gfc_error ("!$OMP ATOMIC WRITE at %L incompatible with "
8650 : "ACQUIRES clause implicitly provided by a "
8651 : "REQUIRES directive", &loc);
8652 1 : c->memorder = OMP_MEMORDER_SEQ_CST;
8653 : }
8654 : else
8655 4 : c->memorder = OMP_MEMORDER_ACQUIRE;
8656 : break;
8657 5 : case OMP_REQ_ATOMIC_MEM_ORDER_RELEASE:
8658 5 : if (c->atomic_op == GFC_OMP_ATOMIC_READ)
8659 : {
8660 1 : gfc_error ("!$OMP ATOMIC READ at %L incompatible with "
8661 : "RELEASE clause implicitly provided by a "
8662 : "REQUIRES directive", &loc);
8663 1 : c->memorder = OMP_MEMORDER_SEQ_CST;
8664 : }
8665 : else
8666 4 : c->memorder = OMP_MEMORDER_RELEASE;
8667 : break;
8668 0 : default:
8669 0 : gcc_unreachable ();
8670 : }
8671 : }
8672 : else
8673 184 : switch (c->atomic_op)
8674 : {
8675 29 : case GFC_OMP_ATOMIC_READ:
8676 29 : if (c->memorder == OMP_MEMORDER_RELEASE)
8677 : {
8678 1 : gfc_error ("!$OMP ATOMIC READ at %L incompatible with "
8679 : "RELEASE clause", &loc);
8680 1 : c->memorder = OMP_MEMORDER_SEQ_CST;
8681 : }
8682 28 : else if (c->memorder == OMP_MEMORDER_ACQ_REL)
8683 1 : c->memorder = OMP_MEMORDER_ACQUIRE;
8684 : break;
8685 35 : case GFC_OMP_ATOMIC_WRITE:
8686 35 : if (c->memorder == OMP_MEMORDER_ACQUIRE)
8687 : {
8688 1 : gfc_error ("!$OMP ATOMIC WRITE at %L incompatible with "
8689 : "ACQUIRE clause", &loc);
8690 1 : c->memorder = OMP_MEMORDER_SEQ_CST;
8691 : }
8692 34 : else if (c->memorder == OMP_MEMORDER_ACQ_REL)
8693 1 : c->memorder = OMP_MEMORDER_RELEASE;
8694 : break;
8695 : default:
8696 : break;
8697 : }
8698 2153 : gfc_error_check ();
8699 2153 : new_st.ext.omp_clauses = c;
8700 2153 : new_st.op = EXEC_OMP_ATOMIC;
8701 2153 : return MATCH_YES;
8702 : }
8703 :
8704 :
8705 : /* acc atomic [ read | write | update | capture] */
8706 :
8707 : match
8708 552 : gfc_match_oacc_atomic (void)
8709 : {
8710 552 : gfc_omp_clauses *c = gfc_get_omp_clauses ();
8711 552 : c->atomic_op = GFC_OMP_ATOMIC_UPDATE;
8712 552 : c->memorder = OMP_MEMORDER_RELAXED;
8713 552 : gfc_gobble_whitespace ();
8714 552 : if (gfc_match ("update") == MATCH_YES)
8715 : ;
8716 373 : else if (gfc_match ("read") == MATCH_YES)
8717 17 : c->atomic_op = GFC_OMP_ATOMIC_READ;
8718 356 : else if (gfc_match ("write") == MATCH_YES)
8719 13 : c->atomic_op = GFC_OMP_ATOMIC_WRITE;
8720 343 : else if (gfc_match ("capture") == MATCH_YES)
8721 319 : c->capture = true;
8722 552 : gfc_gobble_whitespace ();
8723 552 : if (gfc_match_omp_eos () != MATCH_YES)
8724 : {
8725 9 : gfc_error ("Unexpected junk after !$ACC ATOMIC statement at %C");
8726 9 : gfc_free_omp_clauses (c);
8727 9 : return MATCH_ERROR;
8728 : }
8729 543 : new_st.ext.omp_clauses = c;
8730 543 : new_st.op = EXEC_OACC_ATOMIC;
8731 543 : return MATCH_YES;
8732 : }
8733 :
8734 :
8735 : match
8736 614 : gfc_match_omp_barrier (void)
8737 : {
8738 614 : if (gfc_match_omp_eos () != MATCH_YES)
8739 : {
8740 0 : gfc_error ("Unexpected junk after $OMP BARRIER statement at %C");
8741 0 : return MATCH_ERROR;
8742 : }
8743 614 : new_st.op = EXEC_OMP_BARRIER;
8744 614 : new_st.ext.omp_clauses = NULL;
8745 614 : return MATCH_YES;
8746 : }
8747 :
8748 :
8749 : match
8750 188 : gfc_match_omp_taskgroup (void)
8751 : {
8752 188 : return match_omp (EXEC_OMP_TASKGROUP, OMP_TASKGROUP_CLAUSES);
8753 : }
8754 :
8755 :
8756 : static enum gfc_omp_cancel_kind
8757 492 : gfc_match_omp_cancel_kind (void)
8758 : {
8759 492 : if (gfc_match_space () != MATCH_YES)
8760 : return OMP_CANCEL_UNKNOWN;
8761 492 : if (gfc_match ("parallel") == MATCH_YES)
8762 : return OMP_CANCEL_PARALLEL;
8763 352 : if (gfc_match ("sections") == MATCH_YES)
8764 : return OMP_CANCEL_SECTIONS;
8765 253 : if (gfc_match ("do") == MATCH_YES)
8766 : return OMP_CANCEL_DO;
8767 123 : if (gfc_match ("taskgroup") == MATCH_YES)
8768 : return OMP_CANCEL_TASKGROUP;
8769 : return OMP_CANCEL_UNKNOWN;
8770 : }
8771 :
8772 :
8773 : match
8774 319 : gfc_match_omp_cancel (void)
8775 : {
8776 319 : gfc_omp_clauses *c;
8777 319 : enum gfc_omp_cancel_kind kind = gfc_match_omp_cancel_kind ();
8778 319 : if (kind == OMP_CANCEL_UNKNOWN)
8779 : return MATCH_ERROR;
8780 319 : if (gfc_match_omp_clauses (&c, omp_mask (OMP_CLAUSE_IF), false) != MATCH_YES)
8781 : return MATCH_ERROR;
8782 316 : c->cancel = kind;
8783 316 : new_st.op = EXEC_OMP_CANCEL;
8784 316 : new_st.ext.omp_clauses = c;
8785 316 : return MATCH_YES;
8786 : }
8787 :
8788 :
8789 : match
8790 173 : gfc_match_omp_cancellation_point (void)
8791 : {
8792 173 : gfc_omp_clauses *c;
8793 173 : enum gfc_omp_cancel_kind kind = gfc_match_omp_cancel_kind ();
8794 173 : if (kind == OMP_CANCEL_UNKNOWN)
8795 : {
8796 2 : gfc_error ("Expected construct-type PARALLEL, SECTIONS, DO or TASKGROUP "
8797 : "in $OMP CANCELLATION POINT statement at %C");
8798 2 : return MATCH_ERROR;
8799 : }
8800 171 : if (gfc_match_omp_eos () != MATCH_YES)
8801 : {
8802 0 : gfc_error ("Unexpected junk after $OMP CANCELLATION POINT statement "
8803 : "at %C");
8804 0 : return MATCH_ERROR;
8805 : }
8806 171 : c = gfc_get_omp_clauses ();
8807 171 : c->cancel = kind;
8808 171 : new_st.op = EXEC_OMP_CANCELLATION_POINT;
8809 171 : new_st.ext.omp_clauses = c;
8810 171 : return MATCH_YES;
8811 : }
8812 :
8813 :
8814 : match
8815 2730 : gfc_match_omp_end_nowait (void)
8816 : {
8817 2730 : bool nowait = false;
8818 2730 : if (gfc_match ("% nowait") == MATCH_YES)
8819 258 : nowait = true;
8820 2730 : if (gfc_match_omp_eos () != MATCH_YES)
8821 : {
8822 4 : if (nowait)
8823 3 : gfc_error ("Unexpected junk after NOWAIT clause at %C");
8824 : else
8825 1 : gfc_error ("Unexpected junk at %C");
8826 4 : return MATCH_ERROR;
8827 : }
8828 2726 : new_st.op = EXEC_OMP_END_NOWAIT;
8829 2726 : new_st.ext.omp_bool = nowait;
8830 2726 : return MATCH_YES;
8831 : }
8832 :
8833 :
8834 : match
8835 566 : gfc_match_omp_end_single (void)
8836 : {
8837 566 : gfc_omp_clauses *c;
8838 566 : if (gfc_match_omp_clauses (&c, omp_mask (OMP_CLAUSE_COPYPRIVATE)
8839 : | OMP_CLAUSE_NOWAIT) != MATCH_YES)
8840 : return MATCH_ERROR;
8841 566 : new_st.op = EXEC_OMP_END_SINGLE;
8842 566 : new_st.ext.omp_clauses = c;
8843 566 : return MATCH_YES;
8844 : }
8845 :
8846 :
8847 : static bool
8848 37134 : oacc_is_loop (gfc_code *code)
8849 : {
8850 37134 : return code->op == EXEC_OACC_PARALLEL_LOOP
8851 : || code->op == EXEC_OACC_KERNELS_LOOP
8852 20079 : || code->op == EXEC_OACC_SERIAL_LOOP
8853 13457 : || code->op == EXEC_OACC_LOOP;
8854 : }
8855 :
8856 : static void
8857 5725 : resolve_scalar_int_expr (gfc_expr *expr, const char *clause)
8858 : {
8859 5725 : if (!gfc_resolve_expr (expr)
8860 5725 : || expr->ts.type != BT_INTEGER
8861 11379 : || expr->rank != 0)
8862 89 : gfc_error ("%s clause at %L requires a scalar INTEGER expression",
8863 : clause, &expr->where);
8864 5725 : }
8865 :
8866 : static void
8867 3940 : resolve_positive_int_expr (gfc_expr *expr, const char *clause)
8868 : {
8869 3940 : resolve_scalar_int_expr (expr, clause);
8870 3940 : if (expr->expr_type == EXPR_CONSTANT
8871 3519 : && expr->ts.type == BT_INTEGER
8872 3486 : && mpz_sgn (expr->value.integer) <= 0)
8873 54 : gfc_warning ((flag_openmp || flag_openmp_simd) ? OPT_Wopenmp : 0,
8874 : "INTEGER expression of %s clause at %L must be positive",
8875 : clause, &expr->where);
8876 3940 : }
8877 :
8878 : static void
8879 86 : resolve_nonnegative_int_expr (gfc_expr *expr, const char *clause)
8880 : {
8881 86 : resolve_scalar_int_expr (expr, clause);
8882 86 : if (expr->expr_type == EXPR_CONSTANT
8883 13 : && expr->ts.type == BT_INTEGER
8884 11 : && mpz_sgn (expr->value.integer) < 0)
8885 6 : gfc_warning ((flag_openmp || flag_openmp_simd) ? OPT_Wopenmp : 0,
8886 : "INTEGER expression of %s clause at %L must be non-negative",
8887 : clause, &expr->where);
8888 86 : }
8889 :
8890 : /* Emits error when symbol is pointer, cray pointer or cray pointee
8891 : of derived of polymorphic type. */
8892 :
8893 : static void
8894 98 : check_symbol_not_pointer (gfc_symbol *sym, locus loc, const char *name)
8895 : {
8896 98 : if (sym->ts.type == BT_DERIVED && sym->attr.cray_pointer)
8897 0 : gfc_error ("Cray pointer object %qs of derived type in %s clause at %L",
8898 : sym->name, name, &loc);
8899 98 : if (sym->ts.type == BT_DERIVED && sym->attr.cray_pointee)
8900 0 : gfc_error ("Cray pointee object %qs of derived type in %s clause at %L",
8901 : sym->name, name, &loc);
8902 :
8903 98 : if ((sym->ts.type == BT_ASSUMED && sym->attr.pointer)
8904 98 : || (sym->ts.type == BT_CLASS && CLASS_DATA (sym)
8905 0 : && CLASS_DATA (sym)->attr.pointer))
8906 0 : gfc_error ("POINTER object %qs of polymorphic type in %s clause at %L",
8907 : sym->name, name, &loc);
8908 98 : if ((sym->ts.type == BT_ASSUMED && sym->attr.cray_pointer)
8909 98 : || (sym->ts.type == BT_CLASS && CLASS_DATA (sym)
8910 0 : && CLASS_DATA (sym)->attr.cray_pointer))
8911 0 : gfc_error ("Cray pointer object %qs of polymorphic type in %s clause at %L",
8912 : sym->name, name, &loc);
8913 98 : if ((sym->ts.type == BT_ASSUMED && sym->attr.cray_pointee)
8914 98 : || (sym->ts.type == BT_CLASS && CLASS_DATA (sym)
8915 0 : && CLASS_DATA (sym)->attr.cray_pointee))
8916 0 : gfc_error ("Cray pointee object %qs of polymorphic type in %s clause at %L",
8917 : sym->name, name, &loc);
8918 98 : }
8919 :
8920 : /* Emits error when symbol represents assumed size/rank array. */
8921 :
8922 : static void
8923 14844 : check_array_not_assumed (gfc_symbol *sym, locus loc, const char *name)
8924 : {
8925 14844 : if (sym->as && sym->as->type == AS_ASSUMED_SIZE)
8926 13 : gfc_error ("Assumed size array %qs in %s clause at %L",
8927 : sym->name, name, &loc);
8928 14844 : if (sym->as && sym->as->type == AS_ASSUMED_RANK)
8929 11 : gfc_error ("Assumed rank array %qs in %s clause at %L",
8930 : sym->name, name, &loc);
8931 14844 : }
8932 :
8933 : static void
8934 5850 : resolve_oacc_data_clauses (gfc_symbol *sym, locus loc, const char *name)
8935 : {
8936 0 : check_array_not_assumed (sym, loc, name);
8937 0 : }
8938 :
8939 : static void
8940 65 : resolve_oacc_deviceptr_clause (gfc_symbol *sym, locus loc, const char *name)
8941 : {
8942 65 : if (sym->attr.pointer
8943 64 : || (sym->ts.type == BT_CLASS && CLASS_DATA (sym)
8944 0 : && CLASS_DATA (sym)->attr.class_pointer))
8945 1 : gfc_error ("POINTER object %qs in %s clause at %L",
8946 : sym->name, name, &loc);
8947 65 : if (sym->attr.cray_pointer
8948 63 : || (sym->ts.type == BT_CLASS && CLASS_DATA (sym)
8949 0 : && CLASS_DATA (sym)->attr.cray_pointer))
8950 2 : gfc_error ("Cray pointer object %qs in %s clause at %L",
8951 : sym->name, name, &loc);
8952 65 : if (sym->attr.cray_pointee
8953 63 : || (sym->ts.type == BT_CLASS && CLASS_DATA (sym)
8954 0 : && CLASS_DATA (sym)->attr.cray_pointee))
8955 2 : gfc_error ("Cray pointee object %qs in %s clause at %L",
8956 : sym->name, name, &loc);
8957 65 : if (sym->attr.allocatable
8958 64 : || (sym->ts.type == BT_CLASS && CLASS_DATA (sym)
8959 0 : && CLASS_DATA (sym)->attr.allocatable))
8960 1 : gfc_error ("ALLOCATABLE object %qs in %s clause at %L",
8961 : sym->name, name, &loc);
8962 65 : if (sym->attr.value)
8963 1 : gfc_error ("VALUE object %qs in %s clause at %L",
8964 : sym->name, name, &loc);
8965 65 : check_array_not_assumed (sym, loc, name);
8966 65 : }
8967 :
8968 :
8969 : struct resolve_omp_udr_callback_data
8970 : {
8971 : gfc_symbol *sym1, *sym2;
8972 : };
8973 :
8974 :
8975 : static int
8976 1413 : resolve_omp_udr_callback (gfc_expr **e, int *, void *data)
8977 : {
8978 1413 : struct resolve_omp_udr_callback_data *rcd
8979 : = (struct resolve_omp_udr_callback_data *) data;
8980 1413 : if ((*e)->expr_type == EXPR_VARIABLE
8981 801 : && ((*e)->symtree->n.sym == rcd->sym1
8982 255 : || (*e)->symtree->n.sym == rcd->sym2))
8983 : {
8984 801 : gfc_ref *ref = gfc_get_ref ();
8985 801 : ref->type = REF_ARRAY;
8986 801 : ref->u.ar.where = (*e)->where;
8987 801 : ref->u.ar.as = (*e)->symtree->n.sym->as;
8988 801 : ref->u.ar.type = AR_FULL;
8989 801 : ref->u.ar.dimen = 0;
8990 801 : ref->next = (*e)->ref;
8991 801 : (*e)->ref = ref;
8992 : }
8993 1413 : return 0;
8994 : }
8995 :
8996 :
8997 : static int
8998 3004 : resolve_omp_udr_callback2 (gfc_expr **e, int *, void *)
8999 : {
9000 3004 : if ((*e)->expr_type == EXPR_FUNCTION
9001 360 : && (*e)->value.function.isym == NULL)
9002 : {
9003 174 : gfc_symbol *sym = (*e)->symtree->n.sym;
9004 174 : if (!sym->attr.intrinsic
9005 174 : && sym->attr.if_source == IFSRC_UNKNOWN)
9006 4 : gfc_error ("Implicitly declared function %s used in "
9007 : "!$OMP DECLARE REDUCTION at %L", sym->name, &(*e)->where);
9008 : }
9009 3004 : return 0;
9010 : }
9011 :
9012 :
9013 : static gfc_code *
9014 801 : resolve_omp_udr_clause (gfc_omp_namelist *n, gfc_namespace *ns,
9015 : gfc_symbol *sym1, gfc_symbol *sym2)
9016 : {
9017 801 : gfc_code *copy;
9018 801 : gfc_symbol sym1_copy, sym2_copy;
9019 :
9020 801 : if (ns->code->op == EXEC_ASSIGN)
9021 : {
9022 629 : copy = gfc_get_code (EXEC_ASSIGN);
9023 629 : copy->expr1 = gfc_copy_expr (ns->code->expr1);
9024 629 : copy->expr2 = gfc_copy_expr (ns->code->expr2);
9025 : }
9026 : else
9027 : {
9028 172 : copy = gfc_get_code (EXEC_CALL);
9029 172 : copy->symtree = ns->code->symtree;
9030 172 : copy->ext.actual = gfc_copy_actual_arglist (ns->code->ext.actual);
9031 : }
9032 801 : copy->loc = ns->code->loc;
9033 801 : sym1_copy = *sym1;
9034 801 : sym2_copy = *sym2;
9035 801 : *sym1 = *n->sym;
9036 801 : *sym2 = *n->sym;
9037 801 : sym1->name = sym1_copy.name;
9038 801 : sym2->name = sym2_copy.name;
9039 801 : ns->proc_name = ns->parent->proc_name;
9040 801 : if (n->sym->attr.dimension)
9041 : {
9042 348 : struct resolve_omp_udr_callback_data rcd;
9043 348 : rcd.sym1 = sym1;
9044 348 : rcd.sym2 = sym2;
9045 348 : gfc_code_walker (©, gfc_dummy_code_callback,
9046 : resolve_omp_udr_callback, &rcd);
9047 : }
9048 801 : gfc_resolve_code (copy, gfc_current_ns);
9049 801 : if (copy->op == EXEC_CALL && copy->resolved_isym == NULL)
9050 : {
9051 172 : gfc_symbol *sym = copy->resolved_sym;
9052 172 : if (sym
9053 170 : && !sym->attr.intrinsic
9054 170 : && sym->attr.if_source == IFSRC_UNKNOWN)
9055 4 : gfc_error ("Implicitly declared subroutine %s used in "
9056 : "!$OMP DECLARE REDUCTION at %L", sym->name,
9057 : ©->loc);
9058 : }
9059 801 : gfc_code_walker (©, gfc_dummy_code_callback,
9060 : resolve_omp_udr_callback2, NULL);
9061 801 : *sym1 = sym1_copy;
9062 801 : *sym2 = sym2_copy;
9063 801 : return copy;
9064 : }
9065 :
9066 : /* Assume that a constant expression in the range 1 (omp_default_mem_alloc)
9067 : to GOMP_OMP_PREDEF_ALLOC_MAX, or GOMP_OMPX_PREDEF_ALLOC_MIN to
9068 : GOMP_OMPX_PREDEF_ALLOC_MAX is fine. The original symbol name is already
9069 : lost during matching via gfc_match_expr. */
9070 : static bool
9071 130 : is_predefined_allocator (gfc_expr *expr)
9072 : {
9073 130 : return (gfc_resolve_expr (expr)
9074 129 : && expr->rank == 0
9075 124 : && expr->ts.type == BT_INTEGER
9076 119 : && expr->ts.kind == gfc_c_intptr_kind
9077 114 : && expr->expr_type == EXPR_CONSTANT
9078 239 : && ((mpz_sgn (expr->value.integer) > 0
9079 107 : && mpz_cmp_si (expr->value.integer,
9080 : GOMP_OMP_PREDEF_ALLOC_MAX) <= 0)
9081 4 : || (mpz_cmp_si (expr->value.integer,
9082 : GOMP_OMPX_PREDEF_ALLOC_MIN) >= 0
9083 1 : && mpz_cmp_si (expr->value.integer,
9084 130 : GOMP_OMPX_PREDEF_ALLOC_MAX) <= 0)));
9085 : }
9086 :
9087 : /* Resolve declarative ALLOCATE statement. Note: Common block vars only appear
9088 : as /block/ not individual, which is ensured during parsing. */
9089 :
9090 : void
9091 62 : gfc_resolve_omp_allocate (gfc_namespace *ns, gfc_omp_namelist *list)
9092 : {
9093 278 : for (gfc_omp_namelist *n = list; n; n = n->next)
9094 : {
9095 216 : if (n->sym->attr.result || n->sym->result == n->sym)
9096 : {
9097 1 : gfc_error ("Unexpected function-result variable %qs at %L in "
9098 : "declarative !$OMP ALLOCATE", n->sym->name, &n->where);
9099 31 : continue;
9100 : }
9101 215 : if (ns->omp_allocate->sym->attr.proc_pointer)
9102 : {
9103 0 : gfc_error ("Procedure pointer %qs not supported with !$OMP "
9104 : "ALLOCATE at %L", n->sym->name, &n->where);
9105 0 : continue;
9106 : }
9107 215 : if (n->sym->attr.flavor != FL_VARIABLE)
9108 : {
9109 3 : gfc_error ("Argument %qs at %L to declarative !$OMP ALLOCATE "
9110 : "directive must be a variable", n->sym->name,
9111 : &n->where);
9112 3 : continue;
9113 : }
9114 212 : if (ns != n->sym->ns || n->sym->attr.use_assoc || n->sym->attr.imported)
9115 : {
9116 8 : gfc_error ("Argument %qs at %L to declarative !$OMP ALLOCATE shall be"
9117 : " in the same scope as the variable declaration",
9118 : n->sym->name, &n->where);
9119 8 : continue;
9120 : }
9121 204 : if (n->sym->attr.dummy)
9122 : {
9123 3 : gfc_error ("Unexpected dummy argument %qs as argument at %L to "
9124 : "declarative !$OMP ALLOCATE", n->sym->name, &n->where);
9125 3 : continue;
9126 : }
9127 201 : if (n->sym->attr.codimension)
9128 : {
9129 0 : gfc_error ("Unexpected coarray argument %qs as argument at %L to "
9130 : "declarative !$OMP ALLOCATE", n->sym->name, &n->where);
9131 0 : continue;
9132 : }
9133 201 : if (n->sym->attr.omp_allocate)
9134 : {
9135 5 : if (n->sym->attr.in_common)
9136 : {
9137 1 : gfc_error ("Duplicated common block %</%s/%> in !$OMP ALLOCATE "
9138 1 : "at %L", n->sym->common_head->name, &n->where);
9139 3 : while (n->next && n->next->sym
9140 3 : && n->sym->common_head == n->next->sym->common_head)
9141 : n = n->next;
9142 : }
9143 : else
9144 4 : gfc_error ("Duplicated variable %qs in !$OMP ALLOCATE at %L",
9145 : n->sym->name, &n->where);
9146 5 : continue;
9147 : }
9148 : /* For 'equivalence(a,b)', a 'union_type {<type> a,b} equiv.0' is created
9149 : with a value expression for 'a' as 'equiv.0.a' (likewise for b); while
9150 : this can be handled, EQUIVALENCE is marked as obsolescent since Fortran
9151 : 2018 and also not widely used. However, it could be supported,
9152 : if needed. */
9153 196 : if (n->sym->attr.in_equivalence)
9154 : {
9155 2 : gfc_error ("Sorry, EQUIVALENCE object %qs not supported with !$OMP "
9156 : "ALLOCATE at %L", n->sym->name, &n->where);
9157 2 : continue;
9158 : }
9159 : /* Similar for Cray pointer/pointee - they could be implemented but as
9160 : common vendor extension but nowadays rarely used and requiring
9161 : -fcray-pointer, there is no need to support them. */
9162 194 : if (n->sym->attr.cray_pointer || n->sym->attr.cray_pointee)
9163 : {
9164 2 : gfc_error ("Sorry, Cray pointers and pointees such as %qs are not "
9165 : "supported with !$OMP ALLOCATE at %L",
9166 : n->sym->name, &n->where);
9167 2 : continue;
9168 : }
9169 192 : n->sym->attr.omp_allocate = 1;
9170 192 : if ((n->sym->ts.type == BT_CLASS && n->sym->attr.class_ok
9171 0 : && CLASS_DATA (n->sym)->attr.allocatable)
9172 192 : || (n->sym->ts.type != BT_CLASS && n->sym->attr.allocatable))
9173 1 : gfc_error ("Unexpected allocatable variable %qs at %L in declarative "
9174 : "!$OMP ALLOCATE directive", n->sym->name, &n->where);
9175 191 : else if ((n->sym->ts.type == BT_CLASS && n->sym->attr.class_ok
9176 0 : && CLASS_DATA (n->sym)->attr.class_pointer)
9177 191 : || (n->sym->ts.type != BT_CLASS && n->sym->attr.pointer))
9178 1 : gfc_error ("Unexpected pointer variable %qs at %L in declarative "
9179 : "!$OMP ALLOCATE directive", n->sym->name, &n->where);
9180 192 : HOST_WIDE_INT alignment = 0;
9181 198 : if (n->u.align
9182 192 : && (!gfc_resolve_expr (n->u.align)
9183 27 : || n->u.align->ts.type != BT_INTEGER
9184 26 : || n->u.align->rank != 0
9185 24 : || n->u.align->expr_type != EXPR_CONSTANT
9186 23 : || gfc_extract_hwi (n->u.align, &alignment)
9187 23 : || !pow2p_hwi (alignment)))
9188 : {
9189 6 : gfc_error ("ALIGN requires a scalar positive constant integer "
9190 : "alignment expression at %L that is a power of two",
9191 6 : &n->u.align->where);
9192 6 : while (n->sym->attr.in_common && n->next && n->next->sym
9193 6 : && n->sym->common_head == n->next->sym->common_head)
9194 : n = n->next;
9195 6 : continue;
9196 : }
9197 186 : if (n->sym->attr.in_common || n->sym->attr.save || n->sym->ns->save_all
9198 63 : || (n->sym->ns->proc_name
9199 63 : && (n->sym->ns->proc_name->attr.flavor == FL_PROGRAM
9200 : || n->sym->ns->proc_name->attr.flavor == FL_MODULE
9201 : || n->sym->ns->proc_name->attr.flavor == FL_BLOCK_DATA)))
9202 : {
9203 131 : bool com = n->sym->attr.in_common;
9204 131 : if (!n->u2.allocator)
9205 1 : gfc_error ("An ALLOCATOR clause is required as the list item "
9206 : "%<%s%s%s%> at %L has the SAVE attribute", com ? "/" : "",
9207 0 : com ? n->sym->common_head->name : n->sym->name,
9208 : com ? "/" : "", &n->where);
9209 130 : else if (!is_predefined_allocator (n->u2.allocator))
9210 24 : gfc_error ("Predefined allocator required in ALLOCATOR clause at %L"
9211 : " as the list item %<%s%s%s%> at %L has the SAVE attribute",
9212 24 : &n->u2.allocator->where, com ? "/" : "",
9213 24 : com ? n->sym->common_head->name : n->sym->name,
9214 : com ? "/" : "", &n->where);
9215 : /* Static variables may not use omp_cgroup_mem_alloc (6),
9216 : omp_pteam_mem_alloc (7), or omp_thread_mem_alloc (8). */
9217 106 : else if (mpz_cmp_si (n->u2.allocator->value.integer,
9218 : 6 /* cgroup */) >= 0
9219 34 : && mpz_cmp_si (n->u2.allocator->value.integer,
9220 : 8 /* thread */) <= 0)
9221 : {
9222 33 : STATIC_ASSERT (GOMP_OMP_PREDEF_ALLOC_CGROUP == 6);
9223 33 : STATIC_ASSERT (GOMP_OMP_PREDEF_ALLOC_PTEAM == 7);
9224 33 : STATIC_ASSERT (GOMP_OMP_PREDEF_ALLOC_THREAD == 8);
9225 33 : const char *alloc_name[] = {"omp_cgroup_mem_alloc",
9226 : "omp_pteam_mem_alloc",
9227 : "omp_thread_mem_alloc" };
9228 33 : gfc_error ("Predefined allocator %qs in ALLOCATOR clause at %L, "
9229 : "used for list item %<%s%s%s%> at %L, may not be used"
9230 : " for static variables",
9231 33 : alloc_name[mpz_get_ui (n->u2.allocator->value.integer)
9232 33 : - 6 /* cgroup */], &n->u2.allocator->where,
9233 : com ? "/" : "",
9234 33 : com ? n->sym->common_head->name : n->sym->name,
9235 : com ? "/" : "", &n->where);
9236 : }
9237 67 : while (n->sym->attr.in_common && n->next && n->next->sym
9238 186 : && n->sym->common_head == n->next->sym->common_head)
9239 : n = n->next;
9240 : }
9241 55 : else if (n->u2.allocator
9242 55 : && (!gfc_resolve_expr (n->u2.allocator)
9243 20 : || n->u2.allocator->ts.type != BT_INTEGER
9244 19 : || n->u2.allocator->rank != 0
9245 18 : || n->u2.allocator->ts.kind != gfc_c_intptr_kind))
9246 3 : gfc_error ("Expected integer expression of the "
9247 : "%<omp_allocator_handle_kind%> kind at %L",
9248 3 : &n->u2.allocator->where);
9249 : }
9250 62 : }
9251 :
9252 : /* Resolve ASSUME's and ASSUMES' assumption clauses. Note that absent/contains
9253 : is handled during parse time in omp_verify_merge_absent_contains. */
9254 :
9255 : void
9256 29 : gfc_resolve_omp_assumptions (gfc_omp_assumptions *assume)
9257 : {
9258 46 : for (gfc_expr_list *el = assume->holds; el; el = el->next)
9259 17 : if (!gfc_resolve_expr (el->expr)
9260 17 : || el->expr->ts.type != BT_LOGICAL
9261 32 : || el->expr->rank != 0)
9262 4 : gfc_error ("HOLDS expression at %L must be a scalar logical expression",
9263 4 : &el->expr->where);
9264 29 : }
9265 :
9266 :
9267 : /* OpenMP directive resolving routines. */
9268 :
9269 : static void
9270 32594 : resolve_omp_clauses (gfc_code *code, gfc_omp_clauses *omp_clauses,
9271 : gfc_namespace *ns, bool openacc = false)
9272 : {
9273 32594 : gfc_omp_namelist *n, *last;
9274 32594 : gfc_expr_list *el;
9275 32594 : enum gfc_omp_list_type list;
9276 32594 : int ifc;
9277 32594 : bool if_without_mod = false;
9278 32594 : gfc_omp_linear_op linear_op = OMP_LINEAR_DEFAULT;
9279 32594 : static const char *clause_names[]
9280 : = { "PRIVATE", "FIRSTPRIVATE", "LASTPRIVATE", "COPYPRIVATE", "SHARED",
9281 : "COPYIN", "UNIFORM", "AFFINITY", "ALIGNED", "LINEAR", "DEPEND", "MAP",
9282 : "TO", "FROM", "INCLUSIVE", "EXCLUSIVE",
9283 : "REDUCTION", "REDUCTION" /*inscan*/, "REDUCTION" /*task*/,
9284 : "IN_REDUCTION", "TASK_REDUCTION",
9285 : "DEVICE_RESIDENT", "LINK", "LOCAL", "USE_DEVICE",
9286 : "CACHE", "IS_DEVICE_PTR", "USE_DEVICE_PTR", "USE_DEVICE_ADDR",
9287 : "NONTEMPORAL", "ALLOCATE", "HAS_DEVICE_ADDR", "ENTER",
9288 : "USES_ALLOCATORS", "INIT", "USE", "DESTROY", "INTEROP", "ADJUST_ARGS" };
9289 32594 : STATIC_ASSERT (ARRAY_SIZE (clause_names) == OMP_LIST_NUM);
9290 :
9291 32594 : if (omp_clauses == NULL)
9292 : return;
9293 :
9294 32594 : if (ns == NULL)
9295 32151 : ns = gfc_current_ns;
9296 :
9297 32594 : if (omp_clauses->orderedc && omp_clauses->orderedc < omp_clauses->collapse)
9298 0 : gfc_error ("ORDERED clause parameter is less than COLLAPSE at %L",
9299 : &code->loc);
9300 32594 : if (omp_clauses->order_concurrent && omp_clauses->ordered)
9301 4 : gfc_error ("ORDER clause must not be used together with ORDERED at %L",
9302 : &code->loc);
9303 32594 : if (omp_clauses->if_expr)
9304 : {
9305 1190 : gfc_expr *expr = omp_clauses->if_expr;
9306 1190 : if (!gfc_resolve_expr (expr)
9307 1190 : || expr->ts.type != BT_LOGICAL || expr->rank != 0)
9308 16 : gfc_error ("IF clause at %L requires a scalar LOGICAL expression",
9309 : &expr->where);
9310 : if_without_mod = true;
9311 : }
9312 358534 : for (ifc = 0; ifc < OMP_IF_LAST; ifc++)
9313 325940 : if (omp_clauses->if_exprs[ifc])
9314 : {
9315 137 : gfc_expr *expr = omp_clauses->if_exprs[ifc];
9316 137 : bool ok = true;
9317 137 : if (!gfc_resolve_expr (expr)
9318 137 : || expr->ts.type != BT_LOGICAL || expr->rank != 0)
9319 0 : gfc_error ("IF clause at %L requires a scalar LOGICAL expression",
9320 : &expr->where);
9321 137 : else if (if_without_mod)
9322 : {
9323 1 : gfc_error ("IF clause without modifier at %L used together with "
9324 : "IF clauses with modifiers",
9325 1 : &omp_clauses->if_expr->where);
9326 1 : if_without_mod = false;
9327 : }
9328 : else
9329 136 : switch (code->op)
9330 : {
9331 13 : case EXEC_OMP_CANCEL:
9332 13 : ok = ifc == OMP_IF_CANCEL;
9333 13 : break;
9334 :
9335 16 : case EXEC_OMP_PARALLEL:
9336 16 : case EXEC_OMP_PARALLEL_DO:
9337 16 : case EXEC_OMP_PARALLEL_LOOP:
9338 16 : case EXEC_OMP_PARALLEL_MASKED:
9339 16 : case EXEC_OMP_PARALLEL_MASTER:
9340 16 : case EXEC_OMP_PARALLEL_SECTIONS:
9341 16 : case EXEC_OMP_PARALLEL_WORKSHARE:
9342 16 : case EXEC_OMP_DISTRIBUTE_PARALLEL_DO:
9343 16 : case EXEC_OMP_TEAMS_DISTRIBUTE_PARALLEL_DO:
9344 16 : ok = ifc == OMP_IF_PARALLEL;
9345 16 : break;
9346 :
9347 28 : case EXEC_OMP_PARALLEL_DO_SIMD:
9348 28 : case EXEC_OMP_DISTRIBUTE_PARALLEL_DO_SIMD:
9349 28 : case EXEC_OMP_TEAMS_DISTRIBUTE_PARALLEL_DO_SIMD:
9350 28 : ok = ifc == OMP_IF_PARALLEL || ifc == OMP_IF_SIMD;
9351 28 : break;
9352 :
9353 8 : case EXEC_OMP_PARALLEL_MASKED_TASKLOOP:
9354 8 : case EXEC_OMP_PARALLEL_MASTER_TASKLOOP:
9355 8 : ok = ifc == OMP_IF_PARALLEL || ifc == OMP_IF_TASKLOOP;
9356 8 : break;
9357 :
9358 12 : case EXEC_OMP_PARALLEL_MASKED_TASKLOOP_SIMD:
9359 12 : case EXEC_OMP_PARALLEL_MASTER_TASKLOOP_SIMD:
9360 12 : ok = (ifc == OMP_IF_PARALLEL
9361 12 : || ifc == OMP_IF_TASKLOOP
9362 : || ifc == OMP_IF_SIMD);
9363 : break;
9364 :
9365 0 : case EXEC_OMP_SIMD:
9366 0 : case EXEC_OMP_DO_SIMD:
9367 0 : case EXEC_OMP_DISTRIBUTE_SIMD:
9368 0 : case EXEC_OMP_TEAMS_DISTRIBUTE_SIMD:
9369 0 : ok = ifc == OMP_IF_SIMD;
9370 0 : break;
9371 :
9372 1 : case EXEC_OMP_TASK:
9373 1 : ok = ifc == OMP_IF_TASK;
9374 1 : break;
9375 :
9376 5 : case EXEC_OMP_TASKLOOP:
9377 5 : case EXEC_OMP_MASKED_TASKLOOP:
9378 5 : case EXEC_OMP_MASTER_TASKLOOP:
9379 5 : ok = ifc == OMP_IF_TASKLOOP;
9380 5 : break;
9381 :
9382 20 : case EXEC_OMP_TASKLOOP_SIMD:
9383 20 : case EXEC_OMP_MASKED_TASKLOOP_SIMD:
9384 20 : case EXEC_OMP_MASTER_TASKLOOP_SIMD:
9385 20 : ok = ifc == OMP_IF_TASKLOOP || ifc == OMP_IF_SIMD;
9386 20 : break;
9387 :
9388 5 : case EXEC_OMP_TARGET:
9389 5 : case EXEC_OMP_TARGET_TEAMS:
9390 5 : case EXEC_OMP_TARGET_TEAMS_DISTRIBUTE:
9391 5 : case EXEC_OMP_TARGET_TEAMS_LOOP:
9392 5 : ok = ifc == OMP_IF_TARGET;
9393 5 : break;
9394 :
9395 4 : case EXEC_OMP_TARGET_TEAMS_DISTRIBUTE_SIMD:
9396 4 : case EXEC_OMP_TARGET_SIMD:
9397 4 : ok = ifc == OMP_IF_TARGET || ifc == OMP_IF_SIMD;
9398 4 : break;
9399 :
9400 1 : case EXEC_OMP_TARGET_DATA:
9401 1 : ok = ifc == OMP_IF_TARGET_DATA;
9402 1 : break;
9403 :
9404 1 : case EXEC_OMP_TARGET_UPDATE:
9405 1 : ok = ifc == OMP_IF_TARGET_UPDATE;
9406 1 : break;
9407 :
9408 1 : case EXEC_OMP_TARGET_ENTER_DATA:
9409 1 : ok = ifc == OMP_IF_TARGET_ENTER_DATA;
9410 1 : break;
9411 :
9412 1 : case EXEC_OMP_TARGET_EXIT_DATA:
9413 1 : ok = ifc == OMP_IF_TARGET_EXIT_DATA;
9414 1 : break;
9415 :
9416 10 : case EXEC_OMP_TARGET_TEAMS_DISTRIBUTE_PARALLEL_DO:
9417 10 : case EXEC_OMP_TARGET_PARALLEL:
9418 10 : case EXEC_OMP_TARGET_PARALLEL_DO:
9419 10 : case EXEC_OMP_TARGET_PARALLEL_LOOP:
9420 10 : ok = ifc == OMP_IF_TARGET || ifc == OMP_IF_PARALLEL;
9421 10 : break;
9422 :
9423 10 : case EXEC_OMP_TARGET_PARALLEL_DO_SIMD:
9424 10 : case EXEC_OMP_TARGET_TEAMS_DISTRIBUTE_PARALLEL_DO_SIMD:
9425 10 : ok = (ifc == OMP_IF_TARGET
9426 10 : || ifc == OMP_IF_PARALLEL
9427 : || ifc == OMP_IF_SIMD);
9428 : break;
9429 :
9430 : default:
9431 : ok = false;
9432 : break;
9433 : }
9434 115 : if (!ok)
9435 : {
9436 2 : static const char *ifs[] = {
9437 : "CANCEL",
9438 : "PARALLEL",
9439 : "SIMD",
9440 : "TASK",
9441 : "TASKLOOP",
9442 : "TARGET",
9443 : "TARGET DATA",
9444 : "TARGET UPDATE",
9445 : "TARGET ENTER DATA",
9446 : "TARGET EXIT DATA"
9447 : };
9448 2 : gfc_error ("IF clause modifier %s at %L not appropriate for "
9449 : "the current OpenMP construct", ifs[ifc], &expr->where);
9450 : }
9451 : }
9452 :
9453 32594 : if (omp_clauses->self_expr)
9454 : {
9455 177 : gfc_expr *expr = omp_clauses->self_expr;
9456 177 : if (!gfc_resolve_expr (expr)
9457 177 : || expr->ts.type != BT_LOGICAL || expr->rank != 0)
9458 6 : gfc_error ("SELF clause at %L requires a scalar LOGICAL expression",
9459 : &expr->where);
9460 : }
9461 :
9462 32594 : if (omp_clauses->final_expr)
9463 : {
9464 64 : gfc_expr *expr = omp_clauses->final_expr;
9465 64 : if (!gfc_resolve_expr (expr)
9466 64 : || expr->ts.type != BT_LOGICAL || expr->rank != 0)
9467 0 : gfc_error ("FINAL clause at %L requires a scalar LOGICAL expression",
9468 : &expr->where);
9469 : }
9470 32594 : if (omp_clauses->novariants)
9471 : {
9472 9 : gfc_expr *expr = omp_clauses->novariants;
9473 18 : if (!gfc_resolve_expr (expr) || expr->ts.type != BT_LOGICAL
9474 17 : || expr->rank != 0)
9475 1 : gfc_error (
9476 : "NOVARIANTS clause at %L requires a scalar LOGICAL expression",
9477 : &expr->where);
9478 32594 : if_without_mod = true;
9479 : }
9480 32594 : if (omp_clauses->nocontext)
9481 : {
9482 12 : gfc_expr *expr = omp_clauses->nocontext;
9483 24 : if (!gfc_resolve_expr (expr) || expr->ts.type != BT_LOGICAL
9484 23 : || expr->rank != 0)
9485 1 : gfc_error (
9486 : "NOCONTEXT clause at %L requires a scalar LOGICAL expression",
9487 : &expr->where);
9488 32594 : if_without_mod = true;
9489 : }
9490 32594 : if (omp_clauses->num_threads)
9491 962 : resolve_positive_int_expr (omp_clauses->num_threads, "NUM_THREADS");
9492 32594 : if (omp_clauses->dyn_groupprivate)
9493 10 : resolve_nonnegative_int_expr (omp_clauses->dyn_groupprivate,
9494 : "DYN_GROUPPRIVATE");
9495 32594 : if (omp_clauses->chunk_size)
9496 : {
9497 510 : gfc_expr *expr = omp_clauses->chunk_size;
9498 510 : if (!gfc_resolve_expr (expr)
9499 510 : || expr->ts.type != BT_INTEGER || expr->rank != 0)
9500 0 : gfc_error ("SCHEDULE clause's chunk_size at %L requires "
9501 : "a scalar INTEGER expression", &expr->where);
9502 510 : else if (expr->expr_type == EXPR_CONSTANT
9503 : && expr->ts.type == BT_INTEGER
9504 485 : && mpz_sgn (expr->value.integer) <= 0)
9505 2 : gfc_warning (OPT_Wopenmp, "INTEGER expression of SCHEDULE clause's "
9506 : "chunk_size at %L must be positive", &expr->where);
9507 : }
9508 32594 : if (omp_clauses->sched_kind != OMP_SCHED_NONE
9509 891 : && omp_clauses->sched_nonmonotonic)
9510 : {
9511 34 : if (omp_clauses->sched_monotonic)
9512 2 : gfc_error ("Both MONOTONIC and NONMONOTONIC schedule modifiers "
9513 : "specified at %L", &code->loc);
9514 32 : else if (omp_clauses->ordered)
9515 4 : gfc_error ("NONMONOTONIC schedule modifier specified with ORDERED "
9516 : "clause at %L", &code->loc);
9517 : }
9518 :
9519 32594 : if (omp_clauses->depobj
9520 32594 : && (!gfc_resolve_expr (omp_clauses->depobj)
9521 115 : || omp_clauses->depobj->ts.type != BT_INTEGER
9522 114 : || omp_clauses->depobj->ts.kind != 2 * gfc_index_integer_kind
9523 113 : || omp_clauses->depobj->rank != 0))
9524 4 : gfc_error ("DEPOBJ in DEPOBJ construct at %L shall be a scalar integer "
9525 4 : "of OMP_DEPEND_KIND kind", &omp_clauses->depobj->where);
9526 :
9527 : /* Check that no symbol appears on multiple clauses, except that
9528 : a symbol can appear on both firstprivate and lastprivate. */
9529 1303760 : for (list = OMP_LIST_FIRST; list < OMP_LIST_NUM;
9530 1271166 : list = gfc_omp_list_type (list + 1))
9531 1316970 : for (n = omp_clauses->lists[list]; n; n = n->next)
9532 : {
9533 45804 : if (!n->sym) /* omp_all_memory. */
9534 47 : continue;
9535 45757 : n->sym->mark = 0;
9536 45757 : n->sym->comp_mark = 0;
9537 45757 : n->sym->data_mark = 0;
9538 45757 : n->sym->dev_mark = 0;
9539 45757 : n->sym->gen_mark = 0;
9540 45757 : n->sym->reduc_mark = 0;
9541 45757 : if (n->sym->attr.flavor == FL_VARIABLE
9542 274 : || n->sym->attr.proc_pointer
9543 233 : || (!code
9544 0 : && !ns->omp_udm_ns
9545 0 : && (!n->sym->attr.dummy || n->sym->ns != ns)))
9546 : {
9547 45524 : if (!code
9548 300 : && !ns->omp_udm_ns
9549 264 : && (!n->sym->attr.dummy || n->sym->ns != ns))
9550 0 : gfc_error ("Variable %qs is not a dummy argument at %L",
9551 : n->sym->name, &n->where);
9552 45524 : continue;
9553 : }
9554 233 : if (n->sym->attr.flavor == FL_PROCEDURE
9555 153 : && n->sym->result == n->sym
9556 138 : && n->sym->attr.function)
9557 : {
9558 138 : if (ns->proc_name == n->sym
9559 44 : || (ns->parent && ns->parent->proc_name == n->sym))
9560 101 : continue;
9561 37 : if (ns->proc_name->attr.entry_master)
9562 : {
9563 32 : gfc_entry_list *el = ns->entries;
9564 51 : for (; el; el = el->next)
9565 51 : if (el->sym == n->sym)
9566 : break;
9567 32 : if (el)
9568 32 : continue;
9569 : }
9570 5 : if (ns->parent
9571 3 : && ns->parent->proc_name->attr.entry_master)
9572 : {
9573 2 : gfc_entry_list *el = ns->parent->entries;
9574 3 : for (; el; el = el->next)
9575 3 : if (el->sym == n->sym)
9576 : break;
9577 2 : if (el)
9578 2 : continue;
9579 : }
9580 : }
9581 98 : if (list == OMP_LIST_MAP
9582 18 : && n->sym->attr.flavor == FL_PARAMETER)
9583 : {
9584 : /* OpenACC since 3.4 permits for Fortran named constants, but
9585 : permits removing then as optimization is not needed and such
9586 : ignore them. Likewise below for FIRSTPRIVATE. */
9587 12 : if (openacc)
9588 10 : gfc_warning (OPT_Wsurprising, "Clause for object %qs at %L is "
9589 : "ignored as parameters need not be copied",
9590 : n->sym->name, &n->where);
9591 : else
9592 2 : gfc_error ("Object %qs is not a variable at %L; parameters"
9593 : " cannot be and need not be mapped", n->sym->name,
9594 : &n->where);
9595 : }
9596 86 : else if (openacc && n->sym->attr.flavor == FL_PARAMETER)
9597 9 : gfc_warning (OPT_Wsurprising, "Clause for object %qs at %L is ignored"
9598 : " as it is a parameter", n->sym->name, &n->where);
9599 77 : else if (list != OMP_LIST_USES_ALLOCATORS)
9600 30 : gfc_error ("Object %qs is not a variable at %L", n->sym->name,
9601 : &n->where);
9602 : }
9603 32594 : if (omp_clauses->lists[OMP_LIST_REDUCTION_INSCAN])
9604 : {
9605 69 : locus *loc = &omp_clauses->lists[OMP_LIST_REDUCTION_INSCAN]->where;
9606 69 : if (code->op != EXEC_OMP_DO
9607 : && code->op != EXEC_OMP_SIMD
9608 : && code->op != EXEC_OMP_DO_SIMD
9609 : && code->op != EXEC_OMP_PARALLEL_DO
9610 : && code->op != EXEC_OMP_PARALLEL_DO_SIMD)
9611 23 : gfc_error ("%<inscan%> REDUCTION clause on construct other than DO, "
9612 : "SIMD, DO SIMD, PARALLEL DO, PARALLEL DO SIMD at %L",
9613 : loc);
9614 69 : if (omp_clauses->ordered)
9615 2 : gfc_error ("ORDERED clause specified together with %<inscan%> "
9616 : "REDUCTION clause at %L", loc);
9617 69 : if (omp_clauses->sched_kind != OMP_SCHED_NONE)
9618 3 : gfc_error ("SCHEDULE clause specified together with %<inscan%> "
9619 : "REDUCTION clause at %L", loc);
9620 : }
9621 :
9622 1303760 : for (list = OMP_LIST_FIRST; list < OMP_LIST_NUM;
9623 1271166 : list = gfc_omp_list_type (list + 1))
9624 1271166 : if (list != OMP_LIST_FIRSTPRIVATE
9625 1271166 : && list != OMP_LIST_LASTPRIVATE
9626 1271166 : && list != OMP_LIST_ALIGNED
9627 1173384 : && list != OMP_LIST_DEPEND
9628 1173384 : && list != OMP_LIST_FROM
9629 1108196 : && list != OMP_LIST_TO
9630 1108196 : && list != OMP_LIST_INTEROP
9631 1043008 : && (list != OMP_LIST_REDUCTION || !openacc)
9632 1030383 : && list != OMP_LIST_ALLOCATE)
9633 1032689 : for (n = omp_clauses->lists[list]; n; n = n->next)
9634 : {
9635 34900 : bool component_ref_p = false;
9636 :
9637 : /* Allow multiple components of the same (e.g. derived-type)
9638 : variable here. Duplicate components are detected elsewhere. */
9639 34900 : if (n->expr && n->expr->expr_type == EXPR_VARIABLE)
9640 16004 : for (gfc_ref *ref = n->expr->ref; ref; ref = ref->next)
9641 9735 : if (ref->type == REF_COMPONENT)
9642 3189 : component_ref_p = true;
9643 34900 : if ((list == OMP_LIST_IS_DEVICE_PTR
9644 34900 : || list == OMP_LIST_HAS_DEVICE_ADDR)
9645 313 : && !component_ref_p)
9646 : {
9647 313 : if (n->sym->gen_mark
9648 311 : || n->sym->dev_mark
9649 310 : || n->sym->reduc_mark
9650 310 : || n->sym->mark)
9651 5 : gfc_error ("Symbol %qs present on multiple clauses at %L",
9652 : n->sym->name, &n->where);
9653 : else
9654 308 : n->sym->dev_mark = 1;
9655 : }
9656 34587 : else if ((list == OMP_LIST_USE_DEVICE_PTR
9657 34587 : || list == OMP_LIST_USE_DEVICE_ADDR
9658 34587 : || list == OMP_LIST_PRIVATE
9659 : || list == OMP_LIST_SHARED)
9660 12851 : && !component_ref_p)
9661 : {
9662 12851 : if (n->sym->gen_mark || n->sym->dev_mark || n->sym->reduc_mark)
9663 13 : gfc_error ("Symbol %qs present on multiple clauses at %L",
9664 : n->sym->name, &n->where);
9665 : else
9666 : {
9667 12838 : n->sym->gen_mark = 1;
9668 : /* Set both generic and device bits if we have
9669 : use_device_*(x) or shared(x). This allows us to diagnose
9670 : "map(x) private(x)" below. */
9671 12838 : if (list != OMP_LIST_PRIVATE)
9672 3456 : n->sym->dev_mark = 1;
9673 : }
9674 : }
9675 21736 : else if ((list == OMP_LIST_REDUCTION
9676 21736 : || list == OMP_LIST_REDUCTION_TASK
9677 19276 : || list == OMP_LIST_REDUCTION_INSCAN
9678 19276 : || list == OMP_LIST_IN_REDUCTION
9679 19063 : || list == OMP_LIST_TASK_REDUCTION)
9680 2673 : && !component_ref_p)
9681 : {
9682 : /* Attempts to mix reduction types are diagnosed below. */
9683 2673 : if (n->sym->gen_mark || n->sym->dev_mark)
9684 2 : gfc_error ("Symbol %qs present on multiple clauses at %L",
9685 : n->sym->name, &n->where);
9686 2673 : n->sym->reduc_mark = 1;
9687 : }
9688 19063 : else if ((!component_ref_p && n->sym->comp_mark)
9689 2506 : || (component_ref_p && n->sym->mark))
9690 : {
9691 41 : if (openacc)
9692 3 : gfc_error ("Symbol %qs has mixed component and non-component "
9693 3 : "accesses at %L", n->sym->name, &n->where);
9694 : }
9695 19022 : else if ((openacc || list != OMP_LIST_MAP) && n->sym->mark)
9696 88 : gfc_error ("Symbol %qs present on multiple clauses at %L",
9697 : n->sym->name, &n->where);
9698 : else
9699 : {
9700 18934 : if (component_ref_p)
9701 2466 : n->sym->comp_mark = 1;
9702 : else
9703 16468 : n->sym->mark = 1;
9704 : }
9705 : }
9706 :
9707 32594 : if (code
9708 32354 : && code->op == EXEC_OMP_INTEROP
9709 63 : && omp_clauses->lists[OMP_LIST_DEPEND])
9710 : {
9711 12 : if (!omp_clauses->lists[OMP_LIST_INIT]
9712 5 : && !omp_clauses->lists[OMP_LIST_USE]
9713 1 : && !omp_clauses->lists[OMP_LIST_DESTROY])
9714 : {
9715 1 : gfc_error ("DEPEND clause at %L requires action clause with "
9716 : "%<targetsync%> interop-type",
9717 : &omp_clauses->lists[OMP_LIST_DEPEND]->where);
9718 : }
9719 22 : for (n = omp_clauses->lists[OMP_LIST_INIT]; n; n = n->next)
9720 12 : if (!n->u.init.targetsync)
9721 : {
9722 2 : gfc_error ("DEPEND clause at %L requires %<targetsync%> "
9723 : "interop-type, lacking it for %qs at %L",
9724 2 : &omp_clauses->lists[OMP_LIST_DEPEND]->where,
9725 2 : n->sym->name, &n->where);
9726 2 : break;
9727 : }
9728 : }
9729 32354 : if (code && (code->op == EXEC_OMP_INTEROP || code->op == EXEC_OMP_DISPATCH))
9730 1085 : for (list = OMP_LIST_INIT; list <= OMP_LIST_INTEROP;
9731 868 : list = gfc_omp_list_type (list + 1))
9732 1123 : for (n = omp_clauses->lists[list]; n; n = n->next)
9733 : {
9734 255 : if (n->sym->ts.type != BT_INTEGER
9735 252 : || n->sym->ts.kind != gfc_index_integer_kind
9736 248 : || n->sym->attr.dimension
9737 243 : || n->sym->attr.flavor != FL_VARIABLE)
9738 16 : gfc_error ("%qs at %L in %qs clause must be a scalar integer "
9739 : "variable of %<omp_interop_kind%> kind", n->sym->name,
9740 : &n->where, clause_names[list]);
9741 255 : if (list != OMP_LIST_USE && list != OMP_LIST_INTEROP
9742 109 : && n->sym->attr.intent == INTENT_IN)
9743 2 : gfc_error ("%qs at %L in %qs clause must be definable",
9744 : n->sym->name, &n->where, clause_names[list]);
9745 : }
9746 :
9747 : /* Detect specifically the case where we have "map(x) private(x)" and raise
9748 : an error. If we have "...simd" combined directives though, the "private"
9749 : applies to the simd part, so this is permitted though. */
9750 41984 : for (n = omp_clauses->lists[OMP_LIST_PRIVATE]; n; n = n->next)
9751 9390 : if (n->sym->mark
9752 6 : && n->sym->gen_mark
9753 6 : && !n->sym->dev_mark
9754 6 : && !n->sym->reduc_mark
9755 5 : && code->op != EXEC_OMP_TARGET_SIMD
9756 : && code->op != EXEC_OMP_TARGET_PARALLEL_DO_SIMD
9757 : && code->op != EXEC_OMP_TARGET_TEAMS_DISTRIBUTE_SIMD
9758 : && code->op != EXEC_OMP_TARGET_TEAMS_DISTRIBUTE_PARALLEL_DO_SIMD)
9759 1 : gfc_error ("Symbol %qs present on multiple clauses at %L",
9760 : n->sym->name, &n->where);
9761 :
9762 : gcc_assert (OMP_LIST_LASTPRIVATE == OMP_LIST_FIRSTPRIVATE + 1);
9763 97782 : for (list = OMP_LIST_FIRSTPRIVATE; list <= OMP_LIST_LASTPRIVATE;
9764 65188 : list = gfc_omp_list_type (list + 1))
9765 69409 : for (n = omp_clauses->lists[list]; n; n = n->next)
9766 4221 : if (n->sym->data_mark || n->sym->gen_mark || n->sym->dev_mark)
9767 : {
9768 9 : gfc_error ("Symbol %qs present on multiple clauses at %L",
9769 : n->sym->name, &n->where);
9770 9 : n->sym->data_mark = n->sym->gen_mark = n->sym->dev_mark = 0;
9771 : }
9772 4212 : else if (n->sym->mark
9773 18 : && code->op != EXEC_OMP_TARGET_TEAMS
9774 : && code->op != EXEC_OMP_TARGET_TEAMS_DISTRIBUTE
9775 : && code->op != EXEC_OMP_TARGET_TEAMS_LOOP
9776 : && code->op != EXEC_OMP_TARGET_TEAMS_DISTRIBUTE_SIMD
9777 : && code->op != EXEC_OMP_TARGET_TEAMS_DISTRIBUTE_PARALLEL_DO
9778 : && code->op != EXEC_OMP_TARGET_PARALLEL
9779 : && code->op != EXEC_OMP_TARGET_PARALLEL_DO
9780 : && code->op != EXEC_OMP_TARGET_PARALLEL_LOOP
9781 : && code->op != EXEC_OMP_TARGET_PARALLEL_DO_SIMD
9782 : && code->op != EXEC_OMP_TARGET_TEAMS_DISTRIBUTE_PARALLEL_DO_SIMD)
9783 7 : gfc_error ("Symbol %qs present on both data and map clauses "
9784 : "at %L", n->sym->name, &n->where);
9785 :
9786 34509 : for (n = omp_clauses->lists[OMP_LIST_FIRSTPRIVATE]; n; n = n->next)
9787 : {
9788 1915 : if (n->sym->data_mark || n->sym->gen_mark || n->sym->dev_mark)
9789 7 : gfc_error ("Symbol %qs present on multiple clauses at %L",
9790 : n->sym->name, &n->where);
9791 : else
9792 1908 : n->sym->data_mark = 1;
9793 : }
9794 34900 : for (n = omp_clauses->lists[OMP_LIST_LASTPRIVATE]; n; n = n->next)
9795 2306 : n->sym->data_mark = 0;
9796 :
9797 34900 : for (n = omp_clauses->lists[OMP_LIST_LASTPRIVATE]; n; n = n->next)
9798 : {
9799 2306 : if (n->sym->data_mark || n->sym->gen_mark || n->sym->dev_mark)
9800 0 : gfc_error ("Symbol %qs present on multiple clauses at %L",
9801 : n->sym->name, &n->where);
9802 : else
9803 2306 : n->sym->data_mark = 1;
9804 : }
9805 :
9806 32744 : for (n = omp_clauses->lists[OMP_LIST_ALIGNED]; n; n = n->next)
9807 150 : n->sym->mark = 0;
9808 :
9809 32744 : for (n = omp_clauses->lists[OMP_LIST_ALIGNED]; n; n = n->next)
9810 : {
9811 150 : if (n->sym->mark)
9812 0 : gfc_error ("Symbol %qs present on multiple clauses at %L",
9813 : n->sym->name, &n->where);
9814 : else
9815 150 : n->sym->mark = 1;
9816 : }
9817 :
9818 32594 : if (omp_clauses->lists[OMP_LIST_ALLOCATE])
9819 : {
9820 791 : for (n = omp_clauses->lists[OMP_LIST_ALLOCATE]; n; n = n->next)
9821 : {
9822 513 : if (n->u2.allocator
9823 513 : && (!gfc_resolve_expr (n->u2.allocator)
9824 288 : || n->u2.allocator->ts.type != BT_INTEGER
9825 286 : || n->u2.allocator->rank != 0
9826 285 : || n->u2.allocator->ts.kind != gfc_c_intptr_kind))
9827 : {
9828 8 : gfc_error ("Expected integer expression of the "
9829 : "%<omp_allocator_handle_kind%> kind at %L",
9830 8 : &n->u2.allocator->where);
9831 28 : break;
9832 : }
9833 505 : if (!n->u.align)
9834 397 : continue;
9835 108 : HOST_WIDE_INT alignment = 0;
9836 108 : if (!gfc_resolve_expr (n->u.align)
9837 108 : || n->u.align->ts.type != BT_INTEGER
9838 105 : || n->u.align->rank != 0
9839 102 : || n->u.align->expr_type != EXPR_CONSTANT
9840 99 : || gfc_extract_hwi (n->u.align, &alignment)
9841 99 : || alignment <= 0
9842 207 : || !pow2p_hwi (alignment))
9843 : {
9844 12 : gfc_error ("ALIGN requires a scalar positive constant integer "
9845 : "alignment expression at %L that is a power of two",
9846 12 : &n->u.align->where);
9847 12 : break;
9848 : }
9849 : }
9850 :
9851 : /* Check for 2 things here.
9852 : 1. There is no duplication of variable in allocate clause.
9853 : 2. Variable in allocate clause are also present in some
9854 : privatization clase (non-composite case). */
9855 811 : for (n = omp_clauses->lists[OMP_LIST_ALLOCATE]; n; n = n->next)
9856 513 : if (n->sym)
9857 487 : n->sym->mark = 0;
9858 :
9859 : gfc_omp_namelist *prev = NULL;
9860 811 : for (n = omp_clauses->lists[OMP_LIST_ALLOCATE]; n; )
9861 : {
9862 513 : if (n->sym == NULL)
9863 : {
9864 26 : n = n->next;
9865 26 : continue;
9866 : }
9867 487 : if (n->sym->mark == 1)
9868 : {
9869 3 : gfc_warning (OPT_Wopenmp, "%qs appears more than once in "
9870 : "%<allocate%> at %L" , n->sym->name, &n->where);
9871 : /* We have already seen this variable so it is a duplicate.
9872 : Remove it. */
9873 3 : if (prev != NULL && prev->next == n)
9874 : {
9875 3 : prev->next = n->next;
9876 3 : n->next = NULL;
9877 3 : gfc_free_omp_namelist (n, OMP_LIST_ALLOCATE);
9878 3 : n = prev->next;
9879 : }
9880 3 : continue;
9881 : }
9882 484 : n->sym->mark = 1;
9883 484 : prev = n;
9884 484 : n = n->next;
9885 : }
9886 :
9887 : /* Non-composite constructs. */
9888 298 : if (code && code->op < EXEC_OMP_DO_SIMD)
9889 : {
9890 4760 : for (list = OMP_LIST_FIRST; list < OMP_LIST_NUM;
9891 4641 : list = gfc_omp_list_type (list + 1))
9892 4641 : switch (list)
9893 : {
9894 1071 : case OMP_LIST_PRIVATE:
9895 1071 : case OMP_LIST_FIRSTPRIVATE:
9896 1071 : case OMP_LIST_LASTPRIVATE:
9897 1071 : case OMP_LIST_REDUCTION:
9898 1071 : case OMP_LIST_REDUCTION_INSCAN:
9899 1071 : case OMP_LIST_REDUCTION_TASK:
9900 1071 : case OMP_LIST_IN_REDUCTION:
9901 1071 : case OMP_LIST_TASK_REDUCTION:
9902 1071 : case OMP_LIST_LINEAR:
9903 1370 : for (n = omp_clauses->lists[list]; n; n = n->next)
9904 299 : n->sym->mark = 0;
9905 : break;
9906 : default:
9907 : break;
9908 : }
9909 :
9910 410 : for (n = omp_clauses->lists[OMP_LIST_ALLOCATE]; n; n = n->next)
9911 291 : if (n->sym->mark == 1)
9912 4 : gfc_error ("%qs specified in %<allocate%> clause at %L but not "
9913 : "in an explicit privatization clause",
9914 : n->sym->name, &n->where);
9915 : }
9916 : if (code
9917 298 : && (code->op == EXEC_OMP_ALLOCATORS || code->op == EXEC_OMP_ALLOCATE)
9918 73 : && code->block
9919 72 : && code->block->next
9920 71 : && code->block->next->op == EXEC_ALLOCATE)
9921 : {
9922 68 : if (code->op == EXEC_OMP_ALLOCATE)
9923 49 : gfc_warning (OPT_Wdeprecated_openmp,
9924 : "The use of one or more %<allocate%> directives with "
9925 : "an associated %<allocate%> statement at %L is "
9926 : "deprecated since OpenMP 5.2, use an %<allocators%> "
9927 : "directive", &code->loc);
9928 68 : gfc_alloc *a;
9929 68 : gfc_omp_namelist *n_null = NULL;
9930 68 : bool missing_allocator = false;
9931 68 : gfc_symbol *missing_allocator_sym = NULL;
9932 161 : for (n = omp_clauses->lists[OMP_LIST_ALLOCATE]; n; n = n->next)
9933 : {
9934 93 : if (n->u2.allocator == NULL)
9935 : {
9936 77 : if (!missing_allocator_sym)
9937 59 : missing_allocator_sym = n->sym;
9938 : missing_allocator = true;
9939 : }
9940 93 : if (n->sym == NULL)
9941 : {
9942 26 : n_null = n;
9943 26 : continue;
9944 : }
9945 67 : if (n->sym->attr.codimension)
9946 2 : gfc_error ("Unexpected coarray %qs in %<allocate%> at %L",
9947 : n->sym->name, &n->where);
9948 103 : for (a = code->block->next->ext.alloc.list; a; a = a->next)
9949 101 : if (a->expr->expr_type == EXPR_VARIABLE
9950 101 : && a->expr->symtree->n.sym == n->sym)
9951 : {
9952 65 : gfc_ref *ref;
9953 82 : for (ref = a->expr->ref; ref; ref = ref->next)
9954 17 : if (ref->type == REF_COMPONENT)
9955 : break;
9956 : if (ref == NULL)
9957 : break;
9958 : }
9959 67 : if (a == NULL)
9960 2 : gfc_error ("%qs specified in %<allocate%> at %L but not "
9961 : "in the associated ALLOCATE statement",
9962 2 : n->sym->name, &n->where);
9963 : }
9964 : /* If there is an ALLOCATE directive without list argument, a
9965 : namelist with its allocator/align clauses and n->sym = NULL is
9966 : created during parsing; here, we add all not otherwise specified
9967 : items from the Fortran allocate to that list.
9968 : For an ALLOCATORS directive, not listed items use the normal
9969 : Fortran way.
9970 : The behavior of an ALLOCATE directive that does not list all
9971 : arguments but there is no directive without list argument is not
9972 : well specified. Thus, we reject such code below. In OpenMP 5.2
9973 : the executable ALLOCATE directive is deprecated and in 6.0
9974 : deleted such that no spec clarification is to be expected. */
9975 125 : for (a = code->block->next->ext.alloc.list; a; a = a->next)
9976 89 : if (a->expr->expr_type == EXPR_VARIABLE)
9977 : {
9978 154 : for (n = omp_clauses->lists[OMP_LIST_ALLOCATE]; n; n = n->next)
9979 122 : if (a->expr->symtree->n.sym == n->sym)
9980 : {
9981 57 : gfc_ref *ref;
9982 72 : for (ref = a->expr->ref; ref; ref = ref->next)
9983 15 : if (ref->type == REF_COMPONENT)
9984 : break;
9985 : if (ref == NULL)
9986 : break;
9987 : }
9988 89 : if (n == NULL && n_null == NULL)
9989 : {
9990 : /* OK for ALLOCATORS but for ALLOCATE: Unspecified whether
9991 : that should use the default allocator of OpenMP or the
9992 : Fortran allocator. Thus, just reject it. */
9993 7 : if (code->op == EXEC_OMP_ALLOCATE)
9994 1 : gfc_error ("%qs listed in %<allocate%> statement at %L "
9995 : "but it is neither explicitly in listed in "
9996 : "the %<!$OMP ALLOCATE%> directive nor exists"
9997 : " a directive without argument list",
9998 1 : a->expr->symtree->n.sym->name,
9999 : &a->expr->where);
10000 : break;
10001 : }
10002 82 : if (n == NULL)
10003 : {
10004 25 : if (a->expr->symtree->n.sym->attr.codimension)
10005 1 : gfc_error ("Unexpected coarray %qs in %<allocate%> at "
10006 : "%L, implicitly listed in %<!$OMP ALLOCATE%>"
10007 : " at %L", a->expr->symtree->n.sym->name,
10008 : &a->expr->where, &n_null->where);
10009 : break;
10010 : }
10011 : }
10012 68 : gfc_namespace *prog_unit = ns;
10013 87 : while (prog_unit->parent)
10014 : prog_unit = prog_unit->parent;
10015 : gfc_namespace *fn_ns = ns;
10016 72 : while (fn_ns)
10017 : {
10018 70 : if (ns->proc_name
10019 70 : && (ns->proc_name->attr.subroutine
10020 6 : || ns->proc_name->attr.function))
10021 : break;
10022 4 : fn_ns = fn_ns->parent;
10023 : }
10024 68 : if (missing_allocator
10025 58 : && !(prog_unit->omp_requires & OMP_REQ_DYNAMIC_ALLOCATORS)
10026 58 : && ((fn_ns && fn_ns->proc_name->attr.omp_declare_target)
10027 55 : || omp_clauses->contained_in_target_construct))
10028 : {
10029 6 : if (code->op == EXEC_OMP_ALLOCATORS)
10030 2 : gfc_error ("ALLOCATORS directive at %L inside a target region "
10031 : "must specify an ALLOCATOR modifier for %qs",
10032 : &code->loc, missing_allocator_sym->name);
10033 4 : else if (missing_allocator_sym)
10034 2 : gfc_error ("ALLOCATE directive at %L inside a target region "
10035 : "must specify an ALLOCATOR clause for %qs",
10036 : &code->loc, missing_allocator_sym->name);
10037 : else
10038 2 : gfc_error ("ALLOCATE directive at %L inside a target region "
10039 : "must specify an ALLOCATOR clause", &code->loc);
10040 : }
10041 :
10042 : }
10043 : }
10044 :
10045 : /* OpenACC reductions. */
10046 32594 : if (openacc)
10047 : {
10048 14761 : for (n = omp_clauses->lists[OMP_LIST_REDUCTION]; n; n = n->next)
10049 2136 : n->sym->mark = 0;
10050 :
10051 14761 : for (n = omp_clauses->lists[OMP_LIST_REDUCTION]; n; n = n->next)
10052 : {
10053 2136 : if (n->sym->mark)
10054 0 : gfc_error ("Symbol %qs present on multiple clauses at %L",
10055 : n->sym->name, &n->where);
10056 : else
10057 2136 : n->sym->mark = 1;
10058 :
10059 : /* OpenACC does not support reductions on arrays. */
10060 2136 : if (n->sym->as)
10061 71 : gfc_error ("Array %qs is not permitted in reduction at %L",
10062 : n->sym->name, &n->where);
10063 : }
10064 : }
10065 :
10066 33364 : for (n = omp_clauses->lists[OMP_LIST_TO]; n; n = n->next)
10067 770 : n->sym->mark = 0;
10068 33627 : for (n = omp_clauses->lists[OMP_LIST_FROM]; n; n = n->next)
10069 1033 : if (n->expr == NULL)
10070 1015 : n->sym->mark = 1;
10071 33364 : for (n = omp_clauses->lists[OMP_LIST_TO]; n; n = n->next)
10072 : {
10073 770 : if (n->expr == NULL && n->sym->mark)
10074 0 : gfc_error ("Symbol %qs present on both FROM and TO clauses at %L",
10075 : n->sym->name, &n->where);
10076 : else
10077 770 : n->sym->mark = 1;
10078 : }
10079 :
10080 : bool has_inscan = false, has_notinscan = false;
10081 1303760 : for (enum gfc_omp_list_type list = OMP_LIST_FIRST; list < OMP_LIST_NUM;
10082 1271166 : list = gfc_omp_list_type (list + 1))
10083 1271166 : if ((n = omp_clauses->lists[list]) != NULL)
10084 : {
10085 29272 : const char *name = clause_names[list];
10086 :
10087 29272 : switch (list)
10088 : {
10089 : case OMP_LIST_COPYIN:
10090 267 : for (; n != NULL; n = n->next)
10091 : {
10092 170 : if (!n->sym->attr.threadprivate)
10093 0 : gfc_error ("Non-THREADPRIVATE object %qs in COPYIN clause"
10094 : " at %L", n->sym->name, &n->where);
10095 : }
10096 : break;
10097 83 : case OMP_LIST_COPYPRIVATE:
10098 83 : if (omp_clauses->nowait)
10099 6 : gfc_error ("NOWAIT clause must not be used with COPYPRIVATE "
10100 : "clause at %L", &n->where);
10101 376 : for (; n != NULL; n = n->next)
10102 : {
10103 293 : if (n->sym->as && n->sym->as->type == AS_ASSUMED_SIZE)
10104 0 : gfc_error ("Assumed size array %qs in COPYPRIVATE clause "
10105 : "at %L", n->sym->name, &n->where);
10106 293 : if (n->sym->attr.pointer && n->sym->attr.intent == INTENT_IN)
10107 1 : gfc_error ("INTENT(IN) POINTER %qs in COPYPRIVATE clause "
10108 : "at %L", n->sym->name, &n->where);
10109 : }
10110 : break;
10111 : case OMP_LIST_SHARED:
10112 2604 : for (; n != NULL; n = n->next)
10113 : {
10114 1642 : if (n->sym->attr.threadprivate)
10115 0 : gfc_error ("THREADPRIVATE object %qs in SHARED clause at "
10116 : "%L", n->sym->name, &n->where);
10117 1642 : if (n->sym->attr.cray_pointee)
10118 1 : gfc_error ("Cray pointee %qs in SHARED clause at %L",
10119 : n->sym->name, &n->where);
10120 1642 : if (n->sym->attr.associate_var)
10121 8 : gfc_error ("Associate name %qs in SHARED clause at %L",
10122 8 : n->sym->attr.select_type_temporary
10123 4 : ? n->sym->assoc->target->symtree->n.sym->name
10124 : : n->sym->name, &n->where);
10125 1642 : if (omp_clauses->detach
10126 1 : && n->sym == omp_clauses->detach->symtree->n.sym)
10127 1 : gfc_error ("DETACH event handle %qs in SHARED clause at %L",
10128 : n->sym->name, &n->where);
10129 : }
10130 : break;
10131 : case OMP_LIST_ALIGNED:
10132 256 : for (; n != NULL; n = n->next)
10133 : {
10134 150 : if (!n->sym->attr.pointer
10135 45 : && !n->sym->attr.allocatable
10136 30 : && !n->sym->attr.cray_pointer
10137 18 : && (n->sym->ts.type != BT_DERIVED
10138 18 : || (n->sym->ts.u.derived->from_intmod
10139 : != INTMOD_ISO_C_BINDING)
10140 18 : || (n->sym->ts.u.derived->intmod_sym_id
10141 : != ISOCBINDING_PTR)))
10142 0 : gfc_error ("%qs in ALIGNED clause must be POINTER, "
10143 : "ALLOCATABLE, Cray pointer or C_PTR at %L",
10144 : n->sym->name, &n->where);
10145 150 : else if (n->expr)
10146 : {
10147 147 : if (!gfc_resolve_expr (n->expr)
10148 147 : || n->expr->ts.type != BT_INTEGER
10149 146 : || n->expr->rank != 0
10150 146 : || n->expr->expr_type != EXPR_CONSTANT
10151 292 : || mpz_sgn (n->expr->value.integer) <= 0)
10152 4 : gfc_error ("%qs in ALIGNED clause at %L requires a scalar"
10153 : " positive constant integer alignment "
10154 4 : "expression", n->sym->name, &n->where);
10155 : }
10156 : }
10157 : break;
10158 : case OMP_LIST_AFFINITY:
10159 : case OMP_LIST_DEPEND:
10160 : case OMP_LIST_MAP:
10161 : case OMP_LIST_TO:
10162 : case OMP_LIST_FROM:
10163 : case OMP_LIST_CACHE:
10164 33191 : for (; n != NULL; n = n->next)
10165 : {
10166 20940 : if ((list == OMP_LIST_DEPEND || list == OMP_LIST_AFFINITY
10167 : || list == OMP_LIST_MAP
10168 18942 : || list == OMP_LIST_TO || list == OMP_LIST_FROM)
10169 20839 : && n->u2.ns && !n->u2.ns->resolved)
10170 : {
10171 109 : n->u2.ns->resolved = 1;
10172 109 : for (gfc_symbol *sym = n->u2.ns->omp_affinity_iterators;
10173 235 : sym; sym = sym->tlink)
10174 : {
10175 126 : gfc_constructor *c;
10176 126 : c = gfc_constructor_first (sym->value->value.constructor);
10177 126 : if (!gfc_resolve_expr (c->expr)
10178 126 : || c->expr->ts.type != BT_INTEGER
10179 250 : || c->expr->rank != 0)
10180 2 : gfc_error ("Scalar integer expression for range begin"
10181 2 : " expected at %L", &c->expr->where);
10182 126 : c = gfc_constructor_next (c);
10183 126 : if (!gfc_resolve_expr (c->expr)
10184 126 : || c->expr->ts.type != BT_INTEGER
10185 250 : || c->expr->rank != 0)
10186 2 : gfc_error ("Scalar integer expression for range end "
10187 2 : "expected at %L", &c->expr->where);
10188 126 : c = gfc_constructor_next (c);
10189 126 : if (c && (!gfc_resolve_expr (c->expr)
10190 16 : || c->expr->ts.type != BT_INTEGER
10191 14 : || c->expr->rank != 0))
10192 2 : gfc_error ("Scalar integer expression for range step "
10193 2 : "expected at %L", &c->expr->where);
10194 124 : else if (c
10195 14 : && c->expr->expr_type == EXPR_CONSTANT
10196 12 : && mpz_cmp_si (c->expr->value.integer, 0) == 0)
10197 2 : gfc_error ("Nonzero range step expected at %L",
10198 : &c->expr->where);
10199 : }
10200 : }
10201 :
10202 20940 : if (list == OMP_LIST_DEPEND)
10203 : {
10204 3196 : if (n->u.depend_doacross_op == OMP_DEPEND_SINK_FIRST
10205 : || n->u.depend_doacross_op == OMP_DOACROSS_SINK_FIRST
10206 1963 : || n->u.depend_doacross_op == OMP_DOACROSS_SINK)
10207 : {
10208 1233 : if (omp_clauses->doacross_source)
10209 : {
10210 0 : gfc_error ("Dependence-type SINK used together with"
10211 : " SOURCE on the same construct at %L",
10212 : &n->where);
10213 0 : omp_clauses->doacross_source = false;
10214 : }
10215 1233 : else if (n->expr)
10216 : {
10217 571 : if (!gfc_resolve_expr (n->expr)
10218 571 : || n->expr->ts.type != BT_INTEGER
10219 1142 : || n->expr->rank != 0)
10220 0 : gfc_error ("SINK addend not a constant integer "
10221 : "at %L", &n->where);
10222 : }
10223 1233 : if (n->sym == NULL
10224 4 : && (n->expr == NULL
10225 3 : || mpz_cmp_si (n->expr->value.integer, -1) != 0))
10226 2 : gfc_error ("omp_cur_iteration at %L requires %<-1%> "
10227 : "as logical offset", &n->where);
10228 1233 : continue;
10229 : }
10230 730 : else if (n->u.depend_doacross_op == OMP_DEPEND_DEPOBJ
10231 38 : && !n->expr
10232 22 : && (n->sym->ts.type != BT_INTEGER
10233 22 : || n->sym->ts.kind
10234 22 : != 2 * gfc_index_integer_kind
10235 22 : || n->sym->attr.dimension))
10236 0 : gfc_error ("Locator %qs at %L in DEPEND clause of depobj "
10237 : "type shall be a scalar integer of "
10238 : "OMP_DEPEND_KIND kind", n->sym->name,
10239 : &n->where);
10240 730 : else if (n->u.depend_doacross_op == OMP_DEPEND_DEPOBJ
10241 38 : && n->expr
10242 746 : && (!gfc_resolve_expr (n->expr)
10243 16 : || n->expr->ts.type != BT_INTEGER
10244 16 : || n->expr->ts.kind
10245 16 : != 2 * gfc_index_integer_kind
10246 16 : || n->expr->rank != 0))
10247 0 : gfc_error ("Locator at %L in DEPEND clause of depobj "
10248 : "type shall be a scalar integer of "
10249 0 : "OMP_DEPEND_KIND kind", &n->expr->where);
10250 : }
10251 19707 : gfc_ref *lastref = NULL, *lastslice = NULL;
10252 19707 : bool resolved = false;
10253 19707 : if (n->expr)
10254 : {
10255 6538 : lastref = n->expr->ref;
10256 6538 : resolved = gfc_resolve_expr (n->expr);
10257 :
10258 : /* Look through component refs to find last array
10259 : reference. */
10260 6538 : if (resolved)
10261 : {
10262 16568 : for (gfc_ref *ref = n->expr->ref; ref; ref = ref->next)
10263 10048 : if (ref->type == REF_COMPONENT
10264 : || ref->type == REF_SUBSTRING
10265 10048 : || ref->type == REF_INQUIRY)
10266 : lastref = ref;
10267 6798 : else if (ref->type == REF_ARRAY)
10268 : {
10269 14288 : for (int i = 0; i < ref->u.ar.dimen; i++)
10270 7490 : if (ref->u.ar.dimen_type[i] == DIMEN_RANGE)
10271 6276 : lastslice = ref;
10272 :
10273 : lastref = ref;
10274 : }
10275 :
10276 : /* The "!$acc cache" directive allows rectangular
10277 : subarrays to be specified, with some restrictions
10278 : on the form of bounds (not implemented).
10279 : Only raise an error here if we're really sure the
10280 : array isn't contiguous. An expression such as
10281 : arr(-n:n,-n:n) could be contiguous even if it looks
10282 : like it may not be. */
10283 6520 : if (code
10284 6502 : && code->op != EXEC_OACC_UPDATE
10285 5720 : && list != OMP_LIST_CACHE
10286 5720 : && list != OMP_LIST_DEPEND
10287 5398 : && !gfc_is_simply_contiguous (n->expr, false, true)
10288 1517 : && gfc_is_not_contiguous (n->expr)
10289 6533 : && !(lastslice
10290 13 : && (lastslice->next
10291 3 : || lastslice->type != REF_ARRAY)))
10292 3 : gfc_error ("Array is not contiguous at %L",
10293 : &n->where);
10294 : }
10295 : }
10296 19707 : if (list == OMP_LIST_MAP
10297 17038 : && (n->sym->attr.omp_groupprivate
10298 17037 : || n->sym->attr.omp_declare_target_local))
10299 2 : gfc_error ("%qs argument to MAP clause at %L must not be a "
10300 : "device-local variable, including GROUPPRIVATE",
10301 : n->sym->name, &n->where);
10302 19707 : if (openacc
10303 19707 : && list == OMP_LIST_MAP
10304 9571 : && (n->u.map.op == OMP_MAP_ATTACH
10305 9501 : || n->u.map.op == OMP_MAP_DETACH))
10306 : {
10307 117 : symbol_attribute attr;
10308 117 : if (n->expr)
10309 99 : attr = gfc_expr_attr (n->expr);
10310 : else
10311 18 : attr = n->sym->attr;
10312 117 : if (!attr.pointer && !attr.allocatable)
10313 7 : gfc_error ("%qs clause argument must be ALLOCATABLE or "
10314 : "a POINTER at %L",
10315 7 : (n->u.map.op == OMP_MAP_ATTACH) ? "attach"
10316 : : "detach", &n->where);
10317 : }
10318 19707 : if (lastref
10319 13181 : || (n->expr
10320 12 : && (!resolved || n->expr->expr_type != EXPR_VARIABLE)))
10321 : {
10322 6538 : if (!lastslice
10323 6538 : && lastref
10324 912 : && lastref->type == REF_SUBSTRING)
10325 11 : gfc_error ("Unexpected substring reference in %s clause "
10326 : "at %L", name, &n->where);
10327 6527 : else if (!lastslice
10328 : && lastref
10329 901 : && lastref->type == REF_INQUIRY)
10330 : {
10331 12 : gcc_assert (lastref->u.i == INQUIRY_RE
10332 : || lastref->u.i == INQUIRY_IM);
10333 12 : gfc_error ("Unexpected complex-parts designator "
10334 : "reference in %s clause at %L",
10335 : name, &n->where);
10336 : }
10337 6515 : else if (!resolved
10338 6497 : || n->expr->expr_type != EXPR_VARIABLE
10339 6485 : || (lastslice
10340 5614 : && (lastslice->next
10341 5598 : || lastslice->type != REF_ARRAY)))
10342 46 : gfc_error ("%qs in %s clause at %L is not a proper "
10343 46 : "array section", n->sym->name, name,
10344 : &n->where);
10345 : else if (lastslice)
10346 : {
10347 : int i;
10348 : gfc_array_ref *ar = &lastslice->u.ar;
10349 11871 : for (i = 0; i < ar->dimen; i++)
10350 6274 : if (ar->stride[i] && code->op != EXEC_OACC_UPDATE)
10351 : {
10352 1 : gfc_error ("Stride should not be specified for "
10353 : "array section in %s clause at %L",
10354 : name, &n->where);
10355 1 : break;
10356 : }
10357 6273 : else if (ar->dimen_type[i] != DIMEN_ELEMENT
10358 6273 : && ar->dimen_type[i] != DIMEN_RANGE)
10359 : {
10360 0 : gfc_error ("%qs in %s clause at %L is not a "
10361 : "proper array section",
10362 0 : n->sym->name, name, &n->where);
10363 0 : break;
10364 : }
10365 6273 : else if ((list == OMP_LIST_DEPEND
10366 : || list == OMP_LIST_AFFINITY)
10367 161 : && ar->start[i]
10368 133 : && ar->start[i]->expr_type == EXPR_CONSTANT
10369 97 : && ar->end[i]
10370 72 : && ar->end[i]->expr_type == EXPR_CONSTANT
10371 72 : && mpz_cmp (ar->start[i]->value.integer,
10372 72 : ar->end[i]->value.integer) > 0)
10373 : {
10374 0 : gfc_error ("%qs in %s clause at %L is a "
10375 : "zero size array section",
10376 0 : n->sym->name,
10377 : list == OMP_LIST_DEPEND
10378 : ? "DEPEND" : "AFFINITY", &n->where);
10379 0 : break;
10380 : }
10381 : }
10382 : }
10383 13169 : else if (openacc)
10384 : {
10385 5915 : if (list == OMP_LIST_MAP
10386 5900 : && n->u.map.op == OMP_MAP_FORCE_DEVICEPTR)
10387 65 : resolve_oacc_deviceptr_clause (n->sym, n->where, name);
10388 : else
10389 5850 : resolve_oacc_data_clauses (n->sym, n->where, name);
10390 : }
10391 7254 : else if (list != OMP_LIST_DEPEND
10392 6761 : && n->sym->as
10393 3339 : && n->sym->as->type == AS_ASSUMED_SIZE)
10394 5 : gfc_error ("Assumed size array %qs in %s clause at %L",
10395 : n->sym->name, name, &n->where);
10396 19707 : if (code && list == OMP_LIST_MAP && !openacc)
10397 7431 : switch (code->op)
10398 : {
10399 6157 : case EXEC_OMP_TARGET:
10400 6157 : case EXEC_OMP_TARGET_PARALLEL:
10401 6157 : case EXEC_OMP_TARGET_PARALLEL_DO:
10402 6157 : case EXEC_OMP_TARGET_PARALLEL_DO_SIMD:
10403 6157 : case EXEC_OMP_TARGET_PARALLEL_LOOP:
10404 6157 : case EXEC_OMP_TARGET_SIMD:
10405 6157 : case EXEC_OMP_TARGET_TEAMS:
10406 6157 : case EXEC_OMP_TARGET_TEAMS_DISTRIBUTE:
10407 6157 : case EXEC_OMP_TARGET_TEAMS_DISTRIBUTE_PARALLEL_DO:
10408 6157 : case EXEC_OMP_TARGET_TEAMS_DISTRIBUTE_PARALLEL_DO_SIMD:
10409 6157 : case EXEC_OMP_TARGET_TEAMS_DISTRIBUTE_SIMD:
10410 6157 : case EXEC_OMP_TARGET_TEAMS_LOOP:
10411 6157 : case EXEC_OMP_TARGET_DATA:
10412 6157 : switch (n->u.map.op)
10413 : {
10414 : case OMP_MAP_TO:
10415 : case OMP_MAP_ALWAYS_TO:
10416 : case OMP_MAP_PRESENT_TO:
10417 : case OMP_MAP_ALWAYS_PRESENT_TO:
10418 : case OMP_MAP_FROM:
10419 : case OMP_MAP_ALWAYS_FROM:
10420 : case OMP_MAP_PRESENT_FROM:
10421 : case OMP_MAP_ALWAYS_PRESENT_FROM:
10422 : case OMP_MAP_TOFROM:
10423 : case OMP_MAP_ALWAYS_TOFROM:
10424 : case OMP_MAP_PRESENT_TOFROM:
10425 : case OMP_MAP_ALWAYS_PRESENT_TOFROM:
10426 : case OMP_MAP_ALLOC:
10427 : case OMP_MAP_PRESENT_ALLOC:
10428 : break;
10429 2 : default:
10430 2 : gfc_error ("TARGET%s with map-type other than TO, "
10431 : "FROM, TOFROM, or ALLOC on MAP clause "
10432 : "at %L",
10433 : code->op == EXEC_OMP_TARGET_DATA
10434 : ? " DATA" : "", &n->where);
10435 2 : break;
10436 : }
10437 : break;
10438 696 : case EXEC_OMP_TARGET_ENTER_DATA:
10439 696 : switch (n->u.map.op)
10440 : {
10441 : case OMP_MAP_TO:
10442 : case OMP_MAP_ALWAYS_TO:
10443 : case OMP_MAP_PRESENT_TO:
10444 : case OMP_MAP_ALWAYS_PRESENT_TO:
10445 : case OMP_MAP_ALLOC:
10446 : case OMP_MAP_PRESENT_ALLOC:
10447 : break;
10448 178 : case OMP_MAP_TOFROM:
10449 178 : n->u.map.op = OMP_MAP_TO;
10450 178 : break;
10451 3 : case OMP_MAP_ALWAYS_TOFROM:
10452 3 : n->u.map.op = OMP_MAP_ALWAYS_TO;
10453 3 : break;
10454 2 : case OMP_MAP_PRESENT_TOFROM:
10455 2 : n->u.map.op = OMP_MAP_PRESENT_TO;
10456 2 : break;
10457 2 : case OMP_MAP_ALWAYS_PRESENT_TOFROM:
10458 2 : n->u.map.op = OMP_MAP_ALWAYS_PRESENT_TO;
10459 2 : break;
10460 2 : default:
10461 2 : gfc_error ("TARGET ENTER DATA with map-type other "
10462 : "than TO, TOFROM or ALLOC on MAP clause "
10463 : "at %L", &n->where);
10464 2 : break;
10465 : }
10466 : break;
10467 578 : case EXEC_OMP_TARGET_EXIT_DATA:
10468 578 : switch (n->u.map.op)
10469 : {
10470 : case OMP_MAP_FROM:
10471 : case OMP_MAP_ALWAYS_FROM:
10472 : case OMP_MAP_PRESENT_FROM:
10473 : case OMP_MAP_ALWAYS_PRESENT_FROM:
10474 : case OMP_MAP_RELEASE:
10475 : case OMP_MAP_DELETE:
10476 : break;
10477 132 : case OMP_MAP_TOFROM:
10478 132 : n->u.map.op = OMP_MAP_FROM;
10479 132 : break;
10480 1 : case OMP_MAP_ALWAYS_TOFROM:
10481 1 : n->u.map.op = OMP_MAP_ALWAYS_FROM;
10482 1 : break;
10483 0 : case OMP_MAP_PRESENT_TOFROM:
10484 0 : n->u.map.op = OMP_MAP_PRESENT_FROM;
10485 0 : break;
10486 0 : case OMP_MAP_ALWAYS_PRESENT_TOFROM:
10487 0 : n->u.map.op = OMP_MAP_ALWAYS_PRESENT_FROM;
10488 0 : break;
10489 2 : default:
10490 2 : gfc_error ("TARGET EXIT DATA with map-type other "
10491 : "than FROM, TOFROM, RELEASE, or DELETE on "
10492 : "MAP clause at %L", &n->where);
10493 2 : break;
10494 : }
10495 : break;
10496 : default:
10497 : break;
10498 : }
10499 19707 : if (list == OMP_LIST_MAP
10500 : || list == OMP_LIST_TO
10501 19707 : || list == OMP_LIST_FROM)
10502 : {
10503 18841 : gfc_typespec *ts = n->expr ? &n->expr->ts : &n->sym->ts;
10504 :
10505 18841 : if (ts->type == BT_DERIVED || ts->type == BT_CLASS)
10506 : {
10507 8 : const char *mapper_id
10508 997 : = (n->u3.udm ? n->u3.udm->requested_mapper_id : "");
10509 997 : gfc_omp_udm *udm = gfc_find_omp_udm (gfc_current_ns,
10510 : mapper_id, ts);
10511 997 : if (mapper_id[0] != '\0' && !udm)
10512 1 : gfc_error ("User-defined mapper %qs not found at %L",
10513 : mapper_id, &n->where);
10514 994 : else if (udm)
10515 : {
10516 25 : if (!n->u3.udm)
10517 : {
10518 18 : gcc_assert (mapper_id[0] == '\0');
10519 18 : n->u3.udm = gfc_get_omp_namelist_udm ();
10520 18 : n->u3.udm->requested_mapper_id = mapper_id;
10521 : }
10522 25 : n->u3.udm->resolved_udm = udm;
10523 : }
10524 : }
10525 : }
10526 : }
10527 :
10528 12251 : if (list != OMP_LIST_DEPEND)
10529 30381 : for (n = omp_clauses->lists[list]; n != NULL; n = n->next)
10530 : {
10531 18977 : n->sym->attr.referenced = 1;
10532 18977 : if (n->sym->attr.threadprivate)
10533 1 : gfc_error ("THREADPRIVATE object %qs in %s clause at %L",
10534 : n->sym->name, name, &n->where);
10535 18977 : if (n->sym->attr.cray_pointee)
10536 14 : gfc_error ("Cray pointee %qs in %s clause at %L",
10537 : n->sym->name, name, &n->where);
10538 : }
10539 : break;
10540 : case OMP_LIST_IS_DEVICE_PTR:
10541 : last = NULL;
10542 377 : for (n = omp_clauses->lists[list]; n != NULL; )
10543 : {
10544 257 : if ((n->sym->ts.type != BT_DERIVED
10545 71 : || !n->sym->ts.u.derived->ts.is_iso_c
10546 71 : || (n->sym->ts.u.derived->intmod_sym_id
10547 : != ISOCBINDING_PTR))
10548 187 : && code->op == EXEC_OMP_DISPATCH)
10549 : /* Non-TARGET (i.e. DISPATCH) requires a C_PTR. */
10550 3 : gfc_error ("List item %qs in %s clause at %L must be of "
10551 : "TYPE(C_PTR)", n->sym->name, name, &n->where);
10552 254 : else if (n->sym->ts.type != BT_DERIVED
10553 70 : || !n->sym->ts.u.derived->ts.is_iso_c
10554 70 : || (n->sym->ts.u.derived->intmod_sym_id
10555 : != ISOCBINDING_PTR))
10556 : {
10557 : /* For TARGET, non-C_PTR are deprecated and handled as
10558 : has_device_addr. */
10559 184 : gfc_warning (OPT_Wdeprecated_openmp,
10560 : "Non-C_PTR type argument at %L is deprecated, "
10561 : "use HAS_DEVICE_ADDR", &n->where);
10562 184 : gfc_omp_namelist *n2 = n;
10563 184 : n = n->next;
10564 184 : if (last)
10565 0 : last->next = n;
10566 : else
10567 184 : omp_clauses->lists[list] = n;
10568 184 : n2->next = omp_clauses->lists[OMP_LIST_HAS_DEVICE_ADDR];
10569 184 : omp_clauses->lists[OMP_LIST_HAS_DEVICE_ADDR] = n2;
10570 184 : continue;
10571 184 : }
10572 73 : last = n;
10573 73 : n = n->next;
10574 : }
10575 : break;
10576 : case OMP_LIST_HAS_DEVICE_ADDR:
10577 : case OMP_LIST_USE_DEVICE_ADDR:
10578 : break;
10579 : case OMP_LIST_USE_DEVICE_PTR:
10580 : /* Non-C_PTR are deprecated and handled as use_device_ADDR. */
10581 : last = NULL;
10582 475 : for (n = omp_clauses->lists[list]; n != NULL; )
10583 : {
10584 312 : gfc_omp_namelist *n2 = n;
10585 312 : if (n->sym->ts.type != BT_DERIVED
10586 18 : || !n->sym->ts.u.derived->ts.is_iso_c)
10587 : {
10588 294 : gfc_warning (OPT_Wdeprecated_openmp,
10589 : "Non-C_PTR type argument at %L is "
10590 : "deprecated, use USE_DEVICE_ADDR", &n->where);
10591 294 : n = n->next;
10592 294 : if (last)
10593 0 : last->next = n;
10594 : else
10595 294 : omp_clauses->lists[list] = n;
10596 294 : n2->next = omp_clauses->lists[OMP_LIST_USE_DEVICE_ADDR];
10597 294 : omp_clauses->lists[OMP_LIST_USE_DEVICE_ADDR] = n2;
10598 294 : continue;
10599 : }
10600 18 : last = n;
10601 18 : n = n->next;
10602 : }
10603 : break;
10604 48 : case OMP_LIST_USES_ALLOCATORS:
10605 48 : {
10606 48 : if (n != NULL
10607 48 : && n->u.memspace_sym
10608 14 : && (n->u.memspace_sym->attr.flavor != FL_PARAMETER
10609 13 : || n->u.memspace_sym->ts.type != BT_INTEGER
10610 13 : || n->u.memspace_sym->ts.kind != gfc_c_intptr_kind
10611 13 : || n->u.memspace_sym->attr.dimension
10612 13 : || (!startswith (n->u.memspace_sym->name, "omp_")
10613 0 : && !startswith (n->u.memspace_sym->name, "ompx_"))
10614 13 : || !endswith (n->u.memspace_sym->name, "_mem_space")))
10615 2 : gfc_error ("Memspace %qs at %L in USES_ALLOCATORS must be "
10616 : "a predefined memory space",
10617 : n->u.memspace_sym->name, &n->where);
10618 144 : for (; n != NULL; n = n->next)
10619 : {
10620 102 : if (n->sym->ts.type != BT_INTEGER
10621 102 : || n->sym->ts.kind != gfc_c_intptr_kind
10622 101 : || n->sym->attr.dimension)
10623 2 : gfc_error ("Allocator %qs at %L in USES_ALLOCATORS must "
10624 : "be a scalar integer of kind "
10625 : "%<omp_allocator_handle_kind%>", n->sym->name,
10626 : &n->where);
10627 100 : else if (n->sym->attr.flavor != FL_VARIABLE
10628 47 : && strcmp (n->sym->name, "omp_null_allocator") != 0
10629 144 : && ((!startswith (n->sym->name, "omp_")
10630 1 : && !startswith (n->sym->name, "ompx_"))
10631 43 : || !endswith (n->sym->name, "_mem_alloc")))
10632 2 : gfc_error ("Allocator %qs at %L in USES_ALLOCATORS must "
10633 : "either a variable or a predefined allocator",
10634 : n->sym->name, &n->where);
10635 98 : else if ((n->u.memspace_sym || n->u2.traits_sym)
10636 47 : && n->sym->attr.flavor != FL_VARIABLE)
10637 3 : gfc_error ("A memory space or traits array may not be "
10638 : "specified for predefined allocator %qs at %L",
10639 : n->sym->name, &n->where);
10640 102 : if (n->u2.traits_sym
10641 41 : && (n->u2.traits_sym->attr.flavor != FL_PARAMETER
10642 39 : || !n->u2.traits_sym->attr.dimension
10643 37 : || n->u2.traits_sym->as->rank != 1
10644 37 : || n->u2.traits_sym->ts.type != BT_DERIVED
10645 35 : || strcmp (n->u2.traits_sym->ts.u.derived->name,
10646 : "omp_alloctrait") != 0))
10647 : {
10648 6 : gfc_error ("Traits array %qs in USES_ALLOCATORS %L must "
10649 : "be a one-dimensional named constant array of "
10650 : "type %<omp_alloctrait%>",
10651 : n->u2.traits_sym->name, &n->where);
10652 6 : break;
10653 : }
10654 : }
10655 : break;
10656 : }
10657 : default:
10658 34760 : for (; n != NULL; n = n->next)
10659 : {
10660 20372 : if (n->sym == NULL)
10661 : {
10662 26 : gcc_assert (code->op == EXEC_OMP_ALLOCATORS
10663 : || code->op == EXEC_OMP_ALLOCATE);
10664 26 : continue;
10665 : }
10666 20346 : bool bad = false;
10667 20346 : bool is_reduction = (list == OMP_LIST_REDUCTION
10668 : || list == OMP_LIST_REDUCTION_INSCAN
10669 : || list == OMP_LIST_REDUCTION_TASK
10670 : || list == OMP_LIST_IN_REDUCTION
10671 20346 : || list == OMP_LIST_TASK_REDUCTION);
10672 20346 : if (list == OMP_LIST_REDUCTION_INSCAN)
10673 : has_inscan = true;
10674 20274 : else if (is_reduction)
10675 4737 : has_notinscan = true;
10676 20346 : if (has_inscan && has_notinscan && is_reduction)
10677 : {
10678 3 : gfc_error ("%<inscan%> and non-%<inscan%> %<reduction%> "
10679 : "clauses on the same construct at %L",
10680 : &n->where);
10681 3 : break;
10682 : }
10683 20343 : if (n->sym->attr.threadprivate)
10684 1 : gfc_error ("THREADPRIVATE object %qs in %s clause at %L",
10685 : n->sym->name, name, &n->where);
10686 20343 : if (n->sym->attr.cray_pointee)
10687 14 : gfc_error ("Cray pointee %qs in %s clause at %L",
10688 : n->sym->name, name, &n->where);
10689 20343 : if (n->sym->attr.associate_var)
10690 22 : gfc_error ("Associate name %qs in %s clause at %L",
10691 22 : n->sym->attr.select_type_temporary
10692 4 : ? n->sym->assoc->target->symtree->n.sym->name
10693 : : n->sym->name, name, &n->where);
10694 20343 : if (list != OMP_LIST_PRIVATE && is_reduction)
10695 : {
10696 4806 : if (n->sym->attr.proc_pointer)
10697 1 : gfc_error ("Procedure pointer %qs in %s clause at %L",
10698 : n->sym->name, name, &n->where);
10699 4806 : if (n->sym->attr.pointer)
10700 3 : gfc_error ("POINTER object %qs in %s clause at %L",
10701 : n->sym->name, name, &n->where);
10702 4806 : if (n->sym->attr.cray_pointer)
10703 5 : gfc_error ("Cray pointer %qs in %s clause at %L",
10704 : n->sym->name, name, &n->where);
10705 : }
10706 20343 : if (code
10707 20343 : && (oacc_is_loop (code)
10708 : || code->op == EXEC_OACC_PARALLEL
10709 : || code->op == EXEC_OACC_SERIAL))
10710 8741 : check_array_not_assumed (n->sym, n->where, name);
10711 11602 : else if (list != OMP_LIST_UNIFORM
10712 11485 : && n->sym->as && n->sym->as->type == AS_ASSUMED_SIZE)
10713 2 : gfc_error ("Assumed size array %qs in %s clause at %L",
10714 : n->sym->name, name, &n->where);
10715 20343 : if (n->sym->attr.in_namelist && !is_reduction)
10716 0 : gfc_error ("Variable %qs in %s clause is used in "
10717 : "NAMELIST statement at %L",
10718 : n->sym->name, name, &n->where);
10719 20343 : if (n->sym->attr.pointer && n->sym->attr.intent == INTENT_IN)
10720 3 : switch (list)
10721 : {
10722 3 : case OMP_LIST_PRIVATE:
10723 3 : case OMP_LIST_LASTPRIVATE:
10724 3 : case OMP_LIST_LINEAR:
10725 : /* case OMP_LIST_REDUCTION: */
10726 3 : gfc_error ("INTENT(IN) POINTER %qs in %s clause at %L",
10727 : n->sym->name, name, &n->where);
10728 3 : break;
10729 : default:
10730 : break;
10731 : }
10732 20343 : if (omp_clauses->detach
10733 3 : && (list == OMP_LIST_PRIVATE
10734 : || list == OMP_LIST_FIRSTPRIVATE
10735 : || list == OMP_LIST_LASTPRIVATE)
10736 3 : && n->sym == omp_clauses->detach->symtree->n.sym)
10737 1 : gfc_error ("DETACH event handle %qs in %s clause at %L",
10738 : n->sym->name, name, &n->where);
10739 :
10740 20343 : if (!openacc
10741 20343 : && (list == OMP_LIST_PRIVATE
10742 20343 : || list == OMP_LIST_FIRSTPRIVATE)
10743 4700 : && ((n->sym->ts.type == BT_DERIVED
10744 158 : && n->sym->ts.u.derived->attr.alloc_comp)
10745 4590 : || n->sym->ts.type == BT_CLASS))
10746 170 : switch (code->op)
10747 : {
10748 8 : case EXEC_OMP_TARGET:
10749 8 : case EXEC_OMP_TARGET_PARALLEL:
10750 8 : case EXEC_OMP_TARGET_PARALLEL_DO:
10751 8 : case EXEC_OMP_TARGET_PARALLEL_DO_SIMD:
10752 8 : case EXEC_OMP_TARGET_PARALLEL_LOOP:
10753 8 : case EXEC_OMP_TARGET_SIMD:
10754 8 : case EXEC_OMP_TARGET_TEAMS:
10755 8 : case EXEC_OMP_TARGET_TEAMS_DISTRIBUTE:
10756 8 : case EXEC_OMP_TARGET_TEAMS_DISTRIBUTE_PARALLEL_DO:
10757 8 : case EXEC_OMP_TARGET_TEAMS_DISTRIBUTE_PARALLEL_DO_SIMD:
10758 8 : case EXEC_OMP_TARGET_TEAMS_DISTRIBUTE_SIMD:
10759 8 : case EXEC_OMP_TARGET_TEAMS_LOOP:
10760 8 : if (n->sym->ts.type == BT_DERIVED
10761 2 : && n->sym->ts.u.derived->attr.alloc_comp)
10762 3 : gfc_error ("Sorry, list item %qs at %L with allocatable"
10763 : " components is not yet supported in %s "
10764 : "clause", n->sym->name, &n->where,
10765 : list == OMP_LIST_PRIVATE ? "PRIVATE"
10766 : : "FIRSTPRIVATE");
10767 : else
10768 9 : gfc_error ("Polymorphic list item %qs at %L in %s "
10769 : "clause has unspecified behavior and "
10770 : "unsupported", n->sym->name, &n->where,
10771 : list == OMP_LIST_PRIVATE ? "PRIVATE"
10772 : : "FIRSTPRIVATE");
10773 : break;
10774 : default:
10775 : break;
10776 : }
10777 :
10778 20343 : switch (list)
10779 : {
10780 104 : case OMP_LIST_REDUCTION_TASK:
10781 104 : if (code
10782 104 : && (code->op == EXEC_OMP_LOOP
10783 : || code->op == EXEC_OMP_TASKLOOP
10784 : || code->op == EXEC_OMP_TASKLOOP_SIMD
10785 : || code->op == EXEC_OMP_MASKED_TASKLOOP
10786 : || code->op == EXEC_OMP_MASKED_TASKLOOP_SIMD
10787 : || code->op == EXEC_OMP_MASTER_TASKLOOP
10788 : || code->op == EXEC_OMP_MASTER_TASKLOOP_SIMD
10789 : || code->op == EXEC_OMP_PARALLEL_LOOP
10790 : || code->op == EXEC_OMP_PARALLEL_MASKED_TASKLOOP
10791 : || code->op == EXEC_OMP_PARALLEL_MASKED_TASKLOOP_SIMD
10792 : || code->op == EXEC_OMP_PARALLEL_MASTER_TASKLOOP
10793 : || code->op == EXEC_OMP_PARALLEL_MASTER_TASKLOOP_SIMD
10794 : || code->op == EXEC_OMP_TARGET_PARALLEL_LOOP
10795 : || code->op == EXEC_OMP_TARGET_TEAMS_LOOP
10796 : || code->op == EXEC_OMP_TEAMS
10797 : || code->op == EXEC_OMP_TEAMS_DISTRIBUTE
10798 : || code->op == EXEC_OMP_TEAMS_LOOP))
10799 : {
10800 17 : gfc_error ("Only DEFAULT permitted as reduction-"
10801 : "modifier in REDUCTION clause at %L",
10802 : &n->where);
10803 17 : break;
10804 : }
10805 4789 : gcc_fallthrough ();
10806 4789 : case OMP_LIST_REDUCTION:
10807 4789 : case OMP_LIST_IN_REDUCTION:
10808 4789 : case OMP_LIST_TASK_REDUCTION:
10809 4789 : case OMP_LIST_REDUCTION_INSCAN:
10810 4789 : switch (n->u.reduction_op)
10811 : {
10812 2655 : case OMP_REDUCTION_PLUS:
10813 2655 : case OMP_REDUCTION_TIMES:
10814 2655 : case OMP_REDUCTION_MINUS:
10815 2655 : if (!gfc_numeric_ts (&n->sym->ts))
10816 : bad = true;
10817 : break;
10818 1112 : case OMP_REDUCTION_AND:
10819 1112 : case OMP_REDUCTION_OR:
10820 1112 : case OMP_REDUCTION_EQV:
10821 1112 : case OMP_REDUCTION_NEQV:
10822 1112 : if (n->sym->ts.type != BT_LOGICAL)
10823 : bad = true;
10824 : break;
10825 480 : case OMP_REDUCTION_MAX:
10826 480 : case OMP_REDUCTION_MIN:
10827 480 : if (n->sym->ts.type != BT_INTEGER
10828 212 : && n->sym->ts.type != BT_REAL)
10829 : bad = true;
10830 : break;
10831 192 : case OMP_REDUCTION_IAND:
10832 192 : case OMP_REDUCTION_IOR:
10833 192 : case OMP_REDUCTION_IEOR:
10834 192 : if (n->sym->ts.type != BT_INTEGER)
10835 : bad = true;
10836 : break;
10837 : case OMP_REDUCTION_USER:
10838 : bad = true;
10839 : break;
10840 : default:
10841 : break;
10842 : }
10843 : if (!bad)
10844 4215 : n->u2.udr = NULL;
10845 : else
10846 : {
10847 574 : const char *udr_name = NULL;
10848 574 : if (n->u2.udr)
10849 : {
10850 470 : udr_name = n->u2.udr->udr->name;
10851 470 : n->u2.udr->udr
10852 940 : = gfc_find_omp_udr (NULL, udr_name,
10853 470 : &n->sym->ts);
10854 470 : if (n->u2.udr->udr == NULL)
10855 : {
10856 0 : free (n->u2.udr);
10857 0 : n->u2.udr = NULL;
10858 : }
10859 : }
10860 574 : if (n->u2.udr == NULL)
10861 : {
10862 104 : if (udr_name == NULL)
10863 104 : switch (n->u.reduction_op)
10864 : {
10865 50 : case OMP_REDUCTION_PLUS:
10866 50 : case OMP_REDUCTION_TIMES:
10867 50 : case OMP_REDUCTION_MINUS:
10868 50 : case OMP_REDUCTION_AND:
10869 50 : case OMP_REDUCTION_OR:
10870 50 : case OMP_REDUCTION_EQV:
10871 50 : case OMP_REDUCTION_NEQV:
10872 50 : udr_name = gfc_op2string ((gfc_intrinsic_op)
10873 : n->u.reduction_op);
10874 50 : break;
10875 : case OMP_REDUCTION_MAX:
10876 : udr_name = "max";
10877 : break;
10878 9 : case OMP_REDUCTION_MIN:
10879 9 : udr_name = "min";
10880 9 : break;
10881 12 : case OMP_REDUCTION_IAND:
10882 12 : udr_name = "iand";
10883 12 : break;
10884 12 : case OMP_REDUCTION_IOR:
10885 12 : udr_name = "ior";
10886 12 : break;
10887 9 : case OMP_REDUCTION_IEOR:
10888 9 : udr_name = "ieor";
10889 9 : break;
10890 0 : default:
10891 0 : gcc_unreachable ();
10892 : }
10893 104 : gfc_error ("!$OMP DECLARE REDUCTION %s not found "
10894 : "for type %s at %L", udr_name,
10895 104 : gfc_typename (&n->sym->ts), &n->where);
10896 : }
10897 : else
10898 : {
10899 470 : gfc_omp_udr *udr = n->u2.udr->udr;
10900 470 : n->u.reduction_op = OMP_REDUCTION_USER;
10901 470 : n->u2.udr->combiner
10902 940 : = resolve_omp_udr_clause (n, udr->combiner_ns,
10903 470 : udr->omp_out,
10904 470 : udr->omp_in);
10905 470 : if (udr->initializer_ns)
10906 331 : n->u2.udr->initializer
10907 331 : = resolve_omp_udr_clause (n,
10908 : udr->initializer_ns,
10909 331 : udr->omp_priv,
10910 331 : udr->omp_orig);
10911 : }
10912 : }
10913 : break;
10914 874 : case OMP_LIST_LINEAR:
10915 874 : if (code)
10916 : {
10917 727 : bool is_worksharing_for = false;
10918 727 : switch (code->op)
10919 : {
10920 54 : case EXEC_OMP_DO:
10921 54 : case EXEC_OMP_PARALLEL_DO:
10922 54 : case EXEC_OMP_DISTRIBUTE_PARALLEL_DO:
10923 54 : case EXEC_OMP_TARGET_PARALLEL_DO:
10924 54 : case EXEC_OMP_TEAMS_DISTRIBUTE_PARALLEL_DO:
10925 54 : case EXEC_OMP_TARGET_TEAMS_DISTRIBUTE_PARALLEL_DO:
10926 54 : is_worksharing_for = true;
10927 54 : break;
10928 : default:
10929 : break;
10930 : }
10931 :
10932 54 : if (is_worksharing_for
10933 54 : && (n->sym->attr.dimension
10934 53 : || n->sym->attr.allocatable))
10935 : {
10936 1 : if (n->sym->attr.allocatable)
10937 0 : gfc_error ("Sorry, ALLOCATABLE object %qs in "
10938 : "LINEAR clause on worksharing-loop "
10939 : "construct at %L is not yet supported",
10940 : n->sym->name, &n->where);
10941 : else
10942 1 : gfc_error ("Sorry, array %qs in LINEAR clause "
10943 : "on worksharing-loop construct at %L "
10944 : "is not yet supported",
10945 : n->sym->name, &n->where);
10946 : break;
10947 : }
10948 : }
10949 :
10950 726 : if (code
10951 726 : && n->u.linear.op != OMP_LINEAR_DEFAULT
10952 23 : && n->u.linear.op != linear_op)
10953 : {
10954 23 : if (n->u.linear.old_modifier)
10955 : {
10956 9 : gfc_error ("LINEAR clause modifier used on DO or "
10957 : "SIMD construct at %L", &n->where);
10958 9 : linear_op = n->u.linear.op;
10959 : }
10960 14 : else if (n->u.linear.op != OMP_LINEAR_VAL)
10961 : {
10962 6 : gfc_error ("LINEAR clause modifier other than VAL "
10963 : "used on DO or SIMD construct at %L",
10964 : &n->where);
10965 6 : linear_op = n->u.linear.op;
10966 : }
10967 : }
10968 850 : else if (n->u.linear.op != OMP_LINEAR_REF
10969 800 : && n->sym->ts.type != BT_INTEGER)
10970 1 : gfc_error ("LINEAR variable %qs must be INTEGER "
10971 : "at %L", n->sym->name, &n->where);
10972 849 : else if ((n->u.linear.op == OMP_LINEAR_REF
10973 799 : || n->u.linear.op == OMP_LINEAR_UVAL)
10974 61 : && n->sym->attr.value)
10975 0 : gfc_error ("LINEAR dummy argument %qs with VALUE "
10976 : "attribute with %s modifier at %L",
10977 : n->sym->name,
10978 : n->u.linear.op == OMP_LINEAR_REF
10979 : ? "REF" : "UVAL", &n->where);
10980 849 : else if (n->expr)
10981 : {
10982 830 : gfc_expr *expr = n->expr;
10983 830 : if (!gfc_resolve_expr (expr)
10984 830 : || expr->ts.type != BT_INTEGER
10985 1660 : || expr->rank != 0)
10986 0 : gfc_error ("%qs in LINEAR clause at %L requires "
10987 : "a scalar integer linear-step expression",
10988 0 : n->sym->name, &n->where);
10989 830 : else if (!code && expr->expr_type != EXPR_CONSTANT)
10990 : {
10991 11 : if (expr->expr_type == EXPR_VARIABLE
10992 7 : && expr->symtree->n.sym->attr.dummy
10993 6 : && expr->symtree->n.sym->ns == ns)
10994 : {
10995 6 : gfc_omp_namelist *n2;
10996 6 : for (n2 = omp_clauses->lists[OMP_LIST_UNIFORM];
10997 6 : n2; n2 = n2->next)
10998 6 : if (n2->sym == expr->symtree->n.sym)
10999 : break;
11000 6 : if (n2)
11001 : break;
11002 : }
11003 5 : gfc_error ("%qs in LINEAR clause at %L requires "
11004 : "a constant integer linear-step "
11005 : "expression or dummy argument "
11006 : "specified in UNIFORM clause",
11007 5 : n->sym->name, &n->where);
11008 : }
11009 : }
11010 : break;
11011 : /* Workaround for PR middle-end/26316, nothing really needs
11012 : to be done here for OMP_LIST_PRIVATE. */
11013 9390 : case OMP_LIST_PRIVATE:
11014 9390 : gcc_assert (code && code->op != EXEC_NOP);
11015 : break;
11016 98 : case OMP_LIST_USE_DEVICE:
11017 98 : if (n->sym->attr.allocatable
11018 98 : || (n->sym->ts.type == BT_CLASS && CLASS_DATA (n->sym)
11019 0 : && CLASS_DATA (n->sym)->attr.allocatable))
11020 0 : gfc_error ("ALLOCATABLE object %qs in %s clause at %L",
11021 : n->sym->name, name, &n->where);
11022 98 : if (n->sym->ts.type == BT_CLASS
11023 0 : && CLASS_DATA (n->sym)
11024 0 : && CLASS_DATA (n->sym)->attr.class_pointer)
11025 0 : gfc_error ("POINTER object %qs of polymorphic type in "
11026 : "%s clause at %L", n->sym->name, name,
11027 : &n->where);
11028 98 : if (n->sym->attr.cray_pointer)
11029 2 : gfc_error ("Cray pointer object %qs in %s clause at %L",
11030 : n->sym->name, name, &n->where);
11031 96 : else if (n->sym->attr.cray_pointee)
11032 2 : gfc_error ("Cray pointee object %qs in %s clause at %L",
11033 : n->sym->name, name, &n->where);
11034 94 : else if (n->sym->attr.flavor == FL_VARIABLE
11035 93 : && !n->sym->as
11036 54 : && !n->sym->attr.pointer)
11037 13 : gfc_error ("%s clause variable %qs at %L is neither "
11038 : "a POINTER nor an array", name,
11039 : n->sym->name, &n->where);
11040 : /* FALLTHRU */
11041 98 : case OMP_LIST_DEVICE_RESIDENT:
11042 98 : check_symbol_not_pointer (n->sym, n->where, name);
11043 98 : check_array_not_assumed (n->sym, n->where, name);
11044 98 : break;
11045 : default:
11046 : break;
11047 : }
11048 : }
11049 : break;
11050 : }
11051 : }
11052 : /* OpenMP 5.1: use_device_ptr acts like use_device_addr, except for
11053 : type(c_ptr). */
11054 32594 : if (omp_clauses->lists[OMP_LIST_USE_DEVICE_PTR])
11055 : {
11056 9 : gfc_omp_namelist *n_prev, *n_next, *n_addr;
11057 9 : n_addr = omp_clauses->lists[OMP_LIST_USE_DEVICE_ADDR];
11058 28 : for (; n_addr && n_addr->next; n_addr = n_addr->next)
11059 : ;
11060 : n_prev = NULL;
11061 : n = omp_clauses->lists[OMP_LIST_USE_DEVICE_PTR];
11062 27 : while (n)
11063 : {
11064 18 : n_next = n->next;
11065 18 : if (n->sym->ts.type != BT_DERIVED
11066 18 : || n->sym->ts.u.derived->ts.f90_type != BT_VOID)
11067 : {
11068 0 : n->next = NULL;
11069 0 : if (n_addr)
11070 0 : n_addr->next = n;
11071 : else
11072 0 : omp_clauses->lists[OMP_LIST_USE_DEVICE_ADDR] = n;
11073 0 : n_addr = n;
11074 0 : if (n_prev)
11075 0 : n_prev->next = n_next;
11076 : else
11077 0 : omp_clauses->lists[OMP_LIST_USE_DEVICE_PTR] = n_next;
11078 : }
11079 : else
11080 : n_prev = n;
11081 : n = n_next;
11082 : }
11083 : }
11084 32594 : if (omp_clauses->safelen_expr)
11085 93 : resolve_positive_int_expr (omp_clauses->safelen_expr, "SAFELEN");
11086 32594 : if (omp_clauses->simdlen_expr)
11087 123 : resolve_positive_int_expr (omp_clauses->simdlen_expr, "SIMDLEN");
11088 32594 : if (omp_clauses->num_teams_lower)
11089 21 : resolve_positive_int_expr (omp_clauses->num_teams_lower, "NUM_TEAMS");
11090 32594 : if (omp_clauses->num_teams_upper)
11091 127 : resolve_positive_int_expr (omp_clauses->num_teams_upper, "NUM_TEAMS");
11092 32594 : if (omp_clauses->num_teams_lower
11093 21 : && omp_clauses->num_teams_lower->expr_type == EXPR_CONSTANT
11094 7 : && omp_clauses->num_teams_upper->expr_type == EXPR_CONSTANT
11095 7 : && mpz_cmp (omp_clauses->num_teams_lower->value.integer,
11096 7 : omp_clauses->num_teams_upper->value.integer) > 0)
11097 2 : gfc_warning (OPT_Wopenmp, "NUM_TEAMS lower bound at %L larger than upper "
11098 : "bound at %L", &omp_clauses->num_teams_lower->where,
11099 : &omp_clauses->num_teams_upper->where);
11100 32594 : if (omp_clauses->device)
11101 331 : resolve_scalar_int_expr (omp_clauses->device, "DEVICE");
11102 32594 : if (omp_clauses->filter)
11103 42 : resolve_nonnegative_int_expr (omp_clauses->filter, "FILTER");
11104 32594 : if (omp_clauses->hint)
11105 : {
11106 42 : resolve_scalar_int_expr (omp_clauses->hint, "HINT");
11107 42 : if (omp_clauses->hint->ts.type != BT_INTEGER
11108 40 : || omp_clauses->hint->expr_type != EXPR_CONSTANT
11109 38 : || mpz_sgn (omp_clauses->hint->value.integer) < 0)
11110 5 : gfc_error ("Value of HINT clause at %L shall be a valid "
11111 : "constant hint expression", &omp_clauses->hint->where);
11112 : }
11113 32594 : if (omp_clauses->priority)
11114 34 : resolve_nonnegative_int_expr (omp_clauses->priority, "PRIORITY");
11115 32594 : if (omp_clauses->dist_chunk_size)
11116 : {
11117 83 : gfc_expr *expr = omp_clauses->dist_chunk_size;
11118 83 : if (!gfc_resolve_expr (expr)
11119 83 : || expr->ts.type != BT_INTEGER || expr->rank != 0)
11120 0 : gfc_error ("DIST_SCHEDULE clause's chunk_size at %L requires "
11121 : "a scalar INTEGER expression", &expr->where);
11122 : }
11123 32594 : if (omp_clauses->thread_limit)
11124 72 : resolve_positive_int_expr (omp_clauses->thread_limit, "THREAD_LIMIT");
11125 32594 : if (omp_clauses->grainsize)
11126 34 : resolve_positive_int_expr (omp_clauses->grainsize, "GRAINSIZE");
11127 32594 : if (omp_clauses->num_tasks)
11128 26 : resolve_positive_int_expr (omp_clauses->num_tasks, "NUM_TASKS");
11129 32594 : if (omp_clauses->grainsize && omp_clauses->num_tasks)
11130 1 : gfc_error ("%<GRAINSIZE%> clause at %L must not be used together with "
11131 : "%<NUM_TASKS%> clause", &omp_clauses->grainsize->where);
11132 32594 : if (omp_clauses->lists[OMP_LIST_REDUCTION] && omp_clauses->nogroup)
11133 1 : gfc_error ("%<REDUCTION%> clause at %L must not be used together with "
11134 : "%<NOGROUP%> clause",
11135 : &omp_clauses->lists[OMP_LIST_REDUCTION]->where);
11136 32594 : if (omp_clauses->full && omp_clauses->partial)
11137 0 : gfc_error ("%<FULL%> clause at %C must not be used together with "
11138 : "%<PARTIAL%> clause");
11139 32594 : if (omp_clauses->async)
11140 610 : if (omp_clauses->async_expr)
11141 610 : resolve_scalar_int_expr (omp_clauses->async_expr, "ASYNC");
11142 32594 : if (omp_clauses->num_gangs_expr)
11143 682 : resolve_positive_int_expr (omp_clauses->num_gangs_expr, "NUM_GANGS");
11144 32594 : if (omp_clauses->num_workers_expr)
11145 599 : resolve_positive_int_expr (omp_clauses->num_workers_expr, "NUM_WORKERS");
11146 32594 : if (omp_clauses->vector_length_expr)
11147 569 : resolve_positive_int_expr (omp_clauses->vector_length_expr,
11148 : "VECTOR_LENGTH");
11149 32594 : if (omp_clauses->gang_num_expr)
11150 114 : resolve_positive_int_expr (omp_clauses->gang_num_expr, "GANG");
11151 32594 : if (omp_clauses->gang_static_expr)
11152 94 : resolve_positive_int_expr (omp_clauses->gang_static_expr, "GANG");
11153 32594 : if (omp_clauses->worker_expr)
11154 101 : resolve_positive_int_expr (omp_clauses->worker_expr, "WORKER");
11155 32594 : if (omp_clauses->vector_expr)
11156 132 : resolve_positive_int_expr (omp_clauses->vector_expr, "VECTOR");
11157 32933 : for (el = omp_clauses->wait_list; el; el = el->next)
11158 339 : resolve_scalar_int_expr (el->expr, "WAIT");
11159 32594 : if (omp_clauses->collapse && omp_clauses->tile_list)
11160 4 : gfc_error ("Incompatible use of TILE and COLLAPSE at %L", &code->loc);
11161 32594 : if (omp_clauses->message)
11162 : {
11163 45 : gfc_expr *expr = omp_clauses->message;
11164 45 : if (!gfc_resolve_expr (expr)
11165 45 : || expr->ts.kind != gfc_default_character_kind
11166 87 : || expr->ts.type != BT_CHARACTER || expr->rank != 0)
11167 4 : gfc_error ("MESSAGE clause at %L requires a scalar default-kind "
11168 : "CHARACTER expression", &expr->where);
11169 : }
11170 32594 : if (!openacc
11171 32594 : && code
11172 19729 : && omp_clauses->lists[OMP_LIST_MAP] == NULL
11173 15943 : && omp_clauses->lists[OMP_LIST_USE_DEVICE_PTR] == NULL
11174 15940 : && omp_clauses->lists[OMP_LIST_USE_DEVICE_ADDR] == NULL)
11175 : {
11176 15917 : const char *p = NULL;
11177 15917 : switch (code->op)
11178 : {
11179 1 : case EXEC_OMP_TARGET_ENTER_DATA: p = "TARGET ENTER DATA"; break;
11180 1 : case EXEC_OMP_TARGET_EXIT_DATA: p = "TARGET EXIT DATA"; break;
11181 : default: break;
11182 : }
11183 15917 : if (code->op == EXEC_OMP_TARGET_DATA)
11184 1 : gfc_error ("TARGET DATA must contain at least one MAP, USE_DEVICE_PTR, "
11185 : "or USE_DEVICE_ADDR clause at %L", &code->loc);
11186 15916 : else if (p)
11187 2 : gfc_error ("%s must contain at least one MAP clause at %L",
11188 : p, &code->loc);
11189 : }
11190 32594 : if (omp_clauses->sizes_list)
11191 : {
11192 : gfc_expr_list *el;
11193 572 : for (el = omp_clauses->sizes_list; el; el = el->next)
11194 : {
11195 377 : resolve_scalar_int_expr (el->expr, "SIZES");
11196 377 : if (el->expr->expr_type != EXPR_CONSTANT)
11197 1 : gfc_error ("SIZES requires constant expression at %L",
11198 : &el->expr->where);
11199 376 : else if (el->expr->expr_type == EXPR_CONSTANT
11200 376 : && el->expr->ts.type == BT_INTEGER
11201 376 : && mpz_sgn (el->expr->value.integer) <= 0)
11202 2 : gfc_error ("INTEGER expression of %s clause at %L must be "
11203 : "positive", "SIZES", &el->expr->where);
11204 : }
11205 : }
11206 :
11207 32594 : if (!openacc && omp_clauses->detach)
11208 : {
11209 125 : if (!gfc_resolve_expr (omp_clauses->detach)
11210 125 : || omp_clauses->detach->ts.type != BT_INTEGER
11211 124 : || omp_clauses->detach->ts.kind != gfc_c_intptr_kind
11212 248 : || omp_clauses->detach->rank != 0)
11213 3 : gfc_error ("%qs at %L should be a scalar of type "
11214 : "integer(kind=omp_event_handle_kind)",
11215 3 : omp_clauses->detach->symtree->n.sym->name,
11216 3 : &omp_clauses->detach->where);
11217 122 : else if (omp_clauses->detach->symtree->n.sym->attr.dimension > 0)
11218 1 : gfc_error ("The event handle at %L must not be an array element",
11219 : &omp_clauses->detach->where);
11220 121 : else if (omp_clauses->detach->symtree->n.sym->ts.type == BT_DERIVED
11221 120 : || omp_clauses->detach->symtree->n.sym->ts.type == BT_CLASS)
11222 1 : gfc_error ("The event handle at %L must not be part of "
11223 : "a derived type or class", &omp_clauses->detach->where);
11224 :
11225 125 : if (omp_clauses->mergeable)
11226 2 : gfc_error ("%<DETACH%> clause at %L must not be used together with "
11227 2 : "%<MERGEABLE%> clause", &omp_clauses->detach->where);
11228 : }
11229 :
11230 12625 : if (openacc
11231 12625 : && code->op == EXEC_OACC_HOST_DATA
11232 60 : && omp_clauses->lists[OMP_LIST_USE_DEVICE] == NULL)
11233 1 : gfc_error ("%<host_data%> construct at %L requires %<use_device%> clause",
11234 : &code->loc);
11235 :
11236 32594 : if (omp_clauses->assume)
11237 16 : gfc_resolve_omp_assumptions (omp_clauses->assume);
11238 : }
11239 :
11240 :
11241 : /* Return true if SYM is ever referenced in EXPR except in the SE node. */
11242 :
11243 : static bool
11244 4991 : expr_references_sym (gfc_expr *e, gfc_symbol *s, gfc_expr *se)
11245 : {
11246 6617 : gfc_actual_arglist *arg;
11247 6617 : if (e == NULL || e == se)
11248 : return false;
11249 5366 : switch (e->expr_type)
11250 : {
11251 3120 : case EXPR_CONSTANT:
11252 3120 : case EXPR_NULL:
11253 3120 : case EXPR_VARIABLE:
11254 3120 : case EXPR_STRUCTURE:
11255 3120 : case EXPR_ARRAY:
11256 3120 : if (e->symtree != NULL
11257 1152 : && e->symtree->n.sym == s)
11258 : return true;
11259 : return false;
11260 0 : case EXPR_SUBSTRING:
11261 0 : if (e->ref != NULL
11262 0 : && (expr_references_sym (e->ref->u.ss.start, s, se)
11263 0 : || expr_references_sym (e->ref->u.ss.end, s, se)))
11264 0 : return true;
11265 : return false;
11266 1735 : case EXPR_OP:
11267 1735 : if (expr_references_sym (e->value.op.op2, s, se))
11268 : return true;
11269 1626 : return expr_references_sym (e->value.op.op1, s, se);
11270 511 : case EXPR_FUNCTION:
11271 896 : for (arg = e->value.function.actual; arg; arg = arg->next)
11272 586 : if (expr_references_sym (arg->expr, s, se))
11273 : return true;
11274 : return false;
11275 0 : default:
11276 0 : gcc_unreachable ();
11277 : }
11278 : }
11279 :
11280 :
11281 : /* If EXPR is a conversion function that widens the type
11282 : if WIDENING is true or narrows the type if NARROW is true,
11283 : return the inner expression, otherwise return NULL. */
11284 :
11285 : static gfc_expr *
11286 5911 : is_conversion (gfc_expr *expr, bool narrowing, bool widening)
11287 : {
11288 5911 : gfc_typespec *ts1, *ts2;
11289 :
11290 5911 : if (expr->expr_type != EXPR_FUNCTION
11291 917 : || expr->value.function.isym == NULL
11292 894 : || expr->value.function.esym != NULL
11293 894 : || expr->value.function.isym->id != GFC_ISYM_CONVERSION
11294 388 : || (!narrowing && !widening))
11295 : return NULL;
11296 :
11297 388 : if (narrowing && widening)
11298 267 : return expr->value.function.actual->expr;
11299 :
11300 121 : if (widening)
11301 : {
11302 121 : ts1 = &expr->ts;
11303 121 : ts2 = &expr->value.function.actual->expr->ts;
11304 : }
11305 : else
11306 : {
11307 0 : ts1 = &expr->value.function.actual->expr->ts;
11308 0 : ts2 = &expr->ts;
11309 : }
11310 :
11311 121 : if (ts1->type > ts2->type
11312 49 : || (ts1->type == ts2->type && ts1->kind > ts2->kind))
11313 121 : return expr->value.function.actual->expr;
11314 :
11315 : return NULL;
11316 : }
11317 :
11318 : static bool
11319 6855 : is_scalar_intrinsic_expr (gfc_expr *expr, bool must_be_var, bool conv_ok)
11320 : {
11321 6855 : if (must_be_var
11322 4020 : && (expr->expr_type != EXPR_VARIABLE || !expr->symtree))
11323 : {
11324 37 : if (!conv_ok)
11325 : return false;
11326 37 : gfc_expr *conv = is_conversion (expr, true, true);
11327 37 : if (!conv)
11328 : return false;
11329 36 : if (conv->expr_type != EXPR_VARIABLE || !conv->symtree)
11330 : return false;
11331 : }
11332 6852 : return (expr->rank == 0
11333 6848 : && !gfc_is_coindexed (expr)
11334 13700 : && (expr->ts.type == BT_INTEGER
11335 : || expr->ts.type == BT_REAL
11336 : || expr->ts.type == BT_COMPLEX
11337 : || expr->ts.type == BT_LOGICAL));
11338 : }
11339 :
11340 : static void
11341 2697 : resolve_omp_atomic (gfc_code *code)
11342 : {
11343 2697 : gfc_code *atomic_code = code->block;
11344 2697 : gfc_symbol *var;
11345 2697 : gfc_expr *stmt_expr2, *capt_expr2;
11346 2697 : gfc_omp_atomic_op aop
11347 2697 : = (gfc_omp_atomic_op) (atomic_code->ext.omp_clauses->atomic_op
11348 : & GFC_OMP_ATOMIC_MASK);
11349 2697 : gfc_code *stmt = NULL, *capture_stmt = NULL, *tailing_stmt = NULL;
11350 2697 : gfc_expr *comp_cond = NULL;
11351 2697 : locus *loc = NULL;
11352 :
11353 2697 : code = code->block->next;
11354 : /* resolve_blocks asserts this is initially EXEC_ASSIGN or EXEC_IF
11355 : If it changed to EXEC_NOP, assume an error has been emitted already. */
11356 2697 : if (code->op == EXEC_NOP)
11357 : return;
11358 :
11359 2696 : if (atomic_code->ext.omp_clauses->compare
11360 156 : && atomic_code->ext.omp_clauses->capture)
11361 : {
11362 : /* Must be either "if (x == e) then; x = d; else; v = x; end if"
11363 : or "v = expr" followed/preceded by
11364 : "if (x == e) then; x = d; end if" or "if (x == e) x = d". */
11365 103 : gfc_code *next = code;
11366 103 : if (code->op == EXEC_ASSIGN)
11367 : {
11368 19 : capture_stmt = code;
11369 19 : next = code->next;
11370 : }
11371 103 : if (next->op == EXEC_IF
11372 103 : && next->block
11373 103 : && next->block->op == EXEC_IF
11374 103 : && next->block->next
11375 102 : && next->block->next->op == EXEC_ASSIGN)
11376 : {
11377 102 : comp_cond = next->block->expr1;
11378 102 : stmt = next->block->next;
11379 102 : if (stmt->next)
11380 : {
11381 0 : loc = &stmt->loc;
11382 0 : goto unexpected;
11383 : }
11384 : }
11385 1 : else if (capture_stmt)
11386 : {
11387 0 : gfc_error ("Expected IF at %L in atomic compare capture",
11388 : &next->loc);
11389 0 : return;
11390 : }
11391 103 : if (stmt && !capture_stmt && next->block->block)
11392 : {
11393 64 : if (next->block->block->expr1)
11394 : {
11395 0 : gfc_error ("Expected ELSE at %L in atomic compare capture",
11396 : &next->block->block->expr1->where);
11397 0 : return;
11398 : }
11399 64 : if (!code->block->block->next
11400 64 : || code->block->block->next->op != EXEC_ASSIGN)
11401 : {
11402 0 : loc = (code->block->block->next ? &code->block->block->next->loc
11403 : : &code->block->block->loc);
11404 0 : goto unexpected;
11405 : }
11406 64 : capture_stmt = code->block->block->next;
11407 64 : if (capture_stmt->next)
11408 : {
11409 0 : loc = &capture_stmt->next->loc;
11410 0 : goto unexpected;
11411 : }
11412 : }
11413 103 : if (stmt && !capture_stmt && next->next->op == EXEC_ASSIGN)
11414 : capture_stmt = next->next;
11415 84 : else if (!capture_stmt)
11416 : {
11417 1 : loc = &code->loc;
11418 1 : goto unexpected;
11419 : }
11420 : }
11421 2593 : else if (atomic_code->ext.omp_clauses->compare)
11422 : {
11423 : /* Must be: "if (x == e) then; x = d; end if" or "if (x == e) x = d". */
11424 53 : if (code->op == EXEC_IF
11425 53 : && code->block
11426 53 : && code->block->op == EXEC_IF
11427 53 : && code->block->next
11428 51 : && code->block->next->op == EXEC_ASSIGN)
11429 : {
11430 51 : comp_cond = code->block->expr1;
11431 51 : stmt = code->block->next;
11432 51 : if (stmt->next || code->block->block)
11433 : {
11434 0 : loc = stmt->next ? &stmt->next->loc : &code->block->block->loc;
11435 0 : goto unexpected;
11436 : }
11437 : }
11438 : else
11439 : {
11440 2 : loc = &code->loc;
11441 2 : goto unexpected;
11442 : }
11443 : }
11444 2540 : else if (atomic_code->ext.omp_clauses->capture)
11445 : {
11446 : /* Must be: "v = x" followed/preceded by "x = ...". */
11447 489 : if (code->op != EXEC_ASSIGN)
11448 0 : goto unexpected;
11449 489 : if (code->next->op != EXEC_ASSIGN)
11450 : {
11451 0 : loc = &code->next->loc;
11452 0 : goto unexpected;
11453 : }
11454 489 : gfc_expr *expr2, *expr2_next;
11455 489 : expr2 = is_conversion (code->expr2, true, true);
11456 489 : if (expr2 == NULL)
11457 447 : expr2 = code->expr2;
11458 489 : expr2_next = is_conversion (code->next->expr2, true, true);
11459 489 : if (expr2_next == NULL)
11460 478 : expr2_next = code->next->expr2;
11461 489 : if (code->expr1->expr_type == EXPR_VARIABLE
11462 489 : && code->next->expr1->expr_type == EXPR_VARIABLE
11463 489 : && expr2->expr_type == EXPR_VARIABLE
11464 243 : && expr2_next->expr_type == EXPR_VARIABLE)
11465 : {
11466 1 : if (code->expr1->symtree->n.sym == expr2_next->symtree->n.sym)
11467 : {
11468 : stmt = code;
11469 : capture_stmt = code->next;
11470 : }
11471 : else
11472 : {
11473 489 : capture_stmt = code;
11474 489 : stmt = code->next;
11475 : }
11476 : }
11477 488 : else if (expr2->expr_type == EXPR_VARIABLE)
11478 : {
11479 : capture_stmt = code;
11480 : stmt = code->next;
11481 : }
11482 : else
11483 : {
11484 247 : stmt = code;
11485 247 : capture_stmt = code->next;
11486 : }
11487 : /* Shall be NULL but can happen for invalid code. */
11488 489 : tailing_stmt = code->next->next;
11489 : }
11490 : else
11491 : {
11492 : /* x = ... */
11493 2051 : stmt = code;
11494 2051 : if (!atomic_code->ext.omp_clauses->compare && stmt->op != EXEC_ASSIGN)
11495 1 : goto unexpected;
11496 : /* Shall be NULL but can happen for invalid code. */
11497 2050 : tailing_stmt = code->next;
11498 : }
11499 :
11500 2692 : if (comp_cond)
11501 : {
11502 153 : if (comp_cond->expr_type != EXPR_OP
11503 153 : || (comp_cond->value.op.op != INTRINSIC_EQ
11504 : && comp_cond->value.op.op != INTRINSIC_EQ_OS
11505 : && comp_cond->value.op.op != INTRINSIC_EQV))
11506 : {
11507 0 : gfc_error ("Expected %<==%>, %<.EQ.%> or %<.EQV.%> atomic comparison "
11508 : "expression at %L", &comp_cond->where);
11509 0 : return;
11510 : }
11511 153 : if (!is_scalar_intrinsic_expr (comp_cond->value.op.op1, true, true))
11512 : {
11513 1 : gfc_error ("Expected scalar intrinsic variable at %L in atomic "
11514 1 : "comparison", &comp_cond->value.op.op1->where);
11515 1 : return;
11516 : }
11517 152 : if (!gfc_resolve_expr (comp_cond->value.op.op2))
11518 : return;
11519 152 : if (!is_scalar_intrinsic_expr (comp_cond->value.op.op2, false, false))
11520 : {
11521 0 : gfc_error ("Expected scalar intrinsic expression at %L in atomic "
11522 0 : "comparison", &comp_cond->value.op.op1->where);
11523 0 : return;
11524 : }
11525 : }
11526 :
11527 2691 : if (!is_scalar_intrinsic_expr (stmt->expr1, true, false))
11528 : {
11529 4 : gfc_error ("!$OMP ATOMIC statement must set a scalar variable of "
11530 4 : "intrinsic type at %L", &stmt->expr1->where);
11531 4 : return;
11532 : }
11533 :
11534 2687 : if (!gfc_resolve_expr (stmt->expr2))
11535 : return;
11536 2683 : if (!is_scalar_intrinsic_expr (stmt->expr2, false, false))
11537 : {
11538 0 : gfc_error ("!$OMP ATOMIC statement must assign an expression of "
11539 0 : "intrinsic type at %L", &stmt->expr2->where);
11540 0 : return;
11541 : }
11542 :
11543 2683 : if (gfc_expr_attr (stmt->expr1).allocatable)
11544 : {
11545 0 : gfc_error ("!$OMP ATOMIC with ALLOCATABLE variable at %L",
11546 0 : &stmt->expr1->where);
11547 0 : return;
11548 : }
11549 :
11550 : /* Should be diagnosed above already. */
11551 2683 : gcc_assert (tailing_stmt == NULL);
11552 :
11553 2683 : var = stmt->expr1->symtree->n.sym;
11554 2683 : stmt_expr2 = is_conversion (stmt->expr2, true, true);
11555 2683 : if (stmt_expr2 == NULL)
11556 2527 : stmt_expr2 = stmt->expr2;
11557 :
11558 2683 : switch (aop)
11559 : {
11560 503 : case GFC_OMP_ATOMIC_READ:
11561 503 : if (stmt_expr2->expr_type != EXPR_VARIABLE)
11562 0 : gfc_error ("!$OMP ATOMIC READ statement must read from a scalar "
11563 : "variable of intrinsic type at %L", &stmt_expr2->where);
11564 : return;
11565 421 : case GFC_OMP_ATOMIC_WRITE:
11566 421 : if (expr_references_sym (stmt_expr2, var, NULL))
11567 0 : gfc_error ("expr in !$OMP ATOMIC WRITE assignment var = expr "
11568 : "must be scalar and cannot reference var at %L",
11569 : &stmt_expr2->where);
11570 : return;
11571 1759 : default:
11572 1759 : break;
11573 : }
11574 :
11575 1759 : if (atomic_code->ext.omp_clauses->capture)
11576 : {
11577 588 : if (!is_scalar_intrinsic_expr (capture_stmt->expr1, true, false))
11578 : {
11579 0 : gfc_error ("!$OMP ATOMIC capture-statement must set a scalar "
11580 : "variable of intrinsic type at %L",
11581 0 : &capture_stmt->expr1->where);
11582 0 : return;
11583 : }
11584 :
11585 588 : if (!is_scalar_intrinsic_expr (capture_stmt->expr2, true, true))
11586 : {
11587 2 : gfc_error ("!$OMP ATOMIC capture-statement requires a scalar variable"
11588 2 : " of intrinsic type at %L", &capture_stmt->expr2->where);
11589 2 : return;
11590 : }
11591 586 : capt_expr2 = is_conversion (capture_stmt->expr2, true, true);
11592 586 : if (capt_expr2 == NULL)
11593 564 : capt_expr2 = capture_stmt->expr2;
11594 :
11595 586 : if (capt_expr2->symtree->n.sym != var)
11596 : {
11597 1 : gfc_error ("!$OMP ATOMIC CAPTURE capture statement reads from "
11598 : "different variable than update statement writes "
11599 : "into at %L", &capture_stmt->expr2->where);
11600 1 : return;
11601 : }
11602 : }
11603 :
11604 1756 : if (atomic_code->ext.omp_clauses->compare)
11605 : {
11606 149 : gfc_expr *var_expr;
11607 149 : if (comp_cond->value.op.op1->expr_type == EXPR_VARIABLE)
11608 : var_expr = comp_cond->value.op.op1;
11609 : else
11610 12 : var_expr = comp_cond->value.op.op1->value.function.actual->expr;
11611 149 : if (var_expr->symtree->n.sym != var)
11612 : {
11613 2 : gfc_error ("For !$OMP ATOMIC COMPARE, the first operand in comparison"
11614 : " at %L must be the variable %qs that the update statement"
11615 : " writes into at %L", &var_expr->where, var->name,
11616 2 : &stmt->expr1->where);
11617 2 : return;
11618 : }
11619 147 : if (stmt_expr2->rank != 0 || expr_references_sym (stmt_expr2, var, NULL))
11620 : {
11621 1 : gfc_error ("expr in !$OMP ATOMIC COMPARE assignment var = expr "
11622 : "must be scalar and cannot reference var at %L",
11623 : &stmt_expr2->where);
11624 1 : return;
11625 : }
11626 : }
11627 1607 : else if (atomic_code->ext.omp_clauses->capture
11628 1607 : && !expr_references_sym (stmt_expr2, var, NULL))
11629 22 : atomic_code->ext.omp_clauses->atomic_op
11630 22 : = (gfc_omp_atomic_op) (atomic_code->ext.omp_clauses->atomic_op
11631 : | GFC_OMP_ATOMIC_SWAP);
11632 1585 : else if (stmt_expr2->expr_type == EXPR_OP)
11633 : {
11634 1229 : gfc_expr *v = NULL, *e, *c;
11635 1229 : gfc_intrinsic_op op = stmt_expr2->value.op.op;
11636 1229 : gfc_intrinsic_op alt_op = INTRINSIC_NONE;
11637 :
11638 1229 : if (atomic_code->ext.omp_clauses->fail != OMP_MEMORDER_UNSET)
11639 3 : gfc_error ("!$OMP ATOMIC UPDATE at %L with FAIL clause requires either"
11640 : " the COMPARE clause or using the intrinsic MIN/MAX "
11641 : "procedure", &atomic_code->loc);
11642 1229 : switch (op)
11643 : {
11644 742 : case INTRINSIC_PLUS:
11645 742 : alt_op = INTRINSIC_MINUS;
11646 742 : break;
11647 94 : case INTRINSIC_TIMES:
11648 94 : alt_op = INTRINSIC_DIVIDE;
11649 94 : break;
11650 120 : case INTRINSIC_MINUS:
11651 120 : alt_op = INTRINSIC_PLUS;
11652 120 : break;
11653 94 : case INTRINSIC_DIVIDE:
11654 94 : alt_op = INTRINSIC_TIMES;
11655 94 : break;
11656 : case INTRINSIC_AND:
11657 : case INTRINSIC_OR:
11658 : break;
11659 43 : case INTRINSIC_EQV:
11660 43 : alt_op = INTRINSIC_NEQV;
11661 43 : break;
11662 43 : case INTRINSIC_NEQV:
11663 43 : alt_op = INTRINSIC_EQV;
11664 43 : break;
11665 1 : default:
11666 1 : gfc_error ("!$OMP ATOMIC assignment operator must be binary "
11667 : "+, *, -, /, .AND., .OR., .EQV. or .NEQV. at %L",
11668 : &stmt_expr2->where);
11669 1 : return;
11670 : }
11671 :
11672 : /* Check for var = var op expr resp. var = expr op var where
11673 : expr doesn't reference var and var op expr is mathematically
11674 : equivalent to var op (expr) resp. expr op var equivalent to
11675 : (expr) op var. We rely here on the fact that the matcher
11676 : for x op1 y op2 z where op1 and op2 have equal precedence
11677 : returns (x op1 y) op2 z. */
11678 1228 : e = stmt_expr2->value.op.op2;
11679 1228 : if (e->expr_type == EXPR_VARIABLE
11680 288 : && e->symtree != NULL
11681 288 : && e->symtree->n.sym == var)
11682 : v = e;
11683 999 : else if ((c = is_conversion (e, false, true)) != NULL
11684 48 : && c->expr_type == EXPR_VARIABLE
11685 48 : && c->symtree != NULL
11686 1047 : && c->symtree->n.sym == var)
11687 : v = c;
11688 : else
11689 : {
11690 951 : gfc_expr **p = NULL, **q;
11691 1049 : for (q = &stmt_expr2->value.op.op1; (e = *q) != NULL; )
11692 1049 : if (e->expr_type == EXPR_VARIABLE
11693 948 : && e->symtree != NULL
11694 948 : && e->symtree->n.sym == var)
11695 : {
11696 : v = e;
11697 : break;
11698 : }
11699 101 : else if ((c = is_conversion (e, false, true)) != NULL)
11700 60 : q = &e->value.function.actual->expr;
11701 41 : else if (e->expr_type != EXPR_OP
11702 41 : || (e->value.op.op != op
11703 15 : && e->value.op.op != alt_op)
11704 38 : || e->rank != 0)
11705 : break;
11706 : else
11707 : {
11708 38 : p = q;
11709 38 : q = &e->value.op.op1;
11710 : }
11711 :
11712 951 : if (v == NULL)
11713 : {
11714 3 : gfc_error ("!$OMP ATOMIC assignment must be var = var op expr "
11715 : "or var = expr op var at %L", &stmt_expr2->where);
11716 3 : return;
11717 : }
11718 :
11719 948 : if (p != NULL)
11720 : {
11721 38 : e = *p;
11722 38 : switch (e->value.op.op)
11723 : {
11724 8 : case INTRINSIC_MINUS:
11725 8 : case INTRINSIC_DIVIDE:
11726 8 : case INTRINSIC_EQV:
11727 8 : case INTRINSIC_NEQV:
11728 8 : gfc_error ("!$OMP ATOMIC var = var op expr not "
11729 : "mathematically equivalent to var = var op "
11730 : "(expr) at %L", &stmt_expr2->where);
11731 8 : break;
11732 : default:
11733 : break;
11734 : }
11735 :
11736 : /* Canonicalize into var = var op (expr). */
11737 38 : *p = e->value.op.op2;
11738 38 : e->value.op.op2 = stmt_expr2;
11739 38 : e->ts = stmt_expr2->ts;
11740 38 : if (stmt->expr2 == stmt_expr2)
11741 26 : stmt->expr2 = stmt_expr2 = e;
11742 : else
11743 12 : stmt->expr2->value.function.actual->expr = stmt_expr2 = e;
11744 :
11745 38 : if (!gfc_compare_types (&stmt_expr2->value.op.op1->ts,
11746 : &stmt_expr2->ts))
11747 : {
11748 24 : for (p = &stmt_expr2->value.op.op1; *p != v;
11749 12 : p = &(*p)->value.function.actual->expr)
11750 : ;
11751 12 : *p = NULL;
11752 12 : gfc_free_expr (stmt_expr2->value.op.op1);
11753 12 : stmt_expr2->value.op.op1 = v;
11754 12 : gfc_convert_type (v, &stmt_expr2->ts, 2);
11755 : }
11756 : }
11757 : }
11758 :
11759 1225 : if (e->rank != 0 || expr_references_sym (stmt->expr2, var, v))
11760 : {
11761 1 : gfc_error ("expr in !$OMP ATOMIC assignment var = var op expr "
11762 : "must be scalar and cannot reference var at %L",
11763 : &stmt_expr2->where);
11764 1 : return;
11765 : }
11766 : }
11767 356 : else if (stmt_expr2->expr_type == EXPR_FUNCTION
11768 355 : && stmt_expr2->value.function.isym != NULL
11769 355 : && stmt_expr2->value.function.esym == NULL
11770 355 : && stmt_expr2->value.function.actual != NULL
11771 355 : && stmt_expr2->value.function.actual->next != NULL)
11772 : {
11773 355 : gfc_actual_arglist *arg, *var_arg;
11774 :
11775 355 : switch (stmt_expr2->value.function.isym->id)
11776 : {
11777 : case GFC_ISYM_MIN:
11778 : case GFC_ISYM_MAX:
11779 : break;
11780 147 : case GFC_ISYM_IAND:
11781 147 : case GFC_ISYM_IOR:
11782 147 : case GFC_ISYM_IEOR:
11783 147 : if (stmt_expr2->value.function.actual->next->next != NULL)
11784 : {
11785 0 : gfc_error ("!$OMP ATOMIC assignment intrinsic IAND, IOR "
11786 : "or IEOR must have two arguments at %L",
11787 : &stmt_expr2->where);
11788 0 : return;
11789 : }
11790 : break;
11791 1 : default:
11792 1 : gfc_error ("!$OMP ATOMIC assignment intrinsic must be "
11793 : "MIN, MAX, IAND, IOR or IEOR at %L",
11794 : &stmt_expr2->where);
11795 1 : return;
11796 : }
11797 :
11798 : var_arg = NULL;
11799 1088 : for (arg = stmt_expr2->value.function.actual; arg; arg = arg->next)
11800 : {
11801 741 : gfc_expr *e = NULL;
11802 741 : if (arg == stmt_expr2->value.function.actual
11803 387 : || (var_arg == NULL && arg->next == NULL))
11804 : {
11805 527 : e = is_conversion (arg->expr, false, true);
11806 527 : if (!e)
11807 514 : e = arg->expr;
11808 527 : if (e->expr_type == EXPR_VARIABLE
11809 453 : && e->symtree != NULL
11810 453 : && e->symtree->n.sym == var)
11811 741 : var_arg = arg;
11812 : }
11813 741 : if ((!var_arg || !e) && expr_references_sym (arg->expr, var, NULL))
11814 : {
11815 7 : gfc_error ("!$OMP ATOMIC intrinsic arguments except one must "
11816 : "not reference %qs at %L",
11817 : var->name, &arg->expr->where);
11818 7 : return;
11819 : }
11820 734 : if (arg->expr->rank != 0)
11821 : {
11822 0 : gfc_error ("!$OMP ATOMIC intrinsic arguments must be scalar "
11823 : "at %L", &arg->expr->where);
11824 0 : return;
11825 : }
11826 : }
11827 :
11828 347 : if (var_arg == NULL)
11829 : {
11830 1 : gfc_error ("First or last !$OMP ATOMIC intrinsic argument must "
11831 : "be %qs at %L", var->name, &stmt_expr2->where);
11832 1 : return;
11833 : }
11834 :
11835 346 : if (var_arg != stmt_expr2->value.function.actual)
11836 : {
11837 : /* Canonicalize, so that var comes first. */
11838 172 : gcc_assert (var_arg->next == NULL);
11839 : for (arg = stmt_expr2->value.function.actual;
11840 185 : arg->next != var_arg; arg = arg->next)
11841 : ;
11842 172 : var_arg->next = stmt_expr2->value.function.actual;
11843 172 : stmt_expr2->value.function.actual = var_arg;
11844 172 : arg->next = NULL;
11845 : }
11846 : }
11847 : else
11848 1 : gfc_error ("!$OMP ATOMIC assignment must have an operator or "
11849 : "intrinsic on right hand side at %L", &stmt_expr2->where);
11850 : return;
11851 :
11852 4 : unexpected:
11853 4 : gfc_error ("unexpected !$OMP ATOMIC expression at %L",
11854 : loc ? loc : &code->loc);
11855 4 : return;
11856 : }
11857 :
11858 :
11859 : static struct fortran_omp_context
11860 : {
11861 : gfc_code *code;
11862 : hash_set<gfc_symbol *> *sharing_clauses;
11863 : hash_set<gfc_symbol *> *private_iterators;
11864 : struct fortran_omp_context *previous;
11865 : bool is_openmp;
11866 : } *omp_current_ctx;
11867 : static gfc_code *omp_current_do_code;
11868 : static int omp_current_do_collapse;
11869 :
11870 : /* Forward declaration for mutually recursive functions. */
11871 : static gfc_code *
11872 : find_nested_loop_in_block (gfc_code *block);
11873 :
11874 : /* Return the first nested DO loop in CHAIN, or NULL if there
11875 : isn't one. Does no error checking on intervening code. */
11876 :
11877 : static gfc_code *
11878 27482 : find_nested_loop_in_chain (gfc_code *chain)
11879 : {
11880 27482 : gfc_code *code;
11881 :
11882 27482 : if (!chain)
11883 : return NULL;
11884 :
11885 31643 : for (code = chain; code; code = code->next)
11886 31222 : switch (code->op)
11887 : {
11888 : case EXEC_DO:
11889 : case EXEC_OMP_TILE:
11890 : case EXEC_OMP_UNROLL:
11891 : return code;
11892 621 : case EXEC_BLOCK:
11893 621 : if (gfc_code *c = find_nested_loop_in_block (code))
11894 : return c;
11895 : break;
11896 : default:
11897 : break;
11898 : }
11899 : return NULL;
11900 : }
11901 :
11902 : /* Return the first nested DO loop in BLOCK, or NULL if there
11903 : isn't one. Does no error checking on intervening code. */
11904 : static gfc_code *
11905 939 : find_nested_loop_in_block (gfc_code *block)
11906 : {
11907 939 : gfc_namespace *ns;
11908 939 : gcc_assert (block->op == EXEC_BLOCK);
11909 939 : ns = block->ext.block.ns;
11910 939 : gcc_assert (ns);
11911 939 : return find_nested_loop_in_chain (ns->code);
11912 : }
11913 :
11914 : void
11915 5423 : gfc_resolve_omp_do_blocks (gfc_code *code, gfc_namespace *ns)
11916 : {
11917 5423 : if (code->block->next && code->block->next->op == EXEC_DO)
11918 : {
11919 5070 : int i;
11920 :
11921 5070 : omp_current_do_code = code->block->next;
11922 5070 : if (code->ext.omp_clauses->orderedc)
11923 142 : omp_current_do_collapse = code->ext.omp_clauses->orderedc;
11924 4928 : else if (code->ext.omp_clauses->collapse)
11925 1121 : omp_current_do_collapse = code->ext.omp_clauses->collapse;
11926 3807 : else if (code->ext.omp_clauses->sizes_list)
11927 175 : omp_current_do_collapse
11928 175 : = gfc_expr_list_len (code->ext.omp_clauses->sizes_list);
11929 : else
11930 3632 : omp_current_do_collapse = 1;
11931 5070 : if (code->ext.omp_clauses->lists[OMP_LIST_REDUCTION_INSCAN])
11932 : {
11933 : /* Checking that there is a matching EXEC_OMP_SCAN in the
11934 : innermost body cannot be deferred to resolve_omp_do because
11935 : we process directives nested in the loop before we get
11936 : there. */
11937 60 : locus *loc
11938 : = &code->ext.omp_clauses->lists[OMP_LIST_REDUCTION_INSCAN]->where;
11939 60 : gfc_code *c;
11940 :
11941 80 : for (i = 1, c = omp_current_do_code;
11942 80 : i < omp_current_do_collapse; i++)
11943 : {
11944 22 : c = find_nested_loop_in_chain (c->block->next);
11945 22 : if (!c || c->op != EXEC_DO || c->block == NULL)
11946 : break;
11947 : }
11948 :
11949 : /* Skip this if we don't have enough nested loops. That
11950 : problem will be diagnosed elsewhere. */
11951 60 : if (c && c->op == EXEC_DO)
11952 : {
11953 58 : gfc_code *block = c->block ? c->block->next : NULL;
11954 58 : if (block && block->op != EXEC_OMP_SCAN)
11955 54 : while (block && block->next
11956 54 : && block->next->op != EXEC_OMP_SCAN)
11957 : block = block->next;
11958 43 : if (!block
11959 46 : || (block->op != EXEC_OMP_SCAN
11960 43 : && (!block->next || block->next->op != EXEC_OMP_SCAN)))
11961 19 : gfc_error ("With INSCAN at %L, expected loop body with "
11962 : "!$OMP SCAN between two "
11963 : "structured block sequences", loc);
11964 : else
11965 : {
11966 39 : if (block->op == EXEC_OMP_SCAN)
11967 3 : gfc_warning (OPT_Wopenmp,
11968 : "!$OMP SCAN at %L with zero executable "
11969 : "statements in preceding structured block "
11970 : "sequence", &block->loc);
11971 39 : if ((block->op == EXEC_OMP_SCAN && !block->next)
11972 38 : || (block->next && block->next->op == EXEC_OMP_SCAN
11973 36 : && !block->next->next))
11974 3 : gfc_warning (OPT_Wopenmp,
11975 : "!$OMP SCAN at %L with zero executable "
11976 : "statements in succeeding structured block "
11977 : "sequence", block->op == EXEC_OMP_SCAN
11978 1 : ? &block->loc : &block->next->loc);
11979 : }
11980 58 : if (block && block->op != EXEC_OMP_SCAN)
11981 43 : block = block->next;
11982 46 : if (block && block->op == EXEC_OMP_SCAN)
11983 : /* Mark 'omp scan' as checked; flag will be unset later. */
11984 39 : block->ext.omp_clauses->if_present = true;
11985 : }
11986 : }
11987 : }
11988 5423 : gfc_resolve_blocks (code->block, ns);
11989 5423 : omp_current_do_collapse = 0;
11990 5423 : omp_current_do_code = NULL;
11991 5423 : }
11992 :
11993 :
11994 : void
11995 6046 : gfc_resolve_omp_parallel_blocks (gfc_code *code, gfc_namespace *ns)
11996 : {
11997 6046 : struct fortran_omp_context ctx;
11998 6046 : gfc_omp_clauses *omp_clauses = code->ext.omp_clauses;
11999 6046 : gfc_omp_namelist *n;
12000 :
12001 6046 : ctx.code = code;
12002 6046 : ctx.sharing_clauses = new hash_set<gfc_symbol *>;
12003 6046 : ctx.private_iterators = new hash_set<gfc_symbol *>;
12004 6046 : ctx.previous = omp_current_ctx;
12005 6046 : ctx.is_openmp = true;
12006 6046 : omp_current_ctx = &ctx;
12007 :
12008 241840 : for (enum gfc_omp_list_type list = OMP_LIST_FIRST; list < OMP_LIST_NUM;
12009 235794 : list = gfc_omp_list_type (list + 1))
12010 235794 : switch (list)
12011 : {
12012 60460 : case OMP_LIST_SHARED:
12013 60460 : case OMP_LIST_PRIVATE:
12014 60460 : case OMP_LIST_FIRSTPRIVATE:
12015 60460 : case OMP_LIST_LASTPRIVATE:
12016 60460 : case OMP_LIST_REDUCTION:
12017 60460 : case OMP_LIST_REDUCTION_INSCAN:
12018 60460 : case OMP_LIST_REDUCTION_TASK:
12019 60460 : case OMP_LIST_IN_REDUCTION:
12020 60460 : case OMP_LIST_TASK_REDUCTION:
12021 60460 : case OMP_LIST_LINEAR:
12022 69450 : for (n = omp_clauses->lists[list]; n; n = n->next)
12023 8990 : ctx.sharing_clauses->add (n->sym);
12024 : break;
12025 : default:
12026 : break;
12027 : }
12028 :
12029 6046 : switch (code->op)
12030 : {
12031 2360 : case EXEC_OMP_DISTRIBUTE_PARALLEL_DO:
12032 2360 : case EXEC_OMP_DISTRIBUTE_PARALLEL_DO_SIMD:
12033 2360 : case EXEC_OMP_MASKED_TASKLOOP:
12034 2360 : case EXEC_OMP_MASKED_TASKLOOP_SIMD:
12035 2360 : case EXEC_OMP_MASTER_TASKLOOP:
12036 2360 : case EXEC_OMP_MASTER_TASKLOOP_SIMD:
12037 2360 : case EXEC_OMP_PARALLEL_DO:
12038 2360 : case EXEC_OMP_PARALLEL_DO_SIMD:
12039 2360 : case EXEC_OMP_PARALLEL_LOOP:
12040 2360 : case EXEC_OMP_PARALLEL_MASKED_TASKLOOP:
12041 2360 : case EXEC_OMP_PARALLEL_MASKED_TASKLOOP_SIMD:
12042 2360 : case EXEC_OMP_PARALLEL_MASTER_TASKLOOP:
12043 2360 : case EXEC_OMP_PARALLEL_MASTER_TASKLOOP_SIMD:
12044 2360 : case EXEC_OMP_TARGET_PARALLEL_DO:
12045 2360 : case EXEC_OMP_TARGET_PARALLEL_DO_SIMD:
12046 2360 : case EXEC_OMP_TARGET_PARALLEL_LOOP:
12047 2360 : case EXEC_OMP_TARGET_TEAMS_DISTRIBUTE:
12048 2360 : case EXEC_OMP_TARGET_TEAMS_DISTRIBUTE_PARALLEL_DO:
12049 2360 : case EXEC_OMP_TARGET_TEAMS_DISTRIBUTE_PARALLEL_DO_SIMD:
12050 2360 : case EXEC_OMP_TARGET_TEAMS_DISTRIBUTE_SIMD:
12051 2360 : case EXEC_OMP_TARGET_TEAMS_LOOP:
12052 2360 : case EXEC_OMP_TASKLOOP:
12053 2360 : case EXEC_OMP_TASKLOOP_SIMD:
12054 2360 : case EXEC_OMP_TEAMS_DISTRIBUTE:
12055 2360 : case EXEC_OMP_TEAMS_DISTRIBUTE_PARALLEL_DO:
12056 2360 : case EXEC_OMP_TEAMS_DISTRIBUTE_PARALLEL_DO_SIMD:
12057 2360 : case EXEC_OMP_TEAMS_DISTRIBUTE_SIMD:
12058 2360 : case EXEC_OMP_TEAMS_LOOP:
12059 2360 : gfc_resolve_omp_do_blocks (code, ns);
12060 2360 : break;
12061 3686 : default:
12062 3686 : gfc_resolve_blocks (code->block, ns);
12063 : }
12064 :
12065 6046 : omp_current_ctx = ctx.previous;
12066 12092 : delete ctx.sharing_clauses;
12067 12092 : delete ctx.private_iterators;
12068 6046 : }
12069 :
12070 :
12071 : /* Save and clear openmp.cc private state. */
12072 :
12073 : void
12074 289506 : gfc_omp_save_and_clear_state (struct gfc_omp_saved_state *state)
12075 : {
12076 289506 : state->ptrs[0] = omp_current_ctx;
12077 289506 : state->ptrs[1] = omp_current_do_code;
12078 289506 : state->ints[0] = omp_current_do_collapse;
12079 289506 : omp_current_ctx = NULL;
12080 289506 : omp_current_do_code = NULL;
12081 289506 : omp_current_do_collapse = 0;
12082 289506 : }
12083 :
12084 :
12085 : /* Restore openmp.cc private state from the saved state. */
12086 :
12087 : void
12088 289505 : gfc_omp_restore_state (struct gfc_omp_saved_state *state)
12089 : {
12090 289505 : omp_current_ctx = (struct fortran_omp_context *) state->ptrs[0];
12091 289505 : omp_current_do_code = (gfc_code *) state->ptrs[1];
12092 289505 : omp_current_do_collapse = state->ints[0];
12093 289505 : }
12094 :
12095 :
12096 : /* Note a DO iterator variable. This is special in !$omp parallel
12097 : construct, where they are predetermined private. */
12098 :
12099 : void
12100 33056 : gfc_resolve_do_iterator (gfc_code *code, gfc_symbol *sym, bool add_clause)
12101 : {
12102 33056 : if (omp_current_ctx == NULL)
12103 : return;
12104 :
12105 13097 : int i = omp_current_do_collapse;
12106 13097 : gfc_code *c = omp_current_do_code;
12107 :
12108 13097 : if (sym->attr.threadprivate)
12109 : return;
12110 :
12111 : /* !$omp do and !$omp parallel do iteration variable is predetermined
12112 : private just in the !$omp do resp. !$omp parallel do construct,
12113 : with no implications for the outer parallel constructs. */
12114 :
12115 17932 : while (i-- >= 1 && c)
12116 : {
12117 9493 : if (code == c)
12118 : return;
12119 4835 : c = find_nested_loop_in_chain (c->block->next);
12120 4835 : if (c && (c->op == EXEC_OMP_TILE || c->op == EXEC_OMP_UNROLL))
12121 : return;
12122 : }
12123 :
12124 : /* An openacc context may represent a data clause. Abort if so. */
12125 8439 : if (!omp_current_ctx->is_openmp && !oacc_is_loop (omp_current_ctx->code))
12126 : return;
12127 :
12128 7461 : if (omp_current_ctx->sharing_clauses->contains (sym))
12129 : return;
12130 :
12131 6459 : if (! omp_current_ctx->private_iterators->add (sym) && add_clause)
12132 : {
12133 6272 : gfc_omp_clauses *omp_clauses = omp_current_ctx->code->ext.omp_clauses;
12134 6272 : gfc_omp_namelist *p;
12135 :
12136 6272 : p = gfc_get_omp_namelist ();
12137 6272 : p->sym = sym;
12138 6272 : p->where = omp_current_ctx->code->loc;
12139 6272 : p->next = omp_clauses->lists[OMP_LIST_PRIVATE];
12140 6272 : omp_clauses->lists[OMP_LIST_PRIVATE] = p;
12141 : }
12142 : }
12143 :
12144 : static void
12145 698 : handle_local_var (gfc_symbol *sym)
12146 : {
12147 698 : if (sym->attr.flavor != FL_VARIABLE
12148 178 : || sym->as != NULL
12149 137 : || (sym->ts.type != BT_INTEGER && sym->ts.type != BT_REAL))
12150 : return;
12151 71 : gfc_resolve_do_iterator (sym->ns->code, sym, false);
12152 : }
12153 :
12154 : void
12155 336051 : gfc_resolve_omp_local_vars (gfc_namespace *ns)
12156 : {
12157 336051 : if (omp_current_ctx)
12158 452 : gfc_traverse_ns (ns, handle_local_var);
12159 336051 : }
12160 :
12161 :
12162 : /* Error checking on intervening code uses a code walker. */
12163 :
12164 : struct icode_error_state
12165 : {
12166 : const char *name;
12167 : bool errorp;
12168 : gfc_code *nested;
12169 : gfc_code *next;
12170 : };
12171 :
12172 : static int
12173 944 : icode_code_error_callback (gfc_code **codep,
12174 : int *walk_subtrees ATTRIBUTE_UNUSED, void *opaque)
12175 : {
12176 944 : gfc_code *code = *codep;
12177 944 : icode_error_state *state = (icode_error_state *)opaque;
12178 :
12179 : /* gfc_code_walker walks down CODE's next chain as well as
12180 : walking things that are actually nested in CODE. We need to
12181 : special-case traversal of outer blocks, so stop immediately if we
12182 : are heading down such a next chain. */
12183 944 : if (code == state->next)
12184 : return 1;
12185 :
12186 647 : switch (code->op)
12187 : {
12188 1 : case EXEC_DO:
12189 1 : case EXEC_DO_WHILE:
12190 1 : case EXEC_DO_CONCURRENT:
12191 1 : gfc_error ("%s cannot contain loop in intervening code at %L",
12192 : state->name, &code->loc);
12193 1 : state->errorp = true;
12194 1 : break;
12195 0 : case EXEC_CYCLE:
12196 0 : case EXEC_EXIT:
12197 : /* Errors have already been diagnosed in match_exit_cycle. */
12198 0 : state->errorp = true;
12199 0 : break;
12200 : case EXEC_OMP_ASSUME:
12201 : case EXEC_OMP_METADIRECTIVE:
12202 : /* Per OpenMP 6.0, some non-executable directives are allowed in
12203 : intervening code. */
12204 : break;
12205 477 : case EXEC_CALL:
12206 : /* Per OpenMP 5.2, the "omp_" prefix is reserved, so we don't have to
12207 : consider the possibility that some locally-bound definition
12208 : overrides the runtime routine. */
12209 477 : if (code->resolved_sym
12210 477 : && omp_runtime_api_procname (code->resolved_sym->name))
12211 : {
12212 1 : gfc_error ("%s cannot contain OpenMP API call in intervening code "
12213 : "at %L",
12214 : state->name, &code->loc);
12215 1 : state->errorp = true;
12216 : }
12217 : break;
12218 168 : default:
12219 168 : if (code->op >= EXEC_OMP_FIRST_OPENMP_EXEC
12220 168 : && code->op <= EXEC_OMP_LAST_OPENMP_EXEC)
12221 : {
12222 2 : gfc_error ("%s cannot contain OpenMP directive in intervening code "
12223 : "at %L",
12224 : state->name, &code->loc);
12225 2 : state->errorp = true;
12226 : }
12227 : }
12228 : return 0;
12229 : }
12230 :
12231 : static int
12232 1081 : icode_expr_error_callback (gfc_expr **expr,
12233 : int *walk_subtrees ATTRIBUTE_UNUSED, void *opaque)
12234 : {
12235 1081 : icode_error_state *state = (icode_error_state *)opaque;
12236 :
12237 1081 : switch ((*expr)->expr_type)
12238 : {
12239 : /* As for EXPR_CALL with "omp_"-prefixed symbols. */
12240 2 : case EXPR_FUNCTION:
12241 2 : {
12242 2 : gfc_symbol *sym = (*expr)->value.function.esym;
12243 2 : if (sym && omp_runtime_api_procname (sym->name))
12244 : {
12245 1 : gfc_error ("%s cannot contain OpenMP API call in intervening code "
12246 : "at %L",
12247 1 : state->name, &((*expr)->where));
12248 1 : state->errorp = true;
12249 : }
12250 : }
12251 :
12252 : break;
12253 : default:
12254 : break;
12255 : }
12256 :
12257 : /* FIXME: The description of canonical loop form in the OpenMP standard
12258 : also says "array expressions" are not permitted in intervening code.
12259 : That term is not defined in either the OpenMP spec or the Fortran
12260 : standard, although the latter uses it informally to refer to any
12261 : expression that is not scalar-valued. It is also apparently not the
12262 : thing GCC internally calls EXPR_ARRAY. It seems the intent of the
12263 : OpenMP restriction is to disallow elemental operations/intrinsics
12264 : (including things that are not expressions, like assignment
12265 : statements) that generate implicit loops over array operands
12266 : (even if the result is a scalar), but even if the spec said
12267 : that there is no list of all the cases that would be forbidden.
12268 : This is OpenMP issue 3326. */
12269 :
12270 1081 : return 0;
12271 : }
12272 :
12273 : static void
12274 267 : diagnose_intervening_code_errors_1 (gfc_code *chain,
12275 : struct icode_error_state *state)
12276 : {
12277 267 : gfc_code *code;
12278 1080 : for (code = chain; code; code = code->next)
12279 : {
12280 813 : if (code == state->nested)
12281 : /* Do not walk the nested loop or its body, we are only
12282 : interested in intervening code. */
12283 : ;
12284 636 : else if (code->op == EXEC_BLOCK
12285 636 : && find_nested_loop_in_block (code) == state->nested)
12286 : /* This block contains the nested loop, recurse on its
12287 : statements. */
12288 : {
12289 90 : gfc_namespace* ns = code->ext.block.ns;
12290 90 : diagnose_intervening_code_errors_1 (ns->code, state);
12291 : }
12292 : else
12293 : /* Treat the whole statement as a unit. */
12294 : {
12295 546 : gfc_code *temp = state->next;
12296 546 : state->next = code->next;
12297 546 : gfc_code_walker (&code, icode_code_error_callback,
12298 : icode_expr_error_callback, state);
12299 546 : state->next = temp;
12300 : }
12301 : }
12302 267 : }
12303 :
12304 : /* Diagnose intervening code errors in BLOCK with nested loop NESTED.
12305 : NAME is the user-friendly name of the OMP directive, used for error
12306 : messages. Returns true if any error was found. */
12307 : static bool
12308 177 : diagnose_intervening_code_errors (gfc_code *chain, const char *name,
12309 : gfc_code *nested)
12310 : {
12311 177 : struct icode_error_state state;
12312 177 : state.name = name;
12313 177 : state.errorp = false;
12314 177 : state.nested = nested;
12315 177 : state.next = NULL;
12316 0 : diagnose_intervening_code_errors_1 (chain, &state);
12317 177 : return state.errorp;
12318 : }
12319 :
12320 : /* Helper function for restructure_intervening_code: wrap CHAIN in
12321 : a marker to indicate that it is a structured block sequence. That
12322 : information will be used later on (in omp-low.cc) for error checking. */
12323 : static gfc_code *
12324 461 : make_structured_block (gfc_code *chain)
12325 : {
12326 461 : gcc_assert (chain);
12327 461 : gfc_namespace *ns = gfc_build_block_ns (gfc_current_ns);
12328 461 : gfc_code *result = gfc_get_code (EXEC_BLOCK);
12329 461 : result->op = EXEC_BLOCK;
12330 461 : result->ext.block.ns = ns;
12331 461 : result->ext.block.assoc = NULL;
12332 461 : result->loc = chain->loc;
12333 461 : ns->omp_structured_block = 1;
12334 461 : ns->code = chain;
12335 461 : return result;
12336 : }
12337 :
12338 : /* Push intervening code surrounding a loop, including nested scopes,
12339 : into the body of the loop. CHAINP is the pointer to the head of
12340 : the next-chain to scan, OUTER_LOOP is the EXEC_DO for the next outer
12341 : loop level, and COLLAPSE is the number of nested loops we need to
12342 : process.
12343 : Note that CHAINP may point at outer_loop->block->next when we
12344 : are scanning the body of a loop, but if there is an intervening block
12345 : CHAINP points into the block's chain rather than its enclosing outer
12346 : loop. This is why OUTER_LOOP is passed separately. */
12347 : static gfc_code *
12348 7173 : restructure_intervening_code (gfc_code **chainp, gfc_code *outer_loop,
12349 : int count)
12350 : {
12351 7173 : gfc_code *code;
12352 7173 : gfc_code *head = *chainp;
12353 7173 : gfc_code *tail = NULL;
12354 7173 : gfc_code *innermost_loop = NULL;
12355 :
12356 7437 : for (code = *chainp; code; code = code->next, chainp = &(*chainp)->next)
12357 : {
12358 7437 : if (code->op == EXEC_DO)
12359 : {
12360 : /* Cut CODE free from its chain, leaving the ends dangling. */
12361 7089 : *chainp = NULL;
12362 7089 : tail = code->next;
12363 7089 : code->next = NULL;
12364 :
12365 7089 : if (count == 1)
12366 : innermost_loop = code;
12367 : else
12368 2090 : innermost_loop
12369 2090 : = restructure_intervening_code (&code->block->next,
12370 : code, count - 1);
12371 : break;
12372 : }
12373 348 : else if (code->op == EXEC_BLOCK
12374 348 : && find_nested_loop_in_block (code))
12375 : {
12376 84 : gfc_namespace *ns = code->ext.block.ns;
12377 :
12378 : /* Cut CODE free from its chain, leaving the ends dangling. */
12379 84 : *chainp = NULL;
12380 84 : tail = code->next;
12381 84 : code->next = NULL;
12382 :
12383 84 : innermost_loop
12384 84 : = restructure_intervening_code (&ns->code, outer_loop,
12385 : count);
12386 :
12387 : /* At this point we have already pulled out the nested loop and
12388 : pointed outer_loop at it, and moved the intervening code that
12389 : was previously in the block into the body of innermost_loop.
12390 : Now we want to move the BLOCK itself so it wraps the entire
12391 : current body of innermost_loop. */
12392 84 : ns->code = innermost_loop->block->next;
12393 84 : innermost_loop->block->next = code;
12394 84 : break;
12395 : }
12396 : }
12397 :
12398 2174 : gcc_assert (innermost_loop);
12399 :
12400 : /* Now we have split the intervening code into two parts:
12401 : head is the start of the part before the loop/block, terminating
12402 : at *chainp, and tail is the part after it. Mark each part as
12403 : a structured block sequence, and splice the two parts around the
12404 : existing body of the innermost loop. */
12405 7173 : if (head != code)
12406 : {
12407 222 : gfc_code *block = make_structured_block (head);
12408 222 : if (innermost_loop->block->next)
12409 221 : gfc_append_code (block, innermost_loop->block->next);
12410 222 : innermost_loop->block->next = block;
12411 : }
12412 7173 : if (tail)
12413 : {
12414 239 : gfc_code *block = make_structured_block (tail);
12415 239 : if (innermost_loop->block->next)
12416 237 : gfc_append_code (innermost_loop->block->next, block);
12417 : else
12418 2 : innermost_loop->block->next = block;
12419 : }
12420 :
12421 : /* For loops, finally splice CODE into OUTER_LOOP. We already handled
12422 : relinking EXEC_BLOCK above. */
12423 7173 : if (code->op == EXEC_DO && outer_loop)
12424 7089 : outer_loop->block->next = code;
12425 :
12426 7173 : return innermost_loop;
12427 : }
12428 :
12429 : /* CODE is an OMP loop construct. Return true if VAR matches an iteration
12430 : variable outer to level DEPTH. */
12431 : static bool
12432 8086 : is_outer_iteration_variable (gfc_code *code, int depth, gfc_symbol *var)
12433 : {
12434 8086 : int i;
12435 8086 : gfc_code *do_code = code;
12436 :
12437 12613 : for (i = 1; i < depth; i++)
12438 : {
12439 5028 : do_code = find_nested_loop_in_chain (do_code->block->next);
12440 5028 : gcc_assert (do_code);
12441 5028 : if (do_code->op == EXEC_OMP_TILE || do_code->op == EXEC_OMP_UNROLL)
12442 : {
12443 51 : --i;
12444 51 : continue;
12445 : }
12446 4977 : gfc_symbol *ivar = do_code->ext.iterator->var->symtree->n.sym;
12447 4977 : if (var == ivar)
12448 : return true;
12449 : }
12450 : return false;
12451 : }
12452 :
12453 : /* Forward declaration for recursive functions. */
12454 : static gfc_code *
12455 : check_nested_loop_in_block (gfc_code *block, gfc_expr *expr, gfc_symbol *sym,
12456 : bool *bad);
12457 :
12458 : /* Like find_nested_loop_in_chain, but additionally check that EXPR
12459 : does not reference any variables bound in intervening EXEC_BLOCKs
12460 : and that SYM is not bound in such intervening blocks. Either EXPR or SYM
12461 : may be null. Sets *BAD to true if either test fails. */
12462 : static gfc_code *
12463 48177 : check_nested_loop_in_chain (gfc_code *chain, gfc_expr *expr, gfc_symbol *sym,
12464 : bool *bad)
12465 : {
12466 51781 : for (gfc_code *code = chain; code; code = code->next)
12467 : {
12468 51493 : if (code->op == EXEC_DO)
12469 : return code;
12470 4123 : else if (code->op == EXEC_OMP_TILE || code->op == EXEC_OMP_UNROLL)
12471 1682 : return check_nested_loop_in_chain (code->block->next, expr, sym, bad);
12472 2441 : else if (code->op == EXEC_BLOCK)
12473 : {
12474 807 : gfc_code *c = check_nested_loop_in_block (code, expr, sym, bad);
12475 807 : if (c)
12476 : return c;
12477 : }
12478 : }
12479 : return NULL;
12480 : }
12481 :
12482 : /* Code walker for block symtrees. It doesn't take any kind of state
12483 : argument, so use a static variable. */
12484 : static struct check_nested_loop_in_block_state_t {
12485 : gfc_expr *expr;
12486 : gfc_symbol *sym;
12487 : bool *bad;
12488 : } check_nested_loop_in_block_state;
12489 :
12490 : static void
12491 766 : check_nested_loop_in_block_symbol (gfc_symbol *sym)
12492 : {
12493 766 : if (sym == check_nested_loop_in_block_state.sym
12494 766 : || (check_nested_loop_in_block_state.expr
12495 567 : && gfc_find_sym_in_expr (sym,
12496 : check_nested_loop_in_block_state.expr)))
12497 5 : *check_nested_loop_in_block_state.bad = true;
12498 766 : }
12499 :
12500 : /* Return the first nested DO loop in BLOCK, or NULL if there
12501 : isn't one. Set *BAD to true if EXPR references any variables in BLOCK, or
12502 : SYM is bound in BLOCK. Either EXPR or SYM may be null. */
12503 : static gfc_code *
12504 807 : check_nested_loop_in_block (gfc_code *block, gfc_expr *expr,
12505 : gfc_symbol *sym, bool *bad)
12506 : {
12507 807 : gfc_namespace *ns;
12508 807 : gcc_assert (block->op == EXEC_BLOCK);
12509 807 : ns = block->ext.block.ns;
12510 807 : gcc_assert (ns);
12511 :
12512 : /* Skip the check if this block doesn't contain the nested loop, or
12513 : if we already know it's bad. */
12514 807 : gfc_code *result = check_nested_loop_in_chain (ns->code, expr, sym, bad);
12515 807 : if (result && !*bad)
12516 : {
12517 519 : check_nested_loop_in_block_state.expr = expr;
12518 519 : check_nested_loop_in_block_state.sym = sym;
12519 519 : check_nested_loop_in_block_state.bad = bad;
12520 519 : gfc_traverse_ns (ns, check_nested_loop_in_block_symbol);
12521 519 : check_nested_loop_in_block_state.expr = NULL;
12522 519 : check_nested_loop_in_block_state.sym = NULL;
12523 519 : check_nested_loop_in_block_state.bad = NULL;
12524 : }
12525 807 : return result;
12526 : }
12527 :
12528 : /* CODE is an OMP loop construct. Return true if EXPR references
12529 : any variables bound in intervening code, to level DEPTH. */
12530 : static bool
12531 22726 : expr_uses_intervening_var (gfc_code *code, int depth, gfc_expr *expr)
12532 : {
12533 22726 : int i;
12534 22726 : gfc_code *do_code = code;
12535 :
12536 58231 : for (i = 0; i < depth; i++)
12537 : {
12538 35508 : bool bad = false;
12539 35508 : do_code = check_nested_loop_in_chain (do_code->block->next,
12540 : expr, NULL, &bad);
12541 35508 : if (bad)
12542 3 : return true;
12543 : }
12544 : return false;
12545 : }
12546 :
12547 : /* CODE is an OMP loop construct. Return true if SYM is bound in
12548 : intervening code, to level DEPTH. */
12549 : static bool
12550 7585 : is_intervening_var (gfc_code *code, int depth, gfc_symbol *sym)
12551 : {
12552 7585 : int i;
12553 7585 : gfc_code *do_code = code;
12554 :
12555 19445 : for (i = 0; i < depth; i++)
12556 : {
12557 11862 : bool bad = false;
12558 11862 : do_code = check_nested_loop_in_chain (do_code->block->next,
12559 : NULL, sym, &bad);
12560 11862 : if (bad)
12561 2 : return true;
12562 : }
12563 : return false;
12564 : }
12565 :
12566 : /* CODE is an OMP loop construct. Return true if EXPR does not reference
12567 : any iteration variables outer to level DEPTH. */
12568 : static bool
12569 23805 : expr_is_invariant (gfc_code *code, int depth, gfc_expr *expr)
12570 : {
12571 23805 : int i;
12572 23805 : gfc_code *do_code = code;
12573 :
12574 37127 : for (i = 1; i < depth; i++)
12575 : {
12576 14388 : do_code = find_nested_loop_in_chain (do_code->block->next);
12577 14388 : gcc_assert (do_code);
12578 14388 : if (do_code->op == EXEC_OMP_TILE || do_code->op == EXEC_OMP_UNROLL)
12579 : {
12580 136 : --i;
12581 136 : continue;
12582 : }
12583 14252 : gfc_symbol *ivar = do_code->ext.iterator->var->symtree->n.sym;
12584 14252 : if (gfc_find_sym_in_expr (ivar, expr))
12585 : return false;
12586 : }
12587 : return true;
12588 : }
12589 :
12590 : /* CODE is an OMP loop construct. Return true if EXPR matches one of the
12591 : canonical forms for a bound expression. It may include references to
12592 : an iteration variable outer to level DEPTH; set OUTER_VARP if so. */
12593 : static bool
12594 15161 : bound_expr_is_canonical (gfc_code *code, int depth, gfc_expr *expr,
12595 : gfc_symbol **outer_varp)
12596 : {
12597 15161 : gfc_expr *expr2 = NULL;
12598 :
12599 : /* Rectangular case. */
12600 15161 : if (depth == 0 || expr_is_invariant (code, depth, expr))
12601 14593 : return true;
12602 :
12603 : /* Any simple variable that didn't pass expr_is_invariant must be
12604 : an outer_var. */
12605 568 : if (expr->expr_type == EXPR_VARIABLE && expr->rank == 0)
12606 : {
12607 63 : *outer_varp = expr->symtree->n.sym;
12608 63 : return true;
12609 : }
12610 :
12611 : /* All other permitted forms are binary operators. */
12612 505 : if (expr->expr_type != EXPR_OP)
12613 : return false;
12614 :
12615 : /* Check for plus/minus a loop invariant expr. */
12616 503 : if (expr->value.op.op == INTRINSIC_PLUS
12617 503 : || expr->value.op.op == INTRINSIC_MINUS)
12618 : {
12619 483 : if (expr_is_invariant (code, depth, expr->value.op.op1))
12620 48 : expr2 = expr->value.op.op2;
12621 435 : else if (expr_is_invariant (code, depth, expr->value.op.op2))
12622 434 : expr2 = expr->value.op.op1;
12623 : else
12624 : return false;
12625 : }
12626 : else
12627 : expr2 = expr;
12628 :
12629 : /* Check for a product with a loop-invariant expr. */
12630 502 : if (expr2->expr_type == EXPR_OP
12631 96 : && expr2->value.op.op == INTRINSIC_TIMES)
12632 : {
12633 96 : if (expr_is_invariant (code, depth, expr2->value.op.op1))
12634 40 : expr2 = expr2->value.op.op2;
12635 56 : else if (expr_is_invariant (code, depth, expr2->value.op.op2))
12636 53 : expr2 = expr2->value.op.op1;
12637 : else
12638 : return false;
12639 : }
12640 :
12641 : /* What's left must be a reference to an outer loop variable. */
12642 499 : if (expr2->expr_type == EXPR_VARIABLE
12643 499 : && expr2->rank == 0
12644 998 : && is_outer_iteration_variable (code, depth, expr2->symtree->n.sym))
12645 : {
12646 499 : *outer_varp = expr2->symtree->n.sym;
12647 499 : return true;
12648 : }
12649 :
12650 : return false;
12651 : }
12652 :
12653 : static void
12654 5423 : resolve_omp_do (gfc_code *code)
12655 : {
12656 5423 : gfc_code *do_code, *next;
12657 5423 : int i, count, non_generated_count;
12658 5423 : gfc_omp_namelist *n;
12659 5423 : gfc_symbol *dovar;
12660 5423 : const char *name;
12661 5423 : bool is_simd = false;
12662 5423 : bool errorp = false;
12663 5423 : bool perfect_nesting_errorp = false;
12664 5423 : bool imperfect = false;
12665 :
12666 5423 : switch (code->op)
12667 : {
12668 : case EXEC_OMP_DISTRIBUTE: name = "!$OMP DISTRIBUTE"; break;
12669 49 : case EXEC_OMP_DISTRIBUTE_PARALLEL_DO:
12670 49 : name = "!$OMP DISTRIBUTE PARALLEL DO";
12671 49 : break;
12672 32 : case EXEC_OMP_DISTRIBUTE_PARALLEL_DO_SIMD:
12673 32 : name = "!$OMP DISTRIBUTE PARALLEL DO SIMD";
12674 32 : is_simd = true;
12675 32 : break;
12676 50 : case EXEC_OMP_DISTRIBUTE_SIMD:
12677 50 : name = "!$OMP DISTRIBUTE SIMD";
12678 50 : is_simd = true;
12679 50 : break;
12680 1335 : case EXEC_OMP_DO: name = "!$OMP DO"; break;
12681 134 : case EXEC_OMP_DO_SIMD: name = "!$OMP DO SIMD"; is_simd = true; break;
12682 64 : case EXEC_OMP_LOOP: name = "!$OMP LOOP"; break;
12683 1219 : case EXEC_OMP_PARALLEL_DO: name = "!$OMP PARALLEL DO"; break;
12684 304 : case EXEC_OMP_PARALLEL_DO_SIMD:
12685 304 : name = "!$OMP PARALLEL DO SIMD";
12686 304 : is_simd = true;
12687 304 : break;
12688 46 : case EXEC_OMP_PARALLEL_LOOP: name = "!$OMP PARALLEL LOOP"; break;
12689 7 : case EXEC_OMP_PARALLEL_MASKED_TASKLOOP:
12690 7 : name = "!$OMP PARALLEL MASKED TASKLOOP";
12691 7 : break;
12692 10 : case EXEC_OMP_PARALLEL_MASKED_TASKLOOP_SIMD:
12693 10 : name = "!$OMP PARALLEL MASKED TASKLOOP SIMD";
12694 10 : is_simd = true;
12695 10 : break;
12696 12 : case EXEC_OMP_PARALLEL_MASTER_TASKLOOP:
12697 12 : name = "!$OMP PARALLEL MASTER TASKLOOP";
12698 12 : break;
12699 18 : case EXEC_OMP_PARALLEL_MASTER_TASKLOOP_SIMD:
12700 18 : name = "!$OMP PARALLEL MASTER TASKLOOP SIMD";
12701 18 : is_simd = true;
12702 18 : break;
12703 8 : case EXEC_OMP_MASKED_TASKLOOP: name = "!$OMP MASKED TASKLOOP"; break;
12704 14 : case EXEC_OMP_MASKED_TASKLOOP_SIMD:
12705 14 : name = "!$OMP MASKED TASKLOOP SIMD";
12706 14 : is_simd = true;
12707 14 : break;
12708 14 : case EXEC_OMP_MASTER_TASKLOOP: name = "!$OMP MASTER TASKLOOP"; break;
12709 19 : case EXEC_OMP_MASTER_TASKLOOP_SIMD:
12710 19 : name = "!$OMP MASTER TASKLOOP SIMD";
12711 19 : is_simd = true;
12712 19 : break;
12713 783 : case EXEC_OMP_SIMD: name = "!$OMP SIMD"; is_simd = true; break;
12714 88 : case EXEC_OMP_TARGET_PARALLEL_DO: name = "!$OMP TARGET PARALLEL DO"; break;
12715 19 : case EXEC_OMP_TARGET_PARALLEL_DO_SIMD:
12716 19 : name = "!$OMP TARGET PARALLEL DO SIMD";
12717 19 : is_simd = true;
12718 19 : break;
12719 16 : case EXEC_OMP_TARGET_PARALLEL_LOOP:
12720 16 : name = "!$OMP TARGET PARALLEL LOOP";
12721 16 : break;
12722 33 : case EXEC_OMP_TARGET_SIMD:
12723 33 : name = "!$OMP TARGET SIMD";
12724 33 : is_simd = true;
12725 33 : break;
12726 20 : case EXEC_OMP_TARGET_TEAMS_DISTRIBUTE:
12727 20 : name = "!$OMP TARGET TEAMS DISTRIBUTE";
12728 20 : break;
12729 75 : case EXEC_OMP_TARGET_TEAMS_DISTRIBUTE_PARALLEL_DO:
12730 75 : name = "!$OMP TARGET TEAMS DISTRIBUTE PARALLEL DO";
12731 75 : break;
12732 37 : case EXEC_OMP_TARGET_TEAMS_DISTRIBUTE_PARALLEL_DO_SIMD:
12733 37 : name = "!$OMP TARGET TEAMS DISTRIBUTE PARALLEL DO SIMD";
12734 37 : is_simd = true;
12735 37 : break;
12736 20 : case EXEC_OMP_TARGET_TEAMS_DISTRIBUTE_SIMD:
12737 20 : name = "!$OMP TARGET TEAMS DISTRIBUTE SIMD";
12738 20 : is_simd = true;
12739 20 : break;
12740 19 : case EXEC_OMP_TARGET_TEAMS_LOOP: name = "!$OMP TARGET TEAMS LOOP"; break;
12741 69 : case EXEC_OMP_TASKLOOP: name = "!$OMP TASKLOOP"; break;
12742 38 : case EXEC_OMP_TASKLOOP_SIMD:
12743 38 : name = "!$OMP TASKLOOP SIMD";
12744 38 : is_simd = true;
12745 38 : break;
12746 20 : case EXEC_OMP_TEAMS_DISTRIBUTE: name = "!$OMP TEAMS DISTRIBUTE"; break;
12747 37 : case EXEC_OMP_TEAMS_DISTRIBUTE_PARALLEL_DO:
12748 37 : name = "!$OMP TEAMS DISTRIBUTE PARALLEL DO";
12749 37 : break;
12750 60 : case EXEC_OMP_TEAMS_DISTRIBUTE_PARALLEL_DO_SIMD:
12751 60 : name = "!$OMP TEAMS DISTRIBUTE PARALLEL DO SIMD";
12752 60 : is_simd = true;
12753 60 : break;
12754 42 : case EXEC_OMP_TEAMS_DISTRIBUTE_SIMD:
12755 42 : name = "!$OMP TEAMS DISTRIBUTE SIMD";
12756 42 : is_simd = true;
12757 42 : break;
12758 48 : case EXEC_OMP_TEAMS_LOOP: name = "!$OMP TEAMS LOOP"; break;
12759 195 : case EXEC_OMP_TILE: name = "!$OMP TILE"; break;
12760 415 : case EXEC_OMP_UNROLL: name = "!$OMP UNROLL"; break;
12761 0 : default: gcc_unreachable ();
12762 : }
12763 :
12764 5423 : if (code->ext.omp_clauses)
12765 5423 : resolve_omp_clauses (code, code->ext.omp_clauses, NULL);
12766 :
12767 5423 : if (code->op == EXEC_OMP_TILE && code->ext.omp_clauses->sizes_list == NULL)
12768 0 : gfc_error ("SIZES clause is required on !$OMP TILE construct at %L",
12769 : &code->loc);
12770 :
12771 5423 : do_code = code->block->next;
12772 5423 : if (code->ext.omp_clauses->orderedc)
12773 : count = code->ext.omp_clauses->orderedc;
12774 5279 : else if (code->ext.omp_clauses->sizes_list)
12775 195 : count = gfc_expr_list_len (code->ext.omp_clauses->sizes_list);
12776 : else
12777 : {
12778 5084 : count = code->ext.omp_clauses->collapse;
12779 5084 : if (count <= 0)
12780 : count = 1;
12781 : }
12782 :
12783 5423 : non_generated_count = count;
12784 : /* While the spec defines the loop nest depth independently of the COLLAPSE
12785 : clause, in practice the middle end only pays attention to the COLLAPSE
12786 : depth and treats any further inner loops as the final-loop-body. So
12787 : here we also check canonical loop nest form only for the number of
12788 : outer loops specified by the COLLAPSE clause too. */
12789 8063 : for (i = 1; i <= count; i++)
12790 : {
12791 8063 : gfc_symbol *start_var = NULL, *end_var = NULL;
12792 : /* Parse errors are not recoverable. */
12793 8063 : if (do_code->op == EXEC_DO_WHILE)
12794 : {
12795 6 : gfc_error ("%s cannot be a DO WHILE or DO without loop control "
12796 : "at %L", name, &do_code->loc);
12797 106 : goto fail;
12798 : }
12799 8057 : if (do_code->op == EXEC_DO_CONCURRENT)
12800 : {
12801 4 : gfc_error ("%s cannot be a DO CONCURRENT loop at %L", name,
12802 : &do_code->loc);
12803 4 : goto fail;
12804 : }
12805 8053 : if (do_code->op == EXEC_OMP_TILE || do_code->op == EXEC_OMP_UNROLL)
12806 : {
12807 466 : if (do_code->op == EXEC_OMP_UNROLL)
12808 : {
12809 308 : if (!do_code->ext.omp_clauses->partial)
12810 : {
12811 53 : gfc_error ("Generated loop of UNROLL construct at %L "
12812 : "without PARTIAL clause does not have "
12813 : "canonical form", &do_code->loc);
12814 53 : goto fail;
12815 : }
12816 255 : else if (i != count)
12817 : {
12818 5 : gfc_error ("UNROLL construct at %L with PARTIAL clause "
12819 : "generates just one loop with canonical form "
12820 : "but %d loops are needed",
12821 5 : &do_code->loc, count - i + 1);
12822 5 : goto fail;
12823 : }
12824 : }
12825 158 : else if (do_code->op == EXEC_OMP_TILE)
12826 : {
12827 158 : if (do_code->ext.omp_clauses->sizes_list == NULL)
12828 : /* This should have been diagnosed earlier already. */
12829 0 : return;
12830 158 : int l = gfc_expr_list_len (do_code->ext.omp_clauses->sizes_list);
12831 158 : if (count - i + 1 > l)
12832 : {
12833 14 : gfc_error ("TILE construct at %L generates %d loops "
12834 : "with canonical form but %d loops are needed",
12835 : &do_code->loc, l, count - i + 1);
12836 14 : goto fail;
12837 : }
12838 : }
12839 394 : if (do_code->ext.omp_clauses && do_code->ext.omp_clauses->erroneous)
12840 17 : goto fail;
12841 377 : if (imperfect && !perfect_nesting_errorp)
12842 : {
12843 4 : sorry_at (gfc_get_location (&do_code->loc),
12844 : "Imperfectly nested loop using generated loops");
12845 4 : errorp = true;
12846 : }
12847 377 : if (non_generated_count == count)
12848 329 : non_generated_count = i - 1;
12849 377 : --i;
12850 377 : do_code = do_code->block->next;
12851 377 : continue;
12852 377 : }
12853 7587 : gcc_assert (do_code->op == EXEC_DO);
12854 7587 : if (do_code->ext.iterator->var->ts.type != BT_INTEGER)
12855 : {
12856 3 : gfc_error ("%s iteration variable must be of type integer at %L",
12857 : name, &do_code->loc);
12858 3 : errorp = true;
12859 : }
12860 7587 : dovar = do_code->ext.iterator->var->symtree->n.sym;
12861 7587 : if (dovar->attr.threadprivate)
12862 : {
12863 0 : gfc_error ("%s iteration variable must not be THREADPRIVATE "
12864 : "at %L", name, &do_code->loc);
12865 0 : errorp = true;
12866 : }
12867 7587 : if (code->ext.omp_clauses)
12868 303480 : for (enum gfc_omp_list_type list = OMP_LIST_FIRST; list < OMP_LIST_NUM;
12869 295893 : list = gfc_omp_list_type (list + 1))
12870 97461 : if (!is_simd || code->ext.omp_clauses->collapse > 1
12871 295893 : ? (list != OMP_LIST_PRIVATE && list != OMP_LIST_LASTPRIVATE
12872 254787 : && list != OMP_LIST_ALLOCATE)
12873 41106 : : (list != OMP_LIST_PRIVATE && list != OMP_LIST_LASTPRIVATE
12874 41106 : && list != OMP_LIST_ALLOCATE && list != OMP_LIST_LINEAR))
12875 276462 : for (n = code->ext.omp_clauses->lists[list]; n; n = n->next)
12876 4384 : if (dovar == n->sym)
12877 : {
12878 5 : if (!is_simd || code->ext.omp_clauses->collapse > 1)
12879 4 : gfc_error ("%s iteration variable present on clause "
12880 : "other than PRIVATE, LASTPRIVATE or "
12881 : "ALLOCATE at %L", name, &do_code->loc);
12882 : else
12883 1 : gfc_error ("%s iteration variable present on clause "
12884 : "other than PRIVATE, LASTPRIVATE, ALLOCATE or "
12885 : "LINEAR at %L", name, &do_code->loc);
12886 : errorp = true;
12887 : }
12888 7587 : if (is_outer_iteration_variable (code, i, dovar))
12889 : {
12890 2 : gfc_error ("%s iteration variable used in more than one loop at %L",
12891 : name, &do_code->loc);
12892 2 : errorp = true;
12893 : }
12894 7585 : else if (is_intervening_var (code, i, dovar))
12895 : {
12896 2 : gfc_error ("%s iteration variable at %L is bound in "
12897 : "intervening code",
12898 : name, &do_code->loc);
12899 2 : errorp = true;
12900 : }
12901 7583 : else if (!bound_expr_is_canonical (code, i,
12902 7583 : do_code->ext.iterator->start,
12903 : &start_var))
12904 : {
12905 4 : gfc_error ("%s loop start expression not in canonical form at %L",
12906 : name, &do_code->loc);
12907 4 : errorp = true;
12908 : }
12909 7579 : else if (expr_uses_intervening_var (code, i,
12910 7579 : do_code->ext.iterator->start))
12911 : {
12912 1 : gfc_error ("%s loop start expression at %L uses variable bound in "
12913 : "intervening code",
12914 : name, &do_code->loc);
12915 1 : errorp = true;
12916 : }
12917 7578 : else if (!bound_expr_is_canonical (code, i,
12918 7578 : do_code->ext.iterator->end,
12919 : &end_var))
12920 : {
12921 2 : gfc_error ("%s loop end expression not in canonical form at %L",
12922 : name, &do_code->loc);
12923 2 : errorp = true;
12924 : }
12925 7576 : else if (expr_uses_intervening_var (code, i,
12926 7576 : do_code->ext.iterator->end))
12927 : {
12928 1 : gfc_error ("%s loop end expression at %L uses variable bound in "
12929 : "intervening code",
12930 : name, &do_code->loc);
12931 1 : errorp = true;
12932 : }
12933 7575 : else if (start_var && end_var && start_var != end_var)
12934 : {
12935 1 : gfc_error ("%s loop bounds reference different "
12936 : "iteration variables at %L", name, &do_code->loc);
12937 1 : errorp = true;
12938 : }
12939 7574 : else if (!expr_is_invariant (code, i, do_code->ext.iterator->step))
12940 : {
12941 3 : gfc_error ("%s loop increment not in canonical form at %L",
12942 : name, &do_code->loc);
12943 3 : errorp = true;
12944 : }
12945 7571 : else if (expr_uses_intervening_var (code, i,
12946 7571 : do_code->ext.iterator->step))
12947 : {
12948 1 : gfc_error ("%s loop increment expression at %L uses variable "
12949 : "bound in intervening code",
12950 : name, &do_code->loc);
12951 1 : errorp = true;
12952 : }
12953 7587 : if (start_var || end_var)
12954 : {
12955 528 : code->ext.omp_clauses->non_rectangular = 1;
12956 528 : if (i > non_generated_count)
12957 : {
12958 3 : sorry_at (gfc_get_location (&do_code->loc),
12959 : "Non-rectangular loops from generated loops "
12960 : "unsupported");
12961 3 : errorp = true;
12962 : }
12963 : }
12964 :
12965 : /* Only parse loop body into nested loop and intervening code if
12966 : there are supposed to be more loops in the nest to collapse. */
12967 7587 : if (i == count)
12968 : break;
12969 :
12970 2270 : next = find_nested_loop_in_chain (do_code->block->next);
12971 :
12972 2270 : if (!next)
12973 : {
12974 : /* Parse error, can't recover from this. */
12975 7 : gfc_error ("not enough DO loops for collapsed %s (level %d) at %L",
12976 : name, i, &code->loc);
12977 7 : goto fail;
12978 : }
12979 2263 : else if (next != do_code->block->next
12980 2103 : || (next->next && next->next->op != EXEC_CONTINUE))
12981 : /* Imperfectly nested loop found. */
12982 : {
12983 : /* Only diagnose violation of imperfect nesting constraints once. */
12984 177 : if (!perfect_nesting_errorp)
12985 : {
12986 176 : if (code->ext.omp_clauses->orderedc)
12987 : {
12988 3 : gfc_error ("%s inner loops must be perfectly nested with "
12989 : "ORDERED clause at %L",
12990 : name, &code->loc);
12991 3 : perfect_nesting_errorp = true;
12992 : }
12993 173 : else if (code->ext.omp_clauses->lists[OMP_LIST_REDUCTION_INSCAN])
12994 : {
12995 2 : gfc_error ("%s inner loops must be perfectly nested with "
12996 : "REDUCTION INSCAN clause at %L",
12997 : name, &code->loc);
12998 2 : perfect_nesting_errorp = true;
12999 : }
13000 171 : else if (code->op == EXEC_OMP_TILE)
13001 : {
13002 8 : gfc_error ("%s inner loops must be perfectly nested at %L",
13003 : name, &code->loc);
13004 8 : perfect_nesting_errorp = true;
13005 : }
13006 13 : if (perfect_nesting_errorp)
13007 : errorp = true;
13008 : }
13009 177 : if (diagnose_intervening_code_errors (do_code->block->next,
13010 : name, next))
13011 5 : errorp = true;
13012 : imperfect = true;
13013 : }
13014 2263 : do_code = next;
13015 : }
13016 :
13017 : /* Give up now if we found any constraint violations. */
13018 5317 : if (errorp)
13019 : {
13020 48 : fail:
13021 154 : if (code->ext.omp_clauses)
13022 154 : code->ext.omp_clauses->erroneous = 1;
13023 154 : return;
13024 : }
13025 :
13026 5269 : if (non_generated_count)
13027 4999 : restructure_intervening_code (&code->block->next, code,
13028 : non_generated_count);
13029 : }
13030 :
13031 : /* Resolve the context selector. In particular, SKIP_P is set to true,
13032 : the context can never be matched. */
13033 :
13034 : static void
13035 764 : gfc_resolve_omp_context_selector (gfc_omp_set_selector *oss,
13036 : bool is_metadirective, bool *skip_p)
13037 : {
13038 764 : if (skip_p)
13039 310 : *skip_p = false;
13040 1453 : for (gfc_omp_set_selector *set_selector = oss; set_selector;
13041 689 : set_selector = set_selector->next)
13042 1485 : for (gfc_omp_selector *os = set_selector->trait_selectors; os; os = os->next)
13043 : {
13044 814 : if (os->score)
13045 : {
13046 52 : if (!gfc_resolve_expr (os->score)
13047 52 : || os->score->ts.type != BT_INTEGER
13048 104 : || os->score->rank != 0)
13049 : {
13050 0 : gfc_error ("%<score%> argument must be constant integer "
13051 0 : "expression at %L", &os->score->where);
13052 0 : gfc_free_expr (os->score);
13053 0 : os->score = nullptr;
13054 : }
13055 52 : else if (os->score->expr_type == EXPR_CONSTANT
13056 52 : && mpz_sgn (os->score->value.integer) < 0)
13057 : {
13058 1 : gfc_error ("%<score%> argument must be non-negative at %L",
13059 : &os->score->where);
13060 1 : gfc_free_expr (os->score);
13061 1 : os->score = nullptr;
13062 : }
13063 : }
13064 :
13065 814 : if (os->code == OMP_TRAIT_INVALID)
13066 : break;
13067 796 : enum omp_tp_type property_kind = omp_ts_map[os->code].tp_type;
13068 796 : gfc_omp_trait_property *otp = os->properties;
13069 :
13070 796 : if (!otp)
13071 409 : continue;
13072 387 : switch (property_kind)
13073 : {
13074 139 : case OMP_TRAIT_PROPERTY_DEV_NUM_EXPR:
13075 139 : case OMP_TRAIT_PROPERTY_BOOL_EXPR:
13076 139 : if (!gfc_resolve_expr (otp->expr)
13077 138 : || (property_kind == OMP_TRAIT_PROPERTY_BOOL_EXPR
13078 124 : && otp->expr->ts.type != BT_LOGICAL)
13079 137 : || (property_kind == OMP_TRAIT_PROPERTY_DEV_NUM_EXPR
13080 14 : && otp->expr->ts.type != BT_INTEGER)
13081 137 : || otp->expr->rank != 0
13082 276 : || (!is_metadirective && otp->expr->expr_type != EXPR_CONSTANT))
13083 : {
13084 3 : if (is_metadirective)
13085 : {
13086 0 : if (property_kind == OMP_TRAIT_PROPERTY_BOOL_EXPR)
13087 0 : gfc_error ("property must be a "
13088 : "logical expression at %L",
13089 0 : &otp->expr->where);
13090 : else
13091 0 : gfc_error ("property must be an "
13092 : "integer expression at %L",
13093 0 : &otp->expr->where);
13094 : }
13095 : else
13096 : {
13097 3 : if (property_kind == OMP_TRAIT_PROPERTY_BOOL_EXPR)
13098 2 : gfc_error ("property must be a constant "
13099 : "logical expression at %L",
13100 2 : &otp->expr->where);
13101 : else
13102 1 : gfc_error ("property must be a constant "
13103 : "integer expression at %L",
13104 1 : &otp->expr->where);
13105 : }
13106 : /* Prevent later ICEs. */
13107 3 : gfc_expr *e;
13108 3 : if (property_kind == OMP_TRAIT_PROPERTY_BOOL_EXPR)
13109 2 : e = gfc_get_logical_expr (gfc_default_logical_kind,
13110 2 : &otp->expr->where, true);
13111 : else
13112 1 : e = gfc_get_int_expr (gfc_default_integer_kind,
13113 1 : &otp->expr->where, 0);
13114 3 : gfc_free_expr (otp->expr);
13115 3 : otp->expr = e;
13116 3 : continue;
13117 3 : }
13118 : /* Device number must be conforming, which includes
13119 : omp_initial_device (-1), omp_invalid_device (-4),
13120 : and omp_default_device (-5). */
13121 136 : if (property_kind == OMP_TRAIT_PROPERTY_DEV_NUM_EXPR
13122 14 : && otp->expr->expr_type == EXPR_CONSTANT
13123 5 : && mpz_sgn (otp->expr->value.integer) < 0
13124 3 : && mpz_cmp_si (otp->expr->value.integer, -1) != 0
13125 2 : && mpz_cmp_si (otp->expr->value.integer, -4) != 0
13126 1 : && mpz_cmp_si (otp->expr->value.integer, -5) != 0)
13127 1 : gfc_error ("property must be a conforming device number at %L",
13128 : &otp->expr->where);
13129 : break;
13130 : default:
13131 : break;
13132 : }
13133 : /* This only handles one specific case: User condition.
13134 : FIXME: Handle more cases by calling omp_context_selector_matches;
13135 : unfortunately, we cannot generate the tree here as, e.g., PARM_DECL
13136 : backend decl are not available at this stage - but might be used in,
13137 : e.g. user conditions. See PR122361. */
13138 384 : if (skip_p && otp
13139 138 : && os->code == OMP_TRAIT_USER_CONDITION
13140 81 : && otp->expr->expr_type == EXPR_CONSTANT
13141 14 : && otp->expr->value.logical == false)
13142 12 : *skip_p = true;
13143 : }
13144 764 : }
13145 :
13146 :
13147 : static void
13148 138 : resolve_omp_metadirective (gfc_code *code, gfc_namespace *ns)
13149 : {
13150 138 : gfc_omp_variant *variant = code->ext.omp_variants;
13151 138 : gfc_omp_variant *prev_variant = variant;
13152 :
13153 448 : while (variant)
13154 : {
13155 310 : bool skip;
13156 310 : gfc_resolve_omp_context_selector (variant->selectors, true, &skip);
13157 310 : gfc_code *variant_code = variant->code;
13158 310 : gfc_resolve_code (variant_code, ns);
13159 310 : if (skip)
13160 : {
13161 : /* The following should only be true if an error occurred
13162 : as the 'otherwise' clause should always match. */
13163 12 : if (variant == code->ext.omp_variants && !variant->next)
13164 : break;
13165 12 : gfc_omp_variant *tmp = variant;
13166 12 : if (variant == code->ext.omp_variants)
13167 11 : variant = prev_variant = code->ext.omp_variants = variant->next;
13168 : else
13169 1 : variant = prev_variant->next = variant->next;
13170 12 : gfc_free_omp_set_selector_list (tmp->selectors);
13171 12 : free (tmp);
13172 : }
13173 : else
13174 : {
13175 298 : prev_variant = variant;
13176 298 : variant = variant->next;
13177 : }
13178 : }
13179 : /* Replace metadirective by its body if only 'nothing' remains. */
13180 138 : if (!code->ext.omp_variants->next && code->ext.omp_variants->stmt == ST_NONE)
13181 : {
13182 11 : gfc_code *next = code->next;
13183 11 : gfc_code *inner = code->ext.omp_variants->code;
13184 11 : gfc_free_omp_set_selector_list (code->ext.omp_variants->selectors);
13185 11 : free (code->ext.omp_variants);
13186 11 : *code = *inner;
13187 11 : free (inner);
13188 11 : while (code->next)
13189 : code = code->next;
13190 11 : code->next = next;
13191 : }
13192 138 : }
13193 :
13194 :
13195 : static gfc_statement
13196 63 : omp_code_to_statement (gfc_code *code)
13197 : {
13198 63 : switch (code->op)
13199 : {
13200 : case EXEC_OMP_PARALLEL:
13201 : return ST_OMP_PARALLEL;
13202 0 : case EXEC_OMP_PARALLEL_MASKED:
13203 0 : return ST_OMP_PARALLEL_MASKED;
13204 0 : case EXEC_OMP_PARALLEL_MASKED_TASKLOOP:
13205 0 : return ST_OMP_PARALLEL_MASKED_TASKLOOP;
13206 0 : case EXEC_OMP_PARALLEL_MASKED_TASKLOOP_SIMD:
13207 0 : return ST_OMP_PARALLEL_MASKED_TASKLOOP_SIMD;
13208 0 : case EXEC_OMP_PARALLEL_MASTER:
13209 0 : return ST_OMP_PARALLEL_MASTER;
13210 0 : case EXEC_OMP_PARALLEL_MASTER_TASKLOOP:
13211 0 : return ST_OMP_PARALLEL_MASTER_TASKLOOP;
13212 0 : case EXEC_OMP_PARALLEL_MASTER_TASKLOOP_SIMD:
13213 0 : return ST_OMP_PARALLEL_MASTER_TASKLOOP_SIMD;
13214 1 : case EXEC_OMP_PARALLEL_SECTIONS:
13215 1 : return ST_OMP_PARALLEL_SECTIONS;
13216 1 : case EXEC_OMP_SECTIONS:
13217 1 : return ST_OMP_SECTIONS;
13218 1 : case EXEC_OMP_ORDERED:
13219 1 : return ST_OMP_ORDERED;
13220 1 : case EXEC_OMP_CRITICAL:
13221 1 : return ST_OMP_CRITICAL;
13222 0 : case EXEC_OMP_MASKED:
13223 0 : return ST_OMP_MASKED;
13224 0 : case EXEC_OMP_MASKED_TASKLOOP:
13225 0 : return ST_OMP_MASKED_TASKLOOP;
13226 0 : case EXEC_OMP_MASKED_TASKLOOP_SIMD:
13227 0 : return ST_OMP_MASKED_TASKLOOP_SIMD;
13228 1 : case EXEC_OMP_MASTER:
13229 1 : return ST_OMP_MASTER;
13230 0 : case EXEC_OMP_MASTER_TASKLOOP:
13231 0 : return ST_OMP_MASTER_TASKLOOP;
13232 0 : case EXEC_OMP_MASTER_TASKLOOP_SIMD:
13233 0 : return ST_OMP_MASTER_TASKLOOP_SIMD;
13234 1 : case EXEC_OMP_SINGLE:
13235 1 : return ST_OMP_SINGLE;
13236 1 : case EXEC_OMP_TASK:
13237 1 : return ST_OMP_TASK;
13238 1 : case EXEC_OMP_WORKSHARE:
13239 1 : return ST_OMP_WORKSHARE;
13240 1 : case EXEC_OMP_PARALLEL_WORKSHARE:
13241 1 : return ST_OMP_PARALLEL_WORKSHARE;
13242 3 : case EXEC_OMP_DO:
13243 3 : return ST_OMP_DO;
13244 0 : case EXEC_OMP_LOOP:
13245 0 : return ST_OMP_LOOP;
13246 0 : case EXEC_OMP_ALLOCATE:
13247 0 : return ST_OMP_ALLOCATE_EXEC;
13248 0 : case EXEC_OMP_ALLOCATORS:
13249 0 : return ST_OMP_ALLOCATORS;
13250 0 : case EXEC_OMP_ASSUME:
13251 0 : return ST_OMP_ASSUME;
13252 1 : case EXEC_OMP_ATOMIC:
13253 1 : return ST_OMP_ATOMIC;
13254 1 : case EXEC_OMP_BARRIER:
13255 1 : return ST_OMP_BARRIER;
13256 1 : case EXEC_OMP_CANCEL:
13257 1 : return ST_OMP_CANCEL;
13258 1 : case EXEC_OMP_CANCELLATION_POINT:
13259 1 : return ST_OMP_CANCELLATION_POINT;
13260 0 : case EXEC_OMP_ERROR:
13261 0 : return ST_OMP_ERROR;
13262 1 : case EXEC_OMP_FLUSH:
13263 1 : return ST_OMP_FLUSH;
13264 0 : case EXEC_OMP_INTEROP:
13265 0 : return ST_OMP_INTEROP;
13266 1 : case EXEC_OMP_DISTRIBUTE:
13267 1 : return ST_OMP_DISTRIBUTE;
13268 1 : case EXEC_OMP_DISTRIBUTE_PARALLEL_DO:
13269 1 : return ST_OMP_DISTRIBUTE_PARALLEL_DO;
13270 1 : case EXEC_OMP_DISTRIBUTE_PARALLEL_DO_SIMD:
13271 1 : return ST_OMP_DISTRIBUTE_PARALLEL_DO_SIMD;
13272 1 : case EXEC_OMP_DISTRIBUTE_SIMD:
13273 1 : return ST_OMP_DISTRIBUTE_SIMD;
13274 1 : case EXEC_OMP_DO_SIMD:
13275 1 : return ST_OMP_DO_SIMD;
13276 0 : case EXEC_OMP_SCAN:
13277 0 : return ST_OMP_SCAN;
13278 0 : case EXEC_OMP_SCOPE:
13279 0 : return ST_OMP_SCOPE;
13280 1 : case EXEC_OMP_SIMD:
13281 1 : return ST_OMP_SIMD;
13282 1 : case EXEC_OMP_TARGET:
13283 1 : return ST_OMP_TARGET;
13284 1 : case EXEC_OMP_TARGET_DATA:
13285 1 : return ST_OMP_TARGET_DATA;
13286 1 : case EXEC_OMP_TARGET_ENTER_DATA:
13287 1 : return ST_OMP_TARGET_ENTER_DATA;
13288 1 : case EXEC_OMP_TARGET_EXIT_DATA:
13289 1 : return ST_OMP_TARGET_EXIT_DATA;
13290 1 : case EXEC_OMP_TARGET_PARALLEL:
13291 1 : return ST_OMP_TARGET_PARALLEL;
13292 1 : case EXEC_OMP_TARGET_PARALLEL_DO:
13293 1 : return ST_OMP_TARGET_PARALLEL_DO;
13294 1 : case EXEC_OMP_TARGET_PARALLEL_DO_SIMD:
13295 1 : return ST_OMP_TARGET_PARALLEL_DO_SIMD;
13296 0 : case EXEC_OMP_TARGET_PARALLEL_LOOP:
13297 0 : return ST_OMP_TARGET_PARALLEL_LOOP;
13298 1 : case EXEC_OMP_TARGET_SIMD:
13299 1 : return ST_OMP_TARGET_SIMD;
13300 1 : case EXEC_OMP_TARGET_TEAMS:
13301 1 : return ST_OMP_TARGET_TEAMS;
13302 1 : case EXEC_OMP_TARGET_TEAMS_DISTRIBUTE:
13303 1 : return ST_OMP_TARGET_TEAMS_DISTRIBUTE;
13304 1 : case EXEC_OMP_TARGET_TEAMS_DISTRIBUTE_PARALLEL_DO:
13305 1 : return ST_OMP_TARGET_TEAMS_DISTRIBUTE_PARALLEL_DO;
13306 1 : case EXEC_OMP_TARGET_TEAMS_DISTRIBUTE_PARALLEL_DO_SIMD:
13307 1 : return ST_OMP_TARGET_TEAMS_DISTRIBUTE_PARALLEL_DO_SIMD;
13308 1 : case EXEC_OMP_TARGET_TEAMS_DISTRIBUTE_SIMD:
13309 1 : return ST_OMP_TARGET_TEAMS_DISTRIBUTE_SIMD;
13310 0 : case EXEC_OMP_TARGET_TEAMS_LOOP:
13311 0 : return ST_OMP_TARGET_TEAMS_LOOP;
13312 1 : case EXEC_OMP_TARGET_UPDATE:
13313 1 : return ST_OMP_TARGET_UPDATE;
13314 1 : case EXEC_OMP_TASKGROUP:
13315 1 : return ST_OMP_TASKGROUP;
13316 1 : case EXEC_OMP_TASKLOOP:
13317 1 : return ST_OMP_TASKLOOP;
13318 1 : case EXEC_OMP_TASKLOOP_SIMD:
13319 1 : return ST_OMP_TASKLOOP_SIMD;
13320 1 : case EXEC_OMP_TASKWAIT:
13321 1 : return ST_OMP_TASKWAIT;
13322 1 : case EXEC_OMP_TASKYIELD:
13323 1 : return ST_OMP_TASKYIELD;
13324 1 : case EXEC_OMP_TEAMS:
13325 1 : return ST_OMP_TEAMS;
13326 1 : case EXEC_OMP_TEAMS_DISTRIBUTE:
13327 1 : return ST_OMP_TEAMS_DISTRIBUTE;
13328 1 : case EXEC_OMP_TEAMS_DISTRIBUTE_PARALLEL_DO:
13329 1 : return ST_OMP_TEAMS_DISTRIBUTE_PARALLEL_DO;
13330 1 : case EXEC_OMP_TEAMS_DISTRIBUTE_PARALLEL_DO_SIMD:
13331 1 : return ST_OMP_TEAMS_DISTRIBUTE_PARALLEL_DO_SIMD;
13332 1 : case EXEC_OMP_TEAMS_DISTRIBUTE_SIMD:
13333 1 : return ST_OMP_TEAMS_DISTRIBUTE_SIMD;
13334 0 : case EXEC_OMP_TEAMS_LOOP:
13335 0 : return ST_OMP_TEAMS_LOOP;
13336 6 : case EXEC_OMP_PARALLEL_DO:
13337 6 : return ST_OMP_PARALLEL_DO;
13338 1 : case EXEC_OMP_PARALLEL_DO_SIMD:
13339 1 : return ST_OMP_PARALLEL_DO_SIMD;
13340 0 : case EXEC_OMP_PARALLEL_LOOP:
13341 0 : return ST_OMP_PARALLEL_LOOP;
13342 1 : case EXEC_OMP_DEPOBJ:
13343 1 : return ST_OMP_DEPOBJ;
13344 0 : case EXEC_OMP_TILE:
13345 0 : return ST_OMP_TILE;
13346 0 : case EXEC_OMP_UNROLL:
13347 0 : return ST_OMP_UNROLL;
13348 0 : case EXEC_OMP_DISPATCH:
13349 0 : return ST_OMP_DISPATCH;
13350 0 : default:
13351 0 : gcc_unreachable ();
13352 : }
13353 : }
13354 :
13355 : static gfc_statement
13356 63 : oacc_code_to_statement (gfc_code *code)
13357 : {
13358 63 : switch (code->op)
13359 : {
13360 : case EXEC_OACC_PARALLEL:
13361 : return ST_OACC_PARALLEL;
13362 : case EXEC_OACC_KERNELS:
13363 : return ST_OACC_KERNELS;
13364 : case EXEC_OACC_SERIAL:
13365 : return ST_OACC_SERIAL;
13366 : case EXEC_OACC_DATA:
13367 : return ST_OACC_DATA;
13368 : case EXEC_OACC_HOST_DATA:
13369 : return ST_OACC_HOST_DATA;
13370 : case EXEC_OACC_PARALLEL_LOOP:
13371 : return ST_OACC_PARALLEL_LOOP;
13372 : case EXEC_OACC_KERNELS_LOOP:
13373 : return ST_OACC_KERNELS_LOOP;
13374 : case EXEC_OACC_SERIAL_LOOP:
13375 : return ST_OACC_SERIAL_LOOP;
13376 : case EXEC_OACC_LOOP:
13377 : return ST_OACC_LOOP;
13378 : case EXEC_OACC_ATOMIC:
13379 : return ST_OACC_ATOMIC;
13380 : case EXEC_OACC_ROUTINE:
13381 : return ST_OACC_ROUTINE;
13382 : case EXEC_OACC_UPDATE:
13383 : return ST_OACC_UPDATE;
13384 : case EXEC_OACC_WAIT:
13385 : return ST_OACC_WAIT;
13386 : case EXEC_OACC_CACHE:
13387 : return ST_OACC_CACHE;
13388 : case EXEC_OACC_ENTER_DATA:
13389 : return ST_OACC_ENTER_DATA;
13390 : case EXEC_OACC_EXIT_DATA:
13391 : return ST_OACC_EXIT_DATA;
13392 : case EXEC_OACC_DECLARE:
13393 : return ST_OACC_DECLARE;
13394 0 : default:
13395 0 : gcc_unreachable ();
13396 : }
13397 : }
13398 :
13399 : static void
13400 13168 : resolve_oacc_directive_inside_omp_region (gfc_code *code)
13401 : {
13402 13168 : if (omp_current_ctx != NULL && omp_current_ctx->is_openmp)
13403 : {
13404 11 : gfc_statement st = omp_code_to_statement (omp_current_ctx->code);
13405 11 : gfc_statement oacc_st = oacc_code_to_statement (code);
13406 11 : gfc_error ("The %s directive cannot be specified within "
13407 : "a %s region at %L", gfc_ascii_statement (oacc_st),
13408 : gfc_ascii_statement (st), &code->loc);
13409 : }
13410 13168 : }
13411 :
13412 : static void
13413 21169 : resolve_omp_directive_inside_oacc_region (gfc_code *code)
13414 : {
13415 21169 : if (omp_current_ctx != NULL && !omp_current_ctx->is_openmp)
13416 : {
13417 52 : gfc_statement st = oacc_code_to_statement (omp_current_ctx->code);
13418 52 : gfc_statement omp_st = omp_code_to_statement (code);
13419 52 : gfc_error ("The %s directive cannot be specified within "
13420 : "a %s region at %L", gfc_ascii_statement (omp_st),
13421 : gfc_ascii_statement (st), &code->loc);
13422 : }
13423 21169 : }
13424 :
13425 :
13426 : static void
13427 5272 : resolve_oacc_nested_loops (gfc_code *code, gfc_code* do_code, int collapse,
13428 : const char *clause)
13429 : {
13430 5272 : gfc_symbol *dovar;
13431 5272 : gfc_code *c;
13432 5272 : int i;
13433 :
13434 5792 : for (i = 1; i <= collapse; i++)
13435 : {
13436 5792 : if (do_code->op == EXEC_DO_WHILE)
13437 : {
13438 10 : gfc_error ("!$ACC LOOP cannot be a DO WHILE or DO without loop control "
13439 : "at %L", &do_code->loc);
13440 10 : break;
13441 : }
13442 5782 : if (do_code->op == EXEC_DO_CONCURRENT)
13443 : {
13444 3 : gfc_error ("!$ACC LOOP cannot be a DO CONCURRENT loop at %L",
13445 : &do_code->loc);
13446 3 : break;
13447 : }
13448 5779 : gcc_assert (do_code->op == EXEC_DO);
13449 5779 : if (do_code->ext.iterator->var->ts.type != BT_INTEGER)
13450 6 : gfc_error ("!$ACC LOOP iteration variable must be of type integer at %L",
13451 : &do_code->loc);
13452 5779 : dovar = do_code->ext.iterator->var->symtree->n.sym;
13453 5779 : if (i > 1)
13454 : {
13455 518 : gfc_code *do_code2 = code->block->next;
13456 518 : int j;
13457 :
13458 1218 : for (j = 1; j < i; j++)
13459 : {
13460 710 : gfc_symbol *ivar = do_code2->ext.iterator->var->symtree->n.sym;
13461 710 : if (dovar == ivar
13462 710 : || gfc_find_sym_in_expr (ivar, do_code->ext.iterator->start)
13463 701 : || gfc_find_sym_in_expr (ivar, do_code->ext.iterator->end)
13464 1410 : || gfc_find_sym_in_expr (ivar, do_code->ext.iterator->step))
13465 : {
13466 10 : gfc_error ("!$ACC LOOP %s loops don't form rectangular "
13467 : "iteration space at %L", clause, &do_code->loc);
13468 10 : break;
13469 : }
13470 700 : do_code2 = do_code2->block->next;
13471 : }
13472 : }
13473 5779 : if (i == collapse)
13474 : break;
13475 577 : for (c = do_code->next; c; c = c->next)
13476 48 : if (c->op != EXEC_NOP && c->op != EXEC_CONTINUE)
13477 : {
13478 0 : gfc_error ("%s !$ACC LOOP loops not perfectly nested at %L",
13479 : clause, &c->loc);
13480 0 : break;
13481 : }
13482 529 : if (c)
13483 : break;
13484 529 : do_code = do_code->block;
13485 529 : if (do_code->op != EXEC_DO && do_code->op != EXEC_DO_WHILE
13486 0 : && do_code->op != EXEC_DO_CONCURRENT)
13487 : {
13488 0 : gfc_error ("not enough DO loops for %s !$ACC LOOP at %L",
13489 : clause, &code->loc);
13490 0 : break;
13491 : }
13492 529 : do_code = do_code->next;
13493 529 : if (do_code == NULL
13494 522 : || (do_code->op != EXEC_DO && do_code->op != EXEC_DO_WHILE
13495 2 : && do_code->op != EXEC_DO_CONCURRENT))
13496 : {
13497 9 : gfc_error ("not enough DO loops for %s !$ACC LOOP at %L",
13498 : clause, &code->loc);
13499 9 : break;
13500 : }
13501 : }
13502 5272 : }
13503 :
13504 :
13505 : static void
13506 10119 : resolve_oacc_loop_blocks (gfc_code *code)
13507 : {
13508 10119 : if (!oacc_is_loop (code))
13509 : return;
13510 :
13511 5272 : if (code->ext.omp_clauses->tile_list && code->ext.omp_clauses->gang
13512 24 : && code->ext.omp_clauses->worker && code->ext.omp_clauses->vector)
13513 0 : gfc_error ("Tiled loop cannot be parallelized across gangs, workers and "
13514 : "vectors at the same time at %L", &code->loc);
13515 :
13516 5272 : if (code->ext.omp_clauses->tile_list)
13517 : {
13518 : gfc_expr_list *el;
13519 501 : for (el = code->ext.omp_clauses->tile_list; el; el = el->next)
13520 : {
13521 304 : if (el->expr == NULL)
13522 : {
13523 : /* NULL expressions are used to represent '*' arguments.
13524 : Convert those to a 0 expressions. */
13525 113 : el->expr = gfc_get_constant_expr (BT_INTEGER,
13526 : gfc_default_integer_kind,
13527 : &code->loc);
13528 113 : mpz_set_si (el->expr->value.integer, 0);
13529 : }
13530 : else
13531 : {
13532 191 : resolve_positive_int_expr (el->expr, "TILE");
13533 191 : if (el->expr->expr_type != EXPR_CONSTANT)
13534 14 : gfc_error ("TILE requires constant expression at %L",
13535 : &code->loc);
13536 : }
13537 : }
13538 : }
13539 : }
13540 :
13541 :
13542 : void
13543 10119 : gfc_resolve_oacc_blocks (gfc_code *code, gfc_namespace *ns)
13544 : {
13545 10119 : fortran_omp_context ctx;
13546 10119 : gfc_omp_clauses *omp_clauses = code->ext.omp_clauses;
13547 10119 : gfc_omp_namelist *n;
13548 :
13549 10119 : resolve_oacc_loop_blocks (code);
13550 :
13551 10119 : ctx.code = code;
13552 10119 : ctx.sharing_clauses = new hash_set<gfc_symbol *>;
13553 10119 : ctx.private_iterators = new hash_set<gfc_symbol *>;
13554 10119 : ctx.previous = omp_current_ctx;
13555 10119 : ctx.is_openmp = false;
13556 10119 : omp_current_ctx = &ctx;
13557 :
13558 404760 : for (enum gfc_omp_list_type list = OMP_LIST_FIRST; list < OMP_LIST_NUM;
13559 394641 : list = gfc_omp_list_type (list + 1))
13560 394641 : switch (list)
13561 : {
13562 10119 : case OMP_LIST_PRIVATE:
13563 10710 : for (n = omp_clauses->lists[list]; n; n = n->next)
13564 591 : ctx.sharing_clauses->add (n->sym);
13565 : break;
13566 : default:
13567 : break;
13568 : }
13569 :
13570 10119 : gfc_resolve_blocks (code->block, ns);
13571 :
13572 10119 : omp_current_ctx = ctx.previous;
13573 20238 : delete ctx.sharing_clauses;
13574 20238 : delete ctx.private_iterators;
13575 10119 : }
13576 :
13577 :
13578 : static void
13579 5272 : resolve_oacc_loop (gfc_code *code)
13580 : {
13581 5272 : gfc_code *do_code;
13582 5272 : int collapse;
13583 :
13584 5272 : if (code->ext.omp_clauses)
13585 5272 : resolve_omp_clauses (code, code->ext.omp_clauses, NULL, true);
13586 :
13587 5272 : do_code = code->block->next;
13588 5272 : collapse = code->ext.omp_clauses->collapse;
13589 :
13590 : /* Both collapsed and tiled loops are lowered the same way, but are not
13591 : compatible. In gfc_trans_omp_do, the tile is prioritized. */
13592 5272 : if (code->ext.omp_clauses->tile_list)
13593 : {
13594 : int num = 0;
13595 : gfc_expr_list *el;
13596 501 : for (el = code->ext.omp_clauses->tile_list; el; el = el->next)
13597 304 : ++num;
13598 197 : resolve_oacc_nested_loops (code, code->block->next, num, "tiled");
13599 197 : return;
13600 : }
13601 :
13602 5075 : if (collapse <= 0)
13603 : collapse = 1;
13604 5075 : resolve_oacc_nested_loops (code, do_code, collapse, "collapsed");
13605 : }
13606 :
13607 : void
13608 336051 : gfc_resolve_oacc_declare (gfc_namespace *ns)
13609 : {
13610 336051 : enum gfc_omp_list_type list;
13611 336051 : gfc_omp_namelist *n;
13612 336051 : gfc_oacc_declare *oc;
13613 :
13614 336051 : if (ns->oacc_declare == NULL)
13615 : return;
13616 :
13617 290 : for (oc = ns->oacc_declare; oc; oc = oc->next)
13618 : {
13619 6480 : for (list = OMP_LIST_FIRST; list < OMP_LIST_NUM;
13620 6318 : list = gfc_omp_list_type (list + 1))
13621 6574 : for (n = oc->clauses->lists[list]; n; n = n->next)
13622 : {
13623 256 : n->sym->mark = 0;
13624 256 : if (n->sym->attr.flavor != FL_VARIABLE
13625 16 : && (n->sym->attr.flavor != FL_PROCEDURE
13626 8 : || n->sym->result != n->sym))
13627 : {
13628 14 : if (n->sym->attr.flavor != FL_PARAMETER)
13629 : {
13630 8 : gfc_error ("Object %qs is not a variable at %L",
13631 : n->sym->name, &oc->loc);
13632 8 : continue;
13633 : }
13634 : /* Note that OpenACC 3.4 permits name constants, but the
13635 : implementation is permitted to ignore the clause;
13636 : as semantically, device_resident kind of makes sense
13637 : (and the wording with it is a bit odd), the warning
13638 : is suppressed. */
13639 6 : if (list != OMP_LIST_DEVICE_RESIDENT)
13640 5 : gfc_warning (OPT_Wsurprising, "Object %qs at %L is ignored as"
13641 : " parameters need not be copied", n->sym->name,
13642 : &oc->loc);
13643 : }
13644 :
13645 248 : if (n->expr && n->expr->ref->type == REF_ARRAY)
13646 : {
13647 1 : gfc_error ("Array sections: %qs not allowed in"
13648 1 : " !$ACC DECLARE at %L", n->sym->name, &oc->loc);
13649 1 : continue;
13650 : }
13651 : }
13652 :
13653 252 : for (n = oc->clauses->lists[OMP_LIST_DEVICE_RESIDENT]; n; n = n->next)
13654 90 : check_array_not_assumed (n->sym, oc->loc, "DEVICE_RESIDENT");
13655 : }
13656 :
13657 290 : for (oc = ns->oacc_declare; oc; oc = oc->next)
13658 : {
13659 6480 : for (list = OMP_LIST_FIRST; list < OMP_LIST_NUM;
13660 6318 : list = gfc_omp_list_type (list + 1))
13661 6574 : for (n = oc->clauses->lists[list]; n; n = n->next)
13662 : {
13663 256 : if (n->sym->mark)
13664 : {
13665 9 : gfc_error ("Symbol %qs present on multiple clauses at %L",
13666 : n->sym->name, &oc->loc);
13667 9 : continue;
13668 : }
13669 : else
13670 247 : n->sym->mark = 1;
13671 : }
13672 : }
13673 :
13674 290 : for (oc = ns->oacc_declare; oc; oc = oc->next)
13675 : {
13676 6480 : for (list = OMP_LIST_FIRST; list < OMP_LIST_NUM;
13677 6318 : list = gfc_omp_list_type (list + 1))
13678 6574 : for (n = oc->clauses->lists[list]; n; n = n->next)
13679 256 : n->sym->mark = 0;
13680 : }
13681 : }
13682 :
13683 :
13684 : void
13685 336051 : gfc_resolve_oacc_routines (gfc_namespace *ns)
13686 : {
13687 336051 : for (gfc_oacc_routine_name *orn = ns->oacc_routine_names;
13688 336151 : orn;
13689 100 : orn = orn->next)
13690 : {
13691 100 : gfc_symbol *sym = orn->sym;
13692 100 : if (!sym->attr.external
13693 29 : && !sym->attr.function
13694 27 : && !sym->attr.subroutine)
13695 : {
13696 7 : gfc_error ("NAME %qs does not refer to a subroutine or function"
13697 : " in !$ACC ROUTINE ( NAME ) at %L", sym->name, &orn->loc);
13698 7 : continue;
13699 : }
13700 93 : if (!gfc_add_omp_declare_target (&sym->attr, sym->name, &orn->loc))
13701 : {
13702 20 : gfc_error ("NAME %qs invalid"
13703 : " in !$ACC ROUTINE ( NAME ) at %L", sym->name, &orn->loc);
13704 20 : continue;
13705 : }
13706 : }
13707 336051 : }
13708 :
13709 :
13710 : void
13711 13168 : gfc_resolve_oacc_directive (gfc_code *code, gfc_namespace *ns ATTRIBUTE_UNUSED)
13712 : {
13713 13168 : resolve_oacc_directive_inside_omp_region (code);
13714 :
13715 13168 : switch (code->op)
13716 : {
13717 7353 : case EXEC_OACC_PARALLEL:
13718 7353 : case EXEC_OACC_KERNELS:
13719 7353 : case EXEC_OACC_SERIAL:
13720 7353 : case EXEC_OACC_DATA:
13721 7353 : case EXEC_OACC_HOST_DATA:
13722 7353 : case EXEC_OACC_UPDATE:
13723 7353 : case EXEC_OACC_ENTER_DATA:
13724 7353 : case EXEC_OACC_EXIT_DATA:
13725 7353 : case EXEC_OACC_WAIT:
13726 7353 : case EXEC_OACC_CACHE:
13727 7353 : resolve_omp_clauses (code, code->ext.omp_clauses, NULL, true);
13728 7353 : break;
13729 5272 : case EXEC_OACC_PARALLEL_LOOP:
13730 5272 : case EXEC_OACC_KERNELS_LOOP:
13731 5272 : case EXEC_OACC_SERIAL_LOOP:
13732 5272 : case EXEC_OACC_LOOP:
13733 5272 : resolve_oacc_loop (code);
13734 5272 : break;
13735 543 : case EXEC_OACC_ATOMIC:
13736 543 : resolve_omp_atomic (code);
13737 543 : break;
13738 : default:
13739 : break;
13740 : }
13741 13168 : }
13742 :
13743 :
13744 : static void
13745 2164 : resolve_omp_target (gfc_code *code)
13746 : {
13747 : #define GFC_IS_TEAMS_CONSTRUCT(op) \
13748 : (op == EXEC_OMP_TEAMS \
13749 : || op == EXEC_OMP_TEAMS_DISTRIBUTE \
13750 : || op == EXEC_OMP_TEAMS_DISTRIBUTE_SIMD \
13751 : || op == EXEC_OMP_TEAMS_DISTRIBUTE_PARALLEL_DO \
13752 : || op == EXEC_OMP_TEAMS_DISTRIBUTE_PARALLEL_DO_SIMD \
13753 : || op == EXEC_OMP_TEAMS_LOOP)
13754 :
13755 2164 : if (!code->ext.omp_clauses->contains_teams_construct)
13756 : return;
13757 203 : gfc_code *c = code->block->next;
13758 203 : if (c->op == EXEC_BLOCK)
13759 30 : c = c->ext.block.ns->code;
13760 203 : if (code->ext.omp_clauses->target_first_st_is_teams_or_meta)
13761 : {
13762 192 : if (c->op == EXEC_OMP_METADIRECTIVE)
13763 : {
13764 15 : struct gfc_omp_variant *mc
13765 : = c->ext.omp_variants;
13766 : /* All mc->(next...->)code should be identical with regards
13767 : to the diagnostic below. */
13768 16 : do
13769 : {
13770 16 : if (mc->stmt != ST_NONE
13771 15 : && GFC_IS_TEAMS_CONSTRUCT (mc->code->op))
13772 : {
13773 14 : if (c->next == NULL && mc->code->next == NULL)
13774 : return;
13775 : c = mc->code;
13776 : break;
13777 : }
13778 2 : mc = mc->next;
13779 : }
13780 2 : while (mc);
13781 : }
13782 177 : else if (GFC_IS_TEAMS_CONSTRUCT (c->op) && c->next == NULL)
13783 : return;
13784 : }
13785 :
13786 31 : while (c && !GFC_IS_TEAMS_CONSTRUCT (c->op))
13787 8 : c = c->next;
13788 23 : if (c)
13789 19 : gfc_error ("!$OMP TARGET region at %L with a nested TEAMS at %L may not "
13790 : "contain any other statement, declaration or directive outside "
13791 : "of the single TEAMS construct", &c->loc, &code->loc);
13792 : else
13793 4 : gfc_error ("!$OMP TARGET region at %L with a nested TEAMS may not "
13794 : "contain any other statement, declaration or directive outside "
13795 : "of the single TEAMS construct", &code->loc);
13796 : #undef GFC_IS_TEAMS_CONSTRUCT
13797 : }
13798 :
13799 : static void
13800 154 : resolve_omp_dispatch (gfc_code *code)
13801 : {
13802 154 : gfc_code *next = code->block->next;
13803 154 : if (next == NULL)
13804 : return;
13805 :
13806 151 : gfc_exec_op op = next->op;
13807 151 : gcc_assert (op == EXEC_CALL || op == EXEC_ASSIGN);
13808 151 : if (op != EXEC_CALL
13809 74 : && (op != EXEC_ASSIGN || next->expr2->expr_type != EXPR_FUNCTION))
13810 3 : gfc_error (
13811 : "%<OMP DISPATCH%> directive at %L must be followed by a procedure "
13812 : "call with optional assignment",
13813 : &code->loc);
13814 :
13815 77 : if ((op == EXEC_CALL && next->resolved_sym != NULL
13816 76 : && next->resolved_sym->attr.proc_pointer)
13817 150 : || (op == EXEC_ASSIGN && gfc_expr_attr (next->expr2).proc_pointer))
13818 1 : gfc_error ("%<OMP DISPATCH%> directive at %L cannot be followed by a "
13819 : "procedure pointer",
13820 : &code->loc);
13821 : }
13822 :
13823 : /* Resolve OpenMP directive clauses and check various requirements
13824 : of each directive. */
13825 :
13826 : void
13827 21169 : gfc_resolve_omp_directive (gfc_code *code, gfc_namespace *ns)
13828 : {
13829 21169 : resolve_omp_directive_inside_oacc_region (code);
13830 :
13831 21169 : if (code->op != EXEC_OMP_ATOMIC)
13832 19015 : gfc_maybe_initialize_eh ();
13833 :
13834 21169 : switch (code->op)
13835 : {
13836 5423 : case EXEC_OMP_DISTRIBUTE:
13837 5423 : case EXEC_OMP_DISTRIBUTE_PARALLEL_DO:
13838 5423 : case EXEC_OMP_DISTRIBUTE_PARALLEL_DO_SIMD:
13839 5423 : case EXEC_OMP_DISTRIBUTE_SIMD:
13840 5423 : case EXEC_OMP_DO:
13841 5423 : case EXEC_OMP_DO_SIMD:
13842 5423 : case EXEC_OMP_LOOP:
13843 5423 : case EXEC_OMP_PARALLEL_DO:
13844 5423 : case EXEC_OMP_PARALLEL_DO_SIMD:
13845 5423 : case EXEC_OMP_PARALLEL_LOOP:
13846 5423 : case EXEC_OMP_PARALLEL_MASKED_TASKLOOP:
13847 5423 : case EXEC_OMP_PARALLEL_MASKED_TASKLOOP_SIMD:
13848 5423 : case EXEC_OMP_PARALLEL_MASTER_TASKLOOP:
13849 5423 : case EXEC_OMP_PARALLEL_MASTER_TASKLOOP_SIMD:
13850 5423 : case EXEC_OMP_MASKED_TASKLOOP:
13851 5423 : case EXEC_OMP_MASKED_TASKLOOP_SIMD:
13852 5423 : case EXEC_OMP_MASTER_TASKLOOP:
13853 5423 : case EXEC_OMP_MASTER_TASKLOOP_SIMD:
13854 5423 : case EXEC_OMP_SIMD:
13855 5423 : case EXEC_OMP_TARGET_PARALLEL_DO:
13856 5423 : case EXEC_OMP_TARGET_PARALLEL_DO_SIMD:
13857 5423 : case EXEC_OMP_TARGET_PARALLEL_LOOP:
13858 5423 : case EXEC_OMP_TARGET_SIMD:
13859 5423 : case EXEC_OMP_TARGET_TEAMS_DISTRIBUTE:
13860 5423 : case EXEC_OMP_TARGET_TEAMS_DISTRIBUTE_PARALLEL_DO:
13861 5423 : case EXEC_OMP_TARGET_TEAMS_DISTRIBUTE_PARALLEL_DO_SIMD:
13862 5423 : case EXEC_OMP_TARGET_TEAMS_DISTRIBUTE_SIMD:
13863 5423 : case EXEC_OMP_TARGET_TEAMS_LOOP:
13864 5423 : case EXEC_OMP_TASKLOOP:
13865 5423 : case EXEC_OMP_TASKLOOP_SIMD:
13866 5423 : case EXEC_OMP_TEAMS_DISTRIBUTE:
13867 5423 : case EXEC_OMP_TEAMS_DISTRIBUTE_PARALLEL_DO:
13868 5423 : case EXEC_OMP_TEAMS_DISTRIBUTE_PARALLEL_DO_SIMD:
13869 5423 : case EXEC_OMP_TEAMS_DISTRIBUTE_SIMD:
13870 5423 : case EXEC_OMP_TEAMS_LOOP:
13871 5423 : case EXEC_OMP_TILE:
13872 5423 : case EXEC_OMP_UNROLL:
13873 5423 : resolve_omp_do (code);
13874 5423 : break;
13875 2164 : case EXEC_OMP_TARGET:
13876 2164 : resolve_omp_target (code);
13877 10205 : gcc_fallthrough ();
13878 10205 : case EXEC_OMP_ALLOCATE:
13879 10205 : case EXEC_OMP_ALLOCATORS:
13880 10205 : case EXEC_OMP_ASSUME:
13881 10205 : case EXEC_OMP_CANCEL:
13882 10205 : case EXEC_OMP_ERROR:
13883 10205 : case EXEC_OMP_INTEROP:
13884 10205 : case EXEC_OMP_MASKED:
13885 10205 : case EXEC_OMP_ORDERED:
13886 10205 : case EXEC_OMP_PARALLEL_WORKSHARE:
13887 10205 : case EXEC_OMP_PARALLEL:
13888 10205 : case EXEC_OMP_PARALLEL_MASKED:
13889 10205 : case EXEC_OMP_PARALLEL_MASTER:
13890 10205 : case EXEC_OMP_PARALLEL_SECTIONS:
13891 10205 : case EXEC_OMP_SCOPE:
13892 10205 : case EXEC_OMP_SECTIONS:
13893 10205 : case EXEC_OMP_SINGLE:
13894 10205 : case EXEC_OMP_TARGET_DATA:
13895 10205 : case EXEC_OMP_TARGET_ENTER_DATA:
13896 10205 : case EXEC_OMP_TARGET_EXIT_DATA:
13897 10205 : case EXEC_OMP_TARGET_PARALLEL:
13898 10205 : case EXEC_OMP_TARGET_TEAMS:
13899 10205 : case EXEC_OMP_TASK:
13900 10205 : case EXEC_OMP_TASKWAIT:
13901 10205 : case EXEC_OMP_TEAMS:
13902 10205 : case EXEC_OMP_WORKSHARE:
13903 10205 : case EXEC_OMP_DEPOBJ:
13904 10205 : if (code->ext.omp_clauses)
13905 10072 : resolve_omp_clauses (code, code->ext.omp_clauses, NULL);
13906 : break;
13907 1718 : case EXEC_OMP_TARGET_UPDATE:
13908 1718 : if (code->ext.omp_clauses)
13909 1718 : resolve_omp_clauses (code, code->ext.omp_clauses, NULL);
13910 1718 : if (code->ext.omp_clauses == NULL
13911 1718 : || (code->ext.omp_clauses->lists[OMP_LIST_TO] == NULL
13912 994 : && code->ext.omp_clauses->lists[OMP_LIST_FROM] == NULL))
13913 0 : gfc_error ("OMP TARGET UPDATE at %L requires at least one TO or "
13914 : "FROM clause", &code->loc);
13915 : break;
13916 2154 : case EXEC_OMP_ATOMIC:
13917 2154 : resolve_omp_clauses (code, code->block->ext.omp_clauses, NULL);
13918 2154 : resolve_omp_atomic (code);
13919 2154 : break;
13920 159 : case EXEC_OMP_CRITICAL:
13921 159 : resolve_omp_clauses (code, code->ext.omp_clauses, NULL);
13922 159 : if (!code->ext.omp_clauses->critical_name
13923 112 : && code->ext.omp_clauses->hint
13924 3 : && code->ext.omp_clauses->hint->ts.type == BT_INTEGER
13925 3 : && code->ext.omp_clauses->hint->expr_type == EXPR_CONSTANT
13926 3 : && mpz_sgn (code->ext.omp_clauses->hint->value.integer) != 0)
13927 1 : gfc_error ("OMP CRITICAL at %L with HINT clause requires a NAME, "
13928 : "except when omp_sync_hint_none is used", &code->loc);
13929 : break;
13930 49 : case EXEC_OMP_SCAN:
13931 : /* Flag is only used to checking, hence, it is unset afterwards. */
13932 49 : if (!code->ext.omp_clauses->if_present)
13933 10 : gfc_error ("Unexpected !$OMP SCAN at %L outside loop construct with "
13934 : "%<inscan%> REDUCTION clause", &code->loc);
13935 49 : code->ext.omp_clauses->if_present = false;
13936 49 : resolve_omp_clauses (code, code->ext.omp_clauses, ns);
13937 49 : break;
13938 154 : case EXEC_OMP_DISPATCH:
13939 154 : if (code->ext.omp_clauses)
13940 154 : resolve_omp_clauses (code, code->ext.omp_clauses, ns);
13941 154 : resolve_omp_dispatch (code);
13942 154 : break;
13943 138 : case EXEC_OMP_METADIRECTIVE:
13944 138 : resolve_omp_metadirective (code, ns);
13945 138 : break;
13946 : default:
13947 : break;
13948 : }
13949 21169 : }
13950 :
13951 : /* Resolve !$omp declare {variant|simd} constructs in NS.
13952 : Note that !$omp declare target is resolved in resolve_symbol. */
13953 :
13954 : void
13955 347654 : gfc_resolve_omp_declare (gfc_namespace *ns)
13956 : {
13957 347654 : gfc_omp_declare_simd *ods;
13958 347890 : for (ods = ns->omp_declare_simd; ods; ods = ods->next)
13959 : {
13960 236 : if (ods->proc_name != NULL
13961 196 : && ods->proc_name != ns->proc_name)
13962 6 : gfc_error ("!$OMP DECLARE SIMD should refer to containing procedure "
13963 : "%qs at %L", ns->proc_name->name, &ods->where);
13964 236 : if (ods->clauses)
13965 218 : resolve_omp_clauses (NULL, ods->clauses, ns);
13966 : }
13967 :
13968 347654 : gfc_omp_declare_variant *odv;
13969 347654 : gfc_omp_namelist *range_begin = NULL;
13970 :
13971 348108 : for (odv = ns->omp_declare_variant; odv; odv = odv->next)
13972 454 : gfc_resolve_omp_context_selector (odv->set_selectors, false, nullptr);
13973 348108 : for (odv = ns->omp_declare_variant; odv; odv = odv->next)
13974 657 : for (gfc_omp_namelist *n = odv->adjust_args_list; n != NULL; n = n->next)
13975 : {
13976 203 : if ((n->expr == NULL
13977 6 : && (range_begin
13978 4 : || n->u.adj_args.range_start
13979 1 : || n->u.adj_args.omp_num_args_plus
13980 1 : || n->u.adj_args.omp_num_args_minus))
13981 198 : || n->u.adj_args.error_p)
13982 : {
13983 : }
13984 197 : else if (range_begin
13985 191 : || n->u.adj_args.range_start
13986 186 : || n->u.adj_args.omp_num_args_plus
13987 186 : || n->u.adj_args.omp_num_args_minus)
13988 : {
13989 11 : if (!n->expr
13990 11 : || !gfc_resolve_expr (n->expr)
13991 11 : || n->expr->expr_type != EXPR_CONSTANT
13992 10 : || n->expr->ts.type != BT_INTEGER
13993 10 : || n->expr->rank != 0
13994 10 : || mpz_sgn (n->expr->value.integer) < 0
13995 20 : || ((n->u.adj_args.omp_num_args_plus
13996 8 : || n->u.adj_args.omp_num_args_minus)
13997 5 : && mpz_sgn (n->expr->value.integer) == 0))
13998 : {
13999 2 : if (n->u.adj_args.omp_num_args_plus
14000 2 : || n->u.adj_args.omp_num_args_minus)
14001 0 : gfc_error ("Expected constant non-negative scalar integer "
14002 : "offset expression at %L", &n->where);
14003 : else
14004 2 : gfc_error ("For range-based %<adjust_args%>, a constant "
14005 : "positive scalar integer expression is required "
14006 : "at %L", &n->where);
14007 : }
14008 : }
14009 186 : else if (n->expr
14010 186 : && n->expr->expr_type == EXPR_CONSTANT
14011 21 : && n->expr->ts.type == BT_INTEGER
14012 20 : && mpz_sgn (n->expr->value.integer) > 0)
14013 : {
14014 : }
14015 166 : else if (!n->expr
14016 166 : || !gfc_resolve_expr (n->expr)
14017 331 : || n->expr->expr_type != EXPR_VARIABLE)
14018 2 : gfc_error ("Expected dummy parameter name or a positive integer "
14019 : "at %L", &n->where);
14020 164 : else if (n->expr->expr_type == EXPR_VARIABLE)
14021 164 : n->sym = n->expr->symtree->n.sym;
14022 :
14023 203 : range_begin = n->u.adj_args.range_start ? n : NULL;
14024 : }
14025 347654 : }
14026 :
14027 : struct omp_udr_callback_data
14028 : {
14029 : gfc_omp_udr *omp_udr;
14030 : bool is_initializer;
14031 : };
14032 :
14033 : static int
14034 3706 : omp_udr_callback (gfc_expr **e, int *walk_subtrees ATTRIBUTE_UNUSED,
14035 : void *data)
14036 : {
14037 3706 : struct omp_udr_callback_data *cd = (struct omp_udr_callback_data *) data;
14038 3706 : if ((*e)->expr_type == EXPR_VARIABLE)
14039 : {
14040 2276 : if (cd->is_initializer)
14041 : {
14042 539 : if ((*e)->symtree->n.sym != cd->omp_udr->omp_priv
14043 140 : && (*e)->symtree->n.sym != cd->omp_udr->omp_orig)
14044 4 : gfc_error ("Variable other than OMP_PRIV or OMP_ORIG used in "
14045 : "INITIALIZER clause of !$OMP DECLARE REDUCTION at %L",
14046 : &(*e)->where);
14047 : }
14048 : else
14049 : {
14050 1737 : if ((*e)->symtree->n.sym != cd->omp_udr->omp_out
14051 619 : && (*e)->symtree->n.sym != cd->omp_udr->omp_in)
14052 6 : gfc_error ("Variable other than OMP_OUT or OMP_IN used in "
14053 : "combiner of !$OMP DECLARE REDUCTION at %L",
14054 : &(*e)->where);
14055 : }
14056 : }
14057 3706 : return 0;
14058 : }
14059 :
14060 : /* Resolve !$omp declare reduction constructs. */
14061 :
14062 : static void
14063 626 : gfc_resolve_omp_udr (gfc_omp_udr *omp_udr)
14064 : {
14065 626 : gfc_actual_arglist *a;
14066 626 : const char *predef_name = NULL;
14067 :
14068 626 : switch (omp_udr->rop)
14069 : {
14070 625 : case OMP_REDUCTION_PLUS:
14071 625 : case OMP_REDUCTION_TIMES:
14072 625 : case OMP_REDUCTION_MINUS:
14073 625 : case OMP_REDUCTION_AND:
14074 625 : case OMP_REDUCTION_OR:
14075 625 : case OMP_REDUCTION_EQV:
14076 625 : case OMP_REDUCTION_NEQV:
14077 625 : case OMP_REDUCTION_MAX:
14078 625 : case OMP_REDUCTION_USER:
14079 625 : break;
14080 1 : default:
14081 1 : gfc_error ("Invalid operator for !$OMP DECLARE REDUCTION %s at %L",
14082 : omp_udr->name, &omp_udr->where);
14083 26 : return;
14084 : }
14085 :
14086 625 : if (gfc_omp_udr_predef (omp_udr->rop, omp_udr->name,
14087 : &omp_udr->ts, &predef_name))
14088 : {
14089 19 : if (predef_name)
14090 19 : gfc_error ("Redefinition of predefined %qs in "
14091 : "!$OMP DECLARE REDUCTION at %L",
14092 : predef_name, &omp_udr->where);
14093 : else
14094 0 : gfc_error ("Redefinition of predefined %qs in "
14095 : "!$OMP DECLARE REDUCTION at %L", omp_udr->name,
14096 : &omp_udr->where);
14097 19 : return;
14098 : }
14099 :
14100 606 : if (omp_udr->ts.type == BT_CHARACTER
14101 62 : && omp_udr->ts.u.cl->length
14102 32 : && omp_udr->ts.u.cl->length->expr_type != EXPR_CONSTANT)
14103 : {
14104 1 : gfc_error ("CHARACTER length in !$OMP DECLARE REDUCTION %qs not "
14105 : "constant at %L", omp_udr->name, &omp_udr->where);
14106 1 : return;
14107 : }
14108 :
14109 605 : struct omp_udr_callback_data cd;
14110 605 : cd.omp_udr = omp_udr;
14111 605 : cd.is_initializer = false;
14112 605 : gfc_code_walker (&omp_udr->combiner_ns->code, gfc_dummy_code_callback,
14113 : omp_udr_callback, &cd);
14114 605 : if (omp_udr->combiner_ns->code->op == EXEC_CALL)
14115 : {
14116 346 : for (a = omp_udr->combiner_ns->code->ext.actual; a; a = a->next)
14117 237 : if (a->expr == NULL)
14118 : break;
14119 110 : if (a)
14120 1 : gfc_error ("Subroutine call with alternate returns in combiner "
14121 : "of !$OMP DECLARE REDUCTION at %L",
14122 : &omp_udr->combiner_ns->code->loc);
14123 : }
14124 605 : if (omp_udr->initializer_ns)
14125 : {
14126 377 : cd.is_initializer = true;
14127 377 : gfc_code_walker (&omp_udr->initializer_ns->code, gfc_dummy_code_callback,
14128 : omp_udr_callback, &cd);
14129 377 : if (omp_udr->initializer_ns->code->op == EXEC_CALL)
14130 : {
14131 377 : for (a = omp_udr->initializer_ns->code->ext.actual; a; a = a->next)
14132 243 : if (a->expr == NULL)
14133 : break;
14134 135 : if (a)
14135 1 : gfc_error ("Subroutine call with alternate returns in "
14136 : "INITIALIZER clause of !$OMP DECLARE REDUCTION "
14137 : "at %L", &omp_udr->initializer_ns->code->loc);
14138 136 : for (a = omp_udr->initializer_ns->code->ext.actual; a; a = a->next)
14139 135 : if (a->expr
14140 135 : && a->expr->expr_type == EXPR_VARIABLE
14141 135 : && a->expr->symtree->n.sym == omp_udr->omp_priv
14142 134 : && a->expr->ref == NULL)
14143 : break;
14144 135 : if (a == NULL)
14145 1 : gfc_error ("One of actual subroutine arguments in INITIALIZER "
14146 : "clause of !$OMP DECLARE REDUCTION must be OMP_PRIV "
14147 : "at %L", &omp_udr->initializer_ns->code->loc);
14148 : }
14149 : }
14150 228 : else if (omp_udr->ts.type == BT_DERIVED
14151 228 : && !gfc_has_default_initializer (omp_udr->ts.u.derived))
14152 : {
14153 4 : gfc_error ("Missing INITIALIZER clause for !$OMP DECLARE REDUCTION "
14154 : "of derived type without default initializer at %L",
14155 : &omp_udr->where);
14156 4 : return;
14157 : }
14158 : }
14159 :
14160 : void
14161 348708 : gfc_resolve_omp_udrs (gfc_symtree *st)
14162 : {
14163 348708 : gfc_omp_udr *omp_udr;
14164 :
14165 348708 : if (st == NULL)
14166 : return;
14167 527 : gfc_resolve_omp_udrs (st->left);
14168 527 : gfc_resolve_omp_udrs (st->right);
14169 1153 : for (omp_udr = st->n.omp_udr; omp_udr; omp_udr = omp_udr->next)
14170 626 : gfc_resolve_omp_udr (omp_udr);
14171 : }
14172 :
14173 : /* Resolve !$omp declare mapper constructs. */
14174 :
14175 : static void
14176 22 : gfc_resolve_omp_udm (gfc_omp_udm *omp_udm)
14177 : {
14178 22 : resolve_omp_clauses (NULL, omp_udm->clauses, omp_udm->mapper_ns);
14179 :
14180 22 : gfc_omp_namelist *n;
14181 24 : for (n = omp_udm->clauses->lists[OMP_LIST_MAP]; n; n = n->next)
14182 22 : if (n->sym == omp_udm->var_sym)
14183 : break;
14184 22 : if (!n)
14185 2 : gfc_error ("At least one %<map%> clause in !$OMP DECLARE MAPPER at %L must "
14186 : "map %qs or an element of it",
14187 2 : &omp_udm->where, omp_udm->var_sym->name);
14188 22 : }
14189 :
14190 : void
14191 347696 : gfc_resolve_omp_udms (gfc_symtree *st)
14192 : {
14193 347696 : gfc_omp_udm *omp_udm;
14194 :
14195 347696 : if (st == NULL)
14196 : return;
14197 21 : gfc_resolve_omp_udms (st->left);
14198 21 : gfc_resolve_omp_udms (st->right);
14199 43 : for (omp_udm = st->n.omp_udm; omp_udm; omp_udm = omp_udm->next)
14200 22 : gfc_resolve_omp_udm (omp_udm);
14201 : }
|
