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 55508 : gfc_match_omp_eos (void)
135 : {
136 55508 : locus old_loc;
137 55508 : char c;
138 :
139 55508 : old_loc = gfc_current_locus;
140 55508 : gfc_gobble_whitespace ();
141 :
142 55508 : if (gfc_matching_omp_context_selector)
143 : {
144 269 : if (gfc_peek_ascii_char () == ')')
145 : return MATCH_YES;
146 : }
147 : else
148 : {
149 55239 : c = gfc_next_ascii_char ();
150 55239 : 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 53511 : case '\n':
159 53511 : return MATCH_YES;
160 : }
161 : }
162 :
163 1729 : gfc_current_locus = old_loc;
164 1729 : return MATCH_NO;
165 : }
166 :
167 : match
168 13179 : gfc_match_omp_eos_error (void)
169 : {
170 13179 : 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 61452 : gfc_free_omp_clauses (gfc_omp_clauses *c)
182 : {
183 61452 : if (c == NULL)
184 : return;
185 :
186 34612 : gfc_free_expr (c->if_expr);
187 380732 : for (int i = 0; i < OMP_IF_LAST; i++)
188 346120 : gfc_free_expr (c->if_exprs[i]);
189 34612 : gfc_free_expr (c->self_expr);
190 34612 : gfc_free_expr (c->final_expr);
191 34612 : gfc_free_expr (c->num_threads);
192 34612 : gfc_free_expr (c->chunk_size);
193 34612 : gfc_free_expr (c->safelen_expr);
194 34612 : gfc_free_expr (c->simdlen_expr);
195 34612 : gfc_free_expr (c->num_teams_lower);
196 34612 : gfc_free_expr (c->num_teams_upper);
197 34612 : gfc_free_expr (c->device);
198 34612 : gfc_free_expr (c->dyn_groupprivate);
199 34612 : gfc_free_expr (c->thread_limit);
200 34612 : gfc_free_expr (c->dist_chunk_size);
201 34612 : gfc_free_expr (c->grainsize);
202 34612 : gfc_free_expr (c->hint);
203 34612 : gfc_free_expr (c->num_tasks);
204 34612 : gfc_free_expr (c->priority);
205 34612 : gfc_free_expr (c->detach);
206 34612 : gfc_free_expr (c->novariants);
207 34612 : gfc_free_expr (c->nocontext);
208 34612 : gfc_free_expr (c->async_expr);
209 34612 : gfc_free_expr (c->gang_num_expr);
210 34612 : gfc_free_expr (c->gang_static_expr);
211 34612 : gfc_free_expr (c->worker_expr);
212 34612 : gfc_free_expr (c->vector_expr);
213 34612 : gfc_free_expr (c->num_gangs_expr);
214 34612 : gfc_free_expr (c->num_workers_expr);
215 34612 : gfc_free_expr (c->vector_length_expr);
216 1384480 : for (enum gfc_omp_list_type t = OMP_LIST_FIRST; t < OMP_LIST_NUM;
217 1349868 : t = gfc_omp_list_type (t + 1))
218 1349868 : gfc_free_omp_namelist (c->lists[t], t);
219 34612 : gfc_free_expr_list (c->wait_list);
220 34612 : gfc_free_expr_list (c->tile_list);
221 34612 : gfc_free_expr_list (c->sizes_list);
222 34612 : free (const_cast<char *> (c->critical_name));
223 34612 : 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 34612 : 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 104839 : gfc_free_expr_list (gfc_expr_list *list)
255 : {
256 104839 : gfc_expr_list *n;
257 :
258 106246 : for (; list; list = n)
259 : {
260 1407 : n = list->next;
261 1407 : free (list);
262 : }
263 104839 : }
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 534998 : gfc_free_omp_declare_simd_list (gfc_omp_declare_simd *list)
279 : {
280 535234 : 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 534998 : }
287 :
288 : static void
289 721 : gfc_free_omp_trait_property_list (gfc_omp_trait_property *list)
290 : {
291 1128 : 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 721 : }
313 :
314 : static void
315 593 : gfc_free_omp_selector_list (gfc_omp_selector *list)
316 : {
317 1314 : while (list)
318 : {
319 721 : gfc_omp_selector *current = list;
320 721 : list = list->next;
321 721 : gfc_free_omp_trait_property_list (current->properties);
322 721 : free (current);
323 : }
324 593 : }
325 :
326 : static void
327 662 : gfc_free_omp_set_selector_list (gfc_omp_set_selector *list)
328 : {
329 1255 : while (list)
330 : {
331 593 : gfc_omp_set_selector *current = list;
332 593 : list = list->next;
333 593 : gfc_free_omp_selector_list (current->trait_selectors);
334 593 : free (current);
335 : }
336 662 : }
337 :
338 : /* Free an !$omp declare variant construct list. */
339 :
340 : void
341 534998 : gfc_free_omp_declare_variant_list (gfc_omp_declare_variant *list)
342 : {
343 535446 : while (list)
344 : {
345 448 : gfc_omp_declare_variant *current = list;
346 448 : list = list->next;
347 448 : gfc_free_omp_set_selector_list (current->set_selectors);
348 448 : gfc_free_omp_namelist (current->adjust_args_list, OMP_LIST_NONE);
349 448 : free (current);
350 : }
351 534998 : }
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 46 : gfc_free_omp_udm (gfc_omp_udm *omp_udm)
386 : {
387 46 : if (omp_udm)
388 : {
389 23 : gfc_free_omp_udm (omp_udm->next);
390 23 : gfc_free_namespace (omp_udm->mapper_ns);
391 23 : free (omp_udm);
392 : }
393 46 : }
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 31737 : 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 31737 : gfc_omp_namelist *head, *tail, *p;
457 31737 : locus old_loc, cur_loc;
458 31737 : char n[GFC_MAX_SYMBOL_LEN+1];
459 31737 : gfc_symbol *sym;
460 31737 : match m;
461 31737 : gfc_symtree *st;
462 :
463 31737 : head = tail = NULL;
464 :
465 31737 : old_loc = gfc_current_locus;
466 31737 : if (has_all_memory)
467 708 : *has_all_memory = false;
468 31737 : m = gfc_match (str);
469 31737 : if (m != MATCH_YES)
470 : return m;
471 :
472 38493 : for (;;)
473 : {
474 38493 : gfc_gobble_whitespace ();
475 38493 : cur_loc = gfc_current_locus;
476 :
477 38493 : m = gfc_match_name (n);
478 38493 : 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 38214 : if (m == MATCH_YES)
501 : {
502 38214 : gfc_symtree *st;
503 38214 : if ((m = gfc_get_ha_sym_tree (n, &st) ? MATCH_ERROR : MATCH_YES)
504 : == MATCH_YES)
505 38214 : sym = st->n.sym;
506 : }
507 38470 : switch (m)
508 : {
509 38214 : case MATCH_YES:
510 38214 : gfc_expr *expr;
511 38214 : expr = NULL;
512 38214 : gfc_gobble_whitespace ();
513 23527 : if ((allow_sections && gfc_peek_ascii_char () == '(')
514 57379 : || (allow_derived && gfc_peek_ascii_char () == '%'))
515 : {
516 6602 : gfc_current_locus = cur_loc;
517 6602 : m = gfc_match_variable (&expr, 0);
518 6602 : switch (m)
519 : {
520 4 : case MATCH_ERROR:
521 12 : goto cleanup;
522 0 : case MATCH_NO:
523 0 : goto syntax;
524 6598 : default:
525 6598 : break;
526 : }
527 6598 : 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 38205 : gfc_set_sym_referenced (sym);
535 38205 : p = gfc_get_omp_namelist ();
536 38205 : if (head == NULL)
537 : head = tail = p;
538 10165 : else if (reverse_order)
539 : {
540 57 : p->next = head;
541 57 : head = p;
542 : }
543 : else
544 : {
545 10108 : tail->next = p;
546 10108 : tail = tail->next;
547 : }
548 38205 : p->sym = sym;
549 38205 : p->expr = expr;
550 38205 : p->where = gfc_get_location_range (NULL, 0, &cur_loc, 1,
551 : &gfc_current_locus);
552 38205 : 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 38202 : 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 38446 : if (end_colon && gfc_match_char (':') == MATCH_YES)
607 : {
608 793 : *end_colon = true;
609 793 : break;
610 : }
611 37653 : if (gfc_match_char (')') == MATCH_YES)
612 : break;
613 10236 : if (gfc_match_char (',') != MATCH_YES)
614 21 : goto syntax;
615 : }
616 :
617 38248 : while (*list)
618 10038 : list = &(*list)->next;
619 :
620 28210 : *list = head;
621 28210 : if (headp)
622 22317 : *headp = list;
623 : return MATCH_YES;
624 :
625 52 : syntax:
626 52 : gfc_error ("Syntax error in OpenMP variable list at %C");
627 :
628 68 : cleanup:
629 68 : gfc_free_omp_namelist (head, OMP_LIST_NONE);
630 68 : gfc_current_locus = old_loc;
631 68 : 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 32352 : 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 33234 : omp_mask::omp_mask (uint64_t m1, uint64_t m2) : mask1 (m1), mask2 (m2)
1237 : {
1238 : }
1239 :
1240 : omp_mask
1241 32283 : omp_mask::operator| (omp_mask1 m) const
1242 : {
1243 32283 : return omp_mask (mask1 | (((uint64_t) 1) << m), mask2);
1244 : }
1245 :
1246 : omp_mask
1247 16861 : omp_mask::operator| (omp_mask2 m) const
1248 : {
1249 16861 : return omp_mask (mask1, mask2 | (((uint64_t) 1) << m));
1250 : }
1251 :
1252 : omp_mask
1253 4365 : omp_mask::operator| (omp_mask m) const
1254 : {
1255 4365 : return omp_mask (mask1 | m.mask1, mask2 | m.mask2);
1256 : }
1257 :
1258 : omp_mask
1259 2024 : omp_mask::operator& (const omp_inv_mask &m) const
1260 : {
1261 2024 : return omp_mask (mask1 & ~m.mask1, mask2 & ~m.mask2);
1262 : }
1263 :
1264 : bool
1265 125913 : omp_mask::operator& (omp_mask1 m) const
1266 : {
1267 125913 : return (mask1 & (((uint64_t) 1) << m)) != 0;
1268 : }
1269 :
1270 : bool
1271 88420 : omp_mask::operator& (omp_mask2 m) const
1272 : {
1273 88420 : return (mask2 & (((uint64_t) 1) << m)) != 0;
1274 : }
1275 :
1276 : omp_inv_mask
1277 2024 : omp_mask::operator~ () const
1278 : {
1279 2024 : return omp_inv_mask (*this);
1280 : }
1281 :
1282 2024 : 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 8729 : gfc_match_iterator (gfc_namespace **ns, bool permit_var)
1309 : {
1310 8729 : locus old_loc = gfc_current_locus;
1311 :
1312 8729 : 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 1736 : gfc_match_motion_var_list (const char *str, gfc_omp_namelist **list,
1436 : gfc_omp_namelist ***headp)
1437 : {
1438 1736 : match m = gfc_match (str);
1439 1736 : if (m != MATCH_YES)
1440 : return m;
1441 :
1442 1736 : gfc_namespace *ns_iter = NULL, *ns_curr = gfc_current_ns;
1443 1736 : locus old_loc = gfc_current_locus;
1444 1736 : int present_modifier = 0;
1445 1736 : int iterator_modifier = 0;
1446 1736 : locus second_present_locus = old_loc;
1447 1736 : locus second_iterator_locus = old_loc;
1448 1736 : bool saw_modifier = false;
1449 :
1450 1748 : for (;;)
1451 : {
1452 1742 : locus current_locus = gfc_current_locus;
1453 1742 : if (gfc_match ("present ") == MATCH_YES)
1454 : {
1455 8 : if (present_modifier++ == 1)
1456 0 : second_present_locus = current_locus;
1457 : }
1458 1734 : 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 1714 : 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 1732 : if (!saw_modifier)
1489 : {
1490 1712 : gfc_current_locus = old_loc;
1491 1712 : present_modifier = 0;
1492 1712 : iterator_modifier = 0;
1493 : }
1494 :
1495 1732 : 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 1732 : 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 1731 : if (ns_iter)
1508 14 : gfc_current_ns = ns_iter;
1509 :
1510 1731 : m = gfc_match_omp_variable_list ("", list, false, NULL, headp, true, true);
1511 1731 : gfc_current_ns = ns_curr;
1512 1731 : 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 78 : gfc_match_omp_clause_uses_allocators (gfc_omp_clauses *c)
1894 : {
1895 82 : parse_next:
1896 82 : gfc_symbol *memspace_sym = NULL;
1897 82 : gfc_symbol *traits_sym = NULL;
1898 82 : gfc_omp_namelist *head = NULL;
1899 82 : gfc_omp_namelist *p, *tail, **list;
1900 82 : int ntraits, nmemspace;
1901 82 : bool has_modifiers;
1902 82 : locus old_loc, cur_loc;
1903 :
1904 82 : gfc_gobble_whitespace ();
1905 82 : old_loc = gfc_current_locus;
1906 82 : ntraits = nmemspace = 0;
1907 126 : do
1908 : {
1909 104 : cur_loc = gfc_current_locus;
1910 104 : if (gfc_match ("traits ( %S ) ", &traits_sym) == MATCH_YES)
1911 34 : ntraits++;
1912 70 : else if (gfc_match ("memspace ( %S ) ", &memspace_sym) == MATCH_YES)
1913 33 : nmemspace++;
1914 104 : if (ntraits > 1 || nmemspace > 1)
1915 : {
1916 5 : gfc_error ("Duplicate %s modifier at %L in USES_ALLOCATORS clause",
1917 : ntraits > 1 ? "TRAITS" : "MEMSPACE", &cur_loc);
1918 5 : return MATCH_ERROR;
1919 : }
1920 99 : if (gfc_match (", ") == MATCH_YES)
1921 22 : continue;
1922 77 : if (gfc_match (": ") != MATCH_YES)
1923 : {
1924 : /* Assume no modifier. */
1925 39 : memspace_sym = traits_sym = NULL;
1926 39 : gfc_current_locus = old_loc;
1927 39 : break;
1928 : }
1929 : break;
1930 : } while (true);
1931 :
1932 115 : has_modifiers = traits_sym != NULL || memspace_sym != NULL;
1933 179 : do
1934 : {
1935 128 : p = gfc_get_omp_namelist ();
1936 128 : p->where = gfc_current_locus;
1937 128 : if (head == NULL)
1938 : head = tail = p;
1939 : else
1940 : {
1941 51 : tail->next = p;
1942 51 : tail = tail->next;
1943 : }
1944 128 : if (gfc_match ("%S ", &p->sym) != MATCH_YES)
1945 1 : goto error;
1946 127 : if (!has_modifiers)
1947 : {
1948 83 : if (gfc_match ("( %S ) ", &p->u2.traits_sym) == MATCH_YES)
1949 22 : 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 22 : "): %s)%>", &p->where, p->u2.traits_sym->name,
1955 22 : p->sym->name);
1956 : }
1957 44 : else if (gfc_peek_ascii_char () == '(')
1958 : {
1959 1 : gfc_error ("Unexpected %<(%> at %C");
1960 1 : goto error;
1961 : }
1962 : else
1963 : {
1964 43 : p->u.memspace_sym = memspace_sym;
1965 43 : p->u2.traits_sym = traits_sym;
1966 : }
1967 126 : gfc_gobble_whitespace ();
1968 126 : const char c = gfc_peek_ascii_char ();
1969 126 : if (c == ';' || c == ')')
1970 : break;
1971 53 : if (c != ',')
1972 : {
1973 2 : gfc_error ("Expected %<,%>, %<)%> or %<;%> at %C");
1974 2 : goto error;
1975 : }
1976 51 : gfc_match_char (',');
1977 51 : gfc_gobble_whitespace ();
1978 51 : } while (true);
1979 :
1980 73 : list = &c->lists[OMP_LIST_USES_ALLOCATORS];
1981 91 : while (*list)
1982 18 : list = &(*list)->next;
1983 73 : *list = head;
1984 :
1985 73 : if (gfc_match_char (';') == MATCH_YES)
1986 4 : goto parse_next;
1987 :
1988 69 : gfc_match_char (')');
1989 69 : return MATCH_YES;
1990 :
1991 4 : error:
1992 4 : gfc_free_omp_namelist (head, OMP_LIST_USES_ALLOCATORS);
1993 4 : 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 22400 : 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 22400 : match m;
2412 22400 : char c;
2413 22400 : locus old_loc = gfc_current_locus;
2414 22400 : if ((m = gfc_match (name)) != MATCH_YES)
2415 : return m;
2416 : /* Ensure that no partial string is matched. */
2417 17431 : if (gfc_current_form == FORM_FREE
2418 16933 : && gfc_match_eos () != MATCH_YES
2419 30228 : && ((c = gfc_peek_ascii_char ()) == '_' || ISALNUM (c)))
2420 : {
2421 8 : gfc_current_locus = old_loc;
2422 8 : return MATCH_NO;
2423 : }
2424 17423 : 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 17379 : if (open_parens || expr)
2433 : {
2434 9489 : if (gfc_match (" ( ") != MATCH_YES)
2435 : {
2436 22 : gfc_error ("Expected %<(%> after %qs at %C", name);
2437 22 : return MATCH_ERROR;
2438 : }
2439 9467 : if (expr)
2440 : {
2441 4423 : 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 999 : gfc_find_omp_udm (gfc_namespace *ns, const char *mapper_id, gfc_typespec *ts)
2474 : {
2475 999 : gfc_symtree *st;
2476 :
2477 999 : if (ns == NULL)
2478 0 : ns = gfc_current_ns;
2479 :
2480 1177 : do
2481 : {
2482 1177 : gfc_omp_udm *omp_udm;
2483 :
2484 1177 : st = gfc_find_symtree (ns->omp_udm_root, mapper_id);
2485 :
2486 1177 : if (st != NULL)
2487 : {
2488 28 : for (omp_udm = st->n.omp_udm; omp_udm; omp_udm = omp_udm->next)
2489 28 : if (gfc_compare_types (&omp_udm->ts, ts))
2490 : return omp_udm;
2491 : }
2492 :
2493 : /* Don't escape an interface block. */
2494 1151 : if (ns && !ns->has_import_set
2495 1151 : && ns->proc_name && ns->proc_name->attr.if_source == IFSRC_IFBODY)
2496 : break;
2497 :
2498 1151 : ns = ns->parent;
2499 : }
2500 1151 : 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 34557 : 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 34557 : bool error = false;
2516 34557 : gfc_omp_clauses *c = gfc_get_omp_clauses ();
2517 34557 : 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 34557 : bool allow_derived = (openacc
2523 34557 : && ((mask & OMP_CLAUSE_ATTACH)
2524 5932 : || (mask & OMP_CLAUSE_DETACH)));
2525 :
2526 34557 : gcc_checking_assert (OMP_MASK1_LAST <= 64 && OMP_MASK2_LAST <= 64);
2527 34557 : *cp = NULL;
2528 127045 : while (1)
2529 : {
2530 80801 : match m = MATCH_NO;
2531 60014 : if ((first || (m = gfc_match_char (',')) != MATCH_YES)
2532 140459 : && (needs_space && gfc_match_space () != MATCH_YES))
2533 : break;
2534 76235 : needs_space = false;
2535 76235 : first = false;
2536 76235 : gfc_gobble_whitespace ();
2537 76235 : bool end_colon;
2538 76235 : gfc_omp_namelist **head;
2539 76235 : old_loc = gfc_current_locus;
2540 76235 : char pc = gfc_peek_ascii_char ();
2541 76235 : if (pc == '\n' && m == MATCH_YES)
2542 : {
2543 1 : gfc_error ("Clause expected at %C after trailing comma");
2544 1 : goto error;
2545 : }
2546 76234 : switch (pc)
2547 : {
2548 1314 : case 'a':
2549 1314 : end_colon = false;
2550 1314 : head = NULL;
2551 1338 : if ((mask & OMP_CLAUSE_ASSUMPTIONS)
2552 1314 : && 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 1287 : if ((mask & OMP_CLAUSE_ALIGNED)
2560 1287 : && 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 1185 : if ((mask & OMP_CLAUSE_MEMORDER)
2583 1192 : && (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 1172 : if ((mask & OMP_CLAUSE_MEMORDER)
2593 1172 : && (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 1158 : if ((mask & OMP_CLAUSE_AFFINITY)
2603 1158 : && 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 1117 : if ((mask & OMP_CLAUSE_ALLOCATE)
2633 1117 : && gfc_match ("allocate ( ") == MATCH_YES)
2634 : {
2635 281 : gfc_expr *allocator = NULL;
2636 281 : gfc_expr *align = NULL;
2637 281 : old_loc = gfc_current_locus;
2638 281 : if ((m = gfc_match ("allocator ( %e )", &allocator)) == MATCH_YES)
2639 50 : gfc_match (" , align ( %e )", &align);
2640 231 : else if ((m = gfc_match ("align ( %e )", &align)) == MATCH_YES)
2641 29 : gfc_match (" , allocator ( %e )", &allocator);
2642 :
2643 281 : 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 202 : m = gfc_match_expr (&allocator);
2654 202 : 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 276 : gfc_omp_namelist **head = NULL;
2664 276 : m = gfc_match_omp_variable_list ("", &c->lists[OMP_LIST_ALLOCATE],
2665 : true, NULL, &head);
2666 :
2667 276 : 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 729 : for (gfc_omp_namelist *n = *head; n; n = n->next)
2676 : {
2677 456 : n->u2.allocator = allocator;
2678 456 : n->u.align = (align) ? gfc_copy_expr (align) : NULL;
2679 : }
2680 273 : gfc_free_expr (align);
2681 273 : continue;
2682 273 : }
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 3742 : case 'd':
2862 3742 : if ((mask & OMP_CLAUSE_DEFAULTMAP)
2863 3742 : && gfc_match ("defaultmap ( ") == MATCH_YES)
2864 : {
2865 181 : enum gfc_omp_defaultmap behavior;
2866 181 : gfc_omp_defaultmap_category category
2867 : = OMP_DEFAULTMAP_CAT_UNCATEGORIZED;
2868 181 : if (gfc_match ("alloc ") == MATCH_YES)
2869 : behavior = OMP_DEFAULTMAP_ALLOC;
2870 175 : else if (gfc_match ("tofrom ") == MATCH_YES)
2871 : behavior = OMP_DEFAULTMAP_TOFROM;
2872 143 : else if (gfc_match ("to ") == MATCH_YES)
2873 : behavior = OMP_DEFAULTMAP_TO;
2874 133 : else if (gfc_match ("from ") == MATCH_YES)
2875 : behavior = OMP_DEFAULTMAP_FROM;
2876 130 : else if (gfc_match ("firstprivate ") == MATCH_YES)
2877 : behavior = OMP_DEFAULTMAP_FIRSTPRIVATE;
2878 95 : else if (gfc_match ("present ") == MATCH_YES)
2879 : behavior = OMP_DEFAULTMAP_PRESENT;
2880 91 : 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 180 : 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 1200 : for (int i = 0; i < OMP_DEFAULTMAP_CAT_NUM; ++i)
2914 : {
2915 1034 : if (i != category
2916 1034 : && 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 780 : 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 166 : c->defaultmap[category] = behavior;
2950 166 : if (gfc_match (")") != MATCH_YES)
2951 : break;
2952 166 : continue;
2953 166 : }
2954 4528 : if ((mask & OMP_CLAUSE_DEFAULT)
2955 3561 : && (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 2857 : if ((mask & OMP_CLAUSE_DELETE)
2992 345 : && gfc_match ("delete ( ") == MATCH_YES
2993 2857 : && 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 2241 : m = MATCH_NO;
3000 2241 : if (((mask & OMP_CLAUSE_DOACROSS)
3001 383 : && gfc_match ("doacross ( ") == MATCH_YES)
3002 2597 : || (((mask & OMP_CLAUSE_DEPEND) || (mask & OMP_CLAUSE_DOACROSS))
3003 1600 : && (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 1162 : if ((mask & OMP_CLAUSE_DESTROY)
3139 1141 : && gfc_match_omp_variable_list ("destroy (",
3140 : &c->lists[OMP_LIST_DESTROY],
3141 : true) == MATCH_YES)
3142 21 : continue;
3143 1246 : if ((mask & OMP_CLAUSE_DETACH)
3144 164 : && !openacc
3145 127 : && !c->detach
3146 1246 : && gfc_match_omp_detach (&c->detach) == MATCH_YES)
3147 126 : continue;
3148 1031 : if ((mask & OMP_CLAUSE_DETACH)
3149 38 : && openacc
3150 37 : && gfc_match ("detach ( ") == MATCH_YES
3151 1031 : && gfc_match_omp_map_clause (&c->lists[OMP_LIST_MAP],
3152 : OMP_MAP_DETACH, false,
3153 : allow_derived))
3154 37 : continue;
3155 993 : if ((mask & OMP_CLAUSE_DEVICEPTR)
3156 87 : && gfc_match ("deviceptr ( ") == MATCH_YES
3157 995 : && gfc_match_omp_map_clause (&c->lists[OMP_LIST_MAP],
3158 : OMP_MAP_FORCE_DEVICEPTR, false,
3159 : allow_derived))
3160 36 : continue;
3161 1012 : if ((mask & OMP_CLAUSE_DEVICE_TYPE)
3162 921 : && 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 877 : if ((mask & OMP_CLAUSE_DEVICE_RESIDENT)
3181 878 : && gfc_match_omp_variable_list
3182 49 : ("device_resident (",
3183 : &c->lists[OMP_LIST_DEVICE_RESIDENT], true) == MATCH_YES)
3184 48 : continue;
3185 1093 : if ((mask & OMP_CLAUSE_DEVICE)
3186 705 : && openacc
3187 314 : && gfc_match ("device ( ") == MATCH_YES
3188 1094 : && gfc_match_omp_map_clause (&c->lists[OMP_LIST_MAP],
3189 : OMP_MAP_FORCE_TO, true,
3190 : /* allow_derived = */ true))
3191 312 : continue;
3192 469 : if ((mask & OMP_CLAUSE_DEVICE)
3193 393 : && !openacc
3194 860 : && ((m = gfc_match_dupl_check (!c->device, "device", true))
3195 : != MATCH_NO))
3196 : {
3197 351 : if (m == MATCH_ERROR)
3198 0 : goto error;
3199 351 : c->ancestor = false;
3200 351 : 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 333 : 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 288 : 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 334 : continue;
3250 334 : }
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 2336 : case 'l':
3543 2336 : if ((mask & OMP_CLAUSE_LASTPRIVATE)
3544 2336 : && gfc_match ("lastprivate ( ") == MATCH_YES)
3545 : {
3546 1433 : bool conditional = gfc_match ("conditional : ") == MATCH_YES;
3547 1433 : head = NULL;
3548 1433 : if (gfc_match_omp_variable_list ("",
3549 : &c->lists[OMP_LIST_LASTPRIVATE],
3550 : false, NULL, &head) == MATCH_YES)
3551 : {
3552 1433 : gfc_omp_namelist *n;
3553 3741 : for (n = *head; n; n = n->next)
3554 2308 : n->u.lastprivate_conditional = conditional;
3555 1433 : continue;
3556 1433 : }
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 5931 : case 'm':
3803 5931 : if ((mask & OMP_CLAUSE_MAP)
3804 5931 : && gfc_match ("map ( ") == MATCH_YES)
3805 : {
3806 5839 : locus old_loc2 = gfc_current_locus;
3807 5839 : int always_modifier = 0;
3808 5839 : int close_modifier = 0;
3809 5839 : int present_modifier = 0;
3810 5839 : int mapper_modifier = 0;
3811 5839 : int iterator_modifier = 0;
3812 5839 : gfc_namespace *ns_iter = NULL, *ns_curr = gfc_current_ns;
3813 5839 : locus second_always_locus = old_loc2;
3814 5839 : locus second_close_locus = old_loc2;
3815 5839 : locus second_mapper_locus = old_loc2;
3816 5839 : locus second_present_locus = old_loc2;
3817 5839 : char mapper_id[GFC_MAX_SYMBOL_LEN + 1] = { '\0' };
3818 5839 : locus second_iterator_locus = old_loc2;
3819 :
3820 6505 : for (;;)
3821 : {
3822 6172 : locus current_locus = gfc_current_locus;
3823 6172 : if (gfc_match ("always ") == MATCH_YES)
3824 : {
3825 148 : if (always_modifier++ == 1)
3826 5 : second_always_locus = current_locus;
3827 : }
3828 6024 : else if (gfc_match ("close ") == MATCH_YES)
3829 : {
3830 69 : if (close_modifier++ == 1)
3831 5 : second_close_locus = current_locus;
3832 : }
3833 5955 : else if (gfc_match ("present ") == MATCH_YES)
3834 : {
3835 67 : if (present_modifier++ == 1)
3836 4 : second_present_locus = current_locus;
3837 : }
3838 5888 : else if (gfc_match ("mapper ( ") == MATCH_YES)
3839 : {
3840 7 : if (mapper_modifier++ == 1)
3841 0 : second_mapper_locus = current_locus;
3842 7 : m = gfc_match (" %n ) ", mapper_id);
3843 7 : if (m != MATCH_YES)
3844 0 : goto error;
3845 7 : if (strcmp (mapper_id, "default") == 0)
3846 3 : mapper_id[0] = '\0';
3847 : }
3848 5881 : 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 333 : 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 333 : }
3862 :
3863 5839 : gfc_omp_map_op map_op = default_map_op;
3864 5839 : int always_present_modifier
3865 5839 : = always_modifier && present_modifier;
3866 :
3867 5839 : if (gfc_match ("alloc : ") == MATCH_YES)
3868 799 : map_op = (present_modifier ? OMP_MAP_PRESENT_ALLOC
3869 : : OMP_MAP_ALLOC);
3870 5040 : 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 4086 : else if (gfc_match ("to : ") == MATCH_YES)
3876 1814 : map_op = (always_present_modifier ? OMP_MAP_ALWAYS_PRESENT_TO
3877 1808 : : present_modifier ? OMP_MAP_PRESENT_TO
3878 1796 : : 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 5834 : if (close_modifier > 1)
3904 : {
3905 4 : gfc_error ("too many %<close%> modifiers at %L",
3906 : &second_close_locus);
3907 4 : break;
3908 : }
3909 5830 : if (present_modifier > 1)
3910 : {
3911 4 : gfc_error ("too many %<present%> modifiers at %L",
3912 : &second_present_locus);
3913 4 : break;
3914 : }
3915 5826 : if (mapper_modifier > 1)
3916 : {
3917 0 : gfc_error ("too many %<mapper%> modifiers at %L",
3918 : &second_mapper_locus);
3919 0 : break;
3920 : }
3921 5826 : 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 5825 : head = NULL;
3929 5825 : if (ns_iter)
3930 40 : gfc_current_ns = ns_iter;
3931 5825 : m = gfc_match_omp_variable_list ("", &c->lists[OMP_LIST_MAP],
3932 : false, NULL, &head, true, true);
3933 5825 : gfc_current_ns = ns_curr;
3934 5825 : if (m == MATCH_YES)
3935 : {
3936 5820 : gfc_omp_namelist *n;
3937 13223 : for (n = *head; n; n = n->next)
3938 : {
3939 7403 : n->u.map.op = map_op;
3940 7403 : if (mapper_id[0] != '\0')
3941 : {
3942 4 : n->u3.udm = gfc_get_omp_namelist_udm ();
3943 4 : n->u3.udm->requested_mapper_id
3944 4 : = gfc_get_string ("%s", mapper_id);
3945 : }
3946 7403 : n->u2.ns = ns_iter;
3947 7403 : if (ns_iter)
3948 42 : ns_iter->refs++;
3949 : }
3950 5820 : continue;
3951 5820 : }
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 2914 : case 'n':
3974 2966 : if ((mask & OMP_CLAUSE_NO_CREATE)
3975 1343 : && gfc_match ("no_create ( ") == MATCH_YES
3976 2966 : && gfc_match_omp_map_clause (&c->lists[OMP_LIST_MAP],
3977 : OMP_MAP_IF_PRESENT, true,
3978 : allow_derived))
3979 52 : continue;
3980 2863 : if ((mask & OMP_CLAUSE_ASSUMPTIONS)
3981 2888 : && (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 2873 : if ((mask & OMP_CLAUSE_ASSUMPTIONS)
3993 2884 : && (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 2851 : if ((mask & OMP_CLAUSE_ASSUMPTIONS)
4005 2857 : && (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 2849 : if ((mask & OMP_CLAUSE_ASSUMPTIONS)
4016 2850 : && (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 2847 : if ((mask & OMP_CLAUSE_NOVARIANTS)
4029 2837 : && (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 2838 : if ((mask & OMP_CLAUSE_NOCONTEXT)
4038 2825 : && (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 2824 : if ((mask & OMP_CLAUSE_NOGROUP)
4047 2810 : && (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 2946 : if ((mask & OMP_CLAUSE_NOHOST)
4056 2796 : && (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 2687 : if ((mask & OMP_CLAUSE_NOTEMPORAL)
4064 2645 : && gfc_match_omp_variable_list ("nontemporal (",
4065 : &c->lists[OMP_LIST_NONTEMPORAL],
4066 : true) == MATCH_YES)
4067 42 : continue;
4068 2627 : if ((mask & OMP_CLAUSE_NOTINBRANCH)
4069 2604 : && (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 2707 : if ((mask & OMP_CLAUSE_NOWAIT)
4078 2578 : && (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 3128 : if ((mask & OMP_CLAUSE_NUM_GANGS)
4086 2446 : && (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 1786 : if ((mask & OMP_CLAUSE_NUM_TASKS)
4096 1760 : && (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 1863 : if ((mask & OMP_CLAUSE_NUM_TEAMS)
4108 1734 : && (m = gfc_match_dupl_check (!c->num_teams_upper, "num_teams",
4109 : true)) != MATCH_NO)
4110 : {
4111 129 : if (m == MATCH_ERROR)
4112 0 : goto error;
4113 129 : if (gfc_match ("%e ", &c->num_teams_upper) != MATCH_YES)
4114 0 : goto error;
4115 129 : 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 129 : if (gfc_match (") ") != MATCH_YES)
4123 0 : goto error;
4124 129 : continue;
4125 : }
4126 2569 : if ((mask & OMP_CLAUSE_NUM_THREADS)
4127 1605 : && (m = gfc_match_dupl_check (!c->num_threads, "num_threads", true,
4128 : &c->num_threads)) != MATCH_NO)
4129 : {
4130 964 : if (m == MATCH_ERROR)
4131 0 : goto error;
4132 964 : 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 1224 : case 't':
4518 1289 : if ((mask & OMP_CLAUSE_TASK_REDUCTION)
4519 1224 : && gfc_match_omp_clause_reduction (pc, c, openacc,
4520 : allow_derived) == MATCH_YES)
4521 65 : continue;
4522 1233 : if ((mask & OMP_CLAUSE_THREAD_LIMIT)
4523 1159 : && (m = gfc_match_dupl_check (!c->thread_limit, "thread_limit",
4524 : true, &c->thread_limit))
4525 : != MATCH_NO)
4526 : {
4527 74 : if (m == MATCH_ERROR)
4528 0 : goto error;
4529 74 : continue;
4530 : }
4531 1098 : if ((mask & OMP_CLAUSE_THREADS)
4532 1085 : && (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 1269 : if ((mask & OMP_CLAUSE_TILE)
4541 221 : && !c->tile_list
4542 1293 : && match_omp_oacc_expr_list ("tile (", &c->tile_list,
4543 : true, false) == MATCH_YES)
4544 197 : continue;
4545 875 : 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 1487 : else if ((mask & OMP_CLAUSE_TO)
4562 759 : && gfc_match_motion_var_list ("to (", &c->lists[OMP_LIST_TO],
4563 : &head) == MATCH_YES)
4564 728 : continue;
4565 : break;
4566 1538 : case 'u':
4567 1596 : if ((mask & OMP_CLAUSE_UNIFORM)
4568 1538 : && gfc_match_omp_variable_list ("uniform (",
4569 : &c->lists[OMP_LIST_UNIFORM],
4570 : false) == MATCH_YES)
4571 58 : continue;
4572 1621 : if ((mask & OMP_CLAUSE_UNTIED)
4573 1480 : && (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 1583 : if ((mask & OMP_CLAUSE_ATOMIC)
4581 1339 : && (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 1116 : if ((mask & OMP_CLAUSE_USE)
4591 1094 : && gfc_match_omp_variable_list ("use (",
4592 : &c->lists[OMP_LIST_USE],
4593 : true) == MATCH_YES)
4594 22 : continue;
4595 1132 : if ((mask & OMP_CLAUSE_USE_DEVICE)
4596 1072 : && gfc_match_omp_variable_list ("use_device (",
4597 : &c->lists[OMP_LIST_USE_DEVICE],
4598 : true) == MATCH_YES)
4599 60 : continue;
4600 1175 : if ((mask & OMP_CLAUSE_USE_DEVICE_PTR)
4601 1940 : && 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 1614 : if ((mask & OMP_CLAUSE_USE_DEVICE_ADDR)
4606 1614 : && 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 153 : if ((mask & OMP_CLAUSE_USES_ALLOCATORS)
4611 84 : && (gfc_match ("uses_allocators ( ") == MATCH_YES))
4612 : {
4613 78 : if (gfc_match_omp_clause_uses_allocators (c) != MATCH_YES)
4614 9 : goto error;
4615 69 : 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 46244 : }
4700 :
4701 34557 : end:
4702 34297 : if (error || gfc_match_omp_eos () != MATCH_YES)
4703 : {
4704 537 : if (!gfc_error_flag_test ())
4705 137 : gfc_error ("Failed to match clause at %C");
4706 537 : gfc_free_omp_clauses (c);
4707 537 : return MATCH_ERROR;
4708 : }
4709 :
4710 34020 : *cp = c;
4711 34020 : return MATCH_YES;
4712 :
4713 260 : error:
4714 260 : error = true;
4715 260 : 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 17214 : match_omp (gfc_exec_op op, const omp_mask mask)
5415 : {
5416 17214 : gfc_omp_clauses *c;
5417 17214 : if (gfc_match_omp_clauses (&c, mask, true, true, false,
5418 : op == EXEC_OMP_TARGET) != MATCH_YES)
5419 : return MATCH_ERROR;
5420 16951 : new_st.op = op;
5421 16951 : new_st.ext.omp_clauses = c;
5422 16951 : 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 1253 : gfc_match_omp_do (void)
5770 : {
5771 1253 : 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 30 : gfc_omp_udm_find (gfc_symtree *st, gfc_typespec *ts)
5973 : {
5974 30 : gfc_omp_udm *omp_udm;
5975 :
5976 30 : 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 28 : gfc_match_omp_declare_mapper (void)
6003 : {
6004 28 : match m;
6005 28 : gfc_typespec ts;
6006 28 : char mapper_id[GFC_MAX_SYMBOL_LEN + 1];
6007 28 : char var[GFC_MAX_SYMBOL_LEN + 1];
6008 28 : gfc_namespace *mapper_ns = NULL;
6009 28 : gfc_symtree *var_st;
6010 28 : gfc_symtree *st;
6011 28 : gfc_omp_udm *omp_udm = NULL, *prev_udm = NULL;
6012 28 : locus where = gfc_current_locus;
6013 :
6014 28 : if (gfc_match_char ('(') != MATCH_YES)
6015 : {
6016 1 : gfc_error ("Expected %<(%> at %C");
6017 1 : return MATCH_ERROR;
6018 : }
6019 :
6020 27 : locus old_locus = gfc_current_locus;
6021 :
6022 27 : m = gfc_match (" %n : ", mapper_id);
6023 :
6024 27 : 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 27 : if (strcmp (mapper_id, "default") == 0)
6030 0 : mapper_id[0] = '\0';
6031 :
6032 27 : 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 27 : old_locus = gfc_current_locus;
6040 :
6041 27 : m = gfc_match_type_spec (&ts);
6042 27 : 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 23 : 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 22 : if (gfc_match (" :: ") != MATCH_YES)
6056 : {
6057 0 : gfc_error ("Expected %<::%> at %C");
6058 0 : return MATCH_ERROR;
6059 : }
6060 :
6061 22 : 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 21 : if (gfc_match_char (')') != MATCH_YES)
6068 : {
6069 2 : gfc_error ("Expected %<)%> at %C");
6070 2 : return MATCH_ERROR;
6071 : }
6072 :
6073 19 : 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 19 : gfc_current_ns = mapper_ns = gfc_get_namespace (gfc_current_ns, 1);
6080 19 : mapper_ns->proc_name = mapper_ns->parent->proc_name;
6081 19 : mapper_ns->omp_udm_ns = 1;
6082 :
6083 19 : gfc_get_sym_tree (var, mapper_ns, &var_st, false);
6084 19 : var_st->n.sym->ts = ts;
6085 19 : var_st->n.sym->attr.omp_udm_artificial_var = 1;
6086 19 : var_st->n.sym->attr.flavor = FL_VARIABLE;
6087 19 : gfc_commit_symbols ();
6088 :
6089 19 : gfc_omp_clauses *clauses = NULL;
6090 :
6091 19 : m = gfc_match_omp_clauses (&clauses, omp_mask (OMP_CLAUSE_MAP), true, true,
6092 : false, false, OMP_MAP_UNSET);
6093 19 : if (m != MATCH_YES)
6094 1 : goto failure;
6095 :
6096 18 : omp_udm = gfc_get_omp_udm ();
6097 18 : omp_udm->next = NULL;
6098 18 : omp_udm->where = where;
6099 18 : omp_udm->mapper_id = gfc_get_string ("%s", mapper_id);
6100 18 : omp_udm->ts = ts;
6101 18 : omp_udm->var_sym = var_st->n.sym;
6102 18 : omp_udm->mapper_ns = mapper_ns;
6103 18 : omp_udm->clauses = clauses;
6104 :
6105 18 : gfc_current_ns = mapper_ns->parent;
6106 :
6107 18 : prev_udm = gfc_omp_udm_find (st, &ts);
6108 18 : 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 16 : 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 16 : st = gfc_new_symtree (&gfc_current_ns->omp_udm_root, mapper_id);
6128 16 : 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 2160 : gfc_match_omp_parallel (void)
7860 : {
7861 2160 : return match_omp (EXEC_OMP_PARALLEL, OMP_PARALLEL_CLAUSES);
7862 : }
7863 :
7864 :
7865 : match
7866 1203 : gfc_match_omp_parallel_do (void)
7867 : {
7868 1203 : return match_omp (EXEC_OMP_PARALLEL_DO,
7869 1203 : (OMP_PARALLEL_CLAUSES | OMP_DO_CLAUSES)
7870 1203 : & ~(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 49715 : gfc_check_omp_requires (gfc_namespace *ns, int ref_omp_requires)
7957 : {
7958 49715 : 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 49715 : if (ns->omp_target_seen
7962 1292 : && (ns->omp_requires & OMP_REQ_TARGET_MASK)
7963 1292 : != (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 49715 : }
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 2244 : gfc_match_omp_target (void)
8274 : {
8275 2244 : 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 468 : gfc_match_omp_target_enter_data (void)
8288 : {
8289 468 : 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 27 : gfc_match_omp_target_parallel (void)
8302 : {
8303 27 : return match_omp (EXEC_OMP_TARGET_PARALLEL,
8304 27 : (OMP_TARGET_CLAUSES | OMP_PARALLEL_CLAUSES)
8305 27 : & ~(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 74 : gfc_match_omp_target_teams (void)
8337 : {
8338 74 : return match_omp (EXEC_OMP_TARGET_TEAMS,
8339 74 : 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 1725 : gfc_match_omp_target_update (void)
8386 : {
8387 1725 : 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 2733 : gfc_match_omp_end_nowait (void)
8816 : {
8817 2733 : bool nowait = false;
8818 2733 : if (gfc_match ("% nowait") == MATCH_YES)
8819 258 : nowait = true;
8820 2733 : 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 2729 : new_st.op = EXEC_OMP_END_NOWAIT;
8829 2729 : new_st.ext.omp_bool = nowait;
8830 2729 : 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 37142 : oacc_is_loop (gfc_code *code)
8849 : {
8850 37142 : return code->op == EXEC_OACC_PARALLEL_LOOP
8851 : || code->op == EXEC_OACC_KERNELS_LOOP
8852 20087 : || code->op == EXEC_OACC_SERIAL_LOOP
8853 13457 : || code->op == EXEC_OACC_LOOP;
8854 : }
8855 :
8856 : static void
8857 5733 : resolve_scalar_int_expr (gfc_expr *expr, const char *clause)
8858 : {
8859 5733 : if (!gfc_resolve_expr (expr)
8860 5733 : || expr->ts.type != BT_INTEGER
8861 11395 : || expr->rank != 0)
8862 89 : gfc_error ("%s clause at %L requires a scalar INTEGER expression",
8863 : clause, &expr->where);
8864 5733 : }
8865 :
8866 : static void
8867 3946 : resolve_positive_int_expr (gfc_expr *expr, const char *clause)
8868 : {
8869 3946 : resolve_scalar_int_expr (expr, clause);
8870 3946 : if (expr->expr_type == EXPR_CONSTANT
8871 3525 : && expr->ts.type == BT_INTEGER
8872 3492 : && 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 3946 : }
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 : /* Resolve the OpenMP ALLOCATE clauses. */
9268 :
9269 : static void
9270 32620 : resolve_omp_allocate_clauses (gfc_code *code, gfc_omp_clauses *omp_clauses,
9271 : gfc_namespace *ns)
9272 : {
9273 32620 : gfc_omp_namelist *n;
9274 32620 : enum gfc_omp_list_type list;
9275 :
9276 32620 : if (!omp_clauses->lists[OMP_LIST_ALLOCATE])
9277 : return;
9278 795 : for (n = omp_clauses->lists[OMP_LIST_ALLOCATE]; n; n = n->next)
9279 : {
9280 515 : if (n->u2.allocator
9281 515 : && (!gfc_resolve_expr (n->u2.allocator)
9282 290 : || n->u2.allocator->ts.type != BT_INTEGER
9283 288 : || n->u2.allocator->rank != 0
9284 287 : || n->u2.allocator->ts.kind != gfc_c_intptr_kind))
9285 : {
9286 8 : gfc_error ("Expected integer expression of the "
9287 : "%<omp_allocator_handle_kind%> kind at %L",
9288 8 : &n->u2.allocator->where);
9289 28 : break;
9290 : }
9291 507 : if (!n->u.align)
9292 399 : continue;
9293 108 : HOST_WIDE_INT alignment = 0;
9294 108 : if (!gfc_resolve_expr (n->u.align)
9295 108 : || n->u.align->ts.type != BT_INTEGER
9296 105 : || n->u.align->rank != 0
9297 102 : || n->u.align->expr_type != EXPR_CONSTANT
9298 99 : || gfc_extract_hwi (n->u.align, &alignment)
9299 99 : || alignment <= 0
9300 207 : || !pow2p_hwi (alignment))
9301 : {
9302 12 : gfc_error ("ALIGN requires a scalar positive constant integer "
9303 : "alignment expression at %L that is a power of two",
9304 12 : &n->u.align->where);
9305 12 : break;
9306 : }
9307 : }
9308 :
9309 : /* Check for 2 things here.
9310 : 1. There is no duplication of variable in allocate clause.
9311 : 2. Variable in allocate clause are also present in some
9312 : privatization clase (non-composite case). */
9313 815 : for (n = omp_clauses->lists[OMP_LIST_ALLOCATE]; n; n = n->next)
9314 515 : if (n->sym)
9315 489 : n->sym->mark = 0;
9316 :
9317 : gfc_omp_namelist *prev = NULL;
9318 815 : for (n = omp_clauses->lists[OMP_LIST_ALLOCATE]; n; )
9319 : {
9320 515 : if (n->sym == NULL)
9321 : {
9322 26 : n = n->next;
9323 26 : continue;
9324 : }
9325 489 : if (n->sym->mark == 1)
9326 : {
9327 3 : gfc_warning (OPT_Wopenmp, "%qs appears more than once in "
9328 : "%<allocate%> at %L" , n->sym->name, &n->where);
9329 : /* We have already seen this variable so it is a duplicate.
9330 : Remove it. */
9331 3 : if (prev != NULL && prev->next == n)
9332 : {
9333 3 : prev->next = n->next;
9334 3 : n->next = NULL;
9335 3 : gfc_free_omp_namelist (n, OMP_LIST_ALLOCATE);
9336 3 : n = prev->next;
9337 : }
9338 3 : continue;
9339 : }
9340 486 : n->sym->mark = 1;
9341 486 : prev = n;
9342 486 : n = n->next;
9343 : }
9344 :
9345 : /* Non-composite constructs. */
9346 300 : if (code && code->op < EXEC_OMP_DO_SIMD)
9347 : {
9348 4760 : for (list = OMP_LIST_FIRST; list < OMP_LIST_NUM;
9349 4641 : list = gfc_omp_list_type (list + 1))
9350 4641 : switch (list)
9351 : {
9352 1071 : case OMP_LIST_PRIVATE:
9353 1071 : case OMP_LIST_FIRSTPRIVATE:
9354 1071 : case OMP_LIST_LASTPRIVATE:
9355 1071 : case OMP_LIST_REDUCTION:
9356 1071 : case OMP_LIST_REDUCTION_INSCAN:
9357 1071 : case OMP_LIST_REDUCTION_TASK:
9358 1071 : case OMP_LIST_IN_REDUCTION:
9359 1071 : case OMP_LIST_TASK_REDUCTION:
9360 1071 : case OMP_LIST_LINEAR:
9361 1370 : for (n = omp_clauses->lists[list]; n; n = n->next)
9362 299 : n->sym->mark = 0;
9363 : break;
9364 : default:
9365 : break;
9366 : }
9367 :
9368 410 : for (n = omp_clauses->lists[OMP_LIST_ALLOCATE]; n; n = n->next)
9369 291 : if (n->sym->mark == 1)
9370 4 : gfc_error ("%qs specified in %<allocate%> clause at %L but not "
9371 : "in an explicit privatization clause",
9372 : n->sym->name, &n->where);
9373 : }
9374 71 : if (!(code
9375 300 : && (code->op == EXEC_OMP_ALLOCATORS || code->op == EXEC_OMP_ALLOCATE)
9376 73 : && code->block
9377 72 : && code->block->next
9378 71 : && code->block->next->op == EXEC_ALLOCATE))
9379 232 : return;
9380 :
9381 68 : if (code->op == EXEC_OMP_ALLOCATE)
9382 49 : gfc_warning (OPT_Wdeprecated_openmp,
9383 : "The use of one or more %<allocate%> directives with "
9384 : "an associated %<allocate%> statement at %L is "
9385 : "deprecated since OpenMP 5.2, use an %<allocators%> "
9386 : "directive", &code->loc);
9387 68 : gfc_alloc *a;
9388 68 : gfc_omp_namelist *n_null = NULL;
9389 68 : bool missing_allocator = false;
9390 68 : gfc_symbol *missing_allocator_sym = NULL;
9391 161 : for (n = omp_clauses->lists[OMP_LIST_ALLOCATE]; n; n = n->next)
9392 : {
9393 93 : if (n->u2.allocator == NULL)
9394 : {
9395 77 : if (!missing_allocator_sym)
9396 59 : missing_allocator_sym = n->sym;
9397 : missing_allocator = true;
9398 : }
9399 93 : if (n->sym == NULL)
9400 : {
9401 26 : n_null = n;
9402 26 : continue;
9403 : }
9404 67 : if (n->sym->attr.codimension)
9405 2 : gfc_error ("Unexpected coarray %qs in %<allocate%> at %L",
9406 : n->sym->name, &n->where);
9407 103 : for (a = code->block->next->ext.alloc.list; a; a = a->next)
9408 101 : if (a->expr->expr_type == EXPR_VARIABLE
9409 101 : && a->expr->symtree->n.sym == n->sym)
9410 : {
9411 65 : gfc_ref *ref;
9412 82 : for (ref = a->expr->ref; ref; ref = ref->next)
9413 17 : if (ref->type == REF_COMPONENT)
9414 : break;
9415 : if (ref == NULL)
9416 : break;
9417 : }
9418 67 : if (a == NULL)
9419 2 : gfc_error ("%qs specified in %<allocate%> at %L but not "
9420 : "in the associated ALLOCATE statement",
9421 2 : n->sym->name, &n->where);
9422 : }
9423 : /* If there is an ALLOCATE directive without list argument, a
9424 : namelist with its allocator/align clauses and n->sym = NULL is
9425 : created during parsing; here, we add all not otherwise specified
9426 : items from the Fortran allocate to that list.
9427 : For an ALLOCATORS directive, not listed items use the normal
9428 : Fortran way.
9429 : The behavior of an ALLOCATE directive that does not list all
9430 : arguments but there is no directive without list argument is not
9431 : well specified. Thus, we reject such code below. In OpenMP 5.2
9432 : the executable ALLOCATE directive is deprecated and in 6.0
9433 : deleted such that no spec clarification is to be expected. */
9434 125 : for (a = code->block->next->ext.alloc.list; a; a = a->next)
9435 89 : if (a->expr->expr_type == EXPR_VARIABLE)
9436 : {
9437 154 : for (n = omp_clauses->lists[OMP_LIST_ALLOCATE]; n; n = n->next)
9438 122 : if (a->expr->symtree->n.sym == n->sym)
9439 : {
9440 57 : gfc_ref *ref;
9441 72 : for (ref = a->expr->ref; ref; ref = ref->next)
9442 15 : if (ref->type == REF_COMPONENT)
9443 : break;
9444 : if (ref == NULL)
9445 : break;
9446 : }
9447 89 : if (n == NULL && n_null == NULL)
9448 : {
9449 : /* OK for ALLOCATORS but for ALLOCATE: Unspecified whether
9450 : that should use the default allocator of OpenMP or the
9451 : Fortran allocator. Thus, just reject it. */
9452 7 : if (code->op == EXEC_OMP_ALLOCATE)
9453 1 : gfc_error ("%qs listed in %<allocate%> statement at %L "
9454 : "but it is neither explicitly in listed in "
9455 : "the %<!$OMP ALLOCATE%> directive nor exists"
9456 : " a directive without argument list",
9457 1 : a->expr->symtree->n.sym->name,
9458 : &a->expr->where);
9459 : break;
9460 : }
9461 82 : if (n == NULL)
9462 : {
9463 25 : if (a->expr->symtree->n.sym->attr.codimension)
9464 1 : gfc_error ("Unexpected coarray %qs in %<allocate%> at "
9465 : "%L, implicitly listed in %<!$OMP ALLOCATE%>"
9466 : " at %L", a->expr->symtree->n.sym->name,
9467 : &a->expr->where, &n_null->where);
9468 : break;
9469 : }
9470 : }
9471 68 : gfc_namespace *prog_unit = ns;
9472 87 : while (prog_unit->parent)
9473 : prog_unit = prog_unit->parent;
9474 : gfc_namespace *fn_ns = ns;
9475 72 : while (fn_ns)
9476 : {
9477 70 : if (ns->proc_name
9478 70 : && (ns->proc_name->attr.subroutine
9479 6 : || ns->proc_name->attr.function))
9480 : break;
9481 4 : fn_ns = fn_ns->parent;
9482 : }
9483 68 : if (missing_allocator
9484 58 : && !(prog_unit->omp_requires & OMP_REQ_DYNAMIC_ALLOCATORS)
9485 58 : && ((fn_ns && fn_ns->proc_name->attr.omp_declare_target)
9486 55 : || omp_clauses->contained_in_target_construct))
9487 : {
9488 6 : if (code->op == EXEC_OMP_ALLOCATORS)
9489 2 : gfc_error ("ALLOCATORS directive at %L inside a target region "
9490 : "must specify an ALLOCATOR modifier for %qs",
9491 : &code->loc, missing_allocator_sym->name);
9492 4 : else if (missing_allocator_sym)
9493 2 : gfc_error ("ALLOCATE directive at %L inside a target region "
9494 : "must specify an ALLOCATOR clause for %qs",
9495 : &code->loc, missing_allocator_sym->name);
9496 : else
9497 2 : gfc_error ("ALLOCATE directive at %L inside a target region "
9498 : "must specify an ALLOCATOR clause", &code->loc);
9499 : }
9500 : }
9501 :
9502 :
9503 : /* Diagnose list items that appear multiple times in OpenMP or OpenACC clauses,
9504 : unless permitted by the specification. */
9505 :
9506 : static void
9507 32620 : check_omp_clauses_dupl_syms (gfc_code *code, gfc_omp_clauses *omp_clauses,
9508 : bool openacc)
9509 : {
9510 32620 : gfc_omp_namelist *n;
9511 32620 : enum gfc_omp_list_type list;
9512 :
9513 : /* Check that no symbol appears on multiple clauses, except that
9514 : a symbol can appear on both firstprivate and lastprivate. */
9515 1304800 : for (list = OMP_LIST_FIRST; list < OMP_LIST_NUM;
9516 1272180 : list = gfc_omp_list_type (list + 1))
9517 1318015 : for (n = omp_clauses->lists[list]; n; n = n->next)
9518 : {
9519 45835 : if (!n->sym) /* omp_all_memory. */
9520 47 : continue;
9521 45788 : n->sym->mark = 0;
9522 45788 : n->sym->comp_mark = 0;
9523 45788 : n->sym->data_mark = 0;
9524 45788 : n->sym->dev_mark = 0;
9525 45788 : n->sym->gen_mark = 0;
9526 45788 : n->sym->reduc_mark = 0;
9527 : }
9528 1304800 : for (list = OMP_LIST_FIRST; list < OMP_LIST_NUM;
9529 1272180 : list = gfc_omp_list_type (list + 1))
9530 1272180 : if (list != OMP_LIST_FIRSTPRIVATE
9531 1272180 : && list != OMP_LIST_LASTPRIVATE
9532 1272180 : && list != OMP_LIST_ALIGNED
9533 1174320 : && list != OMP_LIST_DEPEND
9534 1174320 : && list != OMP_LIST_FROM
9535 1109080 : && list != OMP_LIST_TO
9536 1109080 : && list != OMP_LIST_INTEROP
9537 1043840 : && (list != OMP_LIST_REDUCTION || !openacc)
9538 1031215 : && list != OMP_LIST_ALLOCATE)
9539 1033522 : for (n = omp_clauses->lists[list]; n; n = n->next)
9540 : {
9541 34927 : bool component_ref_p = false;
9542 :
9543 : /* Allow multiple components of the same (e.g. derived-type)
9544 : variable here. Duplicate components are detected elsewhere. */
9545 34927 : if (n->expr && n->expr->expr_type == EXPR_VARIABLE)
9546 16007 : for (gfc_ref *ref = n->expr->ref; ref; ref = ref->next)
9547 9737 : if (ref->type == REF_COMPONENT)
9548 3190 : component_ref_p = true;
9549 34927 : if ((list == OMP_LIST_IS_DEVICE_PTR
9550 34927 : || list == OMP_LIST_HAS_DEVICE_ADDR)
9551 313 : && !component_ref_p)
9552 : {
9553 313 : if (n->sym->gen_mark
9554 311 : || n->sym->dev_mark
9555 310 : || n->sym->reduc_mark
9556 310 : || n->sym->mark)
9557 5 : gfc_error ("Symbol %qs present on multiple clauses at %L",
9558 : n->sym->name, &n->where);
9559 : else
9560 308 : n->sym->dev_mark = 1;
9561 : }
9562 34614 : else if ((list == OMP_LIST_USE_DEVICE_PTR
9563 34614 : || list == OMP_LIST_USE_DEVICE_ADDR
9564 34614 : || list == OMP_LIST_PRIVATE
9565 : || list == OMP_LIST_SHARED)
9566 12855 : && !component_ref_p)
9567 : {
9568 12855 : if (n->sym->gen_mark || n->sym->dev_mark || n->sym->reduc_mark)
9569 13 : gfc_error ("Symbol %qs present on multiple clauses at %L",
9570 : n->sym->name, &n->where);
9571 : else
9572 : {
9573 12842 : n->sym->gen_mark = 1;
9574 : /* Set both generic and device bits if we have
9575 : use_device_*(x) or shared(x). This allows us to diagnose
9576 : "map(x) private(x)" below. */
9577 12842 : if (list != OMP_LIST_PRIVATE)
9578 3456 : n->sym->dev_mark = 1;
9579 : }
9580 : }
9581 21759 : else if ((list == OMP_LIST_REDUCTION
9582 21759 : || list == OMP_LIST_REDUCTION_TASK
9583 19299 : || list == OMP_LIST_REDUCTION_INSCAN
9584 19299 : || list == OMP_LIST_IN_REDUCTION
9585 19086 : || list == OMP_LIST_TASK_REDUCTION)
9586 2673 : && !component_ref_p)
9587 : {
9588 : /* Attempts to mix reduction types are diagnosed below. */
9589 2673 : if (n->sym->gen_mark || n->sym->dev_mark)
9590 2 : gfc_error ("Symbol %qs present on multiple clauses at %L",
9591 : n->sym->name, &n->where);
9592 2673 : n->sym->reduc_mark = 1;
9593 : }
9594 19086 : else if ((!component_ref_p && n->sym->comp_mark)
9595 19085 : || (component_ref_p && n->sym->mark))
9596 : {
9597 42 : if (openacc)
9598 3 : gfc_error ("Symbol %qs has mixed component and non-component "
9599 3 : "accesses at %L", n->sym->name, &n->where);
9600 : }
9601 19044 : else if ((openacc || list != OMP_LIST_MAP) && n->sym->mark)
9602 88 : gfc_error ("Symbol %qs present on multiple clauses at %L",
9603 : n->sym->name, &n->where);
9604 : else
9605 : {
9606 18956 : if (component_ref_p)
9607 2466 : n->sym->comp_mark = 1;
9608 : else
9609 16490 : n->sym->mark = 1;
9610 : }
9611 : }
9612 :
9613 : /* Detect specifically the case where we have "map(x) private(x)" and raise
9614 : an error. If we have "...simd" combined directives though, the "private"
9615 : applies to the simd part, so this is permitted though. */
9616 42014 : for (n = omp_clauses->lists[OMP_LIST_PRIVATE]; n; n = n->next)
9617 9394 : if (n->sym->mark
9618 6 : && n->sym->gen_mark
9619 6 : && !n->sym->dev_mark
9620 6 : && !n->sym->reduc_mark
9621 5 : && code->op != EXEC_OMP_TARGET_SIMD
9622 : && code->op != EXEC_OMP_TARGET_PARALLEL_DO_SIMD
9623 : && code->op != EXEC_OMP_TARGET_TEAMS_DISTRIBUTE_SIMD
9624 : && code->op != EXEC_OMP_TARGET_TEAMS_DISTRIBUTE_PARALLEL_DO_SIMD)
9625 1 : gfc_error ("Symbol %qs present on multiple clauses at %L",
9626 : n->sym->name, &n->where);
9627 :
9628 : gcc_assert (OMP_LIST_LASTPRIVATE == OMP_LIST_FIRSTPRIVATE + 1);
9629 97860 : for (list = OMP_LIST_FIRSTPRIVATE; list <= OMP_LIST_LASTPRIVATE;
9630 65240 : list = gfc_omp_list_type (list + 1))
9631 69463 : for (n = omp_clauses->lists[list]; n; n = n->next)
9632 4223 : if (n->sym->data_mark || n->sym->gen_mark || n->sym->dev_mark)
9633 : {
9634 9 : gfc_error ("Symbol %qs present on multiple clauses at %L",
9635 : n->sym->name, &n->where);
9636 9 : n->sym->data_mark = n->sym->gen_mark = n->sym->dev_mark = 0;
9637 : }
9638 4214 : else if (n->sym->mark
9639 18 : && code->op != EXEC_OMP_TARGET_TEAMS
9640 : && code->op != EXEC_OMP_TARGET_TEAMS_DISTRIBUTE
9641 : && code->op != EXEC_OMP_TARGET_TEAMS_LOOP
9642 : && code->op != EXEC_OMP_TARGET_TEAMS_DISTRIBUTE_SIMD
9643 : && code->op != EXEC_OMP_TARGET_TEAMS_DISTRIBUTE_PARALLEL_DO
9644 : && code->op != EXEC_OMP_TARGET_PARALLEL
9645 : && code->op != EXEC_OMP_TARGET_PARALLEL_DO
9646 : && code->op != EXEC_OMP_TARGET_PARALLEL_LOOP
9647 : && code->op != EXEC_OMP_TARGET_PARALLEL_DO_SIMD
9648 : && code->op != EXEC_OMP_TARGET_TEAMS_DISTRIBUTE_PARALLEL_DO_SIMD)
9649 7 : gfc_error ("Symbol %qs present on both data and map clauses "
9650 : "at %L", n->sym->name, &n->where);
9651 :
9652 34535 : for (n = omp_clauses->lists[OMP_LIST_FIRSTPRIVATE]; n; n = n->next)
9653 : {
9654 1915 : if (n->sym->data_mark || n->sym->gen_mark || n->sym->dev_mark)
9655 7 : gfc_error ("Symbol %qs present on multiple clauses at %L",
9656 : n->sym->name, &n->where);
9657 : else
9658 1908 : n->sym->data_mark = 1;
9659 : }
9660 :
9661 : /* LASTPRIVATE clauses. */
9662 34928 : for (n = omp_clauses->lists[OMP_LIST_LASTPRIVATE]; n; n = n->next)
9663 2308 : n->sym->data_mark = 0;
9664 34928 : for (n = omp_clauses->lists[OMP_LIST_LASTPRIVATE]; n; n = n->next)
9665 : {
9666 2308 : if (n->sym->data_mark || n->sym->gen_mark || n->sym->dev_mark)
9667 0 : gfc_error ("Symbol %qs present on multiple clauses at %L",
9668 : n->sym->name, &n->where);
9669 : else
9670 2308 : n->sym->data_mark = 1;
9671 : }
9672 :
9673 : /* ALIGNED clauses. */
9674 32770 : for (n = omp_clauses->lists[OMP_LIST_ALIGNED]; n; n = n->next)
9675 150 : n->sym->mark = 0;
9676 :
9677 32770 : for (n = omp_clauses->lists[OMP_LIST_ALIGNED]; n; n = n->next)
9678 : {
9679 150 : if (n->sym->mark)
9680 0 : gfc_error ("Symbol %qs present on multiple clauses at %L",
9681 : n->sym->name, &n->where);
9682 : else
9683 150 : n->sym->mark = 1;
9684 : }
9685 :
9686 : /* FROM and TO clauses. */
9687 33390 : for (n = omp_clauses->lists[OMP_LIST_TO]; n; n = n->next)
9688 770 : n->sym->mark = 0;
9689 33653 : for (n = omp_clauses->lists[OMP_LIST_FROM]; n; n = n->next)
9690 1033 : if (n->expr == NULL)
9691 1015 : n->sym->mark = 1;
9692 33390 : for (n = omp_clauses->lists[OMP_LIST_TO]; n; n = n->next)
9693 : {
9694 770 : if (n->expr == NULL && n->sym->mark)
9695 0 : gfc_error ("Symbol %qs present on both FROM and TO clauses at %L",
9696 : n->sym->name, &n->where);
9697 : else
9698 770 : n->sym->mark = 1;
9699 : }
9700 :
9701 : /* OpenACC reductions. */
9702 32620 : if (openacc)
9703 : {
9704 14761 : for (n = omp_clauses->lists[OMP_LIST_REDUCTION]; n; n = n->next)
9705 2136 : n->sym->mark = 0;
9706 14761 : for (n = omp_clauses->lists[OMP_LIST_REDUCTION]; n; n = n->next)
9707 : {
9708 2136 : if (n->sym->mark)
9709 0 : gfc_error ("Symbol %qs present on multiple clauses at %L",
9710 : n->sym->name, &n->where);
9711 : else
9712 2136 : n->sym->mark = 1;
9713 :
9714 : /* OpenACC does not support reductions on arrays. */
9715 2136 : if (n->sym->as)
9716 71 : gfc_error ("Array %qs is not permitted in reduction at %L",
9717 : n->sym->name, &n->where);
9718 : }
9719 : }
9720 32620 : }
9721 :
9722 : /* OpenMP/OpenACC: Resolve the list item of a MAP, TO, FROM, CACHE, AFFINITY
9723 : or DEPEND clause. */
9724 :
9725 : static void
9726 20943 : resolve_omp_clauses_aff_dep_map_cache (gfc_code *code,
9727 : gfc_omp_namelist *n,
9728 : const char *name,
9729 : enum gfc_omp_list_type list,
9730 : gfc_omp_clauses *omp_clauses,
9731 : bool openacc)
9732 : {
9733 20943 : gcc_checking_assert (list == OMP_LIST_AFFINITY || list == OMP_LIST_DEPEND
9734 : || list == OMP_LIST_MAP || list == OMP_LIST_TO
9735 : || list == OMP_LIST_FROM || list == OMP_LIST_CACHE);
9736 :
9737 20943 : if (list != OMP_LIST_CACHE && n->u2.ns && !n->u2.ns->resolved)
9738 : {
9739 109 : n->u2.ns->resolved = 1;
9740 109 : for (gfc_symbol *sym = n->u2.ns->omp_affinity_iterators;
9741 235 : sym; sym = sym->tlink)
9742 : {
9743 126 : gfc_constructor *c;
9744 126 : c = gfc_constructor_first (sym->value->value.constructor);
9745 126 : if (!gfc_resolve_expr (c->expr)
9746 126 : || c->expr->ts.type != BT_INTEGER
9747 250 : || c->expr->rank != 0)
9748 2 : gfc_error ("Scalar integer expression for range begin expected "
9749 2 : "at %L", &c->expr->where);
9750 126 : c = gfc_constructor_next (c);
9751 126 : if (!gfc_resolve_expr (c->expr)
9752 126 : || c->expr->ts.type != BT_INTEGER
9753 250 : || c->expr->rank != 0)
9754 2 : gfc_error ("Scalar integer expression for range end expected at %L",
9755 2 : &c->expr->where);
9756 126 : c = gfc_constructor_next (c);
9757 126 : if (c && (!gfc_resolve_expr (c->expr)
9758 16 : || c->expr->ts.type != BT_INTEGER
9759 14 : || c->expr->rank != 0))
9760 2 : gfc_error ("Scalar integer expression for range step expected "
9761 2 : "at %L", &c->expr->where);
9762 124 : else if (c
9763 14 : && c->expr->expr_type == EXPR_CONSTANT
9764 12 : && mpz_cmp_si (c->expr->value.integer, 0) == 0)
9765 2 : gfc_error ("Nonzero range step expected at %L", &c->expr->where);
9766 : }
9767 : }
9768 20842 : if (list == OMP_LIST_DEPEND)
9769 : {
9770 1963 : if (n->u.depend_doacross_op == OMP_DEPEND_SINK_FIRST
9771 : || n->u.depend_doacross_op == OMP_DOACROSS_SINK_FIRST
9772 1963 : || n->u.depend_doacross_op == OMP_DOACROSS_SINK)
9773 : {
9774 1233 : if (omp_clauses->doacross_source)
9775 : {
9776 0 : gfc_error ("Dependence-type SINK used together with SOURCE on "
9777 : "the same construct at %L", &n->where);
9778 0 : omp_clauses->doacross_source = false;
9779 : }
9780 1233 : else if (n->expr)
9781 : {
9782 571 : if (!gfc_resolve_expr (n->expr)
9783 571 : || n->expr->ts.type != BT_INTEGER
9784 1142 : || n->expr->rank != 0)
9785 0 : gfc_error ("SINK addend not a constant integer at %L",
9786 : &n->where);
9787 : }
9788 1233 : if (n->sym == NULL
9789 4 : && (n->expr == NULL
9790 3 : || mpz_cmp_si (n->expr->value.integer, -1) != 0))
9791 2 : gfc_error ("omp_cur_iteration at %L requires %<-1%> as "
9792 : "logical offset", &n->where);
9793 1233 : return;
9794 : }
9795 730 : if (n->u.depend_doacross_op == OMP_DEPEND_DEPOBJ
9796 38 : && !n->expr
9797 22 : && (n->sym->ts.type != BT_INTEGER
9798 22 : || n->sym->ts.kind != 2 * gfc_index_integer_kind
9799 22 : || n->sym->attr.dimension))
9800 0 : gfc_error ("Locator %qs at %L in DEPEND clause of depobj type shall be "
9801 : "a scalar integer of OMP_DEPEND_KIND kind",
9802 : n->sym->name, &n->where);
9803 730 : else if (n->u.depend_doacross_op == OMP_DEPEND_DEPOBJ
9804 38 : && n->expr
9805 746 : && (!gfc_resolve_expr (n->expr)
9806 16 : || n->expr->ts.type != BT_INTEGER
9807 16 : || n->expr->ts.kind != 2 * gfc_index_integer_kind
9808 16 : || n->expr->rank != 0))
9809 0 : gfc_error ("Locator at %L in DEPEND clause of depobj type shall be a "
9810 0 : "scalar integer of OMP_DEPEND_KIND kind", &n->expr->where);
9811 : }
9812 19710 : gfc_ref *lastref = NULL, *lastslice = NULL;
9813 19710 : bool resolved = false;
9814 19710 : if (n->expr)
9815 : {
9816 6539 : lastref = n->expr->ref;
9817 6539 : resolved = gfc_resolve_expr (n->expr);
9818 :
9819 : /* Look through component refs to find last array reference. */
9820 6539 : if (resolved)
9821 : {
9822 16571 : for (gfc_ref *ref = n->expr->ref; ref; ref = ref->next)
9823 10050 : if (ref->type == REF_COMPONENT
9824 : || ref->type == REF_SUBSTRING
9825 10050 : || ref->type == REF_INQUIRY)
9826 : lastref = ref;
9827 6799 : else if (ref->type == REF_ARRAY)
9828 : {
9829 14290 : for (int i = 0; i < ref->u.ar.dimen; i++)
9830 7491 : if (ref->u.ar.dimen_type[i] == DIMEN_RANGE)
9831 6277 : lastslice = ref;
9832 : lastref = ref;
9833 : }
9834 :
9835 : /* The "!$acc cache" directive allows rectangular subarrays to be
9836 : specified, with some restrictions on the form of bounds (not
9837 : implemented). Only raise an error here if we're really sure the
9838 : array isn't contiguous. An expression such as arr(-n:n,-n:n)
9839 : could be contiguous even if it looks like it may not be. */
9840 6521 : if (code
9841 6502 : && code->op != EXEC_OACC_UPDATE
9842 5720 : && list != OMP_LIST_CACHE
9843 5720 : && list != OMP_LIST_DEPEND
9844 5398 : && !gfc_is_simply_contiguous (n->expr, false, true)
9845 1517 : && gfc_is_not_contiguous (n->expr)
9846 6534 : && !(lastslice && (lastslice->next
9847 3 : || lastslice->type != REF_ARRAY)))
9848 3 : gfc_error ("Array is not contiguous at %L", &n->where);
9849 : }
9850 : }
9851 19710 : if (list == OMP_LIST_MAP
9852 17041 : && (n->sym->attr.omp_groupprivate
9853 17040 : || n->sym->attr.omp_declare_target_local))
9854 2 : gfc_error ("%qs argument to MAP clause at %L must not be a device-local "
9855 : "variable, including GROUPPRIVATE", n->sym->name, &n->where);
9856 19710 : if (openacc
9857 19710 : && list == OMP_LIST_MAP
9858 9571 : && (n->u.map.op == OMP_MAP_ATTACH || n->u.map.op == OMP_MAP_DETACH))
9859 : {
9860 117 : symbol_attribute attr;
9861 117 : if (n->expr)
9862 99 : attr = gfc_expr_attr (n->expr);
9863 : else
9864 18 : attr = n->sym->attr;
9865 117 : if (!attr.pointer && !attr.allocatable)
9866 7 : gfc_error ("%qs clause argument must be ALLOCATABLE or a POINTER at %L",
9867 7 : (n->u.map.op == OMP_MAP_ATTACH) ? "attach" : "detach",
9868 : &n->where);
9869 : }
9870 19710 : if (lastref
9871 13183 : || (n->expr && (!resolved || n->expr->expr_type != EXPR_VARIABLE)))
9872 : {
9873 6539 : if (!lastslice && lastref && lastref->type == REF_SUBSTRING)
9874 11 : gfc_error ("Unexpected substring reference in %s clause at %L",
9875 : name, &n->where);
9876 6528 : else if (!lastslice && lastref && lastref->type == REF_INQUIRY)
9877 : {
9878 12 : gcc_assert (lastref->u.i == INQUIRY_RE || lastref->u.i == INQUIRY_IM);
9879 12 : gfc_error ("Unexpected complex-parts designator reference in %s "
9880 : "clause at %L", name, &n->where);
9881 : }
9882 6516 : else if (!resolved
9883 6498 : || n->expr->expr_type != EXPR_VARIABLE
9884 6486 : || (lastslice
9885 5615 : && (lastslice->next || lastslice->type != REF_ARRAY)))
9886 46 : gfc_error ("%qs in %s clause at %L is not a proper array section",
9887 46 : n->sym->name, name, &n->where);
9888 : else if (lastslice)
9889 : {
9890 : int i;
9891 : gfc_array_ref *ar = &lastslice->u.ar;
9892 11873 : for (i = 0; i < ar->dimen; i++)
9893 6275 : if (ar->stride[i] && code && code->op != EXEC_OACC_UPDATE)
9894 : {
9895 1 : gfc_error ("Stride should not be specified for array section "
9896 : "in %s clause at %L", name, &n->where);
9897 1 : break;
9898 : }
9899 6274 : else if (ar->dimen_type[i] != DIMEN_ELEMENT
9900 6274 : && ar->dimen_type[i] != DIMEN_RANGE)
9901 : {
9902 0 : gfc_error ("%qs in %s clause at %L is not a proper array "
9903 0 : "section", n->sym->name, name, &n->where);
9904 0 : break;
9905 : }
9906 6274 : else if ((list == OMP_LIST_DEPEND || list == OMP_LIST_AFFINITY)
9907 161 : && ar->start[i]
9908 133 : && ar->start[i]->expr_type == EXPR_CONSTANT
9909 97 : && ar->end[i]
9910 72 : && ar->end[i]->expr_type == EXPR_CONSTANT
9911 72 : && mpz_cmp (ar->start[i]->value.integer,
9912 72 : ar->end[i]->value.integer) > 0)
9913 : {
9914 0 : gfc_error ("%qs in %s clause at %L is a zero size array "
9915 0 : "section", n->sym->name,
9916 : list == OMP_LIST_DEPEND ? "DEPEND" : "AFFINITY",
9917 : &n->where);
9918 0 : break;
9919 : }
9920 : }
9921 : }
9922 13171 : else if (openacc)
9923 : {
9924 5915 : if (list == OMP_LIST_MAP && n->u.map.op == OMP_MAP_FORCE_DEVICEPTR)
9925 65 : resolve_oacc_deviceptr_clause (n->sym, n->where, name);
9926 : else
9927 5850 : resolve_oacc_data_clauses (n->sym, n->where, name);
9928 : }
9929 7256 : else if (list != OMP_LIST_DEPEND
9930 6763 : && n->sym->as
9931 3339 : && n->sym->as->type == AS_ASSUMED_SIZE)
9932 5 : gfc_error ("Assumed size array %qs in %s clause at %L",
9933 : n->sym->name, name, &n->where);
9934 19710 : if (code && list == OMP_LIST_MAP && !openacc)
9935 7432 : switch (code->op)
9936 : {
9937 6157 : case EXEC_OMP_TARGET:
9938 6157 : case EXEC_OMP_TARGET_PARALLEL:
9939 6157 : case EXEC_OMP_TARGET_PARALLEL_DO:
9940 6157 : case EXEC_OMP_TARGET_PARALLEL_DO_SIMD:
9941 6157 : case EXEC_OMP_TARGET_PARALLEL_LOOP:
9942 6157 : case EXEC_OMP_TARGET_SIMD:
9943 6157 : case EXEC_OMP_TARGET_TEAMS:
9944 6157 : case EXEC_OMP_TARGET_TEAMS_DISTRIBUTE:
9945 6157 : case EXEC_OMP_TARGET_TEAMS_DISTRIBUTE_PARALLEL_DO:
9946 6157 : case EXEC_OMP_TARGET_TEAMS_DISTRIBUTE_PARALLEL_DO_SIMD:
9947 6157 : case EXEC_OMP_TARGET_TEAMS_DISTRIBUTE_SIMD:
9948 6157 : case EXEC_OMP_TARGET_TEAMS_LOOP:
9949 6157 : case EXEC_OMP_TARGET_DATA:
9950 6157 : switch (n->u.map.op)
9951 : {
9952 : case OMP_MAP_TO:
9953 : case OMP_MAP_ALWAYS_TO:
9954 : case OMP_MAP_PRESENT_TO:
9955 : case OMP_MAP_ALWAYS_PRESENT_TO:
9956 : case OMP_MAP_FROM:
9957 : case OMP_MAP_ALWAYS_FROM:
9958 : case OMP_MAP_PRESENT_FROM:
9959 : case OMP_MAP_ALWAYS_PRESENT_FROM:
9960 : case OMP_MAP_TOFROM:
9961 : case OMP_MAP_ALWAYS_TOFROM:
9962 : case OMP_MAP_PRESENT_TOFROM:
9963 : case OMP_MAP_ALWAYS_PRESENT_TOFROM:
9964 : case OMP_MAP_ALLOC:
9965 : case OMP_MAP_PRESENT_ALLOC:
9966 : break;
9967 2 : default:
9968 2 : gfc_error ("TARGET%s with map-type other than TO, "
9969 : "FROM, TOFROM, or ALLOC on MAP clause "
9970 : "at %L",
9971 : code->op == EXEC_OMP_TARGET_DATA
9972 : ? " DATA" : "", &n->where);
9973 2 : break;
9974 : }
9975 : break;
9976 697 : case EXEC_OMP_TARGET_ENTER_DATA:
9977 697 : switch (n->u.map.op)
9978 : {
9979 : case OMP_MAP_TO:
9980 : case OMP_MAP_ALWAYS_TO:
9981 : case OMP_MAP_PRESENT_TO:
9982 : case OMP_MAP_ALWAYS_PRESENT_TO:
9983 : case OMP_MAP_ALLOC:
9984 : case OMP_MAP_PRESENT_ALLOC:
9985 : break;
9986 178 : case OMP_MAP_TOFROM:
9987 178 : n->u.map.op = OMP_MAP_TO;
9988 178 : break;
9989 3 : case OMP_MAP_ALWAYS_TOFROM:
9990 3 : n->u.map.op = OMP_MAP_ALWAYS_TO;
9991 3 : break;
9992 2 : case OMP_MAP_PRESENT_TOFROM:
9993 2 : n->u.map.op = OMP_MAP_PRESENT_TO;
9994 2 : break;
9995 2 : case OMP_MAP_ALWAYS_PRESENT_TOFROM:
9996 2 : n->u.map.op = OMP_MAP_ALWAYS_PRESENT_TO;
9997 2 : break;
9998 2 : default:
9999 2 : gfc_error ("TARGET ENTER DATA with map-type other "
10000 : "than TO, TOFROM or ALLOC on MAP clause "
10001 : "at %L", &n->where);
10002 2 : break;
10003 : }
10004 : break;
10005 578 : case EXEC_OMP_TARGET_EXIT_DATA:
10006 578 : switch (n->u.map.op)
10007 : {
10008 : case OMP_MAP_FROM:
10009 : case OMP_MAP_ALWAYS_FROM:
10010 : case OMP_MAP_PRESENT_FROM:
10011 : case OMP_MAP_ALWAYS_PRESENT_FROM:
10012 : case OMP_MAP_RELEASE:
10013 : case OMP_MAP_DELETE:
10014 : break;
10015 132 : case OMP_MAP_TOFROM:
10016 132 : n->u.map.op = OMP_MAP_FROM;
10017 132 : break;
10018 1 : case OMP_MAP_ALWAYS_TOFROM:
10019 1 : n->u.map.op = OMP_MAP_ALWAYS_FROM;
10020 1 : break;
10021 0 : case OMP_MAP_PRESENT_TOFROM:
10022 0 : n->u.map.op = OMP_MAP_PRESENT_FROM;
10023 0 : break;
10024 0 : case OMP_MAP_ALWAYS_PRESENT_TOFROM:
10025 0 : n->u.map.op = OMP_MAP_ALWAYS_PRESENT_FROM;
10026 0 : break;
10027 2 : default:
10028 2 : gfc_error ("TARGET EXIT DATA with map-type other "
10029 : "than FROM, TOFROM, RELEASE, or DELETE on "
10030 : "MAP clause at %L", &n->where);
10031 2 : break;
10032 : }
10033 : break;
10034 : default:
10035 : break;
10036 : }
10037 19710 : if (list == OMP_LIST_MAP || list == OMP_LIST_TO || list == OMP_LIST_FROM)
10038 : {
10039 18844 : gfc_typespec *ts = n->expr ? &n->expr->ts : &n->sym->ts;
10040 :
10041 18844 : if (ts->type == BT_DERIVED || ts->type == BT_CLASS)
10042 : {
10043 9 : const char *mapper_id = (n->u3.udm
10044 999 : ? n->u3.udm->requested_mapper_id : "");
10045 999 : gfc_omp_udm *udm = gfc_find_omp_udm (gfc_current_ns, mapper_id, ts);
10046 999 : if (mapper_id[0] != '\0' && !udm)
10047 1 : gfc_error ("User-defined mapper %qs not found at %L",
10048 : mapper_id, &n->where);
10049 995 : else if (udm)
10050 : {
10051 26 : if (!n->u3.udm)
10052 : {
10053 18 : gcc_assert (mapper_id[0] == '\0');
10054 18 : n->u3.udm = gfc_get_omp_namelist_udm ();
10055 18 : n->u3.udm->requested_mapper_id = mapper_id;
10056 : }
10057 26 : n->u3.udm->resolved_udm = udm;
10058 : }
10059 : }
10060 : }
10061 :
10062 19710 : if (list != OMP_LIST_DEPEND)
10063 : {
10064 18980 : n->sym->attr.referenced = 1;
10065 18980 : if (n->sym->attr.threadprivate)
10066 1 : gfc_error ("THREADPRIVATE object %qs in %s clause at %L",
10067 : n->sym->name, name, &n->where);
10068 18980 : if (n->sym->attr.cray_pointee)
10069 14 : gfc_error ("Cray pointee %qs in %s clause at %L",
10070 : n->sym->name, name, &n->where);
10071 : }
10072 : }
10073 :
10074 : /* OpenMP directive resolving routines. */
10075 :
10076 : static void
10077 32620 : resolve_omp_clauses (gfc_code *code, gfc_omp_clauses *omp_clauses,
10078 : gfc_namespace *ns, bool openacc = false)
10079 : {
10080 32620 : gfc_omp_namelist *n, *last;
10081 32620 : gfc_expr_list *el;
10082 32620 : enum gfc_omp_list_type list;
10083 32620 : int ifc;
10084 32620 : bool if_without_mod = false;
10085 32620 : gfc_omp_linear_op linear_op = OMP_LINEAR_DEFAULT;
10086 32620 : static const char *clause_names[]
10087 : = { "PRIVATE", "FIRSTPRIVATE", "LASTPRIVATE", "COPYPRIVATE", "SHARED",
10088 : "COPYIN", "UNIFORM", "AFFINITY", "ALIGNED", "LINEAR", "DEPEND", "MAP",
10089 : "TO", "FROM", "INCLUSIVE", "EXCLUSIVE",
10090 : "REDUCTION", "REDUCTION" /*inscan*/, "REDUCTION" /*task*/,
10091 : "IN_REDUCTION", "TASK_REDUCTION",
10092 : "DEVICE_RESIDENT", "LINK", "LOCAL", "USE_DEVICE",
10093 : "CACHE", "IS_DEVICE_PTR", "USE_DEVICE_PTR", "USE_DEVICE_ADDR",
10094 : "NONTEMPORAL", "ALLOCATE", "HAS_DEVICE_ADDR", "ENTER",
10095 : "USES_ALLOCATORS", "INIT", "USE", "DESTROY", "INTEROP", "ADJUST_ARGS" };
10096 32620 : STATIC_ASSERT (ARRAY_SIZE (clause_names) == OMP_LIST_NUM);
10097 :
10098 32620 : if (omp_clauses == NULL)
10099 : return;
10100 :
10101 32620 : if (ns == NULL)
10102 32176 : ns = gfc_current_ns;
10103 :
10104 32620 : check_omp_clauses_dupl_syms (code, omp_clauses, openacc);
10105 :
10106 32620 : if (omp_clauses->orderedc && omp_clauses->orderedc < omp_clauses->collapse)
10107 0 : gfc_error ("ORDERED clause parameter is less than COLLAPSE at %L",
10108 : &code->loc);
10109 32620 : if (omp_clauses->order_concurrent && omp_clauses->ordered)
10110 4 : gfc_error ("ORDER clause must not be used together with ORDERED at %L",
10111 : &code->loc);
10112 32620 : if (omp_clauses->if_expr)
10113 : {
10114 1190 : gfc_expr *expr = omp_clauses->if_expr;
10115 1190 : if (!gfc_resolve_expr (expr)
10116 1190 : || expr->ts.type != BT_LOGICAL || expr->rank != 0)
10117 16 : gfc_error ("IF clause at %L requires a scalar LOGICAL expression",
10118 : &expr->where);
10119 : if_without_mod = true;
10120 : }
10121 358820 : for (ifc = 0; ifc < OMP_IF_LAST; ifc++)
10122 326200 : if (omp_clauses->if_exprs[ifc])
10123 : {
10124 137 : gfc_expr *expr = omp_clauses->if_exprs[ifc];
10125 137 : bool ok = true;
10126 137 : if (!gfc_resolve_expr (expr)
10127 137 : || expr->ts.type != BT_LOGICAL || expr->rank != 0)
10128 0 : gfc_error ("IF clause at %L requires a scalar LOGICAL expression",
10129 : &expr->where);
10130 137 : else if (if_without_mod)
10131 : {
10132 1 : gfc_error ("IF clause without modifier at %L used together with "
10133 : "IF clauses with modifiers",
10134 1 : &omp_clauses->if_expr->where);
10135 1 : if_without_mod = false;
10136 : }
10137 : else
10138 136 : switch (code->op)
10139 : {
10140 13 : case EXEC_OMP_CANCEL:
10141 13 : ok = ifc == OMP_IF_CANCEL;
10142 13 : break;
10143 :
10144 16 : case EXEC_OMP_PARALLEL:
10145 16 : case EXEC_OMP_PARALLEL_DO:
10146 16 : case EXEC_OMP_PARALLEL_LOOP:
10147 16 : case EXEC_OMP_PARALLEL_MASKED:
10148 16 : case EXEC_OMP_PARALLEL_MASTER:
10149 16 : case EXEC_OMP_PARALLEL_SECTIONS:
10150 16 : case EXEC_OMP_PARALLEL_WORKSHARE:
10151 16 : case EXEC_OMP_DISTRIBUTE_PARALLEL_DO:
10152 16 : case EXEC_OMP_TEAMS_DISTRIBUTE_PARALLEL_DO:
10153 16 : ok = ifc == OMP_IF_PARALLEL;
10154 16 : break;
10155 :
10156 28 : case EXEC_OMP_PARALLEL_DO_SIMD:
10157 28 : case EXEC_OMP_DISTRIBUTE_PARALLEL_DO_SIMD:
10158 28 : case EXEC_OMP_TEAMS_DISTRIBUTE_PARALLEL_DO_SIMD:
10159 28 : ok = ifc == OMP_IF_PARALLEL || ifc == OMP_IF_SIMD;
10160 28 : break;
10161 :
10162 8 : case EXEC_OMP_PARALLEL_MASKED_TASKLOOP:
10163 8 : case EXEC_OMP_PARALLEL_MASTER_TASKLOOP:
10164 8 : ok = ifc == OMP_IF_PARALLEL || ifc == OMP_IF_TASKLOOP;
10165 8 : break;
10166 :
10167 12 : case EXEC_OMP_PARALLEL_MASKED_TASKLOOP_SIMD:
10168 12 : case EXEC_OMP_PARALLEL_MASTER_TASKLOOP_SIMD:
10169 12 : ok = (ifc == OMP_IF_PARALLEL
10170 12 : || ifc == OMP_IF_TASKLOOP
10171 : || ifc == OMP_IF_SIMD);
10172 : break;
10173 :
10174 0 : case EXEC_OMP_SIMD:
10175 0 : case EXEC_OMP_DO_SIMD:
10176 0 : case EXEC_OMP_DISTRIBUTE_SIMD:
10177 0 : case EXEC_OMP_TEAMS_DISTRIBUTE_SIMD:
10178 0 : ok = ifc == OMP_IF_SIMD;
10179 0 : break;
10180 :
10181 1 : case EXEC_OMP_TASK:
10182 1 : ok = ifc == OMP_IF_TASK;
10183 1 : break;
10184 :
10185 5 : case EXEC_OMP_TASKLOOP:
10186 5 : case EXEC_OMP_MASKED_TASKLOOP:
10187 5 : case EXEC_OMP_MASTER_TASKLOOP:
10188 5 : ok = ifc == OMP_IF_TASKLOOP;
10189 5 : break;
10190 :
10191 20 : case EXEC_OMP_TASKLOOP_SIMD:
10192 20 : case EXEC_OMP_MASKED_TASKLOOP_SIMD:
10193 20 : case EXEC_OMP_MASTER_TASKLOOP_SIMD:
10194 20 : ok = ifc == OMP_IF_TASKLOOP || ifc == OMP_IF_SIMD;
10195 20 : break;
10196 :
10197 5 : case EXEC_OMP_TARGET:
10198 5 : case EXEC_OMP_TARGET_TEAMS:
10199 5 : case EXEC_OMP_TARGET_TEAMS_DISTRIBUTE:
10200 5 : case EXEC_OMP_TARGET_TEAMS_LOOP:
10201 5 : ok = ifc == OMP_IF_TARGET;
10202 5 : break;
10203 :
10204 4 : case EXEC_OMP_TARGET_TEAMS_DISTRIBUTE_SIMD:
10205 4 : case EXEC_OMP_TARGET_SIMD:
10206 4 : ok = ifc == OMP_IF_TARGET || ifc == OMP_IF_SIMD;
10207 4 : break;
10208 :
10209 1 : case EXEC_OMP_TARGET_DATA:
10210 1 : ok = ifc == OMP_IF_TARGET_DATA;
10211 1 : break;
10212 :
10213 1 : case EXEC_OMP_TARGET_UPDATE:
10214 1 : ok = ifc == OMP_IF_TARGET_UPDATE;
10215 1 : break;
10216 :
10217 1 : case EXEC_OMP_TARGET_ENTER_DATA:
10218 1 : ok = ifc == OMP_IF_TARGET_ENTER_DATA;
10219 1 : break;
10220 :
10221 1 : case EXEC_OMP_TARGET_EXIT_DATA:
10222 1 : ok = ifc == OMP_IF_TARGET_EXIT_DATA;
10223 1 : break;
10224 :
10225 10 : case EXEC_OMP_TARGET_TEAMS_DISTRIBUTE_PARALLEL_DO:
10226 10 : case EXEC_OMP_TARGET_PARALLEL:
10227 10 : case EXEC_OMP_TARGET_PARALLEL_DO:
10228 10 : case EXEC_OMP_TARGET_PARALLEL_LOOP:
10229 10 : ok = ifc == OMP_IF_TARGET || ifc == OMP_IF_PARALLEL;
10230 10 : break;
10231 :
10232 10 : case EXEC_OMP_TARGET_PARALLEL_DO_SIMD:
10233 10 : case EXEC_OMP_TARGET_TEAMS_DISTRIBUTE_PARALLEL_DO_SIMD:
10234 10 : ok = (ifc == OMP_IF_TARGET
10235 10 : || ifc == OMP_IF_PARALLEL
10236 : || ifc == OMP_IF_SIMD);
10237 : break;
10238 :
10239 : default:
10240 : ok = false;
10241 : break;
10242 : }
10243 115 : if (!ok)
10244 : {
10245 2 : static const char *ifs[] = {
10246 : "CANCEL",
10247 : "PARALLEL",
10248 : "SIMD",
10249 : "TASK",
10250 : "TASKLOOP",
10251 : "TARGET",
10252 : "TARGET DATA",
10253 : "TARGET UPDATE",
10254 : "TARGET ENTER DATA",
10255 : "TARGET EXIT DATA"
10256 : };
10257 2 : gfc_error ("IF clause modifier %s at %L not appropriate for "
10258 : "the current OpenMP construct", ifs[ifc], &expr->where);
10259 : }
10260 : }
10261 :
10262 32620 : if (omp_clauses->self_expr)
10263 : {
10264 177 : gfc_expr *expr = omp_clauses->self_expr;
10265 177 : if (!gfc_resolve_expr (expr)
10266 177 : || expr->ts.type != BT_LOGICAL || expr->rank != 0)
10267 6 : gfc_error ("SELF clause at %L requires a scalar LOGICAL expression",
10268 : &expr->where);
10269 : }
10270 :
10271 32620 : if (omp_clauses->final_expr)
10272 : {
10273 64 : gfc_expr *expr = omp_clauses->final_expr;
10274 64 : if (!gfc_resolve_expr (expr)
10275 64 : || expr->ts.type != BT_LOGICAL || expr->rank != 0)
10276 0 : gfc_error ("FINAL clause at %L requires a scalar LOGICAL expression",
10277 : &expr->where);
10278 : }
10279 32620 : if (omp_clauses->novariants)
10280 : {
10281 9 : gfc_expr *expr = omp_clauses->novariants;
10282 18 : if (!gfc_resolve_expr (expr) || expr->ts.type != BT_LOGICAL
10283 17 : || expr->rank != 0)
10284 1 : gfc_error (
10285 : "NOVARIANTS clause at %L requires a scalar LOGICAL expression",
10286 : &expr->where);
10287 32620 : if_without_mod = true;
10288 : }
10289 32620 : if (omp_clauses->nocontext)
10290 : {
10291 12 : gfc_expr *expr = omp_clauses->nocontext;
10292 24 : if (!gfc_resolve_expr (expr) || expr->ts.type != BT_LOGICAL
10293 23 : || expr->rank != 0)
10294 1 : gfc_error (
10295 : "NOCONTEXT clause at %L requires a scalar LOGICAL expression",
10296 : &expr->where);
10297 32620 : if_without_mod = true;
10298 : }
10299 32620 : if (omp_clauses->num_threads)
10300 964 : resolve_positive_int_expr (omp_clauses->num_threads, "NUM_THREADS");
10301 32620 : if (omp_clauses->dyn_groupprivate)
10302 10 : resolve_nonnegative_int_expr (omp_clauses->dyn_groupprivate,
10303 : "DYN_GROUPPRIVATE");
10304 32620 : if (omp_clauses->chunk_size)
10305 : {
10306 510 : gfc_expr *expr = omp_clauses->chunk_size;
10307 510 : if (!gfc_resolve_expr (expr)
10308 510 : || expr->ts.type != BT_INTEGER || expr->rank != 0)
10309 0 : gfc_error ("SCHEDULE clause's chunk_size at %L requires "
10310 : "a scalar INTEGER expression", &expr->where);
10311 510 : else if (expr->expr_type == EXPR_CONSTANT
10312 : && expr->ts.type == BT_INTEGER
10313 485 : && mpz_sgn (expr->value.integer) <= 0)
10314 2 : gfc_warning (OPT_Wopenmp, "INTEGER expression of SCHEDULE clause's "
10315 : "chunk_size at %L must be positive", &expr->where);
10316 : }
10317 32620 : if (omp_clauses->sched_kind != OMP_SCHED_NONE
10318 891 : && omp_clauses->sched_nonmonotonic)
10319 : {
10320 34 : if (omp_clauses->sched_monotonic)
10321 2 : gfc_error ("Both MONOTONIC and NONMONOTONIC schedule modifiers "
10322 : "specified at %L", &code->loc);
10323 32 : else if (omp_clauses->ordered)
10324 4 : gfc_error ("NONMONOTONIC schedule modifier specified with ORDERED "
10325 : "clause at %L", &code->loc);
10326 : }
10327 :
10328 32620 : if (omp_clauses->depobj
10329 32620 : && (!gfc_resolve_expr (omp_clauses->depobj)
10330 115 : || omp_clauses->depobj->ts.type != BT_INTEGER
10331 114 : || omp_clauses->depobj->ts.kind != 2 * gfc_index_integer_kind
10332 113 : || omp_clauses->depobj->rank != 0))
10333 4 : gfc_error ("DEPOBJ in DEPOBJ construct at %L shall be a scalar integer "
10334 4 : "of OMP_DEPEND_KIND kind", &omp_clauses->depobj->where);
10335 :
10336 : /* Check that list items are variables. */
10337 1304800 : for (list = OMP_LIST_FIRST; list < OMP_LIST_NUM;
10338 1272180 : list = gfc_omp_list_type (list + 1))
10339 1318015 : for (n = omp_clauses->lists[list]; n; n = n->next)
10340 : {
10341 45835 : if (!n->sym) /* omp_all_memory. */
10342 47 : continue;
10343 45788 : if (n->sym->attr.flavor == FL_VARIABLE
10344 277 : || n->sym->attr.proc_pointer
10345 236 : || (!code
10346 0 : && !ns->omp_udm_ns
10347 0 : && (!n->sym->attr.dummy || n->sym->ns != ns)))
10348 : {
10349 45552 : if (!code
10350 302 : && !ns->omp_udm_ns
10351 264 : && (!n->sym->attr.dummy || n->sym->ns != ns))
10352 0 : gfc_error ("Variable %qs is not a dummy argument at %L",
10353 : n->sym->name, &n->where);
10354 45552 : continue;
10355 : }
10356 236 : if (n->sym->attr.flavor == FL_PROCEDURE
10357 153 : && n->sym->result == n->sym
10358 138 : && n->sym->attr.function)
10359 : {
10360 138 : if (ns->proc_name == n->sym
10361 44 : || (ns->parent && ns->parent->proc_name == n->sym))
10362 101 : continue;
10363 37 : if (ns->proc_name->attr.entry_master)
10364 : {
10365 32 : gfc_entry_list *el = ns->entries;
10366 51 : for (; el; el = el->next)
10367 51 : if (el->sym == n->sym)
10368 : break;
10369 32 : if (el)
10370 32 : continue;
10371 : }
10372 5 : if (ns->parent
10373 3 : && ns->parent->proc_name->attr.entry_master)
10374 : {
10375 2 : gfc_entry_list *el = ns->parent->entries;
10376 3 : for (; el; el = el->next)
10377 3 : if (el->sym == n->sym)
10378 : break;
10379 2 : if (el)
10380 2 : continue;
10381 : }
10382 : }
10383 101 : if (list == OMP_LIST_MAP
10384 18 : && n->sym->attr.flavor == FL_PARAMETER)
10385 : {
10386 : /* OpenACC since 3.4 permits for Fortran named constants, but
10387 : permits removing then as optimization is not needed and such
10388 : ignore them. Likewise below for FIRSTPRIVATE. */
10389 12 : if (openacc)
10390 10 : gfc_warning (OPT_Wsurprising, "Clause for object %qs at %L is "
10391 : "ignored as parameters need not be copied",
10392 : n->sym->name, &n->where);
10393 : else
10394 2 : gfc_error ("Object %qs is not a variable at %L; parameters"
10395 : " cannot be and need not be mapped", n->sym->name,
10396 : &n->where);
10397 : }
10398 89 : else if (openacc && n->sym->attr.flavor == FL_PARAMETER)
10399 9 : gfc_warning (OPT_Wsurprising, "Clause for object %qs at %L is ignored"
10400 : " as it is a parameter", n->sym->name, &n->where);
10401 80 : else if (list != OMP_LIST_USES_ALLOCATORS)
10402 30 : gfc_error ("Object %qs is not a variable at %L", n->sym->name,
10403 : &n->where);
10404 : }
10405 :
10406 32620 : if (omp_clauses->lists[OMP_LIST_REDUCTION_INSCAN])
10407 : {
10408 69 : locus *loc = &omp_clauses->lists[OMP_LIST_REDUCTION_INSCAN]->where;
10409 69 : if (code->op != EXEC_OMP_DO
10410 : && code->op != EXEC_OMP_SIMD
10411 : && code->op != EXEC_OMP_DO_SIMD
10412 : && code->op != EXEC_OMP_PARALLEL_DO
10413 : && code->op != EXEC_OMP_PARALLEL_DO_SIMD)
10414 23 : gfc_error ("%<inscan%> REDUCTION clause on construct other than DO, "
10415 : "SIMD, DO SIMD, PARALLEL DO, PARALLEL DO SIMD at %L",
10416 : loc);
10417 69 : if (omp_clauses->ordered)
10418 2 : gfc_error ("ORDERED clause specified together with %<inscan%> "
10419 : "REDUCTION clause at %L", loc);
10420 69 : if (omp_clauses->sched_kind != OMP_SCHED_NONE)
10421 3 : gfc_error ("SCHEDULE clause specified together with %<inscan%> "
10422 : "REDUCTION clause at %L", loc);
10423 : }
10424 :
10425 32620 : if (code
10426 32379 : && code->op == EXEC_OMP_INTEROP
10427 63 : && omp_clauses->lists[OMP_LIST_DEPEND])
10428 : {
10429 12 : if (!omp_clauses->lists[OMP_LIST_INIT]
10430 5 : && !omp_clauses->lists[OMP_LIST_USE]
10431 1 : && !omp_clauses->lists[OMP_LIST_DESTROY])
10432 : {
10433 1 : gfc_error ("DEPEND clause at %L requires action clause with "
10434 : "%<targetsync%> interop-type",
10435 : &omp_clauses->lists[OMP_LIST_DEPEND]->where);
10436 : }
10437 22 : for (n = omp_clauses->lists[OMP_LIST_INIT]; n; n = n->next)
10438 12 : if (!n->u.init.targetsync)
10439 : {
10440 2 : gfc_error ("DEPEND clause at %L requires %<targetsync%> "
10441 : "interop-type, lacking it for %qs at %L",
10442 2 : &omp_clauses->lists[OMP_LIST_DEPEND]->where,
10443 2 : n->sym->name, &n->where);
10444 2 : break;
10445 : }
10446 : }
10447 32379 : if (code && (code->op == EXEC_OMP_INTEROP || code->op == EXEC_OMP_DISPATCH))
10448 1085 : for (list = OMP_LIST_INIT; list <= OMP_LIST_INTEROP;
10449 868 : list = gfc_omp_list_type (list + 1))
10450 1123 : for (n = omp_clauses->lists[list]; n; n = n->next)
10451 : {
10452 255 : if (n->sym->ts.type != BT_INTEGER
10453 252 : || n->sym->ts.kind != gfc_index_integer_kind
10454 248 : || n->sym->attr.dimension
10455 243 : || n->sym->attr.flavor != FL_VARIABLE)
10456 16 : gfc_error ("%qs at %L in %qs clause must be a scalar integer "
10457 : "variable of %<omp_interop_kind%> kind", n->sym->name,
10458 : &n->where, clause_names[list]);
10459 255 : if (list != OMP_LIST_USE && list != OMP_LIST_INTEROP
10460 109 : && n->sym->attr.intent == INTENT_IN)
10461 2 : gfc_error ("%qs at %L in %qs clause must be definable",
10462 : n->sym->name, &n->where, clause_names[list]);
10463 : }
10464 :
10465 32620 : resolve_omp_allocate_clauses (code, omp_clauses, ns);
10466 :
10467 32620 : bool has_inscan = false, has_notinscan = false;
10468 1304800 : for (enum gfc_omp_list_type list = OMP_LIST_FIRST; list < OMP_LIST_NUM;
10469 1272180 : list = gfc_omp_list_type (list + 1))
10470 1272180 : if ((n = omp_clauses->lists[list]) != NULL)
10471 : {
10472 29299 : const char *name = clause_names[list];
10473 :
10474 29299 : switch (list)
10475 : {
10476 : case OMP_LIST_COPYIN:
10477 267 : for (; n != NULL; n = n->next)
10478 : {
10479 170 : if (!n->sym->attr.threadprivate)
10480 0 : gfc_error ("Non-THREADPRIVATE object %qs in COPYIN clause"
10481 : " at %L", n->sym->name, &n->where);
10482 : }
10483 : break;
10484 83 : case OMP_LIST_COPYPRIVATE:
10485 83 : if (omp_clauses->nowait)
10486 6 : gfc_error ("NOWAIT clause must not be used with COPYPRIVATE "
10487 : "clause at %L", &n->where);
10488 376 : for (; n != NULL; n = n->next)
10489 : {
10490 293 : if (n->sym->as && n->sym->as->type == AS_ASSUMED_SIZE)
10491 0 : gfc_error ("Assumed size array %qs in COPYPRIVATE clause "
10492 : "at %L", n->sym->name, &n->where);
10493 293 : if (n->sym->attr.pointer && n->sym->attr.intent == INTENT_IN)
10494 1 : gfc_error ("INTENT(IN) POINTER %qs in COPYPRIVATE clause "
10495 : "at %L", n->sym->name, &n->where);
10496 : }
10497 : break;
10498 : case OMP_LIST_SHARED:
10499 2604 : for (; n != NULL; n = n->next)
10500 : {
10501 1642 : if (n->sym->attr.threadprivate)
10502 0 : gfc_error ("THREADPRIVATE object %qs in SHARED clause at "
10503 : "%L", n->sym->name, &n->where);
10504 1642 : if (n->sym->attr.cray_pointee)
10505 1 : gfc_error ("Cray pointee %qs in SHARED clause at %L",
10506 : n->sym->name, &n->where);
10507 1642 : if (n->sym->attr.associate_var)
10508 8 : gfc_error ("Associate name %qs in SHARED clause at %L",
10509 8 : n->sym->attr.select_type_temporary
10510 4 : ? n->sym->assoc->target->symtree->n.sym->name
10511 : : n->sym->name, &n->where);
10512 1642 : if (omp_clauses->detach
10513 1 : && n->sym == omp_clauses->detach->symtree->n.sym)
10514 1 : gfc_error ("DETACH event handle %qs in SHARED clause at %L",
10515 : n->sym->name, &n->where);
10516 : }
10517 : break;
10518 : case OMP_LIST_ALIGNED:
10519 256 : for (; n != NULL; n = n->next)
10520 : {
10521 150 : if (!n->sym->attr.pointer
10522 45 : && !n->sym->attr.allocatable
10523 30 : && !n->sym->attr.cray_pointer
10524 18 : && (n->sym->ts.type != BT_DERIVED
10525 18 : || (n->sym->ts.u.derived->from_intmod
10526 : != INTMOD_ISO_C_BINDING)
10527 18 : || (n->sym->ts.u.derived->intmod_sym_id
10528 : != ISOCBINDING_PTR)))
10529 0 : gfc_error ("%qs in ALIGNED clause must be POINTER, "
10530 : "ALLOCATABLE, Cray pointer or C_PTR at %L",
10531 : n->sym->name, &n->where);
10532 150 : else if (n->expr)
10533 : {
10534 147 : if (!gfc_resolve_expr (n->expr)
10535 147 : || n->expr->ts.type != BT_INTEGER
10536 146 : || n->expr->rank != 0
10537 146 : || n->expr->expr_type != EXPR_CONSTANT
10538 292 : || mpz_sgn (n->expr->value.integer) <= 0)
10539 4 : gfc_error ("%qs in ALIGNED clause at %L requires a scalar"
10540 : " positive constant integer alignment "
10541 4 : "expression", n->sym->name, &n->where);
10542 : }
10543 : }
10544 : break;
10545 : case OMP_LIST_AFFINITY:
10546 : case OMP_LIST_DEPEND:
10547 : case OMP_LIST_MAP:
10548 : case OMP_LIST_TO:
10549 : case OMP_LIST_FROM:
10550 : case OMP_LIST_CACHE:
10551 33196 : for (; n != NULL; n = n->next)
10552 20943 : resolve_omp_clauses_aff_dep_map_cache (code, n, name, list,
10553 : omp_clauses, openacc);
10554 : break;
10555 : case OMP_LIST_IS_DEVICE_PTR:
10556 : last = NULL;
10557 377 : for (n = omp_clauses->lists[list]; n != NULL; )
10558 : {
10559 257 : if ((n->sym->ts.type != BT_DERIVED
10560 71 : || !n->sym->ts.u.derived->ts.is_iso_c
10561 71 : || (n->sym->ts.u.derived->intmod_sym_id
10562 : != ISOCBINDING_PTR))
10563 187 : && code->op == EXEC_OMP_DISPATCH)
10564 : /* Non-TARGET (i.e. DISPATCH) requires a C_PTR. */
10565 3 : gfc_error ("List item %qs in %s clause at %L must be of "
10566 : "TYPE(C_PTR)", n->sym->name, name, &n->where);
10567 254 : else if (n->sym->ts.type != BT_DERIVED
10568 70 : || !n->sym->ts.u.derived->ts.is_iso_c
10569 70 : || (n->sym->ts.u.derived->intmod_sym_id
10570 : != ISOCBINDING_PTR))
10571 : {
10572 : /* For TARGET, non-C_PTR are deprecated and handled as
10573 : has_device_addr. */
10574 184 : gfc_warning (OPT_Wdeprecated_openmp,
10575 : "Non-C_PTR type argument at %L is deprecated, "
10576 : "use HAS_DEVICE_ADDR", &n->where);
10577 184 : gfc_omp_namelist *n2 = n;
10578 184 : n = n->next;
10579 184 : if (last)
10580 0 : last->next = n;
10581 : else
10582 184 : omp_clauses->lists[list] = n;
10583 184 : n2->next = omp_clauses->lists[OMP_LIST_HAS_DEVICE_ADDR];
10584 184 : omp_clauses->lists[OMP_LIST_HAS_DEVICE_ADDR] = n2;
10585 184 : continue;
10586 184 : }
10587 73 : last = n;
10588 73 : n = n->next;
10589 : }
10590 : break;
10591 : case OMP_LIST_HAS_DEVICE_ADDR:
10592 : case OMP_LIST_USE_DEVICE_ADDR:
10593 : break;
10594 : case OMP_LIST_USE_DEVICE_PTR:
10595 : /* Non-C_PTR are deprecated and handled as use_device_ADDR. */
10596 : last = NULL;
10597 475 : for (n = omp_clauses->lists[list]; n != NULL; )
10598 : {
10599 312 : gfc_omp_namelist *n2 = n;
10600 312 : if (n->sym->ts.type != BT_DERIVED
10601 18 : || !n->sym->ts.u.derived->ts.is_iso_c)
10602 : {
10603 294 : gfc_warning (OPT_Wdeprecated_openmp,
10604 : "Non-C_PTR type argument at %L is "
10605 : "deprecated, use USE_DEVICE_ADDR", &n->where);
10606 294 : n = n->next;
10607 294 : if (last)
10608 0 : last->next = n;
10609 : else
10610 294 : omp_clauses->lists[list] = n;
10611 294 : n2->next = omp_clauses->lists[OMP_LIST_USE_DEVICE_ADDR];
10612 294 : omp_clauses->lists[OMP_LIST_USE_DEVICE_ADDR] = n2;
10613 294 : continue;
10614 : }
10615 18 : last = n;
10616 18 : n = n->next;
10617 : }
10618 : break;
10619 65 : case OMP_LIST_USES_ALLOCATORS:
10620 65 : {
10621 65 : if (n != NULL
10622 65 : && n->u.memspace_sym
10623 20 : && (n->u.memspace_sym->attr.flavor != FL_PARAMETER
10624 18 : || n->u.memspace_sym->ts.type != BT_INTEGER
10625 18 : || n->u.memspace_sym->ts.kind != gfc_c_intptr_kind
10626 18 : || n->u.memspace_sym->attr.dimension
10627 18 : || (!startswith (n->u.memspace_sym->name, "omp_")
10628 0 : && !startswith (n->u.memspace_sym->name, "ompx_"))
10629 18 : || !endswith (n->u.memspace_sym->name, "_mem_space")))
10630 3 : gfc_error ("Memspace %qs at %L in USES_ALLOCATORS must be "
10631 : "a predefined memory space",
10632 : n->u.memspace_sym->name, &n->where);
10633 180 : for (; n != NULL; n = n->next)
10634 : {
10635 122 : if (n->sym->ts.type != BT_INTEGER
10636 121 : || n->sym->ts.kind != gfc_c_intptr_kind
10637 120 : || n->sym->attr.dimension)
10638 3 : gfc_error ("Allocator %qs at %L in USES_ALLOCATORS must "
10639 : "be a scalar integer of kind "
10640 : "%<omp_allocator_handle_kind%>", n->sym->name,
10641 : &n->where);
10642 119 : else if (n->sym->attr.flavor != FL_VARIABLE
10643 50 : && strcmp (n->sym->name, "omp_null_allocator") != 0
10644 165 : && ((!startswith (n->sym->name, "omp_")
10645 1 : && !startswith (n->sym->name, "ompx_"))
10646 45 : || !endswith (n->sym->name, "_mem_alloc")))
10647 2 : gfc_error ("Allocator %qs at %L in USES_ALLOCATORS must "
10648 : "either a variable or a predefined allocator",
10649 : n->sym->name, &n->where);
10650 117 : else if ((n->u.memspace_sym || n->u2.traits_sym)
10651 61 : && n->sym->attr.flavor != FL_VARIABLE)
10652 3 : gfc_error ("A memory space or traits array may not be "
10653 : "specified for predefined allocator %qs at %L",
10654 : n->sym->name, &n->where);
10655 122 : if (n->u2.traits_sym
10656 50 : && (n->u2.traits_sym->attr.flavor != FL_PARAMETER
10657 47 : || !n->u2.traits_sym->attr.dimension
10658 45 : || n->u2.traits_sym->as->rank != 1
10659 45 : || n->u2.traits_sym->ts.type != BT_DERIVED
10660 43 : || strcmp (n->u2.traits_sym->ts.u.derived->name,
10661 : "omp_alloctrait") != 0))
10662 : {
10663 7 : gfc_error ("Traits array %qs in USES_ALLOCATORS %L must "
10664 : "be a one-dimensional named constant array of "
10665 : "type %<omp_alloctrait%>",
10666 : n->u2.traits_sym->name, &n->where);
10667 7 : break;
10668 : }
10669 : }
10670 : break;
10671 : }
10672 : default:
10673 34776 : for (; n != NULL; n = n->next)
10674 : {
10675 20380 : if (n->sym == NULL)
10676 : {
10677 26 : gcc_assert (code->op == EXEC_OMP_ALLOCATORS
10678 : || code->op == EXEC_OMP_ALLOCATE);
10679 26 : continue;
10680 : }
10681 20354 : bool bad = false;
10682 20354 : bool is_reduction = (list == OMP_LIST_REDUCTION
10683 : || list == OMP_LIST_REDUCTION_INSCAN
10684 : || list == OMP_LIST_REDUCTION_TASK
10685 : || list == OMP_LIST_IN_REDUCTION
10686 20354 : || list == OMP_LIST_TASK_REDUCTION);
10687 20354 : if (list == OMP_LIST_REDUCTION_INSCAN)
10688 : has_inscan = true;
10689 20282 : else if (is_reduction)
10690 4737 : has_notinscan = true;
10691 20354 : if (has_inscan && has_notinscan && is_reduction)
10692 : {
10693 3 : gfc_error ("%<inscan%> and non-%<inscan%> %<reduction%> "
10694 : "clauses on the same construct at %L",
10695 : &n->where);
10696 3 : break;
10697 : }
10698 20351 : if (n->sym->attr.threadprivate)
10699 1 : gfc_error ("THREADPRIVATE object %qs in %s clause at %L",
10700 : n->sym->name, name, &n->where);
10701 20351 : if (n->sym->attr.cray_pointee)
10702 14 : gfc_error ("Cray pointee %qs in %s clause at %L",
10703 : n->sym->name, name, &n->where);
10704 20351 : if (n->sym->attr.associate_var)
10705 22 : gfc_error ("Associate name %qs in %s clause at %L",
10706 22 : n->sym->attr.select_type_temporary
10707 4 : ? n->sym->assoc->target->symtree->n.sym->name
10708 : : n->sym->name, name, &n->where);
10709 20351 : if (list != OMP_LIST_PRIVATE && is_reduction)
10710 : {
10711 4806 : if (n->sym->attr.proc_pointer)
10712 1 : gfc_error ("Procedure pointer %qs in %s clause at %L",
10713 : n->sym->name, name, &n->where);
10714 4806 : if (n->sym->attr.pointer)
10715 3 : gfc_error ("POINTER object %qs in %s clause at %L",
10716 : n->sym->name, name, &n->where);
10717 4806 : if (n->sym->attr.cray_pointer)
10718 5 : gfc_error ("Cray pointer %qs in %s clause at %L",
10719 : n->sym->name, name, &n->where);
10720 : }
10721 20351 : if (code
10722 20351 : && (oacc_is_loop (code)
10723 : || code->op == EXEC_OACC_PARALLEL
10724 : || code->op == EXEC_OACC_SERIAL))
10725 8741 : check_array_not_assumed (n->sym, n->where, name);
10726 11610 : else if (list != OMP_LIST_UNIFORM
10727 11493 : && n->sym->as && n->sym->as->type == AS_ASSUMED_SIZE)
10728 2 : gfc_error ("Assumed size array %qs in %s clause at %L",
10729 : n->sym->name, name, &n->where);
10730 20351 : if (n->sym->attr.in_namelist && !is_reduction)
10731 0 : gfc_error ("Variable %qs in %s clause is used in "
10732 : "NAMELIST statement at %L",
10733 : n->sym->name, name, &n->where);
10734 20351 : if (n->sym->attr.pointer && n->sym->attr.intent == INTENT_IN)
10735 3 : switch (list)
10736 : {
10737 3 : case OMP_LIST_PRIVATE:
10738 3 : case OMP_LIST_LASTPRIVATE:
10739 3 : case OMP_LIST_LINEAR:
10740 : /* case OMP_LIST_REDUCTION: */
10741 3 : gfc_error ("INTENT(IN) POINTER %qs in %s clause at %L",
10742 : n->sym->name, name, &n->where);
10743 3 : break;
10744 : default:
10745 : break;
10746 : }
10747 20351 : if (omp_clauses->detach
10748 3 : && (list == OMP_LIST_PRIVATE
10749 : || list == OMP_LIST_FIRSTPRIVATE
10750 : || list == OMP_LIST_LASTPRIVATE)
10751 3 : && n->sym == omp_clauses->detach->symtree->n.sym)
10752 1 : gfc_error ("DETACH event handle %qs in %s clause at %L",
10753 : n->sym->name, name, &n->where);
10754 :
10755 20351 : if (!openacc
10756 20351 : && (list == OMP_LIST_PRIVATE
10757 20351 : || list == OMP_LIST_FIRSTPRIVATE)
10758 4704 : && ((n->sym->ts.type == BT_DERIVED
10759 158 : && n->sym->ts.u.derived->attr.alloc_comp)
10760 4594 : || n->sym->ts.type == BT_CLASS))
10761 170 : switch (code->op)
10762 : {
10763 8 : case EXEC_OMP_TARGET:
10764 8 : case EXEC_OMP_TARGET_PARALLEL:
10765 8 : case EXEC_OMP_TARGET_PARALLEL_DO:
10766 8 : case EXEC_OMP_TARGET_PARALLEL_DO_SIMD:
10767 8 : case EXEC_OMP_TARGET_PARALLEL_LOOP:
10768 8 : case EXEC_OMP_TARGET_SIMD:
10769 8 : case EXEC_OMP_TARGET_TEAMS:
10770 8 : case EXEC_OMP_TARGET_TEAMS_DISTRIBUTE:
10771 8 : case EXEC_OMP_TARGET_TEAMS_DISTRIBUTE_PARALLEL_DO:
10772 8 : case EXEC_OMP_TARGET_TEAMS_DISTRIBUTE_PARALLEL_DO_SIMD:
10773 8 : case EXEC_OMP_TARGET_TEAMS_DISTRIBUTE_SIMD:
10774 8 : case EXEC_OMP_TARGET_TEAMS_LOOP:
10775 8 : if (n->sym->ts.type == BT_DERIVED
10776 2 : && n->sym->ts.u.derived->attr.alloc_comp)
10777 3 : gfc_error ("Sorry, list item %qs at %L with allocatable"
10778 : " components is not yet supported in %s "
10779 : "clause", n->sym->name, &n->where,
10780 : list == OMP_LIST_PRIVATE ? "PRIVATE"
10781 : : "FIRSTPRIVATE");
10782 : else
10783 9 : gfc_error ("Polymorphic list item %qs at %L in %s "
10784 : "clause has unspecified behavior and "
10785 : "unsupported", n->sym->name, &n->where,
10786 : list == OMP_LIST_PRIVATE ? "PRIVATE"
10787 : : "FIRSTPRIVATE");
10788 : break;
10789 : default:
10790 : break;
10791 : }
10792 :
10793 20351 : switch (list)
10794 : {
10795 104 : case OMP_LIST_REDUCTION_TASK:
10796 104 : if (code
10797 104 : && (code->op == EXEC_OMP_LOOP
10798 : || code->op == EXEC_OMP_TASKLOOP
10799 : || code->op == EXEC_OMP_TASKLOOP_SIMD
10800 : || code->op == EXEC_OMP_MASKED_TASKLOOP
10801 : || code->op == EXEC_OMP_MASKED_TASKLOOP_SIMD
10802 : || code->op == EXEC_OMP_MASTER_TASKLOOP
10803 : || code->op == EXEC_OMP_MASTER_TASKLOOP_SIMD
10804 : || code->op == EXEC_OMP_PARALLEL_LOOP
10805 : || code->op == EXEC_OMP_PARALLEL_MASKED_TASKLOOP
10806 : || code->op == EXEC_OMP_PARALLEL_MASKED_TASKLOOP_SIMD
10807 : || code->op == EXEC_OMP_PARALLEL_MASTER_TASKLOOP
10808 : || code->op == EXEC_OMP_PARALLEL_MASTER_TASKLOOP_SIMD
10809 : || code->op == EXEC_OMP_TARGET_PARALLEL_LOOP
10810 : || code->op == EXEC_OMP_TARGET_TEAMS_LOOP
10811 : || code->op == EXEC_OMP_TEAMS
10812 : || code->op == EXEC_OMP_TEAMS_DISTRIBUTE
10813 : || code->op == EXEC_OMP_TEAMS_LOOP))
10814 : {
10815 17 : gfc_error ("Only DEFAULT permitted as reduction-"
10816 : "modifier in REDUCTION clause at %L",
10817 : &n->where);
10818 17 : break;
10819 : }
10820 4789 : gcc_fallthrough ();
10821 4789 : case OMP_LIST_REDUCTION:
10822 4789 : case OMP_LIST_IN_REDUCTION:
10823 4789 : case OMP_LIST_TASK_REDUCTION:
10824 4789 : case OMP_LIST_REDUCTION_INSCAN:
10825 4789 : switch (n->u.reduction_op)
10826 : {
10827 2655 : case OMP_REDUCTION_PLUS:
10828 2655 : case OMP_REDUCTION_TIMES:
10829 2655 : case OMP_REDUCTION_MINUS:
10830 2655 : if (!gfc_numeric_ts (&n->sym->ts))
10831 : bad = true;
10832 : break;
10833 1112 : case OMP_REDUCTION_AND:
10834 1112 : case OMP_REDUCTION_OR:
10835 1112 : case OMP_REDUCTION_EQV:
10836 1112 : case OMP_REDUCTION_NEQV:
10837 1112 : if (n->sym->ts.type != BT_LOGICAL)
10838 : bad = true;
10839 : break;
10840 480 : case OMP_REDUCTION_MAX:
10841 480 : case OMP_REDUCTION_MIN:
10842 480 : if (n->sym->ts.type != BT_INTEGER
10843 212 : && n->sym->ts.type != BT_REAL)
10844 : bad = true;
10845 : break;
10846 192 : case OMP_REDUCTION_IAND:
10847 192 : case OMP_REDUCTION_IOR:
10848 192 : case OMP_REDUCTION_IEOR:
10849 192 : if (n->sym->ts.type != BT_INTEGER)
10850 : bad = true;
10851 : break;
10852 : case OMP_REDUCTION_USER:
10853 : bad = true;
10854 : break;
10855 : default:
10856 : break;
10857 : }
10858 : if (!bad)
10859 4215 : n->u2.udr = NULL;
10860 : else
10861 : {
10862 574 : const char *udr_name = NULL;
10863 574 : if (n->u2.udr)
10864 : {
10865 470 : udr_name = n->u2.udr->udr->name;
10866 470 : n->u2.udr->udr
10867 940 : = gfc_find_omp_udr (NULL, udr_name,
10868 470 : &n->sym->ts);
10869 470 : if (n->u2.udr->udr == NULL)
10870 : {
10871 0 : free (n->u2.udr);
10872 0 : n->u2.udr = NULL;
10873 : }
10874 : }
10875 574 : if (n->u2.udr == NULL)
10876 : {
10877 104 : if (udr_name == NULL)
10878 104 : switch (n->u.reduction_op)
10879 : {
10880 50 : case OMP_REDUCTION_PLUS:
10881 50 : case OMP_REDUCTION_TIMES:
10882 50 : case OMP_REDUCTION_MINUS:
10883 50 : case OMP_REDUCTION_AND:
10884 50 : case OMP_REDUCTION_OR:
10885 50 : case OMP_REDUCTION_EQV:
10886 50 : case OMP_REDUCTION_NEQV:
10887 50 : udr_name = gfc_op2string ((gfc_intrinsic_op)
10888 : n->u.reduction_op);
10889 50 : break;
10890 : case OMP_REDUCTION_MAX:
10891 : udr_name = "max";
10892 : break;
10893 9 : case OMP_REDUCTION_MIN:
10894 9 : udr_name = "min";
10895 9 : break;
10896 12 : case OMP_REDUCTION_IAND:
10897 12 : udr_name = "iand";
10898 12 : break;
10899 12 : case OMP_REDUCTION_IOR:
10900 12 : udr_name = "ior";
10901 12 : break;
10902 9 : case OMP_REDUCTION_IEOR:
10903 9 : udr_name = "ieor";
10904 9 : break;
10905 0 : default:
10906 0 : gcc_unreachable ();
10907 : }
10908 104 : gfc_error ("!$OMP DECLARE REDUCTION %s not found "
10909 : "for type %s at %L", udr_name,
10910 104 : gfc_typename (&n->sym->ts), &n->where);
10911 : }
10912 : else
10913 : {
10914 470 : gfc_omp_udr *udr = n->u2.udr->udr;
10915 470 : n->u.reduction_op = OMP_REDUCTION_USER;
10916 470 : n->u2.udr->combiner
10917 940 : = resolve_omp_udr_clause (n, udr->combiner_ns,
10918 470 : udr->omp_out,
10919 470 : udr->omp_in);
10920 470 : if (udr->initializer_ns)
10921 331 : n->u2.udr->initializer
10922 331 : = resolve_omp_udr_clause (n,
10923 : udr->initializer_ns,
10924 331 : udr->omp_priv,
10925 331 : udr->omp_orig);
10926 : }
10927 : }
10928 : break;
10929 874 : case OMP_LIST_LINEAR:
10930 874 : if (code)
10931 : {
10932 727 : bool is_worksharing_for = false;
10933 727 : switch (code->op)
10934 : {
10935 54 : case EXEC_OMP_DO:
10936 54 : case EXEC_OMP_PARALLEL_DO:
10937 54 : case EXEC_OMP_DISTRIBUTE_PARALLEL_DO:
10938 54 : case EXEC_OMP_TARGET_PARALLEL_DO:
10939 54 : case EXEC_OMP_TEAMS_DISTRIBUTE_PARALLEL_DO:
10940 54 : case EXEC_OMP_TARGET_TEAMS_DISTRIBUTE_PARALLEL_DO:
10941 54 : is_worksharing_for = true;
10942 54 : break;
10943 : default:
10944 : break;
10945 : }
10946 :
10947 54 : if (is_worksharing_for
10948 54 : && (n->sym->attr.dimension
10949 53 : || n->sym->attr.allocatable))
10950 : {
10951 1 : if (n->sym->attr.allocatable)
10952 0 : gfc_error ("Sorry, ALLOCATABLE object %qs in "
10953 : "LINEAR clause on worksharing-loop "
10954 : "construct at %L is not yet supported",
10955 : n->sym->name, &n->where);
10956 : else
10957 1 : gfc_error ("Sorry, array %qs in LINEAR clause "
10958 : "on worksharing-loop construct at %L "
10959 : "is not yet supported",
10960 : n->sym->name, &n->where);
10961 : break;
10962 : }
10963 : }
10964 :
10965 726 : if (code
10966 726 : && n->u.linear.op != OMP_LINEAR_DEFAULT
10967 23 : && n->u.linear.op != linear_op)
10968 : {
10969 23 : if (n->u.linear.old_modifier)
10970 : {
10971 9 : gfc_error ("LINEAR clause modifier used on DO or "
10972 : "SIMD construct at %L", &n->where);
10973 9 : linear_op = n->u.linear.op;
10974 : }
10975 14 : else if (n->u.linear.op != OMP_LINEAR_VAL)
10976 : {
10977 6 : gfc_error ("LINEAR clause modifier other than VAL "
10978 : "used on DO or SIMD construct at %L",
10979 : &n->where);
10980 6 : linear_op = n->u.linear.op;
10981 : }
10982 : }
10983 850 : else if (n->u.linear.op != OMP_LINEAR_REF
10984 800 : && n->sym->ts.type != BT_INTEGER)
10985 1 : gfc_error ("LINEAR variable %qs must be INTEGER "
10986 : "at %L", n->sym->name, &n->where);
10987 849 : else if ((n->u.linear.op == OMP_LINEAR_REF
10988 799 : || n->u.linear.op == OMP_LINEAR_UVAL)
10989 61 : && n->sym->attr.value)
10990 0 : gfc_error ("LINEAR dummy argument %qs with VALUE "
10991 : "attribute with %s modifier at %L",
10992 : n->sym->name,
10993 : n->u.linear.op == OMP_LINEAR_REF
10994 : ? "REF" : "UVAL", &n->where);
10995 849 : else if (n->expr)
10996 : {
10997 830 : gfc_expr *expr = n->expr;
10998 830 : if (!gfc_resolve_expr (expr)
10999 830 : || expr->ts.type != BT_INTEGER
11000 1660 : || expr->rank != 0)
11001 0 : gfc_error ("%qs in LINEAR clause at %L requires "
11002 : "a scalar integer linear-step expression",
11003 0 : n->sym->name, &n->where);
11004 830 : else if (!code && expr->expr_type != EXPR_CONSTANT)
11005 : {
11006 11 : if (expr->expr_type == EXPR_VARIABLE
11007 7 : && expr->symtree->n.sym->attr.dummy
11008 6 : && expr->symtree->n.sym->ns == ns)
11009 : {
11010 6 : gfc_omp_namelist *n2;
11011 6 : for (n2 = omp_clauses->lists[OMP_LIST_UNIFORM];
11012 6 : n2; n2 = n2->next)
11013 6 : if (n2->sym == expr->symtree->n.sym)
11014 : break;
11015 6 : if (n2)
11016 : break;
11017 : }
11018 5 : gfc_error ("%qs in LINEAR clause at %L requires "
11019 : "a constant integer linear-step "
11020 : "expression or dummy argument "
11021 : "specified in UNIFORM clause",
11022 5 : n->sym->name, &n->where);
11023 : }
11024 : }
11025 : break;
11026 : /* Workaround for PR middle-end/26316, nothing really needs
11027 : to be done here for OMP_LIST_PRIVATE. */
11028 9394 : case OMP_LIST_PRIVATE:
11029 9394 : gcc_assert (code && code->op != EXEC_NOP);
11030 : break;
11031 98 : case OMP_LIST_USE_DEVICE:
11032 98 : if (n->sym->attr.allocatable
11033 98 : || (n->sym->ts.type == BT_CLASS && CLASS_DATA (n->sym)
11034 0 : && CLASS_DATA (n->sym)->attr.allocatable))
11035 0 : gfc_error ("ALLOCATABLE object %qs in %s clause at %L",
11036 : n->sym->name, name, &n->where);
11037 98 : if (n->sym->ts.type == BT_CLASS
11038 0 : && CLASS_DATA (n->sym)
11039 0 : && CLASS_DATA (n->sym)->attr.class_pointer)
11040 0 : gfc_error ("POINTER object %qs of polymorphic type in "
11041 : "%s clause at %L", n->sym->name, name,
11042 : &n->where);
11043 98 : if (n->sym->attr.cray_pointer)
11044 2 : gfc_error ("Cray pointer object %qs in %s clause at %L",
11045 : n->sym->name, name, &n->where);
11046 96 : else if (n->sym->attr.cray_pointee)
11047 2 : gfc_error ("Cray pointee object %qs in %s clause at %L",
11048 : n->sym->name, name, &n->where);
11049 94 : else if (n->sym->attr.flavor == FL_VARIABLE
11050 93 : && !n->sym->as
11051 54 : && !n->sym->attr.pointer)
11052 13 : gfc_error ("%s clause variable %qs at %L is neither "
11053 : "a POINTER nor an array", name,
11054 : n->sym->name, &n->where);
11055 : /* FALLTHRU */
11056 98 : case OMP_LIST_DEVICE_RESIDENT:
11057 98 : check_symbol_not_pointer (n->sym, n->where, name);
11058 98 : check_array_not_assumed (n->sym, n->where, name);
11059 98 : break;
11060 : default:
11061 : break;
11062 : }
11063 : }
11064 : break;
11065 : }
11066 : }
11067 : /* OpenMP 5.1: use_device_ptr acts like use_device_addr, except for
11068 : type(c_ptr). */
11069 32620 : if (omp_clauses->lists[OMP_LIST_USE_DEVICE_PTR])
11070 : {
11071 9 : gfc_omp_namelist *n_prev, *n_next, *n_addr;
11072 9 : n_addr = omp_clauses->lists[OMP_LIST_USE_DEVICE_ADDR];
11073 28 : for (; n_addr && n_addr->next; n_addr = n_addr->next)
11074 : ;
11075 : n_prev = NULL;
11076 : n = omp_clauses->lists[OMP_LIST_USE_DEVICE_PTR];
11077 27 : while (n)
11078 : {
11079 18 : n_next = n->next;
11080 18 : if (n->sym->ts.type != BT_DERIVED
11081 18 : || n->sym->ts.u.derived->ts.f90_type != BT_VOID)
11082 : {
11083 0 : n->next = NULL;
11084 0 : if (n_addr)
11085 0 : n_addr->next = n;
11086 : else
11087 0 : omp_clauses->lists[OMP_LIST_USE_DEVICE_ADDR] = n;
11088 0 : n_addr = n;
11089 0 : if (n_prev)
11090 0 : n_prev->next = n_next;
11091 : else
11092 0 : omp_clauses->lists[OMP_LIST_USE_DEVICE_PTR] = n_next;
11093 : }
11094 : else
11095 : n_prev = n;
11096 : n = n_next;
11097 : }
11098 : }
11099 32620 : if (omp_clauses->safelen_expr)
11100 93 : resolve_positive_int_expr (omp_clauses->safelen_expr, "SAFELEN");
11101 32620 : if (omp_clauses->simdlen_expr)
11102 123 : resolve_positive_int_expr (omp_clauses->simdlen_expr, "SIMDLEN");
11103 32620 : if (omp_clauses->num_teams_lower)
11104 21 : resolve_positive_int_expr (omp_clauses->num_teams_lower, "NUM_TEAMS");
11105 32620 : if (omp_clauses->num_teams_upper)
11106 129 : resolve_positive_int_expr (omp_clauses->num_teams_upper, "NUM_TEAMS");
11107 32620 : if (omp_clauses->num_teams_lower
11108 21 : && omp_clauses->num_teams_lower->expr_type == EXPR_CONSTANT
11109 7 : && omp_clauses->num_teams_upper->expr_type == EXPR_CONSTANT
11110 7 : && mpz_cmp (omp_clauses->num_teams_lower->value.integer,
11111 7 : omp_clauses->num_teams_upper->value.integer) > 0)
11112 2 : gfc_warning (OPT_Wopenmp, "NUM_TEAMS lower bound at %L larger than upper "
11113 : "bound at %L", &omp_clauses->num_teams_lower->where,
11114 : &omp_clauses->num_teams_upper->where);
11115 32620 : if (omp_clauses->device)
11116 333 : resolve_scalar_int_expr (omp_clauses->device, "DEVICE");
11117 32620 : if (omp_clauses->filter)
11118 42 : resolve_nonnegative_int_expr (omp_clauses->filter, "FILTER");
11119 32620 : if (omp_clauses->hint)
11120 : {
11121 42 : resolve_scalar_int_expr (omp_clauses->hint, "HINT");
11122 42 : if (omp_clauses->hint->ts.type != BT_INTEGER
11123 40 : || omp_clauses->hint->expr_type != EXPR_CONSTANT
11124 38 : || mpz_sgn (omp_clauses->hint->value.integer) < 0)
11125 5 : gfc_error ("Value of HINT clause at %L shall be a valid "
11126 : "constant hint expression", &omp_clauses->hint->where);
11127 : }
11128 32620 : if (omp_clauses->priority)
11129 34 : resolve_nonnegative_int_expr (omp_clauses->priority, "PRIORITY");
11130 32620 : if (omp_clauses->dist_chunk_size)
11131 : {
11132 83 : gfc_expr *expr = omp_clauses->dist_chunk_size;
11133 83 : if (!gfc_resolve_expr (expr)
11134 83 : || expr->ts.type != BT_INTEGER || expr->rank != 0)
11135 0 : gfc_error ("DIST_SCHEDULE clause's chunk_size at %L requires "
11136 : "a scalar INTEGER expression", &expr->where);
11137 : }
11138 32620 : if (omp_clauses->thread_limit)
11139 74 : resolve_positive_int_expr (omp_clauses->thread_limit, "THREAD_LIMIT");
11140 32620 : if (omp_clauses->grainsize)
11141 34 : resolve_positive_int_expr (omp_clauses->grainsize, "GRAINSIZE");
11142 32620 : if (omp_clauses->num_tasks)
11143 26 : resolve_positive_int_expr (omp_clauses->num_tasks, "NUM_TASKS");
11144 32620 : if (omp_clauses->grainsize && omp_clauses->num_tasks)
11145 1 : gfc_error ("%<GRAINSIZE%> clause at %L must not be used together with "
11146 : "%<NUM_TASKS%> clause", &omp_clauses->grainsize->where);
11147 32620 : if (omp_clauses->lists[OMP_LIST_REDUCTION] && omp_clauses->nogroup)
11148 1 : gfc_error ("%<REDUCTION%> clause at %L must not be used together with "
11149 : "%<NOGROUP%> clause",
11150 : &omp_clauses->lists[OMP_LIST_REDUCTION]->where);
11151 32620 : if (omp_clauses->full && omp_clauses->partial)
11152 0 : gfc_error ("%<FULL%> clause at %C must not be used together with "
11153 : "%<PARTIAL%> clause");
11154 32620 : if (omp_clauses->async)
11155 610 : if (omp_clauses->async_expr)
11156 610 : resolve_scalar_int_expr (omp_clauses->async_expr, "ASYNC");
11157 32620 : if (omp_clauses->num_gangs_expr)
11158 682 : resolve_positive_int_expr (omp_clauses->num_gangs_expr, "NUM_GANGS");
11159 32620 : if (omp_clauses->num_workers_expr)
11160 599 : resolve_positive_int_expr (omp_clauses->num_workers_expr, "NUM_WORKERS");
11161 32620 : if (omp_clauses->vector_length_expr)
11162 569 : resolve_positive_int_expr (omp_clauses->vector_length_expr,
11163 : "VECTOR_LENGTH");
11164 32620 : if (omp_clauses->gang_num_expr)
11165 114 : resolve_positive_int_expr (omp_clauses->gang_num_expr, "GANG");
11166 32620 : if (omp_clauses->gang_static_expr)
11167 94 : resolve_positive_int_expr (omp_clauses->gang_static_expr, "GANG");
11168 32620 : if (omp_clauses->worker_expr)
11169 101 : resolve_positive_int_expr (omp_clauses->worker_expr, "WORKER");
11170 32620 : if (omp_clauses->vector_expr)
11171 132 : resolve_positive_int_expr (omp_clauses->vector_expr, "VECTOR");
11172 32959 : for (el = omp_clauses->wait_list; el; el = el->next)
11173 339 : resolve_scalar_int_expr (el->expr, "WAIT");
11174 32620 : if (omp_clauses->collapse && omp_clauses->tile_list)
11175 4 : gfc_error ("Incompatible use of TILE and COLLAPSE at %L", &code->loc);
11176 32620 : if (omp_clauses->message)
11177 : {
11178 45 : gfc_expr *expr = omp_clauses->message;
11179 45 : if (!gfc_resolve_expr (expr)
11180 45 : || expr->ts.kind != gfc_default_character_kind
11181 87 : || expr->ts.type != BT_CHARACTER || expr->rank != 0)
11182 4 : gfc_error ("MESSAGE clause at %L requires a scalar default-kind "
11183 : "CHARACTER expression", &expr->where);
11184 : }
11185 32620 : if (!openacc
11186 32620 : && code
11187 19754 : && omp_clauses->lists[OMP_LIST_MAP] == NULL
11188 15967 : && omp_clauses->lists[OMP_LIST_USE_DEVICE_PTR] == NULL
11189 15964 : && omp_clauses->lists[OMP_LIST_USE_DEVICE_ADDR] == NULL)
11190 : {
11191 15941 : const char *p = NULL;
11192 15941 : switch (code->op)
11193 : {
11194 1 : case EXEC_OMP_TARGET_ENTER_DATA: p = "TARGET ENTER DATA"; break;
11195 1 : case EXEC_OMP_TARGET_EXIT_DATA: p = "TARGET EXIT DATA"; break;
11196 : default: break;
11197 : }
11198 15941 : if (code->op == EXEC_OMP_TARGET_DATA)
11199 1 : gfc_error ("TARGET DATA must contain at least one MAP, USE_DEVICE_PTR, "
11200 : "or USE_DEVICE_ADDR clause at %L", &code->loc);
11201 15940 : else if (p)
11202 2 : gfc_error ("%s must contain at least one MAP clause at %L",
11203 : p, &code->loc);
11204 : }
11205 32620 : if (omp_clauses->sizes_list)
11206 : {
11207 : gfc_expr_list *el;
11208 572 : for (el = omp_clauses->sizes_list; el; el = el->next)
11209 : {
11210 377 : resolve_scalar_int_expr (el->expr, "SIZES");
11211 377 : if (el->expr->expr_type != EXPR_CONSTANT)
11212 1 : gfc_error ("SIZES requires constant expression at %L",
11213 : &el->expr->where);
11214 376 : else if (el->expr->expr_type == EXPR_CONSTANT
11215 376 : && el->expr->ts.type == BT_INTEGER
11216 376 : && mpz_sgn (el->expr->value.integer) <= 0)
11217 2 : gfc_error ("INTEGER expression of %s clause at %L must be "
11218 : "positive", "SIZES", &el->expr->where);
11219 : }
11220 : }
11221 :
11222 32620 : if (!openacc && omp_clauses->detach)
11223 : {
11224 125 : if (!gfc_resolve_expr (omp_clauses->detach)
11225 125 : || omp_clauses->detach->ts.type != BT_INTEGER
11226 124 : || omp_clauses->detach->ts.kind != gfc_c_intptr_kind
11227 248 : || omp_clauses->detach->rank != 0)
11228 3 : gfc_error ("%qs at %L should be a scalar of type "
11229 : "integer(kind=omp_event_handle_kind)",
11230 3 : omp_clauses->detach->symtree->n.sym->name,
11231 3 : &omp_clauses->detach->where);
11232 122 : else if (omp_clauses->detach->symtree->n.sym->attr.dimension > 0)
11233 1 : gfc_error ("The event handle at %L must not be an array element",
11234 : &omp_clauses->detach->where);
11235 121 : else if (omp_clauses->detach->symtree->n.sym->ts.type == BT_DERIVED
11236 120 : || omp_clauses->detach->symtree->n.sym->ts.type == BT_CLASS)
11237 1 : gfc_error ("The event handle at %L must not be part of "
11238 : "a derived type or class", &omp_clauses->detach->where);
11239 :
11240 125 : if (omp_clauses->mergeable)
11241 2 : gfc_error ("%<DETACH%> clause at %L must not be used together with "
11242 2 : "%<MERGEABLE%> clause", &omp_clauses->detach->where);
11243 : }
11244 :
11245 12625 : if (openacc
11246 12625 : && code->op == EXEC_OACC_HOST_DATA
11247 60 : && omp_clauses->lists[OMP_LIST_USE_DEVICE] == NULL)
11248 1 : gfc_error ("%<host_data%> construct at %L requires %<use_device%> clause",
11249 : &code->loc);
11250 :
11251 32620 : if (omp_clauses->assume)
11252 16 : gfc_resolve_omp_assumptions (omp_clauses->assume);
11253 : }
11254 :
11255 :
11256 : /* Return true if SYM is ever referenced in EXPR except in the SE node. */
11257 :
11258 : static bool
11259 4991 : expr_references_sym (gfc_expr *e, gfc_symbol *s, gfc_expr *se)
11260 : {
11261 6617 : gfc_actual_arglist *arg;
11262 6617 : if (e == NULL || e == se)
11263 : return false;
11264 5366 : switch (e->expr_type)
11265 : {
11266 3120 : case EXPR_CONSTANT:
11267 3120 : case EXPR_NULL:
11268 3120 : case EXPR_VARIABLE:
11269 3120 : case EXPR_STRUCTURE:
11270 3120 : case EXPR_ARRAY:
11271 3120 : if (e->symtree != NULL
11272 1152 : && e->symtree->n.sym == s)
11273 : return true;
11274 : return false;
11275 0 : case EXPR_SUBSTRING:
11276 0 : if (e->ref != NULL
11277 0 : && (expr_references_sym (e->ref->u.ss.start, s, se)
11278 0 : || expr_references_sym (e->ref->u.ss.end, s, se)))
11279 0 : return true;
11280 : return false;
11281 1735 : case EXPR_OP:
11282 1735 : if (expr_references_sym (e->value.op.op2, s, se))
11283 : return true;
11284 1626 : return expr_references_sym (e->value.op.op1, s, se);
11285 511 : case EXPR_FUNCTION:
11286 896 : for (arg = e->value.function.actual; arg; arg = arg->next)
11287 586 : if (expr_references_sym (arg->expr, s, se))
11288 : return true;
11289 : return false;
11290 0 : default:
11291 0 : gcc_unreachable ();
11292 : }
11293 : }
11294 :
11295 :
11296 : /* If EXPR is a conversion function that widens the type
11297 : if WIDENING is true or narrows the type if NARROW is true,
11298 : return the inner expression, otherwise return NULL. */
11299 :
11300 : static gfc_expr *
11301 5911 : is_conversion (gfc_expr *expr, bool narrowing, bool widening)
11302 : {
11303 5911 : gfc_typespec *ts1, *ts2;
11304 :
11305 5911 : if (expr->expr_type != EXPR_FUNCTION
11306 917 : || expr->value.function.isym == NULL
11307 894 : || expr->value.function.esym != NULL
11308 894 : || expr->value.function.isym->id != GFC_ISYM_CONVERSION
11309 388 : || (!narrowing && !widening))
11310 : return NULL;
11311 :
11312 388 : if (narrowing && widening)
11313 267 : return expr->value.function.actual->expr;
11314 :
11315 121 : if (widening)
11316 : {
11317 121 : ts1 = &expr->ts;
11318 121 : ts2 = &expr->value.function.actual->expr->ts;
11319 : }
11320 : else
11321 : {
11322 0 : ts1 = &expr->value.function.actual->expr->ts;
11323 0 : ts2 = &expr->ts;
11324 : }
11325 :
11326 121 : if (ts1->type > ts2->type
11327 49 : || (ts1->type == ts2->type && ts1->kind > ts2->kind))
11328 121 : return expr->value.function.actual->expr;
11329 :
11330 : return NULL;
11331 : }
11332 :
11333 : static bool
11334 6855 : is_scalar_intrinsic_expr (gfc_expr *expr, bool must_be_var, bool conv_ok)
11335 : {
11336 6855 : if (must_be_var
11337 4020 : && (expr->expr_type != EXPR_VARIABLE || !expr->symtree))
11338 : {
11339 37 : if (!conv_ok)
11340 : return false;
11341 37 : gfc_expr *conv = is_conversion (expr, true, true);
11342 37 : if (!conv)
11343 : return false;
11344 36 : if (conv->expr_type != EXPR_VARIABLE || !conv->symtree)
11345 : return false;
11346 : }
11347 6852 : return (expr->rank == 0
11348 6848 : && !gfc_is_coindexed (expr)
11349 13700 : && (expr->ts.type == BT_INTEGER
11350 : || expr->ts.type == BT_REAL
11351 : || expr->ts.type == BT_COMPLEX
11352 : || expr->ts.type == BT_LOGICAL));
11353 : }
11354 :
11355 : static void
11356 2697 : resolve_omp_atomic (gfc_code *code)
11357 : {
11358 2697 : gfc_code *atomic_code = code->block;
11359 2697 : gfc_symbol *var;
11360 2697 : gfc_expr *stmt_expr2, *capt_expr2;
11361 2697 : gfc_omp_atomic_op aop
11362 2697 : = (gfc_omp_atomic_op) (atomic_code->ext.omp_clauses->atomic_op
11363 : & GFC_OMP_ATOMIC_MASK);
11364 2697 : gfc_code *stmt = NULL, *capture_stmt = NULL, *tailing_stmt = NULL;
11365 2697 : gfc_expr *comp_cond = NULL;
11366 2697 : locus *loc = NULL;
11367 :
11368 2697 : code = code->block->next;
11369 : /* resolve_blocks asserts this is initially EXEC_ASSIGN or EXEC_IF
11370 : If it changed to EXEC_NOP, assume an error has been emitted already. */
11371 2697 : if (code->op == EXEC_NOP)
11372 : return;
11373 :
11374 2696 : if (atomic_code->ext.omp_clauses->compare
11375 156 : && atomic_code->ext.omp_clauses->capture)
11376 : {
11377 : /* Must be either "if (x == e) then; x = d; else; v = x; end if"
11378 : or "v = expr" followed/preceded by
11379 : "if (x == e) then; x = d; end if" or "if (x == e) x = d". */
11380 103 : gfc_code *next = code;
11381 103 : if (code->op == EXEC_ASSIGN)
11382 : {
11383 19 : capture_stmt = code;
11384 19 : next = code->next;
11385 : }
11386 103 : if (next->op == EXEC_IF
11387 103 : && next->block
11388 103 : && next->block->op == EXEC_IF
11389 103 : && next->block->next
11390 102 : && next->block->next->op == EXEC_ASSIGN)
11391 : {
11392 102 : comp_cond = next->block->expr1;
11393 102 : stmt = next->block->next;
11394 102 : if (stmt->next)
11395 : {
11396 0 : loc = &stmt->loc;
11397 0 : goto unexpected;
11398 : }
11399 : }
11400 1 : else if (capture_stmt)
11401 : {
11402 0 : gfc_error ("Expected IF at %L in atomic compare capture",
11403 : &next->loc);
11404 0 : return;
11405 : }
11406 103 : if (stmt && !capture_stmt && next->block->block)
11407 : {
11408 64 : if (next->block->block->expr1)
11409 : {
11410 0 : gfc_error ("Expected ELSE at %L in atomic compare capture",
11411 : &next->block->block->expr1->where);
11412 0 : return;
11413 : }
11414 64 : if (!code->block->block->next
11415 64 : || code->block->block->next->op != EXEC_ASSIGN)
11416 : {
11417 0 : loc = (code->block->block->next ? &code->block->block->next->loc
11418 : : &code->block->block->loc);
11419 0 : goto unexpected;
11420 : }
11421 64 : capture_stmt = code->block->block->next;
11422 64 : if (capture_stmt->next)
11423 : {
11424 0 : loc = &capture_stmt->next->loc;
11425 0 : goto unexpected;
11426 : }
11427 : }
11428 103 : if (stmt && !capture_stmt && next->next->op == EXEC_ASSIGN)
11429 : capture_stmt = next->next;
11430 84 : else if (!capture_stmt)
11431 : {
11432 1 : loc = &code->loc;
11433 1 : goto unexpected;
11434 : }
11435 : }
11436 2593 : else if (atomic_code->ext.omp_clauses->compare)
11437 : {
11438 : /* Must be: "if (x == e) then; x = d; end if" or "if (x == e) x = d". */
11439 53 : if (code->op == EXEC_IF
11440 53 : && code->block
11441 53 : && code->block->op == EXEC_IF
11442 53 : && code->block->next
11443 51 : && code->block->next->op == EXEC_ASSIGN)
11444 : {
11445 51 : comp_cond = code->block->expr1;
11446 51 : stmt = code->block->next;
11447 51 : if (stmt->next || code->block->block)
11448 : {
11449 0 : loc = stmt->next ? &stmt->next->loc : &code->block->block->loc;
11450 0 : goto unexpected;
11451 : }
11452 : }
11453 : else
11454 : {
11455 2 : loc = &code->loc;
11456 2 : goto unexpected;
11457 : }
11458 : }
11459 2540 : else if (atomic_code->ext.omp_clauses->capture)
11460 : {
11461 : /* Must be: "v = x" followed/preceded by "x = ...". */
11462 489 : if (code->op != EXEC_ASSIGN)
11463 0 : goto unexpected;
11464 489 : if (code->next->op != EXEC_ASSIGN)
11465 : {
11466 0 : loc = &code->next->loc;
11467 0 : goto unexpected;
11468 : }
11469 489 : gfc_expr *expr2, *expr2_next;
11470 489 : expr2 = is_conversion (code->expr2, true, true);
11471 489 : if (expr2 == NULL)
11472 447 : expr2 = code->expr2;
11473 489 : expr2_next = is_conversion (code->next->expr2, true, true);
11474 489 : if (expr2_next == NULL)
11475 478 : expr2_next = code->next->expr2;
11476 489 : if (code->expr1->expr_type == EXPR_VARIABLE
11477 489 : && code->next->expr1->expr_type == EXPR_VARIABLE
11478 489 : && expr2->expr_type == EXPR_VARIABLE
11479 243 : && expr2_next->expr_type == EXPR_VARIABLE)
11480 : {
11481 1 : if (code->expr1->symtree->n.sym == expr2_next->symtree->n.sym)
11482 : {
11483 : stmt = code;
11484 : capture_stmt = code->next;
11485 : }
11486 : else
11487 : {
11488 489 : capture_stmt = code;
11489 489 : stmt = code->next;
11490 : }
11491 : }
11492 488 : else if (expr2->expr_type == EXPR_VARIABLE)
11493 : {
11494 : capture_stmt = code;
11495 : stmt = code->next;
11496 : }
11497 : else
11498 : {
11499 247 : stmt = code;
11500 247 : capture_stmt = code->next;
11501 : }
11502 : /* Shall be NULL but can happen for invalid code. */
11503 489 : tailing_stmt = code->next->next;
11504 : }
11505 : else
11506 : {
11507 : /* x = ... */
11508 2051 : stmt = code;
11509 2051 : if (!atomic_code->ext.omp_clauses->compare && stmt->op != EXEC_ASSIGN)
11510 1 : goto unexpected;
11511 : /* Shall be NULL but can happen for invalid code. */
11512 2050 : tailing_stmt = code->next;
11513 : }
11514 :
11515 2692 : if (comp_cond)
11516 : {
11517 153 : if (comp_cond->expr_type != EXPR_OP
11518 153 : || (comp_cond->value.op.op != INTRINSIC_EQ
11519 : && comp_cond->value.op.op != INTRINSIC_EQ_OS
11520 : && comp_cond->value.op.op != INTRINSIC_EQV))
11521 : {
11522 0 : gfc_error ("Expected %<==%>, %<.EQ.%> or %<.EQV.%> atomic comparison "
11523 : "expression at %L", &comp_cond->where);
11524 0 : return;
11525 : }
11526 153 : if (!is_scalar_intrinsic_expr (comp_cond->value.op.op1, true, true))
11527 : {
11528 1 : gfc_error ("Expected scalar intrinsic variable at %L in atomic "
11529 1 : "comparison", &comp_cond->value.op.op1->where);
11530 1 : return;
11531 : }
11532 152 : if (!gfc_resolve_expr (comp_cond->value.op.op2))
11533 : return;
11534 152 : if (!is_scalar_intrinsic_expr (comp_cond->value.op.op2, false, false))
11535 : {
11536 0 : gfc_error ("Expected scalar intrinsic expression at %L in atomic "
11537 0 : "comparison", &comp_cond->value.op.op1->where);
11538 0 : return;
11539 : }
11540 : }
11541 :
11542 2691 : if (!is_scalar_intrinsic_expr (stmt->expr1, true, false))
11543 : {
11544 4 : gfc_error ("!$OMP ATOMIC statement must set a scalar variable of "
11545 4 : "intrinsic type at %L", &stmt->expr1->where);
11546 4 : return;
11547 : }
11548 :
11549 2687 : if (!gfc_resolve_expr (stmt->expr2))
11550 : return;
11551 2683 : if (!is_scalar_intrinsic_expr (stmt->expr2, false, false))
11552 : {
11553 0 : gfc_error ("!$OMP ATOMIC statement must assign an expression of "
11554 0 : "intrinsic type at %L", &stmt->expr2->where);
11555 0 : return;
11556 : }
11557 :
11558 2683 : if (gfc_expr_attr (stmt->expr1).allocatable)
11559 : {
11560 0 : gfc_error ("!$OMP ATOMIC with ALLOCATABLE variable at %L",
11561 0 : &stmt->expr1->where);
11562 0 : return;
11563 : }
11564 :
11565 : /* Should be diagnosed above already. */
11566 2683 : gcc_assert (tailing_stmt == NULL);
11567 :
11568 2683 : var = stmt->expr1->symtree->n.sym;
11569 2683 : stmt_expr2 = is_conversion (stmt->expr2, true, true);
11570 2683 : if (stmt_expr2 == NULL)
11571 2527 : stmt_expr2 = stmt->expr2;
11572 :
11573 2683 : switch (aop)
11574 : {
11575 503 : case GFC_OMP_ATOMIC_READ:
11576 503 : if (stmt_expr2->expr_type != EXPR_VARIABLE)
11577 0 : gfc_error ("!$OMP ATOMIC READ statement must read from a scalar "
11578 : "variable of intrinsic type at %L", &stmt_expr2->where);
11579 : return;
11580 421 : case GFC_OMP_ATOMIC_WRITE:
11581 421 : if (expr_references_sym (stmt_expr2, var, NULL))
11582 0 : gfc_error ("expr in !$OMP ATOMIC WRITE assignment var = expr "
11583 : "must be scalar and cannot reference var at %L",
11584 : &stmt_expr2->where);
11585 : return;
11586 1759 : default:
11587 1759 : break;
11588 : }
11589 :
11590 1759 : if (atomic_code->ext.omp_clauses->capture)
11591 : {
11592 588 : if (!is_scalar_intrinsic_expr (capture_stmt->expr1, true, false))
11593 : {
11594 0 : gfc_error ("!$OMP ATOMIC capture-statement must set a scalar "
11595 : "variable of intrinsic type at %L",
11596 0 : &capture_stmt->expr1->where);
11597 0 : return;
11598 : }
11599 :
11600 588 : if (!is_scalar_intrinsic_expr (capture_stmt->expr2, true, true))
11601 : {
11602 2 : gfc_error ("!$OMP ATOMIC capture-statement requires a scalar variable"
11603 2 : " of intrinsic type at %L", &capture_stmt->expr2->where);
11604 2 : return;
11605 : }
11606 586 : capt_expr2 = is_conversion (capture_stmt->expr2, true, true);
11607 586 : if (capt_expr2 == NULL)
11608 564 : capt_expr2 = capture_stmt->expr2;
11609 :
11610 586 : if (capt_expr2->symtree->n.sym != var)
11611 : {
11612 1 : gfc_error ("!$OMP ATOMIC CAPTURE capture statement reads from "
11613 : "different variable than update statement writes "
11614 : "into at %L", &capture_stmt->expr2->where);
11615 1 : return;
11616 : }
11617 : }
11618 :
11619 1756 : if (atomic_code->ext.omp_clauses->compare)
11620 : {
11621 149 : gfc_expr *var_expr;
11622 149 : if (comp_cond->value.op.op1->expr_type == EXPR_VARIABLE)
11623 : var_expr = comp_cond->value.op.op1;
11624 : else
11625 12 : var_expr = comp_cond->value.op.op1->value.function.actual->expr;
11626 149 : if (var_expr->symtree->n.sym != var)
11627 : {
11628 2 : gfc_error ("For !$OMP ATOMIC COMPARE, the first operand in comparison"
11629 : " at %L must be the variable %qs that the update statement"
11630 : " writes into at %L", &var_expr->where, var->name,
11631 2 : &stmt->expr1->where);
11632 2 : return;
11633 : }
11634 147 : if (stmt_expr2->rank != 0 || expr_references_sym (stmt_expr2, var, NULL))
11635 : {
11636 1 : gfc_error ("expr in !$OMP ATOMIC COMPARE assignment var = expr "
11637 : "must be scalar and cannot reference var at %L",
11638 : &stmt_expr2->where);
11639 1 : return;
11640 : }
11641 : }
11642 1607 : else if (atomic_code->ext.omp_clauses->capture
11643 1607 : && !expr_references_sym (stmt_expr2, var, NULL))
11644 22 : atomic_code->ext.omp_clauses->atomic_op
11645 22 : = (gfc_omp_atomic_op) (atomic_code->ext.omp_clauses->atomic_op
11646 : | GFC_OMP_ATOMIC_SWAP);
11647 1585 : else if (stmt_expr2->expr_type == EXPR_OP)
11648 : {
11649 1229 : gfc_expr *v = NULL, *e, *c;
11650 1229 : gfc_intrinsic_op op = stmt_expr2->value.op.op;
11651 1229 : gfc_intrinsic_op alt_op = INTRINSIC_NONE;
11652 :
11653 1229 : if (atomic_code->ext.omp_clauses->fail != OMP_MEMORDER_UNSET)
11654 3 : gfc_error ("!$OMP ATOMIC UPDATE at %L with FAIL clause requires either"
11655 : " the COMPARE clause or using the intrinsic MIN/MAX "
11656 : "procedure", &atomic_code->loc);
11657 1229 : switch (op)
11658 : {
11659 742 : case INTRINSIC_PLUS:
11660 742 : alt_op = INTRINSIC_MINUS;
11661 742 : break;
11662 94 : case INTRINSIC_TIMES:
11663 94 : alt_op = INTRINSIC_DIVIDE;
11664 94 : break;
11665 120 : case INTRINSIC_MINUS:
11666 120 : alt_op = INTRINSIC_PLUS;
11667 120 : break;
11668 94 : case INTRINSIC_DIVIDE:
11669 94 : alt_op = INTRINSIC_TIMES;
11670 94 : break;
11671 : case INTRINSIC_AND:
11672 : case INTRINSIC_OR:
11673 : break;
11674 43 : case INTRINSIC_EQV:
11675 43 : alt_op = INTRINSIC_NEQV;
11676 43 : break;
11677 43 : case INTRINSIC_NEQV:
11678 43 : alt_op = INTRINSIC_EQV;
11679 43 : break;
11680 1 : default:
11681 1 : gfc_error ("!$OMP ATOMIC assignment operator must be binary "
11682 : "+, *, -, /, .AND., .OR., .EQV. or .NEQV. at %L",
11683 : &stmt_expr2->where);
11684 1 : return;
11685 : }
11686 :
11687 : /* Check for var = var op expr resp. var = expr op var where
11688 : expr doesn't reference var and var op expr is mathematically
11689 : equivalent to var op (expr) resp. expr op var equivalent to
11690 : (expr) op var. We rely here on the fact that the matcher
11691 : for x op1 y op2 z where op1 and op2 have equal precedence
11692 : returns (x op1 y) op2 z. */
11693 1228 : e = stmt_expr2->value.op.op2;
11694 1228 : if (e->expr_type == EXPR_VARIABLE
11695 288 : && e->symtree != NULL
11696 288 : && e->symtree->n.sym == var)
11697 : v = e;
11698 999 : else if ((c = is_conversion (e, false, true)) != NULL
11699 48 : && c->expr_type == EXPR_VARIABLE
11700 48 : && c->symtree != NULL
11701 1047 : && c->symtree->n.sym == var)
11702 : v = c;
11703 : else
11704 : {
11705 951 : gfc_expr **p = NULL, **q;
11706 1049 : for (q = &stmt_expr2->value.op.op1; (e = *q) != NULL; )
11707 1049 : if (e->expr_type == EXPR_VARIABLE
11708 948 : && e->symtree != NULL
11709 948 : && e->symtree->n.sym == var)
11710 : {
11711 : v = e;
11712 : break;
11713 : }
11714 101 : else if ((c = is_conversion (e, false, true)) != NULL)
11715 60 : q = &e->value.function.actual->expr;
11716 41 : else if (e->expr_type != EXPR_OP
11717 41 : || (e->value.op.op != op
11718 15 : && e->value.op.op != alt_op)
11719 38 : || e->rank != 0)
11720 : break;
11721 : else
11722 : {
11723 38 : p = q;
11724 38 : q = &e->value.op.op1;
11725 : }
11726 :
11727 951 : if (v == NULL)
11728 : {
11729 3 : gfc_error ("!$OMP ATOMIC assignment must be var = var op expr "
11730 : "or var = expr op var at %L", &stmt_expr2->where);
11731 3 : return;
11732 : }
11733 :
11734 948 : if (p != NULL)
11735 : {
11736 38 : e = *p;
11737 38 : switch (e->value.op.op)
11738 : {
11739 8 : case INTRINSIC_MINUS:
11740 8 : case INTRINSIC_DIVIDE:
11741 8 : case INTRINSIC_EQV:
11742 8 : case INTRINSIC_NEQV:
11743 8 : gfc_error ("!$OMP ATOMIC var = var op expr not "
11744 : "mathematically equivalent to var = var op "
11745 : "(expr) at %L", &stmt_expr2->where);
11746 8 : break;
11747 : default:
11748 : break;
11749 : }
11750 :
11751 : /* Canonicalize into var = var op (expr). */
11752 38 : *p = e->value.op.op2;
11753 38 : e->value.op.op2 = stmt_expr2;
11754 38 : e->ts = stmt_expr2->ts;
11755 38 : if (stmt->expr2 == stmt_expr2)
11756 26 : stmt->expr2 = stmt_expr2 = e;
11757 : else
11758 12 : stmt->expr2->value.function.actual->expr = stmt_expr2 = e;
11759 :
11760 38 : if (!gfc_compare_types (&stmt_expr2->value.op.op1->ts,
11761 : &stmt_expr2->ts))
11762 : {
11763 24 : for (p = &stmt_expr2->value.op.op1; *p != v;
11764 12 : p = &(*p)->value.function.actual->expr)
11765 : ;
11766 12 : *p = NULL;
11767 12 : gfc_free_expr (stmt_expr2->value.op.op1);
11768 12 : stmt_expr2->value.op.op1 = v;
11769 12 : gfc_convert_type (v, &stmt_expr2->ts, 2);
11770 : }
11771 : }
11772 : }
11773 :
11774 1225 : if (e->rank != 0 || expr_references_sym (stmt->expr2, var, v))
11775 : {
11776 1 : gfc_error ("expr in !$OMP ATOMIC assignment var = var op expr "
11777 : "must be scalar and cannot reference var at %L",
11778 : &stmt_expr2->where);
11779 1 : return;
11780 : }
11781 : }
11782 356 : else if (stmt_expr2->expr_type == EXPR_FUNCTION
11783 355 : && stmt_expr2->value.function.isym != NULL
11784 355 : && stmt_expr2->value.function.esym == NULL
11785 355 : && stmt_expr2->value.function.actual != NULL
11786 355 : && stmt_expr2->value.function.actual->next != NULL)
11787 : {
11788 355 : gfc_actual_arglist *arg, *var_arg;
11789 :
11790 355 : switch (stmt_expr2->value.function.isym->id)
11791 : {
11792 : case GFC_ISYM_MIN:
11793 : case GFC_ISYM_MAX:
11794 : break;
11795 147 : case GFC_ISYM_IAND:
11796 147 : case GFC_ISYM_IOR:
11797 147 : case GFC_ISYM_IEOR:
11798 147 : if (stmt_expr2->value.function.actual->next->next != NULL)
11799 : {
11800 0 : gfc_error ("!$OMP ATOMIC assignment intrinsic IAND, IOR "
11801 : "or IEOR must have two arguments at %L",
11802 : &stmt_expr2->where);
11803 0 : return;
11804 : }
11805 : break;
11806 1 : default:
11807 1 : gfc_error ("!$OMP ATOMIC assignment intrinsic must be "
11808 : "MIN, MAX, IAND, IOR or IEOR at %L",
11809 : &stmt_expr2->where);
11810 1 : return;
11811 : }
11812 :
11813 : var_arg = NULL;
11814 1088 : for (arg = stmt_expr2->value.function.actual; arg; arg = arg->next)
11815 : {
11816 741 : gfc_expr *e = NULL;
11817 741 : if (arg == stmt_expr2->value.function.actual
11818 387 : || (var_arg == NULL && arg->next == NULL))
11819 : {
11820 527 : e = is_conversion (arg->expr, false, true);
11821 527 : if (!e)
11822 514 : e = arg->expr;
11823 527 : if (e->expr_type == EXPR_VARIABLE
11824 453 : && e->symtree != NULL
11825 453 : && e->symtree->n.sym == var)
11826 741 : var_arg = arg;
11827 : }
11828 741 : if ((!var_arg || !e) && expr_references_sym (arg->expr, var, NULL))
11829 : {
11830 7 : gfc_error ("!$OMP ATOMIC intrinsic arguments except one must "
11831 : "not reference %qs at %L",
11832 : var->name, &arg->expr->where);
11833 7 : return;
11834 : }
11835 734 : if (arg->expr->rank != 0)
11836 : {
11837 0 : gfc_error ("!$OMP ATOMIC intrinsic arguments must be scalar "
11838 : "at %L", &arg->expr->where);
11839 0 : return;
11840 : }
11841 : }
11842 :
11843 347 : if (var_arg == NULL)
11844 : {
11845 1 : gfc_error ("First or last !$OMP ATOMIC intrinsic argument must "
11846 : "be %qs at %L", var->name, &stmt_expr2->where);
11847 1 : return;
11848 : }
11849 :
11850 346 : if (var_arg != stmt_expr2->value.function.actual)
11851 : {
11852 : /* Canonicalize, so that var comes first. */
11853 172 : gcc_assert (var_arg->next == NULL);
11854 : for (arg = stmt_expr2->value.function.actual;
11855 185 : arg->next != var_arg; arg = arg->next)
11856 : ;
11857 172 : var_arg->next = stmt_expr2->value.function.actual;
11858 172 : stmt_expr2->value.function.actual = var_arg;
11859 172 : arg->next = NULL;
11860 : }
11861 : }
11862 : else
11863 1 : gfc_error ("!$OMP ATOMIC assignment must have an operator or "
11864 : "intrinsic on right hand side at %L", &stmt_expr2->where);
11865 : return;
11866 :
11867 4 : unexpected:
11868 4 : gfc_error ("unexpected !$OMP ATOMIC expression at %L",
11869 : loc ? loc : &code->loc);
11870 4 : return;
11871 : }
11872 :
11873 :
11874 : static struct fortran_omp_context
11875 : {
11876 : gfc_code *code;
11877 : hash_set<gfc_symbol *> *sharing_clauses;
11878 : hash_set<gfc_symbol *> *private_iterators;
11879 : struct fortran_omp_context *previous;
11880 : bool is_openmp;
11881 : } *omp_current_ctx;
11882 : static gfc_code *omp_current_do_code;
11883 : static int omp_current_do_collapse;
11884 :
11885 : /* Forward declaration for mutually recursive functions. */
11886 : static gfc_code *
11887 : find_nested_loop_in_block (gfc_code *block);
11888 :
11889 : /* Return the first nested DO loop in CHAIN, or NULL if there
11890 : isn't one. Does no error checking on intervening code. */
11891 :
11892 : static gfc_code *
11893 27482 : find_nested_loop_in_chain (gfc_code *chain)
11894 : {
11895 27482 : gfc_code *code;
11896 :
11897 27482 : if (!chain)
11898 : return NULL;
11899 :
11900 31643 : for (code = chain; code; code = code->next)
11901 31222 : switch (code->op)
11902 : {
11903 : case EXEC_DO:
11904 : case EXEC_OMP_TILE:
11905 : case EXEC_OMP_UNROLL:
11906 : return code;
11907 621 : case EXEC_BLOCK:
11908 621 : if (gfc_code *c = find_nested_loop_in_block (code))
11909 : return c;
11910 : break;
11911 : default:
11912 : break;
11913 : }
11914 : return NULL;
11915 : }
11916 :
11917 : /* Return the first nested DO loop in BLOCK, or NULL if there
11918 : isn't one. Does no error checking on intervening code. */
11919 : static gfc_code *
11920 939 : find_nested_loop_in_block (gfc_code *block)
11921 : {
11922 939 : gfc_namespace *ns;
11923 939 : gcc_assert (block->op == EXEC_BLOCK);
11924 939 : ns = block->ext.block.ns;
11925 939 : gcc_assert (ns);
11926 939 : return find_nested_loop_in_chain (ns->code);
11927 : }
11928 :
11929 : void
11930 5425 : gfc_resolve_omp_do_blocks (gfc_code *code, gfc_namespace *ns)
11931 : {
11932 5425 : if (code->block->next && code->block->next->op == EXEC_DO)
11933 : {
11934 5072 : int i;
11935 :
11936 5072 : omp_current_do_code = code->block->next;
11937 5072 : if (code->ext.omp_clauses->orderedc)
11938 142 : omp_current_do_collapse = code->ext.omp_clauses->orderedc;
11939 4930 : else if (code->ext.omp_clauses->collapse)
11940 1121 : omp_current_do_collapse = code->ext.omp_clauses->collapse;
11941 3809 : else if (code->ext.omp_clauses->sizes_list)
11942 175 : omp_current_do_collapse
11943 175 : = gfc_expr_list_len (code->ext.omp_clauses->sizes_list);
11944 : else
11945 3634 : omp_current_do_collapse = 1;
11946 5072 : if (code->ext.omp_clauses->lists[OMP_LIST_REDUCTION_INSCAN])
11947 : {
11948 : /* Checking that there is a matching EXEC_OMP_SCAN in the
11949 : innermost body cannot be deferred to resolve_omp_do because
11950 : we process directives nested in the loop before we get
11951 : there. */
11952 60 : locus *loc
11953 : = &code->ext.omp_clauses->lists[OMP_LIST_REDUCTION_INSCAN]->where;
11954 60 : gfc_code *c;
11955 :
11956 80 : for (i = 1, c = omp_current_do_code;
11957 80 : i < omp_current_do_collapse; i++)
11958 : {
11959 22 : c = find_nested_loop_in_chain (c->block->next);
11960 22 : if (!c || c->op != EXEC_DO || c->block == NULL)
11961 : break;
11962 : }
11963 :
11964 : /* Skip this if we don't have enough nested loops. That
11965 : problem will be diagnosed elsewhere. */
11966 60 : if (c && c->op == EXEC_DO)
11967 : {
11968 58 : gfc_code *block = c->block ? c->block->next : NULL;
11969 58 : if (block && block->op != EXEC_OMP_SCAN)
11970 54 : while (block && block->next
11971 54 : && block->next->op != EXEC_OMP_SCAN)
11972 : block = block->next;
11973 43 : if (!block
11974 46 : || (block->op != EXEC_OMP_SCAN
11975 43 : && (!block->next || block->next->op != EXEC_OMP_SCAN)))
11976 19 : gfc_error ("With INSCAN at %L, expected loop body with "
11977 : "!$OMP SCAN between two "
11978 : "structured block sequences", loc);
11979 : else
11980 : {
11981 39 : if (block->op == EXEC_OMP_SCAN)
11982 3 : gfc_warning (OPT_Wopenmp,
11983 : "!$OMP SCAN at %L with zero executable "
11984 : "statements in preceding structured block "
11985 : "sequence", &block->loc);
11986 39 : if ((block->op == EXEC_OMP_SCAN && !block->next)
11987 38 : || (block->next && block->next->op == EXEC_OMP_SCAN
11988 36 : && !block->next->next))
11989 3 : gfc_warning (OPT_Wopenmp,
11990 : "!$OMP SCAN at %L with zero executable "
11991 : "statements in succeeding structured block "
11992 : "sequence", block->op == EXEC_OMP_SCAN
11993 1 : ? &block->loc : &block->next->loc);
11994 : }
11995 58 : if (block && block->op != EXEC_OMP_SCAN)
11996 43 : block = block->next;
11997 46 : if (block && block->op == EXEC_OMP_SCAN)
11998 : /* Mark 'omp scan' as checked; flag will be unset later. */
11999 39 : block->ext.omp_clauses->if_present = true;
12000 : }
12001 : }
12002 : }
12003 5425 : gfc_resolve_blocks (code->block, ns);
12004 5425 : omp_current_do_collapse = 0;
12005 5425 : omp_current_do_code = NULL;
12006 5425 : }
12007 :
12008 :
12009 : void
12010 6054 : gfc_resolve_omp_parallel_blocks (gfc_code *code, gfc_namespace *ns)
12011 : {
12012 6054 : struct fortran_omp_context ctx;
12013 6054 : gfc_omp_clauses *omp_clauses = code->ext.omp_clauses;
12014 6054 : gfc_omp_namelist *n;
12015 :
12016 6054 : ctx.code = code;
12017 6054 : ctx.sharing_clauses = new hash_set<gfc_symbol *>;
12018 6054 : ctx.private_iterators = new hash_set<gfc_symbol *>;
12019 6054 : ctx.previous = omp_current_ctx;
12020 6054 : ctx.is_openmp = true;
12021 6054 : omp_current_ctx = &ctx;
12022 :
12023 242160 : for (enum gfc_omp_list_type list = OMP_LIST_FIRST; list < OMP_LIST_NUM;
12024 236106 : list = gfc_omp_list_type (list + 1))
12025 236106 : switch (list)
12026 : {
12027 60540 : case OMP_LIST_SHARED:
12028 60540 : case OMP_LIST_PRIVATE:
12029 60540 : case OMP_LIST_FIRSTPRIVATE:
12030 60540 : case OMP_LIST_LASTPRIVATE:
12031 60540 : case OMP_LIST_REDUCTION:
12032 60540 : case OMP_LIST_REDUCTION_INSCAN:
12033 60540 : case OMP_LIST_REDUCTION_TASK:
12034 60540 : case OMP_LIST_IN_REDUCTION:
12035 60540 : case OMP_LIST_TASK_REDUCTION:
12036 60540 : case OMP_LIST_LINEAR:
12037 69531 : for (n = omp_clauses->lists[list]; n; n = n->next)
12038 8991 : ctx.sharing_clauses->add (n->sym);
12039 : break;
12040 : default:
12041 : break;
12042 : }
12043 :
12044 6054 : switch (code->op)
12045 : {
12046 2361 : case EXEC_OMP_DISTRIBUTE_PARALLEL_DO:
12047 2361 : case EXEC_OMP_DISTRIBUTE_PARALLEL_DO_SIMD:
12048 2361 : case EXEC_OMP_MASKED_TASKLOOP:
12049 2361 : case EXEC_OMP_MASKED_TASKLOOP_SIMD:
12050 2361 : case EXEC_OMP_MASTER_TASKLOOP:
12051 2361 : case EXEC_OMP_MASTER_TASKLOOP_SIMD:
12052 2361 : case EXEC_OMP_PARALLEL_DO:
12053 2361 : case EXEC_OMP_PARALLEL_DO_SIMD:
12054 2361 : case EXEC_OMP_PARALLEL_LOOP:
12055 2361 : case EXEC_OMP_PARALLEL_MASKED_TASKLOOP:
12056 2361 : case EXEC_OMP_PARALLEL_MASKED_TASKLOOP_SIMD:
12057 2361 : case EXEC_OMP_PARALLEL_MASTER_TASKLOOP:
12058 2361 : case EXEC_OMP_PARALLEL_MASTER_TASKLOOP_SIMD:
12059 2361 : case EXEC_OMP_TARGET_PARALLEL_DO:
12060 2361 : case EXEC_OMP_TARGET_PARALLEL_DO_SIMD:
12061 2361 : case EXEC_OMP_TARGET_PARALLEL_LOOP:
12062 2361 : case EXEC_OMP_TARGET_TEAMS_DISTRIBUTE:
12063 2361 : case EXEC_OMP_TARGET_TEAMS_DISTRIBUTE_PARALLEL_DO:
12064 2361 : case EXEC_OMP_TARGET_TEAMS_DISTRIBUTE_PARALLEL_DO_SIMD:
12065 2361 : case EXEC_OMP_TARGET_TEAMS_DISTRIBUTE_SIMD:
12066 2361 : case EXEC_OMP_TARGET_TEAMS_LOOP:
12067 2361 : case EXEC_OMP_TASKLOOP:
12068 2361 : case EXEC_OMP_TASKLOOP_SIMD:
12069 2361 : case EXEC_OMP_TEAMS_DISTRIBUTE:
12070 2361 : case EXEC_OMP_TEAMS_DISTRIBUTE_PARALLEL_DO:
12071 2361 : case EXEC_OMP_TEAMS_DISTRIBUTE_PARALLEL_DO_SIMD:
12072 2361 : case EXEC_OMP_TEAMS_DISTRIBUTE_SIMD:
12073 2361 : case EXEC_OMP_TEAMS_LOOP:
12074 2361 : gfc_resolve_omp_do_blocks (code, ns);
12075 2361 : break;
12076 3693 : default:
12077 3693 : gfc_resolve_blocks (code->block, ns);
12078 : }
12079 :
12080 6054 : omp_current_ctx = ctx.previous;
12081 12108 : delete ctx.sharing_clauses;
12082 12108 : delete ctx.private_iterators;
12083 6054 : }
12084 :
12085 :
12086 : /* Save and clear openmp.cc private state. */
12087 :
12088 : void
12089 295052 : gfc_omp_save_and_clear_state (struct gfc_omp_saved_state *state)
12090 : {
12091 295052 : state->ptrs[0] = omp_current_ctx;
12092 295052 : state->ptrs[1] = omp_current_do_code;
12093 295052 : state->ints[0] = omp_current_do_collapse;
12094 295052 : omp_current_ctx = NULL;
12095 295052 : omp_current_do_code = NULL;
12096 295052 : omp_current_do_collapse = 0;
12097 295052 : }
12098 :
12099 :
12100 : /* Restore openmp.cc private state from the saved state. */
12101 :
12102 : void
12103 295051 : gfc_omp_restore_state (struct gfc_omp_saved_state *state)
12104 : {
12105 295051 : omp_current_ctx = (struct fortran_omp_context *) state->ptrs[0];
12106 295051 : omp_current_do_code = (gfc_code *) state->ptrs[1];
12107 295051 : omp_current_do_collapse = state->ints[0];
12108 295051 : }
12109 :
12110 :
12111 : /* Note a DO iterator variable. This is special in !$omp parallel
12112 : construct, where they are predetermined private. */
12113 :
12114 : void
12115 33161 : gfc_resolve_do_iterator (gfc_code *code, gfc_symbol *sym, bool add_clause)
12116 : {
12117 33161 : if (omp_current_ctx == NULL)
12118 : return;
12119 :
12120 13106 : int i = omp_current_do_collapse;
12121 13106 : gfc_code *c = omp_current_do_code;
12122 :
12123 13106 : if (sym->attr.threadprivate)
12124 : return;
12125 :
12126 : /* !$omp do and !$omp parallel do iteration variable is predetermined
12127 : private just in the !$omp do resp. !$omp parallel do construct,
12128 : with no implications for the outer parallel constructs. */
12129 :
12130 17941 : while (i-- >= 1 && c)
12131 : {
12132 9495 : if (code == c)
12133 : return;
12134 4835 : c = find_nested_loop_in_chain (c->block->next);
12135 4835 : if (c && (c->op == EXEC_OMP_TILE || c->op == EXEC_OMP_UNROLL))
12136 : return;
12137 : }
12138 :
12139 : /* An openacc context may represent a data clause. Abort if so. */
12140 8446 : if (!omp_current_ctx->is_openmp && !oacc_is_loop (omp_current_ctx->code))
12141 : return;
12142 :
12143 7468 : if (omp_current_ctx->sharing_clauses->contains (sym))
12144 : return;
12145 :
12146 6466 : if (! omp_current_ctx->private_iterators->add (sym) && add_clause)
12147 : {
12148 6276 : gfc_omp_clauses *omp_clauses = omp_current_ctx->code->ext.omp_clauses;
12149 6276 : gfc_omp_namelist *p;
12150 :
12151 6276 : p = gfc_get_omp_namelist ();
12152 6276 : p->sym = sym;
12153 6276 : p->where = omp_current_ctx->code->loc;
12154 6276 : p->next = omp_clauses->lists[OMP_LIST_PRIVATE];
12155 6276 : omp_clauses->lists[OMP_LIST_PRIVATE] = p;
12156 : }
12157 : }
12158 :
12159 : static void
12160 760 : handle_local_var (gfc_symbol *sym)
12161 : {
12162 760 : if (sym->attr.flavor != FL_VARIABLE
12163 180 : || sym->as != NULL
12164 139 : || (sym->ts.type != BT_INTEGER && sym->ts.type != BT_REAL))
12165 : return;
12166 72 : gfc_resolve_do_iterator (sym->ns->code, sym, false);
12167 : }
12168 :
12169 : void
12170 341841 : gfc_resolve_omp_local_vars (gfc_namespace *ns)
12171 : {
12172 341841 : if (omp_current_ctx)
12173 454 : gfc_traverse_ns (ns, handle_local_var);
12174 341841 : }
12175 :
12176 :
12177 : /* Error checking on intervening code uses a code walker. */
12178 :
12179 : struct icode_error_state
12180 : {
12181 : const char *name;
12182 : bool errorp;
12183 : gfc_code *nested;
12184 : gfc_code *next;
12185 : };
12186 :
12187 : static int
12188 944 : icode_code_error_callback (gfc_code **codep,
12189 : int *walk_subtrees ATTRIBUTE_UNUSED, void *opaque)
12190 : {
12191 944 : gfc_code *code = *codep;
12192 944 : icode_error_state *state = (icode_error_state *)opaque;
12193 :
12194 : /* gfc_code_walker walks down CODE's next chain as well as
12195 : walking things that are actually nested in CODE. We need to
12196 : special-case traversal of outer blocks, so stop immediately if we
12197 : are heading down such a next chain. */
12198 944 : if (code == state->next)
12199 : return 1;
12200 :
12201 647 : switch (code->op)
12202 : {
12203 1 : case EXEC_DO:
12204 1 : case EXEC_DO_WHILE:
12205 1 : case EXEC_DO_CONCURRENT:
12206 1 : gfc_error ("%s cannot contain loop in intervening code at %L",
12207 : state->name, &code->loc);
12208 1 : state->errorp = true;
12209 1 : break;
12210 0 : case EXEC_CYCLE:
12211 0 : case EXEC_EXIT:
12212 : /* Errors have already been diagnosed in match_exit_cycle. */
12213 0 : state->errorp = true;
12214 0 : break;
12215 : case EXEC_OMP_ASSUME:
12216 : case EXEC_OMP_METADIRECTIVE:
12217 : /* Per OpenMP 6.0, some non-executable directives are allowed in
12218 : intervening code. */
12219 : break;
12220 477 : case EXEC_CALL:
12221 : /* Per OpenMP 5.2, the "omp_" prefix is reserved, so we don't have to
12222 : consider the possibility that some locally-bound definition
12223 : overrides the runtime routine. */
12224 477 : if (code->resolved_sym
12225 477 : && omp_runtime_api_procname (code->resolved_sym->name))
12226 : {
12227 1 : gfc_error ("%s cannot contain OpenMP API call in intervening code "
12228 : "at %L",
12229 : state->name, &code->loc);
12230 1 : state->errorp = true;
12231 : }
12232 : break;
12233 168 : default:
12234 168 : if (code->op >= EXEC_OMP_FIRST_OPENMP_EXEC
12235 168 : && code->op <= EXEC_OMP_LAST_OPENMP_EXEC)
12236 : {
12237 2 : gfc_error ("%s cannot contain OpenMP directive in intervening code "
12238 : "at %L",
12239 : state->name, &code->loc);
12240 2 : state->errorp = true;
12241 : }
12242 : }
12243 : return 0;
12244 : }
12245 :
12246 : static int
12247 1081 : icode_expr_error_callback (gfc_expr **expr,
12248 : int *walk_subtrees ATTRIBUTE_UNUSED, void *opaque)
12249 : {
12250 1081 : icode_error_state *state = (icode_error_state *)opaque;
12251 :
12252 1081 : switch ((*expr)->expr_type)
12253 : {
12254 : /* As for EXPR_CALL with "omp_"-prefixed symbols. */
12255 2 : case EXPR_FUNCTION:
12256 2 : {
12257 2 : gfc_symbol *sym = (*expr)->value.function.esym;
12258 2 : if (sym && omp_runtime_api_procname (sym->name))
12259 : {
12260 1 : gfc_error ("%s cannot contain OpenMP API call in intervening code "
12261 : "at %L",
12262 1 : state->name, &((*expr)->where));
12263 1 : state->errorp = true;
12264 : }
12265 : }
12266 :
12267 : break;
12268 : default:
12269 : break;
12270 : }
12271 :
12272 : /* FIXME: The description of canonical loop form in the OpenMP standard
12273 : also says "array expressions" are not permitted in intervening code.
12274 : That term is not defined in either the OpenMP spec or the Fortran
12275 : standard, although the latter uses it informally to refer to any
12276 : expression that is not scalar-valued. It is also apparently not the
12277 : thing GCC internally calls EXPR_ARRAY. It seems the intent of the
12278 : OpenMP restriction is to disallow elemental operations/intrinsics
12279 : (including things that are not expressions, like assignment
12280 : statements) that generate implicit loops over array operands
12281 : (even if the result is a scalar), but even if the spec said
12282 : that there is no list of all the cases that would be forbidden.
12283 : This is OpenMP issue 3326. */
12284 :
12285 1081 : return 0;
12286 : }
12287 :
12288 : static void
12289 267 : diagnose_intervening_code_errors_1 (gfc_code *chain,
12290 : struct icode_error_state *state)
12291 : {
12292 267 : gfc_code *code;
12293 1080 : for (code = chain; code; code = code->next)
12294 : {
12295 813 : if (code == state->nested)
12296 : /* Do not walk the nested loop or its body, we are only
12297 : interested in intervening code. */
12298 : ;
12299 636 : else if (code->op == EXEC_BLOCK
12300 636 : && find_nested_loop_in_block (code) == state->nested)
12301 : /* This block contains the nested loop, recurse on its
12302 : statements. */
12303 : {
12304 90 : gfc_namespace* ns = code->ext.block.ns;
12305 90 : diagnose_intervening_code_errors_1 (ns->code, state);
12306 : }
12307 : else
12308 : /* Treat the whole statement as a unit. */
12309 : {
12310 546 : gfc_code *temp = state->next;
12311 546 : state->next = code->next;
12312 546 : gfc_code_walker (&code, icode_code_error_callback,
12313 : icode_expr_error_callback, state);
12314 546 : state->next = temp;
12315 : }
12316 : }
12317 267 : }
12318 :
12319 : /* Diagnose intervening code errors in BLOCK with nested loop NESTED.
12320 : NAME is the user-friendly name of the OMP directive, used for error
12321 : messages. Returns true if any error was found. */
12322 : static bool
12323 177 : diagnose_intervening_code_errors (gfc_code *chain, const char *name,
12324 : gfc_code *nested)
12325 : {
12326 177 : struct icode_error_state state;
12327 177 : state.name = name;
12328 177 : state.errorp = false;
12329 177 : state.nested = nested;
12330 177 : state.next = NULL;
12331 0 : diagnose_intervening_code_errors_1 (chain, &state);
12332 177 : return state.errorp;
12333 : }
12334 :
12335 : /* Helper function for restructure_intervening_code: wrap CHAIN in
12336 : a marker to indicate that it is a structured block sequence. That
12337 : information will be used later on (in omp-low.cc) for error checking. */
12338 : static gfc_code *
12339 461 : make_structured_block (gfc_code *chain)
12340 : {
12341 461 : gcc_assert (chain);
12342 461 : gfc_namespace *ns = gfc_build_block_ns (gfc_current_ns);
12343 461 : gfc_code *result = gfc_get_code (EXEC_BLOCK);
12344 461 : result->op = EXEC_BLOCK;
12345 461 : result->ext.block.ns = ns;
12346 461 : result->ext.block.assoc = NULL;
12347 461 : result->loc = chain->loc;
12348 461 : ns->omp_structured_block = 1;
12349 461 : ns->code = chain;
12350 461 : return result;
12351 : }
12352 :
12353 : /* Push intervening code surrounding a loop, including nested scopes,
12354 : into the body of the loop. CHAINP is the pointer to the head of
12355 : the next-chain to scan, OUTER_LOOP is the EXEC_DO for the next outer
12356 : loop level, and COLLAPSE is the number of nested loops we need to
12357 : process.
12358 : Note that CHAINP may point at outer_loop->block->next when we
12359 : are scanning the body of a loop, but if there is an intervening block
12360 : CHAINP points into the block's chain rather than its enclosing outer
12361 : loop. This is why OUTER_LOOP is passed separately. */
12362 : static gfc_code *
12363 7175 : restructure_intervening_code (gfc_code **chainp, gfc_code *outer_loop,
12364 : int count)
12365 : {
12366 7175 : gfc_code *code;
12367 7175 : gfc_code *head = *chainp;
12368 7175 : gfc_code *tail = NULL;
12369 7175 : gfc_code *innermost_loop = NULL;
12370 :
12371 7439 : for (code = *chainp; code; code = code->next, chainp = &(*chainp)->next)
12372 : {
12373 7439 : if (code->op == EXEC_DO)
12374 : {
12375 : /* Cut CODE free from its chain, leaving the ends dangling. */
12376 7091 : *chainp = NULL;
12377 7091 : tail = code->next;
12378 7091 : code->next = NULL;
12379 :
12380 7091 : if (count == 1)
12381 : innermost_loop = code;
12382 : else
12383 2090 : innermost_loop
12384 2090 : = restructure_intervening_code (&code->block->next,
12385 : code, count - 1);
12386 : break;
12387 : }
12388 348 : else if (code->op == EXEC_BLOCK
12389 348 : && find_nested_loop_in_block (code))
12390 : {
12391 84 : gfc_namespace *ns = code->ext.block.ns;
12392 :
12393 : /* Cut CODE free from its chain, leaving the ends dangling. */
12394 84 : *chainp = NULL;
12395 84 : tail = code->next;
12396 84 : code->next = NULL;
12397 :
12398 84 : innermost_loop
12399 84 : = restructure_intervening_code (&ns->code, outer_loop,
12400 : count);
12401 :
12402 : /* At this point we have already pulled out the nested loop and
12403 : pointed outer_loop at it, and moved the intervening code that
12404 : was previously in the block into the body of innermost_loop.
12405 : Now we want to move the BLOCK itself so it wraps the entire
12406 : current body of innermost_loop. */
12407 84 : ns->code = innermost_loop->block->next;
12408 84 : innermost_loop->block->next = code;
12409 84 : break;
12410 : }
12411 : }
12412 :
12413 2174 : gcc_assert (innermost_loop);
12414 :
12415 : /* Now we have split the intervening code into two parts:
12416 : head is the start of the part before the loop/block, terminating
12417 : at *chainp, and tail is the part after it. Mark each part as
12418 : a structured block sequence, and splice the two parts around the
12419 : existing body of the innermost loop. */
12420 7175 : if (head != code)
12421 : {
12422 222 : gfc_code *block = make_structured_block (head);
12423 222 : if (innermost_loop->block->next)
12424 221 : gfc_append_code (block, innermost_loop->block->next);
12425 222 : innermost_loop->block->next = block;
12426 : }
12427 7175 : if (tail)
12428 : {
12429 239 : gfc_code *block = make_structured_block (tail);
12430 239 : if (innermost_loop->block->next)
12431 237 : gfc_append_code (innermost_loop->block->next, block);
12432 : else
12433 2 : innermost_loop->block->next = block;
12434 : }
12435 :
12436 : /* For loops, finally splice CODE into OUTER_LOOP. We already handled
12437 : relinking EXEC_BLOCK above. */
12438 7175 : if (code->op == EXEC_DO && outer_loop)
12439 7091 : outer_loop->block->next = code;
12440 :
12441 7175 : return innermost_loop;
12442 : }
12443 :
12444 : /* CODE is an OMP loop construct. Return true if VAR matches an iteration
12445 : variable outer to level DEPTH. */
12446 : static bool
12447 8088 : is_outer_iteration_variable (gfc_code *code, int depth, gfc_symbol *var)
12448 : {
12449 8088 : int i;
12450 8088 : gfc_code *do_code = code;
12451 :
12452 12615 : for (i = 1; i < depth; i++)
12453 : {
12454 5028 : do_code = find_nested_loop_in_chain (do_code->block->next);
12455 5028 : gcc_assert (do_code);
12456 5028 : if (do_code->op == EXEC_OMP_TILE || do_code->op == EXEC_OMP_UNROLL)
12457 : {
12458 51 : --i;
12459 51 : continue;
12460 : }
12461 4977 : gfc_symbol *ivar = do_code->ext.iterator->var->symtree->n.sym;
12462 4977 : if (var == ivar)
12463 : return true;
12464 : }
12465 : return false;
12466 : }
12467 :
12468 : /* Forward declaration for recursive functions. */
12469 : static gfc_code *
12470 : check_nested_loop_in_block (gfc_code *block, gfc_expr *expr, gfc_symbol *sym,
12471 : bool *bad);
12472 :
12473 : /* Like find_nested_loop_in_chain, but additionally check that EXPR
12474 : does not reference any variables bound in intervening EXEC_BLOCKs
12475 : and that SYM is not bound in such intervening blocks. Either EXPR or SYM
12476 : may be null. Sets *BAD to true if either test fails. */
12477 : static gfc_code *
12478 48185 : check_nested_loop_in_chain (gfc_code *chain, gfc_expr *expr, gfc_symbol *sym,
12479 : bool *bad)
12480 : {
12481 51789 : for (gfc_code *code = chain; code; code = code->next)
12482 : {
12483 51501 : if (code->op == EXEC_DO)
12484 : return code;
12485 4123 : else if (code->op == EXEC_OMP_TILE || code->op == EXEC_OMP_UNROLL)
12486 1682 : return check_nested_loop_in_chain (code->block->next, expr, sym, bad);
12487 2441 : else if (code->op == EXEC_BLOCK)
12488 : {
12489 807 : gfc_code *c = check_nested_loop_in_block (code, expr, sym, bad);
12490 807 : if (c)
12491 : return c;
12492 : }
12493 : }
12494 : return NULL;
12495 : }
12496 :
12497 : /* Code walker for block symtrees. It doesn't take any kind of state
12498 : argument, so use a static variable. */
12499 : static struct check_nested_loop_in_block_state_t {
12500 : gfc_expr *expr;
12501 : gfc_symbol *sym;
12502 : bool *bad;
12503 : } check_nested_loop_in_block_state;
12504 :
12505 : static void
12506 766 : check_nested_loop_in_block_symbol (gfc_symbol *sym)
12507 : {
12508 766 : if (sym == check_nested_loop_in_block_state.sym
12509 766 : || (check_nested_loop_in_block_state.expr
12510 567 : && gfc_find_sym_in_expr (sym,
12511 : check_nested_loop_in_block_state.expr)))
12512 5 : *check_nested_loop_in_block_state.bad = true;
12513 766 : }
12514 :
12515 : /* Return the first nested DO loop in BLOCK, or NULL if there
12516 : isn't one. Set *BAD to true if EXPR references any variables in BLOCK, or
12517 : SYM is bound in BLOCK. Either EXPR or SYM may be null. */
12518 : static gfc_code *
12519 807 : check_nested_loop_in_block (gfc_code *block, gfc_expr *expr,
12520 : gfc_symbol *sym, bool *bad)
12521 : {
12522 807 : gfc_namespace *ns;
12523 807 : gcc_assert (block->op == EXEC_BLOCK);
12524 807 : ns = block->ext.block.ns;
12525 807 : gcc_assert (ns);
12526 :
12527 : /* Skip the check if this block doesn't contain the nested loop, or
12528 : if we already know it's bad. */
12529 807 : gfc_code *result = check_nested_loop_in_chain (ns->code, expr, sym, bad);
12530 807 : if (result && !*bad)
12531 : {
12532 519 : check_nested_loop_in_block_state.expr = expr;
12533 519 : check_nested_loop_in_block_state.sym = sym;
12534 519 : check_nested_loop_in_block_state.bad = bad;
12535 519 : gfc_traverse_ns (ns, check_nested_loop_in_block_symbol);
12536 519 : check_nested_loop_in_block_state.expr = NULL;
12537 519 : check_nested_loop_in_block_state.sym = NULL;
12538 519 : check_nested_loop_in_block_state.bad = NULL;
12539 : }
12540 807 : return result;
12541 : }
12542 :
12543 : /* CODE is an OMP loop construct. Return true if EXPR references
12544 : any variables bound in intervening code, to level DEPTH. */
12545 : static bool
12546 22732 : expr_uses_intervening_var (gfc_code *code, int depth, gfc_expr *expr)
12547 : {
12548 22732 : int i;
12549 22732 : gfc_code *do_code = code;
12550 :
12551 58243 : for (i = 0; i < depth; i++)
12552 : {
12553 35514 : bool bad = false;
12554 35514 : do_code = check_nested_loop_in_chain (do_code->block->next,
12555 : expr, NULL, &bad);
12556 35514 : if (bad)
12557 3 : return true;
12558 : }
12559 : return false;
12560 : }
12561 :
12562 : /* CODE is an OMP loop construct. Return true if SYM is bound in
12563 : intervening code, to level DEPTH. */
12564 : static bool
12565 7587 : is_intervening_var (gfc_code *code, int depth, gfc_symbol *sym)
12566 : {
12567 7587 : int i;
12568 7587 : gfc_code *do_code = code;
12569 :
12570 19449 : for (i = 0; i < depth; i++)
12571 : {
12572 11864 : bool bad = false;
12573 11864 : do_code = check_nested_loop_in_chain (do_code->block->next,
12574 : NULL, sym, &bad);
12575 11864 : if (bad)
12576 2 : return true;
12577 : }
12578 : return false;
12579 : }
12580 :
12581 : /* CODE is an OMP loop construct. Return true if EXPR does not reference
12582 : any iteration variables outer to level DEPTH. */
12583 : static bool
12584 23811 : expr_is_invariant (gfc_code *code, int depth, gfc_expr *expr)
12585 : {
12586 23811 : int i;
12587 23811 : gfc_code *do_code = code;
12588 :
12589 37133 : for (i = 1; i < depth; i++)
12590 : {
12591 14388 : do_code = find_nested_loop_in_chain (do_code->block->next);
12592 14388 : gcc_assert (do_code);
12593 14388 : if (do_code->op == EXEC_OMP_TILE || do_code->op == EXEC_OMP_UNROLL)
12594 : {
12595 136 : --i;
12596 136 : continue;
12597 : }
12598 14252 : gfc_symbol *ivar = do_code->ext.iterator->var->symtree->n.sym;
12599 14252 : if (gfc_find_sym_in_expr (ivar, expr))
12600 : return false;
12601 : }
12602 : return true;
12603 : }
12604 :
12605 : /* CODE is an OMP loop construct. Return true if EXPR matches one of the
12606 : canonical forms for a bound expression. It may include references to
12607 : an iteration variable outer to level DEPTH; set OUTER_VARP if so. */
12608 : static bool
12609 15165 : bound_expr_is_canonical (gfc_code *code, int depth, gfc_expr *expr,
12610 : gfc_symbol **outer_varp)
12611 : {
12612 15165 : gfc_expr *expr2 = NULL;
12613 :
12614 : /* Rectangular case. */
12615 15165 : if (depth == 0 || expr_is_invariant (code, depth, expr))
12616 14597 : return true;
12617 :
12618 : /* Any simple variable that didn't pass expr_is_invariant must be
12619 : an outer_var. */
12620 568 : if (expr->expr_type == EXPR_VARIABLE && expr->rank == 0)
12621 : {
12622 63 : *outer_varp = expr->symtree->n.sym;
12623 63 : return true;
12624 : }
12625 :
12626 : /* All other permitted forms are binary operators. */
12627 505 : if (expr->expr_type != EXPR_OP)
12628 : return false;
12629 :
12630 : /* Check for plus/minus a loop invariant expr. */
12631 503 : if (expr->value.op.op == INTRINSIC_PLUS
12632 503 : || expr->value.op.op == INTRINSIC_MINUS)
12633 : {
12634 483 : if (expr_is_invariant (code, depth, expr->value.op.op1))
12635 48 : expr2 = expr->value.op.op2;
12636 435 : else if (expr_is_invariant (code, depth, expr->value.op.op2))
12637 434 : expr2 = expr->value.op.op1;
12638 : else
12639 : return false;
12640 : }
12641 : else
12642 : expr2 = expr;
12643 :
12644 : /* Check for a product with a loop-invariant expr. */
12645 502 : if (expr2->expr_type == EXPR_OP
12646 96 : && expr2->value.op.op == INTRINSIC_TIMES)
12647 : {
12648 96 : if (expr_is_invariant (code, depth, expr2->value.op.op1))
12649 40 : expr2 = expr2->value.op.op2;
12650 56 : else if (expr_is_invariant (code, depth, expr2->value.op.op2))
12651 53 : expr2 = expr2->value.op.op1;
12652 : else
12653 : return false;
12654 : }
12655 :
12656 : /* What's left must be a reference to an outer loop variable. */
12657 499 : if (expr2->expr_type == EXPR_VARIABLE
12658 499 : && expr2->rank == 0
12659 998 : && is_outer_iteration_variable (code, depth, expr2->symtree->n.sym))
12660 : {
12661 499 : *outer_varp = expr2->symtree->n.sym;
12662 499 : return true;
12663 : }
12664 :
12665 : return false;
12666 : }
12667 :
12668 : static void
12669 5425 : resolve_omp_do (gfc_code *code)
12670 : {
12671 5425 : gfc_code *do_code, *next;
12672 5425 : int i, count, non_generated_count;
12673 5425 : gfc_omp_namelist *n;
12674 5425 : gfc_symbol *dovar;
12675 5425 : const char *name;
12676 5425 : bool is_simd = false;
12677 5425 : bool errorp = false;
12678 5425 : bool perfect_nesting_errorp = false;
12679 5425 : bool imperfect = false;
12680 :
12681 5425 : switch (code->op)
12682 : {
12683 : case EXEC_OMP_DISTRIBUTE: name = "!$OMP DISTRIBUTE"; break;
12684 49 : case EXEC_OMP_DISTRIBUTE_PARALLEL_DO:
12685 49 : name = "!$OMP DISTRIBUTE PARALLEL DO";
12686 49 : break;
12687 32 : case EXEC_OMP_DISTRIBUTE_PARALLEL_DO_SIMD:
12688 32 : name = "!$OMP DISTRIBUTE PARALLEL DO SIMD";
12689 32 : is_simd = true;
12690 32 : break;
12691 50 : case EXEC_OMP_DISTRIBUTE_SIMD:
12692 50 : name = "!$OMP DISTRIBUTE SIMD";
12693 50 : is_simd = true;
12694 50 : break;
12695 1336 : case EXEC_OMP_DO: name = "!$OMP DO"; break;
12696 134 : case EXEC_OMP_DO_SIMD: name = "!$OMP DO SIMD"; is_simd = true; break;
12697 64 : case EXEC_OMP_LOOP: name = "!$OMP LOOP"; break;
12698 1220 : case EXEC_OMP_PARALLEL_DO: name = "!$OMP PARALLEL DO"; break;
12699 304 : case EXEC_OMP_PARALLEL_DO_SIMD:
12700 304 : name = "!$OMP PARALLEL DO SIMD";
12701 304 : is_simd = true;
12702 304 : break;
12703 46 : case EXEC_OMP_PARALLEL_LOOP: name = "!$OMP PARALLEL LOOP"; break;
12704 7 : case EXEC_OMP_PARALLEL_MASKED_TASKLOOP:
12705 7 : name = "!$OMP PARALLEL MASKED TASKLOOP";
12706 7 : break;
12707 10 : case EXEC_OMP_PARALLEL_MASKED_TASKLOOP_SIMD:
12708 10 : name = "!$OMP PARALLEL MASKED TASKLOOP SIMD";
12709 10 : is_simd = true;
12710 10 : break;
12711 12 : case EXEC_OMP_PARALLEL_MASTER_TASKLOOP:
12712 12 : name = "!$OMP PARALLEL MASTER TASKLOOP";
12713 12 : break;
12714 18 : case EXEC_OMP_PARALLEL_MASTER_TASKLOOP_SIMD:
12715 18 : name = "!$OMP PARALLEL MASTER TASKLOOP SIMD";
12716 18 : is_simd = true;
12717 18 : break;
12718 8 : case EXEC_OMP_MASKED_TASKLOOP: name = "!$OMP MASKED TASKLOOP"; break;
12719 14 : case EXEC_OMP_MASKED_TASKLOOP_SIMD:
12720 14 : name = "!$OMP MASKED TASKLOOP SIMD";
12721 14 : is_simd = true;
12722 14 : break;
12723 14 : case EXEC_OMP_MASTER_TASKLOOP: name = "!$OMP MASTER TASKLOOP"; break;
12724 19 : case EXEC_OMP_MASTER_TASKLOOP_SIMD:
12725 19 : name = "!$OMP MASTER TASKLOOP SIMD";
12726 19 : is_simd = true;
12727 19 : break;
12728 783 : case EXEC_OMP_SIMD: name = "!$OMP SIMD"; is_simd = true; break;
12729 88 : case EXEC_OMP_TARGET_PARALLEL_DO: name = "!$OMP TARGET PARALLEL DO"; break;
12730 19 : case EXEC_OMP_TARGET_PARALLEL_DO_SIMD:
12731 19 : name = "!$OMP TARGET PARALLEL DO SIMD";
12732 19 : is_simd = true;
12733 19 : break;
12734 16 : case EXEC_OMP_TARGET_PARALLEL_LOOP:
12735 16 : name = "!$OMP TARGET PARALLEL LOOP";
12736 16 : break;
12737 33 : case EXEC_OMP_TARGET_SIMD:
12738 33 : name = "!$OMP TARGET SIMD";
12739 33 : is_simd = true;
12740 33 : break;
12741 20 : case EXEC_OMP_TARGET_TEAMS_DISTRIBUTE:
12742 20 : name = "!$OMP TARGET TEAMS DISTRIBUTE";
12743 20 : break;
12744 75 : case EXEC_OMP_TARGET_TEAMS_DISTRIBUTE_PARALLEL_DO:
12745 75 : name = "!$OMP TARGET TEAMS DISTRIBUTE PARALLEL DO";
12746 75 : break;
12747 37 : case EXEC_OMP_TARGET_TEAMS_DISTRIBUTE_PARALLEL_DO_SIMD:
12748 37 : name = "!$OMP TARGET TEAMS DISTRIBUTE PARALLEL DO SIMD";
12749 37 : is_simd = true;
12750 37 : break;
12751 20 : case EXEC_OMP_TARGET_TEAMS_DISTRIBUTE_SIMD:
12752 20 : name = "!$OMP TARGET TEAMS DISTRIBUTE SIMD";
12753 20 : is_simd = true;
12754 20 : break;
12755 19 : case EXEC_OMP_TARGET_TEAMS_LOOP: name = "!$OMP TARGET TEAMS LOOP"; break;
12756 69 : case EXEC_OMP_TASKLOOP: name = "!$OMP TASKLOOP"; break;
12757 38 : case EXEC_OMP_TASKLOOP_SIMD:
12758 38 : name = "!$OMP TASKLOOP SIMD";
12759 38 : is_simd = true;
12760 38 : break;
12761 20 : case EXEC_OMP_TEAMS_DISTRIBUTE: name = "!$OMP TEAMS DISTRIBUTE"; break;
12762 37 : case EXEC_OMP_TEAMS_DISTRIBUTE_PARALLEL_DO:
12763 37 : name = "!$OMP TEAMS DISTRIBUTE PARALLEL DO";
12764 37 : break;
12765 60 : case EXEC_OMP_TEAMS_DISTRIBUTE_PARALLEL_DO_SIMD:
12766 60 : name = "!$OMP TEAMS DISTRIBUTE PARALLEL DO SIMD";
12767 60 : is_simd = true;
12768 60 : break;
12769 42 : case EXEC_OMP_TEAMS_DISTRIBUTE_SIMD:
12770 42 : name = "!$OMP TEAMS DISTRIBUTE SIMD";
12771 42 : is_simd = true;
12772 42 : break;
12773 48 : case EXEC_OMP_TEAMS_LOOP: name = "!$OMP TEAMS LOOP"; break;
12774 195 : case EXEC_OMP_TILE: name = "!$OMP TILE"; break;
12775 415 : case EXEC_OMP_UNROLL: name = "!$OMP UNROLL"; break;
12776 0 : default: gcc_unreachable ();
12777 : }
12778 :
12779 5425 : if (code->ext.omp_clauses)
12780 5425 : resolve_omp_clauses (code, code->ext.omp_clauses, NULL);
12781 :
12782 5425 : if (code->op == EXEC_OMP_TILE && code->ext.omp_clauses->sizes_list == NULL)
12783 0 : gfc_error ("SIZES clause is required on !$OMP TILE construct at %L",
12784 : &code->loc);
12785 :
12786 5425 : do_code = code->block->next;
12787 5425 : if (code->ext.omp_clauses->orderedc)
12788 : count = code->ext.omp_clauses->orderedc;
12789 5281 : else if (code->ext.omp_clauses->sizes_list)
12790 195 : count = gfc_expr_list_len (code->ext.omp_clauses->sizes_list);
12791 : else
12792 : {
12793 5086 : count = code->ext.omp_clauses->collapse;
12794 5086 : if (count <= 0)
12795 : count = 1;
12796 : }
12797 :
12798 5425 : non_generated_count = count;
12799 : /* While the spec defines the loop nest depth independently of the COLLAPSE
12800 : clause, in practice the middle end only pays attention to the COLLAPSE
12801 : depth and treats any further inner loops as the final-loop-body. So
12802 : here we also check canonical loop nest form only for the number of
12803 : outer loops specified by the COLLAPSE clause too. */
12804 8065 : for (i = 1; i <= count; i++)
12805 : {
12806 8065 : gfc_symbol *start_var = NULL, *end_var = NULL;
12807 : /* Parse errors are not recoverable. */
12808 8065 : if (do_code->op == EXEC_DO_WHILE)
12809 : {
12810 6 : gfc_error ("%s cannot be a DO WHILE or DO without loop control "
12811 : "at %L", name, &do_code->loc);
12812 106 : goto fail;
12813 : }
12814 8059 : if (do_code->op == EXEC_DO_CONCURRENT)
12815 : {
12816 4 : gfc_error ("%s cannot be a DO CONCURRENT loop at %L", name,
12817 : &do_code->loc);
12818 4 : goto fail;
12819 : }
12820 8055 : if (do_code->op == EXEC_OMP_TILE || do_code->op == EXEC_OMP_UNROLL)
12821 : {
12822 466 : if (do_code->op == EXEC_OMP_UNROLL)
12823 : {
12824 308 : if (!do_code->ext.omp_clauses->partial)
12825 : {
12826 53 : gfc_error ("Generated loop of UNROLL construct at %L "
12827 : "without PARTIAL clause does not have "
12828 : "canonical form", &do_code->loc);
12829 53 : goto fail;
12830 : }
12831 255 : else if (i != count)
12832 : {
12833 5 : gfc_error ("UNROLL construct at %L with PARTIAL clause "
12834 : "generates just one loop with canonical form "
12835 : "but %d loops are needed",
12836 5 : &do_code->loc, count - i + 1);
12837 5 : goto fail;
12838 : }
12839 : }
12840 158 : else if (do_code->op == EXEC_OMP_TILE)
12841 : {
12842 158 : if (do_code->ext.omp_clauses->sizes_list == NULL)
12843 : /* This should have been diagnosed earlier already. */
12844 0 : return;
12845 158 : int l = gfc_expr_list_len (do_code->ext.omp_clauses->sizes_list);
12846 158 : if (count - i + 1 > l)
12847 : {
12848 14 : gfc_error ("TILE construct at %L generates %d loops "
12849 : "with canonical form but %d loops are needed",
12850 : &do_code->loc, l, count - i + 1);
12851 14 : goto fail;
12852 : }
12853 : }
12854 394 : if (do_code->ext.omp_clauses && do_code->ext.omp_clauses->erroneous)
12855 17 : goto fail;
12856 377 : if (imperfect && !perfect_nesting_errorp)
12857 : {
12858 4 : sorry_at (gfc_get_location (&do_code->loc),
12859 : "Imperfectly nested loop using generated loops");
12860 4 : errorp = true;
12861 : }
12862 377 : if (non_generated_count == count)
12863 329 : non_generated_count = i - 1;
12864 377 : --i;
12865 377 : do_code = do_code->block->next;
12866 377 : continue;
12867 377 : }
12868 7589 : gcc_assert (do_code->op == EXEC_DO);
12869 7589 : if (do_code->ext.iterator->var->ts.type != BT_INTEGER)
12870 : {
12871 3 : gfc_error ("%s iteration variable must be of type integer at %L",
12872 : name, &do_code->loc);
12873 3 : errorp = true;
12874 : }
12875 7589 : dovar = do_code->ext.iterator->var->symtree->n.sym;
12876 7589 : if (dovar->attr.threadprivate)
12877 : {
12878 0 : gfc_error ("%s iteration variable must not be THREADPRIVATE "
12879 : "at %L", name, &do_code->loc);
12880 0 : errorp = true;
12881 : }
12882 7589 : if (code->ext.omp_clauses)
12883 303560 : for (enum gfc_omp_list_type list = OMP_LIST_FIRST; list < OMP_LIST_NUM;
12884 295971 : list = gfc_omp_list_type (list + 1))
12885 97461 : if (!is_simd || code->ext.omp_clauses->collapse > 1
12886 295971 : ? (list != OMP_LIST_PRIVATE && list != OMP_LIST_LASTPRIVATE
12887 254865 : && list != OMP_LIST_ALLOCATE)
12888 41106 : : (list != OMP_LIST_PRIVATE && list != OMP_LIST_LASTPRIVATE
12889 41106 : && list != OMP_LIST_ALLOCATE && list != OMP_LIST_LINEAR))
12890 276535 : for (n = code->ext.omp_clauses->lists[list]; n; n = n->next)
12891 4385 : if (dovar == n->sym)
12892 : {
12893 5 : if (!is_simd || code->ext.omp_clauses->collapse > 1)
12894 4 : gfc_error ("%s iteration variable present on clause "
12895 : "other than PRIVATE, LASTPRIVATE or "
12896 : "ALLOCATE at %L", name, &do_code->loc);
12897 : else
12898 1 : gfc_error ("%s iteration variable present on clause "
12899 : "other than PRIVATE, LASTPRIVATE, ALLOCATE or "
12900 : "LINEAR at %L", name, &do_code->loc);
12901 : errorp = true;
12902 : }
12903 7589 : if (is_outer_iteration_variable (code, i, dovar))
12904 : {
12905 2 : gfc_error ("%s iteration variable used in more than one loop at %L",
12906 : name, &do_code->loc);
12907 2 : errorp = true;
12908 : }
12909 7587 : else if (is_intervening_var (code, i, dovar))
12910 : {
12911 2 : gfc_error ("%s iteration variable at %L is bound in "
12912 : "intervening code",
12913 : name, &do_code->loc);
12914 2 : errorp = true;
12915 : }
12916 7585 : else if (!bound_expr_is_canonical (code, i,
12917 7585 : do_code->ext.iterator->start,
12918 : &start_var))
12919 : {
12920 4 : gfc_error ("%s loop start expression not in canonical form at %L",
12921 : name, &do_code->loc);
12922 4 : errorp = true;
12923 : }
12924 7581 : else if (expr_uses_intervening_var (code, i,
12925 7581 : do_code->ext.iterator->start))
12926 : {
12927 1 : gfc_error ("%s loop start expression at %L uses variable bound in "
12928 : "intervening code",
12929 : name, &do_code->loc);
12930 1 : errorp = true;
12931 : }
12932 7580 : else if (!bound_expr_is_canonical (code, i,
12933 7580 : do_code->ext.iterator->end,
12934 : &end_var))
12935 : {
12936 2 : gfc_error ("%s loop end expression not in canonical form at %L",
12937 : name, &do_code->loc);
12938 2 : errorp = true;
12939 : }
12940 7578 : else if (expr_uses_intervening_var (code, i,
12941 7578 : do_code->ext.iterator->end))
12942 : {
12943 1 : gfc_error ("%s loop end expression at %L uses variable bound in "
12944 : "intervening code",
12945 : name, &do_code->loc);
12946 1 : errorp = true;
12947 : }
12948 7577 : else if (start_var && end_var && start_var != end_var)
12949 : {
12950 1 : gfc_error ("%s loop bounds reference different "
12951 : "iteration variables at %L", name, &do_code->loc);
12952 1 : errorp = true;
12953 : }
12954 7576 : else if (!expr_is_invariant (code, i, do_code->ext.iterator->step))
12955 : {
12956 3 : gfc_error ("%s loop increment not in canonical form at %L",
12957 : name, &do_code->loc);
12958 3 : errorp = true;
12959 : }
12960 7573 : else if (expr_uses_intervening_var (code, i,
12961 7573 : do_code->ext.iterator->step))
12962 : {
12963 1 : gfc_error ("%s loop increment expression at %L uses variable "
12964 : "bound in intervening code",
12965 : name, &do_code->loc);
12966 1 : errorp = true;
12967 : }
12968 7589 : if (start_var || end_var)
12969 : {
12970 528 : code->ext.omp_clauses->non_rectangular = 1;
12971 528 : if (i > non_generated_count)
12972 : {
12973 3 : sorry_at (gfc_get_location (&do_code->loc),
12974 : "Non-rectangular loops from generated loops "
12975 : "unsupported");
12976 3 : errorp = true;
12977 : }
12978 : }
12979 :
12980 : /* Only parse loop body into nested loop and intervening code if
12981 : there are supposed to be more loops in the nest to collapse. */
12982 7589 : if (i == count)
12983 : break;
12984 :
12985 2270 : next = find_nested_loop_in_chain (do_code->block->next);
12986 :
12987 2270 : if (!next)
12988 : {
12989 : /* Parse error, can't recover from this. */
12990 7 : gfc_error ("not enough DO loops for collapsed %s (level %d) at %L",
12991 : name, i, &code->loc);
12992 7 : goto fail;
12993 : }
12994 2263 : else if (next != do_code->block->next
12995 2103 : || (next->next && next->next->op != EXEC_CONTINUE))
12996 : /* Imperfectly nested loop found. */
12997 : {
12998 : /* Only diagnose violation of imperfect nesting constraints once. */
12999 177 : if (!perfect_nesting_errorp)
13000 : {
13001 176 : if (code->ext.omp_clauses->orderedc)
13002 : {
13003 3 : gfc_error ("%s inner loops must be perfectly nested with "
13004 : "ORDERED clause at %L",
13005 : name, &code->loc);
13006 3 : perfect_nesting_errorp = true;
13007 : }
13008 173 : else if (code->ext.omp_clauses->lists[OMP_LIST_REDUCTION_INSCAN])
13009 : {
13010 2 : gfc_error ("%s inner loops must be perfectly nested with "
13011 : "REDUCTION INSCAN clause at %L",
13012 : name, &code->loc);
13013 2 : perfect_nesting_errorp = true;
13014 : }
13015 171 : else if (code->op == EXEC_OMP_TILE)
13016 : {
13017 8 : gfc_error ("%s inner loops must be perfectly nested at %L",
13018 : name, &code->loc);
13019 8 : perfect_nesting_errorp = true;
13020 : }
13021 13 : if (perfect_nesting_errorp)
13022 : errorp = true;
13023 : }
13024 177 : if (diagnose_intervening_code_errors (do_code->block->next,
13025 : name, next))
13026 5 : errorp = true;
13027 : imperfect = true;
13028 : }
13029 2263 : do_code = next;
13030 : }
13031 :
13032 : /* Give up now if we found any constraint violations. */
13033 5319 : if (errorp)
13034 : {
13035 48 : fail:
13036 154 : if (code->ext.omp_clauses)
13037 154 : code->ext.omp_clauses->erroneous = 1;
13038 154 : return;
13039 : }
13040 :
13041 5271 : if (non_generated_count)
13042 5001 : restructure_intervening_code (&code->block->next, code,
13043 : non_generated_count);
13044 : }
13045 :
13046 : /* Resolve the context selector. In particular, SKIP_P is set to true,
13047 : the context can never be matched. */
13048 :
13049 : static void
13050 758 : gfc_resolve_omp_context_selector (gfc_omp_set_selector *oss,
13051 : bool is_metadirective, bool *skip_p)
13052 : {
13053 758 : if (skip_p)
13054 310 : *skip_p = false;
13055 1441 : for (gfc_omp_set_selector *set_selector = oss; set_selector;
13056 683 : set_selector = set_selector->next)
13057 1473 : for (gfc_omp_selector *os = set_selector->trait_selectors; os; os = os->next)
13058 : {
13059 808 : if (os->score)
13060 : {
13061 52 : if (!gfc_resolve_expr (os->score)
13062 52 : || os->score->ts.type != BT_INTEGER
13063 104 : || os->score->rank != 0)
13064 : {
13065 0 : gfc_error ("%<score%> argument must be constant integer "
13066 0 : "expression at %L", &os->score->where);
13067 0 : gfc_free_expr (os->score);
13068 0 : os->score = nullptr;
13069 : }
13070 52 : else if (os->score->expr_type == EXPR_CONSTANT
13071 52 : && mpz_sgn (os->score->value.integer) < 0)
13072 : {
13073 1 : gfc_error ("%<score%> argument must be non-negative at %L",
13074 : &os->score->where);
13075 1 : gfc_free_expr (os->score);
13076 1 : os->score = nullptr;
13077 : }
13078 : }
13079 :
13080 808 : if (os->code == OMP_TRAIT_INVALID)
13081 : break;
13082 790 : enum omp_tp_type property_kind = omp_ts_map[os->code].tp_type;
13083 790 : gfc_omp_trait_property *otp = os->properties;
13084 :
13085 790 : if (!otp)
13086 403 : continue;
13087 387 : switch (property_kind)
13088 : {
13089 139 : case OMP_TRAIT_PROPERTY_DEV_NUM_EXPR:
13090 139 : case OMP_TRAIT_PROPERTY_BOOL_EXPR:
13091 139 : if (!gfc_resolve_expr (otp->expr)
13092 138 : || (property_kind == OMP_TRAIT_PROPERTY_BOOL_EXPR
13093 124 : && otp->expr->ts.type != BT_LOGICAL)
13094 137 : || (property_kind == OMP_TRAIT_PROPERTY_DEV_NUM_EXPR
13095 14 : && otp->expr->ts.type != BT_INTEGER)
13096 137 : || otp->expr->rank != 0
13097 276 : || (!is_metadirective && otp->expr->expr_type != EXPR_CONSTANT))
13098 : {
13099 3 : if (is_metadirective)
13100 : {
13101 0 : if (property_kind == OMP_TRAIT_PROPERTY_BOOL_EXPR)
13102 0 : gfc_error ("property must be a "
13103 : "logical expression at %L",
13104 0 : &otp->expr->where);
13105 : else
13106 0 : gfc_error ("property must be an "
13107 : "integer expression at %L",
13108 0 : &otp->expr->where);
13109 : }
13110 : else
13111 : {
13112 3 : if (property_kind == OMP_TRAIT_PROPERTY_BOOL_EXPR)
13113 2 : gfc_error ("property must be a constant "
13114 : "logical expression at %L",
13115 2 : &otp->expr->where);
13116 : else
13117 1 : gfc_error ("property must be a constant "
13118 : "integer expression at %L",
13119 1 : &otp->expr->where);
13120 : }
13121 : /* Prevent later ICEs. */
13122 3 : gfc_expr *e;
13123 3 : if (property_kind == OMP_TRAIT_PROPERTY_BOOL_EXPR)
13124 2 : e = gfc_get_logical_expr (gfc_default_logical_kind,
13125 2 : &otp->expr->where, true);
13126 : else
13127 1 : e = gfc_get_int_expr (gfc_default_integer_kind,
13128 1 : &otp->expr->where, 0);
13129 3 : gfc_free_expr (otp->expr);
13130 3 : otp->expr = e;
13131 3 : continue;
13132 3 : }
13133 : /* Device number must be conforming, which includes
13134 : omp_initial_device (-1), omp_invalid_device (-4),
13135 : and omp_default_device (-5). */
13136 136 : if (property_kind == OMP_TRAIT_PROPERTY_DEV_NUM_EXPR
13137 14 : && otp->expr->expr_type == EXPR_CONSTANT
13138 5 : && mpz_sgn (otp->expr->value.integer) < 0
13139 3 : && mpz_cmp_si (otp->expr->value.integer, -1) != 0
13140 2 : && mpz_cmp_si (otp->expr->value.integer, -4) != 0
13141 1 : && mpz_cmp_si (otp->expr->value.integer, -5) != 0)
13142 1 : gfc_error ("property must be a conforming device number at %L",
13143 : &otp->expr->where);
13144 : break;
13145 : default:
13146 : break;
13147 : }
13148 : /* This only handles one specific case: User condition.
13149 : FIXME: Handle more cases by calling omp_context_selector_matches;
13150 : unfortunately, we cannot generate the tree here as, e.g., PARM_DECL
13151 : backend decl are not available at this stage - but might be used in,
13152 : e.g. user conditions. See PR122361. */
13153 384 : if (skip_p && otp
13154 138 : && os->code == OMP_TRAIT_USER_CONDITION
13155 81 : && otp->expr->expr_type == EXPR_CONSTANT
13156 14 : && otp->expr->value.logical == false)
13157 12 : *skip_p = true;
13158 : }
13159 758 : }
13160 :
13161 :
13162 : static void
13163 138 : resolve_omp_metadirective (gfc_code *code, gfc_namespace *ns)
13164 : {
13165 138 : gfc_omp_variant *variant = code->ext.omp_variants;
13166 138 : gfc_omp_variant *prev_variant = variant;
13167 :
13168 448 : while (variant)
13169 : {
13170 310 : bool skip;
13171 310 : gfc_resolve_omp_context_selector (variant->selectors, true, &skip);
13172 310 : gfc_code *variant_code = variant->code;
13173 310 : gfc_resolve_code (variant_code, ns);
13174 310 : if (skip)
13175 : {
13176 : /* The following should only be true if an error occurred
13177 : as the 'otherwise' clause should always match. */
13178 12 : if (variant == code->ext.omp_variants && !variant->next)
13179 : break;
13180 12 : gfc_omp_variant *tmp = variant;
13181 12 : if (variant == code->ext.omp_variants)
13182 11 : variant = prev_variant = code->ext.omp_variants = variant->next;
13183 : else
13184 1 : variant = prev_variant->next = variant->next;
13185 12 : gfc_free_omp_set_selector_list (tmp->selectors);
13186 12 : free (tmp);
13187 : }
13188 : else
13189 : {
13190 298 : prev_variant = variant;
13191 298 : variant = variant->next;
13192 : }
13193 : }
13194 : /* Replace metadirective by its body if only 'nothing' remains. */
13195 138 : if (!code->ext.omp_variants->next && code->ext.omp_variants->stmt == ST_NONE)
13196 : {
13197 11 : gfc_code *next = code->next;
13198 11 : gfc_code *inner = code->ext.omp_variants->code;
13199 11 : gfc_free_omp_set_selector_list (code->ext.omp_variants->selectors);
13200 11 : free (code->ext.omp_variants);
13201 11 : *code = *inner;
13202 11 : free (inner);
13203 11 : while (code->next)
13204 : code = code->next;
13205 11 : code->next = next;
13206 : }
13207 138 : }
13208 :
13209 :
13210 : static gfc_statement
13211 63 : omp_code_to_statement (gfc_code *code)
13212 : {
13213 63 : switch (code->op)
13214 : {
13215 : case EXEC_OMP_PARALLEL:
13216 : return ST_OMP_PARALLEL;
13217 0 : case EXEC_OMP_PARALLEL_MASKED:
13218 0 : return ST_OMP_PARALLEL_MASKED;
13219 0 : case EXEC_OMP_PARALLEL_MASKED_TASKLOOP:
13220 0 : return ST_OMP_PARALLEL_MASKED_TASKLOOP;
13221 0 : case EXEC_OMP_PARALLEL_MASKED_TASKLOOP_SIMD:
13222 0 : return ST_OMP_PARALLEL_MASKED_TASKLOOP_SIMD;
13223 0 : case EXEC_OMP_PARALLEL_MASTER:
13224 0 : return ST_OMP_PARALLEL_MASTER;
13225 0 : case EXEC_OMP_PARALLEL_MASTER_TASKLOOP:
13226 0 : return ST_OMP_PARALLEL_MASTER_TASKLOOP;
13227 0 : case EXEC_OMP_PARALLEL_MASTER_TASKLOOP_SIMD:
13228 0 : return ST_OMP_PARALLEL_MASTER_TASKLOOP_SIMD;
13229 1 : case EXEC_OMP_PARALLEL_SECTIONS:
13230 1 : return ST_OMP_PARALLEL_SECTIONS;
13231 1 : case EXEC_OMP_SECTIONS:
13232 1 : return ST_OMP_SECTIONS;
13233 1 : case EXEC_OMP_ORDERED:
13234 1 : return ST_OMP_ORDERED;
13235 1 : case EXEC_OMP_CRITICAL:
13236 1 : return ST_OMP_CRITICAL;
13237 0 : case EXEC_OMP_MASKED:
13238 0 : return ST_OMP_MASKED;
13239 0 : case EXEC_OMP_MASKED_TASKLOOP:
13240 0 : return ST_OMP_MASKED_TASKLOOP;
13241 0 : case EXEC_OMP_MASKED_TASKLOOP_SIMD:
13242 0 : return ST_OMP_MASKED_TASKLOOP_SIMD;
13243 1 : case EXEC_OMP_MASTER:
13244 1 : return ST_OMP_MASTER;
13245 0 : case EXEC_OMP_MASTER_TASKLOOP:
13246 0 : return ST_OMP_MASTER_TASKLOOP;
13247 0 : case EXEC_OMP_MASTER_TASKLOOP_SIMD:
13248 0 : return ST_OMP_MASTER_TASKLOOP_SIMD;
13249 1 : case EXEC_OMP_SINGLE:
13250 1 : return ST_OMP_SINGLE;
13251 1 : case EXEC_OMP_TASK:
13252 1 : return ST_OMP_TASK;
13253 1 : case EXEC_OMP_WORKSHARE:
13254 1 : return ST_OMP_WORKSHARE;
13255 1 : case EXEC_OMP_PARALLEL_WORKSHARE:
13256 1 : return ST_OMP_PARALLEL_WORKSHARE;
13257 3 : case EXEC_OMP_DO:
13258 3 : return ST_OMP_DO;
13259 0 : case EXEC_OMP_LOOP:
13260 0 : return ST_OMP_LOOP;
13261 0 : case EXEC_OMP_ALLOCATE:
13262 0 : return ST_OMP_ALLOCATE_EXEC;
13263 0 : case EXEC_OMP_ALLOCATORS:
13264 0 : return ST_OMP_ALLOCATORS;
13265 0 : case EXEC_OMP_ASSUME:
13266 0 : return ST_OMP_ASSUME;
13267 1 : case EXEC_OMP_ATOMIC:
13268 1 : return ST_OMP_ATOMIC;
13269 1 : case EXEC_OMP_BARRIER:
13270 1 : return ST_OMP_BARRIER;
13271 1 : case EXEC_OMP_CANCEL:
13272 1 : return ST_OMP_CANCEL;
13273 1 : case EXEC_OMP_CANCELLATION_POINT:
13274 1 : return ST_OMP_CANCELLATION_POINT;
13275 0 : case EXEC_OMP_ERROR:
13276 0 : return ST_OMP_ERROR;
13277 1 : case EXEC_OMP_FLUSH:
13278 1 : return ST_OMP_FLUSH;
13279 0 : case EXEC_OMP_INTEROP:
13280 0 : return ST_OMP_INTEROP;
13281 1 : case EXEC_OMP_DISTRIBUTE:
13282 1 : return ST_OMP_DISTRIBUTE;
13283 1 : case EXEC_OMP_DISTRIBUTE_PARALLEL_DO:
13284 1 : return ST_OMP_DISTRIBUTE_PARALLEL_DO;
13285 1 : case EXEC_OMP_DISTRIBUTE_PARALLEL_DO_SIMD:
13286 1 : return ST_OMP_DISTRIBUTE_PARALLEL_DO_SIMD;
13287 1 : case EXEC_OMP_DISTRIBUTE_SIMD:
13288 1 : return ST_OMP_DISTRIBUTE_SIMD;
13289 1 : case EXEC_OMP_DO_SIMD:
13290 1 : return ST_OMP_DO_SIMD;
13291 0 : case EXEC_OMP_SCAN:
13292 0 : return ST_OMP_SCAN;
13293 0 : case EXEC_OMP_SCOPE:
13294 0 : return ST_OMP_SCOPE;
13295 1 : case EXEC_OMP_SIMD:
13296 1 : return ST_OMP_SIMD;
13297 1 : case EXEC_OMP_TARGET:
13298 1 : return ST_OMP_TARGET;
13299 1 : case EXEC_OMP_TARGET_DATA:
13300 1 : return ST_OMP_TARGET_DATA;
13301 1 : case EXEC_OMP_TARGET_ENTER_DATA:
13302 1 : return ST_OMP_TARGET_ENTER_DATA;
13303 1 : case EXEC_OMP_TARGET_EXIT_DATA:
13304 1 : return ST_OMP_TARGET_EXIT_DATA;
13305 1 : case EXEC_OMP_TARGET_PARALLEL:
13306 1 : return ST_OMP_TARGET_PARALLEL;
13307 1 : case EXEC_OMP_TARGET_PARALLEL_DO:
13308 1 : return ST_OMP_TARGET_PARALLEL_DO;
13309 1 : case EXEC_OMP_TARGET_PARALLEL_DO_SIMD:
13310 1 : return ST_OMP_TARGET_PARALLEL_DO_SIMD;
13311 0 : case EXEC_OMP_TARGET_PARALLEL_LOOP:
13312 0 : return ST_OMP_TARGET_PARALLEL_LOOP;
13313 1 : case EXEC_OMP_TARGET_SIMD:
13314 1 : return ST_OMP_TARGET_SIMD;
13315 1 : case EXEC_OMP_TARGET_TEAMS:
13316 1 : return ST_OMP_TARGET_TEAMS;
13317 1 : case EXEC_OMP_TARGET_TEAMS_DISTRIBUTE:
13318 1 : return ST_OMP_TARGET_TEAMS_DISTRIBUTE;
13319 1 : case EXEC_OMP_TARGET_TEAMS_DISTRIBUTE_PARALLEL_DO:
13320 1 : return ST_OMP_TARGET_TEAMS_DISTRIBUTE_PARALLEL_DO;
13321 1 : case EXEC_OMP_TARGET_TEAMS_DISTRIBUTE_PARALLEL_DO_SIMD:
13322 1 : return ST_OMP_TARGET_TEAMS_DISTRIBUTE_PARALLEL_DO_SIMD;
13323 1 : case EXEC_OMP_TARGET_TEAMS_DISTRIBUTE_SIMD:
13324 1 : return ST_OMP_TARGET_TEAMS_DISTRIBUTE_SIMD;
13325 0 : case EXEC_OMP_TARGET_TEAMS_LOOP:
13326 0 : return ST_OMP_TARGET_TEAMS_LOOP;
13327 1 : case EXEC_OMP_TARGET_UPDATE:
13328 1 : return ST_OMP_TARGET_UPDATE;
13329 1 : case EXEC_OMP_TASKGROUP:
13330 1 : return ST_OMP_TASKGROUP;
13331 1 : case EXEC_OMP_TASKLOOP:
13332 1 : return ST_OMP_TASKLOOP;
13333 1 : case EXEC_OMP_TASKLOOP_SIMD:
13334 1 : return ST_OMP_TASKLOOP_SIMD;
13335 1 : case EXEC_OMP_TASKWAIT:
13336 1 : return ST_OMP_TASKWAIT;
13337 1 : case EXEC_OMP_TASKYIELD:
13338 1 : return ST_OMP_TASKYIELD;
13339 1 : case EXEC_OMP_TEAMS:
13340 1 : return ST_OMP_TEAMS;
13341 1 : case EXEC_OMP_TEAMS_DISTRIBUTE:
13342 1 : return ST_OMP_TEAMS_DISTRIBUTE;
13343 1 : case EXEC_OMP_TEAMS_DISTRIBUTE_PARALLEL_DO:
13344 1 : return ST_OMP_TEAMS_DISTRIBUTE_PARALLEL_DO;
13345 1 : case EXEC_OMP_TEAMS_DISTRIBUTE_PARALLEL_DO_SIMD:
13346 1 : return ST_OMP_TEAMS_DISTRIBUTE_PARALLEL_DO_SIMD;
13347 1 : case EXEC_OMP_TEAMS_DISTRIBUTE_SIMD:
13348 1 : return ST_OMP_TEAMS_DISTRIBUTE_SIMD;
13349 0 : case EXEC_OMP_TEAMS_LOOP:
13350 0 : return ST_OMP_TEAMS_LOOP;
13351 6 : case EXEC_OMP_PARALLEL_DO:
13352 6 : return ST_OMP_PARALLEL_DO;
13353 1 : case EXEC_OMP_PARALLEL_DO_SIMD:
13354 1 : return ST_OMP_PARALLEL_DO_SIMD;
13355 0 : case EXEC_OMP_PARALLEL_LOOP:
13356 0 : return ST_OMP_PARALLEL_LOOP;
13357 1 : case EXEC_OMP_DEPOBJ:
13358 1 : return ST_OMP_DEPOBJ;
13359 0 : case EXEC_OMP_TILE:
13360 0 : return ST_OMP_TILE;
13361 0 : case EXEC_OMP_UNROLL:
13362 0 : return ST_OMP_UNROLL;
13363 0 : case EXEC_OMP_DISPATCH:
13364 0 : return ST_OMP_DISPATCH;
13365 0 : default:
13366 0 : gcc_unreachable ();
13367 : }
13368 : }
13369 :
13370 : static gfc_statement
13371 63 : oacc_code_to_statement (gfc_code *code)
13372 : {
13373 63 : switch (code->op)
13374 : {
13375 : case EXEC_OACC_PARALLEL:
13376 : return ST_OACC_PARALLEL;
13377 : case EXEC_OACC_KERNELS:
13378 : return ST_OACC_KERNELS;
13379 : case EXEC_OACC_SERIAL:
13380 : return ST_OACC_SERIAL;
13381 : case EXEC_OACC_DATA:
13382 : return ST_OACC_DATA;
13383 : case EXEC_OACC_HOST_DATA:
13384 : return ST_OACC_HOST_DATA;
13385 : case EXEC_OACC_PARALLEL_LOOP:
13386 : return ST_OACC_PARALLEL_LOOP;
13387 : case EXEC_OACC_KERNELS_LOOP:
13388 : return ST_OACC_KERNELS_LOOP;
13389 : case EXEC_OACC_SERIAL_LOOP:
13390 : return ST_OACC_SERIAL_LOOP;
13391 : case EXEC_OACC_LOOP:
13392 : return ST_OACC_LOOP;
13393 : case EXEC_OACC_ATOMIC:
13394 : return ST_OACC_ATOMIC;
13395 : case EXEC_OACC_ROUTINE:
13396 : return ST_OACC_ROUTINE;
13397 : case EXEC_OACC_UPDATE:
13398 : return ST_OACC_UPDATE;
13399 : case EXEC_OACC_WAIT:
13400 : return ST_OACC_WAIT;
13401 : case EXEC_OACC_CACHE:
13402 : return ST_OACC_CACHE;
13403 : case EXEC_OACC_ENTER_DATA:
13404 : return ST_OACC_ENTER_DATA;
13405 : case EXEC_OACC_EXIT_DATA:
13406 : return ST_OACC_EXIT_DATA;
13407 : case EXEC_OACC_DECLARE:
13408 : return ST_OACC_DECLARE;
13409 0 : default:
13410 0 : gcc_unreachable ();
13411 : }
13412 : }
13413 :
13414 : static void
13415 13168 : resolve_oacc_directive_inside_omp_region (gfc_code *code)
13416 : {
13417 13168 : if (omp_current_ctx != NULL && omp_current_ctx->is_openmp)
13418 : {
13419 11 : gfc_statement st = omp_code_to_statement (omp_current_ctx->code);
13420 11 : gfc_statement oacc_st = oacc_code_to_statement (code);
13421 11 : gfc_error ("The %s directive cannot be specified within "
13422 : "a %s region at %L", gfc_ascii_statement (oacc_st),
13423 : gfc_ascii_statement (st), &code->loc);
13424 : }
13425 13168 : }
13426 :
13427 : static void
13428 21194 : resolve_omp_directive_inside_oacc_region (gfc_code *code)
13429 : {
13430 21194 : if (omp_current_ctx != NULL && !omp_current_ctx->is_openmp)
13431 : {
13432 52 : gfc_statement st = oacc_code_to_statement (omp_current_ctx->code);
13433 52 : gfc_statement omp_st = omp_code_to_statement (code);
13434 52 : gfc_error ("The %s directive cannot be specified within "
13435 : "a %s region at %L", gfc_ascii_statement (omp_st),
13436 : gfc_ascii_statement (st), &code->loc);
13437 : }
13438 21194 : }
13439 :
13440 :
13441 : static void
13442 5272 : resolve_oacc_nested_loops (gfc_code *code, gfc_code* do_code, int collapse,
13443 : const char *clause)
13444 : {
13445 5272 : gfc_symbol *dovar;
13446 5272 : gfc_code *c;
13447 5272 : int i;
13448 :
13449 5792 : for (i = 1; i <= collapse; i++)
13450 : {
13451 5792 : if (do_code->op == EXEC_DO_WHILE)
13452 : {
13453 10 : gfc_error ("!$ACC LOOP cannot be a DO WHILE or DO without loop control "
13454 : "at %L", &do_code->loc);
13455 10 : break;
13456 : }
13457 5782 : if (do_code->op == EXEC_DO_CONCURRENT)
13458 : {
13459 3 : gfc_error ("!$ACC LOOP cannot be a DO CONCURRENT loop at %L",
13460 : &do_code->loc);
13461 3 : break;
13462 : }
13463 5779 : gcc_assert (do_code->op == EXEC_DO);
13464 5779 : if (do_code->ext.iterator->var->ts.type != BT_INTEGER)
13465 6 : gfc_error ("!$ACC LOOP iteration variable must be of type integer at %L",
13466 : &do_code->loc);
13467 5779 : dovar = do_code->ext.iterator->var->symtree->n.sym;
13468 5779 : if (i > 1)
13469 : {
13470 518 : gfc_code *do_code2 = code->block->next;
13471 518 : int j;
13472 :
13473 1218 : for (j = 1; j < i; j++)
13474 : {
13475 710 : gfc_symbol *ivar = do_code2->ext.iterator->var->symtree->n.sym;
13476 710 : if (dovar == ivar
13477 710 : || gfc_find_sym_in_expr (ivar, do_code->ext.iterator->start)
13478 701 : || gfc_find_sym_in_expr (ivar, do_code->ext.iterator->end)
13479 1410 : || gfc_find_sym_in_expr (ivar, do_code->ext.iterator->step))
13480 : {
13481 10 : gfc_error ("!$ACC LOOP %s loops don't form rectangular "
13482 : "iteration space at %L", clause, &do_code->loc);
13483 10 : break;
13484 : }
13485 700 : do_code2 = do_code2->block->next;
13486 : }
13487 : }
13488 5779 : if (i == collapse)
13489 : break;
13490 577 : for (c = do_code->next; c; c = c->next)
13491 48 : if (c->op != EXEC_NOP && c->op != EXEC_CONTINUE)
13492 : {
13493 0 : gfc_error ("%s !$ACC LOOP loops not perfectly nested at %L",
13494 : clause, &c->loc);
13495 0 : break;
13496 : }
13497 529 : if (c)
13498 : break;
13499 529 : do_code = do_code->block;
13500 529 : if (do_code->op != EXEC_DO && do_code->op != EXEC_DO_WHILE
13501 0 : && do_code->op != EXEC_DO_CONCURRENT)
13502 : {
13503 0 : gfc_error ("not enough DO loops for %s !$ACC LOOP at %L",
13504 : clause, &code->loc);
13505 0 : break;
13506 : }
13507 529 : do_code = do_code->next;
13508 529 : if (do_code == NULL
13509 522 : || (do_code->op != EXEC_DO && do_code->op != EXEC_DO_WHILE
13510 2 : && do_code->op != EXEC_DO_CONCURRENT))
13511 : {
13512 9 : gfc_error ("not enough DO loops for %s !$ACC LOOP at %L",
13513 : clause, &code->loc);
13514 9 : break;
13515 : }
13516 : }
13517 5272 : }
13518 :
13519 :
13520 : static void
13521 10119 : resolve_oacc_loop_blocks (gfc_code *code)
13522 : {
13523 10119 : if (!oacc_is_loop (code))
13524 : return;
13525 :
13526 5272 : if (code->ext.omp_clauses->tile_list && code->ext.omp_clauses->gang
13527 24 : && code->ext.omp_clauses->worker && code->ext.omp_clauses->vector)
13528 0 : gfc_error ("Tiled loop cannot be parallelized across gangs, workers and "
13529 : "vectors at the same time at %L", &code->loc);
13530 :
13531 5272 : if (code->ext.omp_clauses->tile_list)
13532 : {
13533 : gfc_expr_list *el;
13534 501 : for (el = code->ext.omp_clauses->tile_list; el; el = el->next)
13535 : {
13536 304 : if (el->expr == NULL)
13537 : {
13538 : /* NULL expressions are used to represent '*' arguments.
13539 : Convert those to a 0 expressions. */
13540 113 : el->expr = gfc_get_constant_expr (BT_INTEGER,
13541 : gfc_default_integer_kind,
13542 : &code->loc);
13543 113 : mpz_set_si (el->expr->value.integer, 0);
13544 : }
13545 : else
13546 : {
13547 191 : resolve_positive_int_expr (el->expr, "TILE");
13548 191 : if (el->expr->expr_type != EXPR_CONSTANT)
13549 14 : gfc_error ("TILE requires constant expression at %L",
13550 : &code->loc);
13551 : }
13552 : }
13553 : }
13554 : }
13555 :
13556 :
13557 : void
13558 10119 : gfc_resolve_oacc_blocks (gfc_code *code, gfc_namespace *ns)
13559 : {
13560 10119 : fortran_omp_context ctx;
13561 10119 : gfc_omp_clauses *omp_clauses = code->ext.omp_clauses;
13562 10119 : gfc_omp_namelist *n;
13563 :
13564 10119 : resolve_oacc_loop_blocks (code);
13565 :
13566 10119 : ctx.code = code;
13567 10119 : ctx.sharing_clauses = new hash_set<gfc_symbol *>;
13568 10119 : ctx.private_iterators = new hash_set<gfc_symbol *>;
13569 10119 : ctx.previous = omp_current_ctx;
13570 10119 : ctx.is_openmp = false;
13571 10119 : omp_current_ctx = &ctx;
13572 :
13573 404760 : for (enum gfc_omp_list_type list = OMP_LIST_FIRST; list < OMP_LIST_NUM;
13574 394641 : list = gfc_omp_list_type (list + 1))
13575 394641 : switch (list)
13576 : {
13577 10119 : case OMP_LIST_PRIVATE:
13578 10710 : for (n = omp_clauses->lists[list]; n; n = n->next)
13579 591 : ctx.sharing_clauses->add (n->sym);
13580 : break;
13581 : default:
13582 : break;
13583 : }
13584 :
13585 10119 : gfc_resolve_blocks (code->block, ns);
13586 :
13587 10119 : omp_current_ctx = ctx.previous;
13588 20238 : delete ctx.sharing_clauses;
13589 20238 : delete ctx.private_iterators;
13590 10119 : }
13591 :
13592 :
13593 : static void
13594 5272 : resolve_oacc_loop (gfc_code *code)
13595 : {
13596 5272 : gfc_code *do_code;
13597 5272 : int collapse;
13598 :
13599 5272 : if (code->ext.omp_clauses)
13600 5272 : resolve_omp_clauses (code, code->ext.omp_clauses, NULL, true);
13601 :
13602 5272 : do_code = code->block->next;
13603 5272 : collapse = code->ext.omp_clauses->collapse;
13604 :
13605 : /* Both collapsed and tiled loops are lowered the same way, but are not
13606 : compatible. In gfc_trans_omp_do, the tile is prioritized. */
13607 5272 : if (code->ext.omp_clauses->tile_list)
13608 : {
13609 : int num = 0;
13610 : gfc_expr_list *el;
13611 501 : for (el = code->ext.omp_clauses->tile_list; el; el = el->next)
13612 304 : ++num;
13613 197 : resolve_oacc_nested_loops (code, code->block->next, num, "tiled");
13614 197 : return;
13615 : }
13616 :
13617 5075 : if (collapse <= 0)
13618 : collapse = 1;
13619 5075 : resolve_oacc_nested_loops (code, do_code, collapse, "collapsed");
13620 : }
13621 :
13622 : void
13623 341841 : gfc_resolve_oacc_declare (gfc_namespace *ns)
13624 : {
13625 341841 : enum gfc_omp_list_type list;
13626 341841 : gfc_omp_namelist *n;
13627 341841 : gfc_oacc_declare *oc;
13628 :
13629 341841 : if (ns->oacc_declare == NULL)
13630 : return;
13631 :
13632 290 : for (oc = ns->oacc_declare; oc; oc = oc->next)
13633 : {
13634 6480 : for (list = OMP_LIST_FIRST; list < OMP_LIST_NUM;
13635 6318 : list = gfc_omp_list_type (list + 1))
13636 6574 : for (n = oc->clauses->lists[list]; n; n = n->next)
13637 : {
13638 256 : n->sym->mark = 0;
13639 256 : if (n->sym->attr.flavor != FL_VARIABLE
13640 16 : && (n->sym->attr.flavor != FL_PROCEDURE
13641 8 : || n->sym->result != n->sym))
13642 : {
13643 14 : if (n->sym->attr.flavor != FL_PARAMETER)
13644 : {
13645 8 : gfc_error ("Object %qs is not a variable at %L",
13646 : n->sym->name, &oc->loc);
13647 8 : continue;
13648 : }
13649 : /* Note that OpenACC 3.4 permits name constants, but the
13650 : implementation is permitted to ignore the clause;
13651 : as semantically, device_resident kind of makes sense
13652 : (and the wording with it is a bit odd), the warning
13653 : is suppressed. */
13654 6 : if (list != OMP_LIST_DEVICE_RESIDENT)
13655 5 : gfc_warning (OPT_Wsurprising, "Object %qs at %L is ignored as"
13656 : " parameters need not be copied", n->sym->name,
13657 : &oc->loc);
13658 : }
13659 :
13660 248 : if (n->expr && n->expr->ref->type == REF_ARRAY)
13661 : {
13662 1 : gfc_error ("Array sections: %qs not allowed in"
13663 1 : " !$ACC DECLARE at %L", n->sym->name, &oc->loc);
13664 1 : continue;
13665 : }
13666 : }
13667 :
13668 252 : for (n = oc->clauses->lists[OMP_LIST_DEVICE_RESIDENT]; n; n = n->next)
13669 90 : check_array_not_assumed (n->sym, oc->loc, "DEVICE_RESIDENT");
13670 : }
13671 :
13672 290 : for (oc = ns->oacc_declare; oc; oc = oc->next)
13673 : {
13674 6480 : for (list = OMP_LIST_FIRST; list < OMP_LIST_NUM;
13675 6318 : list = gfc_omp_list_type (list + 1))
13676 6574 : for (n = oc->clauses->lists[list]; n; n = n->next)
13677 : {
13678 256 : if (n->sym->mark)
13679 : {
13680 9 : gfc_error ("Symbol %qs present on multiple clauses at %L",
13681 : n->sym->name, &oc->loc);
13682 9 : continue;
13683 : }
13684 : else
13685 247 : n->sym->mark = 1;
13686 : }
13687 : }
13688 :
13689 290 : for (oc = ns->oacc_declare; oc; oc = oc->next)
13690 : {
13691 6480 : for (list = OMP_LIST_FIRST; list < OMP_LIST_NUM;
13692 6318 : list = gfc_omp_list_type (list + 1))
13693 6574 : for (n = oc->clauses->lists[list]; n; n = n->next)
13694 256 : n->sym->mark = 0;
13695 : }
13696 : }
13697 :
13698 :
13699 : void
13700 341841 : gfc_resolve_oacc_routines (gfc_namespace *ns)
13701 : {
13702 341841 : for (gfc_oacc_routine_name *orn = ns->oacc_routine_names;
13703 341941 : orn;
13704 100 : orn = orn->next)
13705 : {
13706 100 : gfc_symbol *sym = orn->sym;
13707 100 : if (!sym->attr.external
13708 29 : && !sym->attr.function
13709 27 : && !sym->attr.subroutine)
13710 : {
13711 7 : gfc_error ("NAME %qs does not refer to a subroutine or function"
13712 : " in !$ACC ROUTINE ( NAME ) at %L", sym->name, &orn->loc);
13713 7 : continue;
13714 : }
13715 93 : if (!gfc_add_omp_declare_target (&sym->attr, sym->name, &orn->loc))
13716 : {
13717 20 : gfc_error ("NAME %qs invalid"
13718 : " in !$ACC ROUTINE ( NAME ) at %L", sym->name, &orn->loc);
13719 20 : continue;
13720 : }
13721 : }
13722 341841 : }
13723 :
13724 :
13725 : void
13726 13168 : gfc_resolve_oacc_directive (gfc_code *code, gfc_namespace *ns ATTRIBUTE_UNUSED)
13727 : {
13728 13168 : resolve_oacc_directive_inside_omp_region (code);
13729 :
13730 13168 : switch (code->op)
13731 : {
13732 7353 : case EXEC_OACC_PARALLEL:
13733 7353 : case EXEC_OACC_KERNELS:
13734 7353 : case EXEC_OACC_SERIAL:
13735 7353 : case EXEC_OACC_DATA:
13736 7353 : case EXEC_OACC_HOST_DATA:
13737 7353 : case EXEC_OACC_UPDATE:
13738 7353 : case EXEC_OACC_ENTER_DATA:
13739 7353 : case EXEC_OACC_EXIT_DATA:
13740 7353 : case EXEC_OACC_WAIT:
13741 7353 : case EXEC_OACC_CACHE:
13742 7353 : resolve_omp_clauses (code, code->ext.omp_clauses, NULL, true);
13743 7353 : break;
13744 5272 : case EXEC_OACC_PARALLEL_LOOP:
13745 5272 : case EXEC_OACC_KERNELS_LOOP:
13746 5272 : case EXEC_OACC_SERIAL_LOOP:
13747 5272 : case EXEC_OACC_LOOP:
13748 5272 : resolve_oacc_loop (code);
13749 5272 : break;
13750 543 : case EXEC_OACC_ATOMIC:
13751 543 : resolve_omp_atomic (code);
13752 543 : break;
13753 : default:
13754 : break;
13755 : }
13756 13168 : }
13757 :
13758 :
13759 : static void
13760 2179 : resolve_omp_target (gfc_code *code)
13761 : {
13762 : #define GFC_IS_TEAMS_CONSTRUCT(op) \
13763 : (op == EXEC_OMP_TEAMS \
13764 : || op == EXEC_OMP_TEAMS_DISTRIBUTE \
13765 : || op == EXEC_OMP_TEAMS_DISTRIBUTE_SIMD \
13766 : || op == EXEC_OMP_TEAMS_DISTRIBUTE_PARALLEL_DO \
13767 : || op == EXEC_OMP_TEAMS_DISTRIBUTE_PARALLEL_DO_SIMD \
13768 : || op == EXEC_OMP_TEAMS_LOOP)
13769 :
13770 2179 : if (!code->ext.omp_clauses->contains_teams_construct)
13771 : return;
13772 203 : gfc_code *c = code->block->next;
13773 203 : if (c->op == EXEC_BLOCK)
13774 30 : c = c->ext.block.ns->code;
13775 203 : if (code->ext.omp_clauses->target_first_st_is_teams_or_meta)
13776 : {
13777 192 : if (c->op == EXEC_OMP_METADIRECTIVE)
13778 : {
13779 15 : struct gfc_omp_variant *mc
13780 : = c->ext.omp_variants;
13781 : /* All mc->(next...->)code should be identical with regards
13782 : to the diagnostic below. */
13783 16 : do
13784 : {
13785 16 : if (mc->stmt != ST_NONE
13786 15 : && GFC_IS_TEAMS_CONSTRUCT (mc->code->op))
13787 : {
13788 14 : if (c->next == NULL && mc->code->next == NULL)
13789 : return;
13790 : c = mc->code;
13791 : break;
13792 : }
13793 2 : mc = mc->next;
13794 : }
13795 2 : while (mc);
13796 : }
13797 177 : else if (GFC_IS_TEAMS_CONSTRUCT (c->op) && c->next == NULL)
13798 : return;
13799 : }
13800 :
13801 31 : while (c && !GFC_IS_TEAMS_CONSTRUCT (c->op))
13802 8 : c = c->next;
13803 23 : if (c)
13804 19 : gfc_error ("!$OMP TARGET region at %L with a nested TEAMS at %L may not "
13805 : "contain any other statement, declaration or directive outside "
13806 : "of the single TEAMS construct", &c->loc, &code->loc);
13807 : else
13808 4 : gfc_error ("!$OMP TARGET region at %L with a nested TEAMS may not "
13809 : "contain any other statement, declaration or directive outside "
13810 : "of the single TEAMS construct", &code->loc);
13811 : #undef GFC_IS_TEAMS_CONSTRUCT
13812 : }
13813 :
13814 : static void
13815 154 : resolve_omp_dispatch (gfc_code *code)
13816 : {
13817 154 : gfc_code *next = code->block->next;
13818 154 : if (next == NULL)
13819 : return;
13820 :
13821 151 : gfc_exec_op op = next->op;
13822 151 : gcc_assert (op == EXEC_CALL || op == EXEC_ASSIGN);
13823 151 : if (op != EXEC_CALL
13824 74 : && (op != EXEC_ASSIGN || next->expr2->expr_type != EXPR_FUNCTION))
13825 3 : gfc_error (
13826 : "%<OMP DISPATCH%> directive at %L must be followed by a procedure "
13827 : "call with optional assignment",
13828 : &code->loc);
13829 :
13830 77 : if ((op == EXEC_CALL && next->resolved_sym != NULL
13831 76 : && next->resolved_sym->attr.proc_pointer)
13832 150 : || (op == EXEC_ASSIGN && gfc_expr_attr (next->expr2).proc_pointer))
13833 1 : gfc_error ("%<OMP DISPATCH%> directive at %L cannot be followed by a "
13834 : "procedure pointer",
13835 : &code->loc);
13836 : }
13837 :
13838 : /* Resolve OpenMP directive clauses and check various requirements
13839 : of each directive. */
13840 :
13841 : void
13842 21194 : gfc_resolve_omp_directive (gfc_code *code, gfc_namespace *ns)
13843 : {
13844 21194 : resolve_omp_directive_inside_oacc_region (code);
13845 :
13846 21194 : if (code->op != EXEC_OMP_ATOMIC)
13847 19040 : gfc_maybe_initialize_eh ();
13848 :
13849 21194 : switch (code->op)
13850 : {
13851 5425 : case EXEC_OMP_DISTRIBUTE:
13852 5425 : case EXEC_OMP_DISTRIBUTE_PARALLEL_DO:
13853 5425 : case EXEC_OMP_DISTRIBUTE_PARALLEL_DO_SIMD:
13854 5425 : case EXEC_OMP_DISTRIBUTE_SIMD:
13855 5425 : case EXEC_OMP_DO:
13856 5425 : case EXEC_OMP_DO_SIMD:
13857 5425 : case EXEC_OMP_LOOP:
13858 5425 : case EXEC_OMP_PARALLEL_DO:
13859 5425 : case EXEC_OMP_PARALLEL_DO_SIMD:
13860 5425 : case EXEC_OMP_PARALLEL_LOOP:
13861 5425 : case EXEC_OMP_PARALLEL_MASKED_TASKLOOP:
13862 5425 : case EXEC_OMP_PARALLEL_MASKED_TASKLOOP_SIMD:
13863 5425 : case EXEC_OMP_PARALLEL_MASTER_TASKLOOP:
13864 5425 : case EXEC_OMP_PARALLEL_MASTER_TASKLOOP_SIMD:
13865 5425 : case EXEC_OMP_MASKED_TASKLOOP:
13866 5425 : case EXEC_OMP_MASKED_TASKLOOP_SIMD:
13867 5425 : case EXEC_OMP_MASTER_TASKLOOP:
13868 5425 : case EXEC_OMP_MASTER_TASKLOOP_SIMD:
13869 5425 : case EXEC_OMP_SIMD:
13870 5425 : case EXEC_OMP_TARGET_PARALLEL_DO:
13871 5425 : case EXEC_OMP_TARGET_PARALLEL_DO_SIMD:
13872 5425 : case EXEC_OMP_TARGET_PARALLEL_LOOP:
13873 5425 : case EXEC_OMP_TARGET_SIMD:
13874 5425 : case EXEC_OMP_TARGET_TEAMS_DISTRIBUTE:
13875 5425 : case EXEC_OMP_TARGET_TEAMS_DISTRIBUTE_PARALLEL_DO:
13876 5425 : case EXEC_OMP_TARGET_TEAMS_DISTRIBUTE_PARALLEL_DO_SIMD:
13877 5425 : case EXEC_OMP_TARGET_TEAMS_DISTRIBUTE_SIMD:
13878 5425 : case EXEC_OMP_TARGET_TEAMS_LOOP:
13879 5425 : case EXEC_OMP_TASKLOOP:
13880 5425 : case EXEC_OMP_TASKLOOP_SIMD:
13881 5425 : case EXEC_OMP_TEAMS_DISTRIBUTE:
13882 5425 : case EXEC_OMP_TEAMS_DISTRIBUTE_PARALLEL_DO:
13883 5425 : case EXEC_OMP_TEAMS_DISTRIBUTE_PARALLEL_DO_SIMD:
13884 5425 : case EXEC_OMP_TEAMS_DISTRIBUTE_SIMD:
13885 5425 : case EXEC_OMP_TEAMS_LOOP:
13886 5425 : case EXEC_OMP_TILE:
13887 5425 : case EXEC_OMP_UNROLL:
13888 5425 : resolve_omp_do (code);
13889 5425 : break;
13890 2179 : case EXEC_OMP_TARGET:
13891 2179 : resolve_omp_target (code);
13892 10228 : gcc_fallthrough ();
13893 10228 : case EXEC_OMP_ALLOCATE:
13894 10228 : case EXEC_OMP_ALLOCATORS:
13895 10228 : case EXEC_OMP_ASSUME:
13896 10228 : case EXEC_OMP_CANCEL:
13897 10228 : case EXEC_OMP_ERROR:
13898 10228 : case EXEC_OMP_INTEROP:
13899 10228 : case EXEC_OMP_MASKED:
13900 10228 : case EXEC_OMP_ORDERED:
13901 10228 : case EXEC_OMP_PARALLEL_WORKSHARE:
13902 10228 : case EXEC_OMP_PARALLEL:
13903 10228 : case EXEC_OMP_PARALLEL_MASKED:
13904 10228 : case EXEC_OMP_PARALLEL_MASTER:
13905 10228 : case EXEC_OMP_PARALLEL_SECTIONS:
13906 10228 : case EXEC_OMP_SCOPE:
13907 10228 : case EXEC_OMP_SECTIONS:
13908 10228 : case EXEC_OMP_SINGLE:
13909 10228 : case EXEC_OMP_TARGET_DATA:
13910 10228 : case EXEC_OMP_TARGET_ENTER_DATA:
13911 10228 : case EXEC_OMP_TARGET_EXIT_DATA:
13912 10228 : case EXEC_OMP_TARGET_PARALLEL:
13913 10228 : case EXEC_OMP_TARGET_TEAMS:
13914 10228 : case EXEC_OMP_TASK:
13915 10228 : case EXEC_OMP_TASKWAIT:
13916 10228 : case EXEC_OMP_TEAMS:
13917 10228 : case EXEC_OMP_WORKSHARE:
13918 10228 : case EXEC_OMP_DEPOBJ:
13919 10228 : if (code->ext.omp_clauses)
13920 10095 : resolve_omp_clauses (code, code->ext.omp_clauses, NULL);
13921 : break;
13922 1718 : case EXEC_OMP_TARGET_UPDATE:
13923 1718 : if (code->ext.omp_clauses)
13924 1718 : resolve_omp_clauses (code, code->ext.omp_clauses, NULL);
13925 1718 : if (code->ext.omp_clauses == NULL
13926 1718 : || (code->ext.omp_clauses->lists[OMP_LIST_TO] == NULL
13927 994 : && code->ext.omp_clauses->lists[OMP_LIST_FROM] == NULL))
13928 0 : gfc_error ("OMP TARGET UPDATE at %L requires at least one TO or "
13929 : "FROM clause", &code->loc);
13930 : break;
13931 2154 : case EXEC_OMP_ATOMIC:
13932 2154 : resolve_omp_clauses (code, code->block->ext.omp_clauses, NULL);
13933 2154 : resolve_omp_atomic (code);
13934 2154 : break;
13935 159 : case EXEC_OMP_CRITICAL:
13936 159 : resolve_omp_clauses (code, code->ext.omp_clauses, NULL);
13937 159 : if (!code->ext.omp_clauses->critical_name
13938 112 : && code->ext.omp_clauses->hint
13939 3 : && code->ext.omp_clauses->hint->ts.type == BT_INTEGER
13940 3 : && code->ext.omp_clauses->hint->expr_type == EXPR_CONSTANT
13941 3 : && mpz_sgn (code->ext.omp_clauses->hint->value.integer) != 0)
13942 1 : gfc_error ("OMP CRITICAL at %L with HINT clause requires a NAME, "
13943 : "except when omp_sync_hint_none is used", &code->loc);
13944 : break;
13945 49 : case EXEC_OMP_SCAN:
13946 : /* Flag is only used to checking, hence, it is unset afterwards. */
13947 49 : if (!code->ext.omp_clauses->if_present)
13948 10 : gfc_error ("Unexpected !$OMP SCAN at %L outside loop construct with "
13949 : "%<inscan%> REDUCTION clause", &code->loc);
13950 49 : code->ext.omp_clauses->if_present = false;
13951 49 : resolve_omp_clauses (code, code->ext.omp_clauses, ns);
13952 49 : break;
13953 154 : case EXEC_OMP_DISPATCH:
13954 154 : if (code->ext.omp_clauses)
13955 154 : resolve_omp_clauses (code, code->ext.omp_clauses, ns);
13956 154 : resolve_omp_dispatch (code);
13957 154 : break;
13958 138 : case EXEC_OMP_METADIRECTIVE:
13959 138 : resolve_omp_metadirective (code, ns);
13960 138 : break;
13961 : default:
13962 : break;
13963 : }
13964 21194 : }
13965 :
13966 : /* Resolve !$omp declare {variant|simd} constructs in NS.
13967 : Note that !$omp declare target is resolved in resolve_symbol. */
13968 :
13969 : void
13970 353613 : gfc_resolve_omp_declare (gfc_namespace *ns)
13971 : {
13972 353613 : gfc_omp_declare_simd *ods;
13973 353849 : for (ods = ns->omp_declare_simd; ods; ods = ods->next)
13974 : {
13975 236 : if (ods->proc_name != NULL
13976 196 : && ods->proc_name != ns->proc_name)
13977 6 : gfc_error ("!$OMP DECLARE SIMD should refer to containing procedure "
13978 : "%qs at %L", ns->proc_name->name, &ods->where);
13979 236 : if (ods->clauses)
13980 218 : resolve_omp_clauses (NULL, ods->clauses, ns);
13981 : }
13982 :
13983 353613 : gfc_omp_declare_variant *odv;
13984 353613 : gfc_omp_namelist *range_begin = NULL;
13985 :
13986 354061 : for (odv = ns->omp_declare_variant; odv; odv = odv->next)
13987 448 : gfc_resolve_omp_context_selector (odv->set_selectors, false, nullptr);
13988 354061 : for (odv = ns->omp_declare_variant; odv; odv = odv->next)
13989 627 : for (gfc_omp_namelist *n = odv->adjust_args_list; n != NULL; n = n->next)
13990 : {
13991 179 : if ((n->expr == NULL
13992 6 : && (range_begin
13993 4 : || n->u.adj_args.range_start
13994 1 : || n->u.adj_args.omp_num_args_plus
13995 1 : || n->u.adj_args.omp_num_args_minus))
13996 174 : || n->u.adj_args.error_p)
13997 : {
13998 : }
13999 173 : else if (range_begin
14000 167 : || n->u.adj_args.range_start
14001 162 : || n->u.adj_args.omp_num_args_plus
14002 162 : || n->u.adj_args.omp_num_args_minus)
14003 : {
14004 11 : if (!n->expr
14005 11 : || !gfc_resolve_expr (n->expr)
14006 11 : || n->expr->expr_type != EXPR_CONSTANT
14007 10 : || n->expr->ts.type != BT_INTEGER
14008 10 : || n->expr->rank != 0
14009 10 : || mpz_sgn (n->expr->value.integer) < 0
14010 20 : || ((n->u.adj_args.omp_num_args_plus
14011 8 : || n->u.adj_args.omp_num_args_minus)
14012 5 : && mpz_sgn (n->expr->value.integer) == 0))
14013 : {
14014 2 : if (n->u.adj_args.omp_num_args_plus
14015 2 : || n->u.adj_args.omp_num_args_minus)
14016 0 : gfc_error ("Expected constant non-negative scalar integer "
14017 : "offset expression at %L", &n->where);
14018 : else
14019 2 : gfc_error ("For range-based %<adjust_args%>, a constant "
14020 : "positive scalar integer expression is required "
14021 : "at %L", &n->where);
14022 : }
14023 : }
14024 162 : else if (n->expr
14025 162 : && n->expr->expr_type == EXPR_CONSTANT
14026 21 : && n->expr->ts.type == BT_INTEGER
14027 20 : && mpz_sgn (n->expr->value.integer) > 0)
14028 : {
14029 : }
14030 142 : else if (!n->expr
14031 142 : || !gfc_resolve_expr (n->expr)
14032 283 : || n->expr->expr_type != EXPR_VARIABLE)
14033 2 : gfc_error ("Expected dummy parameter name or a positive integer "
14034 : "at %L", &n->where);
14035 140 : else if (n->expr->expr_type == EXPR_VARIABLE)
14036 140 : n->sym = n->expr->symtree->n.sym;
14037 :
14038 179 : range_begin = n->u.adj_args.range_start ? n : NULL;
14039 : }
14040 353613 : }
14041 :
14042 : struct omp_udr_callback_data
14043 : {
14044 : gfc_omp_udr *omp_udr;
14045 : bool is_initializer;
14046 : };
14047 :
14048 : static int
14049 3706 : omp_udr_callback (gfc_expr **e, int *walk_subtrees ATTRIBUTE_UNUSED,
14050 : void *data)
14051 : {
14052 3706 : struct omp_udr_callback_data *cd = (struct omp_udr_callback_data *) data;
14053 3706 : if ((*e)->expr_type == EXPR_VARIABLE)
14054 : {
14055 2276 : if (cd->is_initializer)
14056 : {
14057 539 : if ((*e)->symtree->n.sym != cd->omp_udr->omp_priv
14058 140 : && (*e)->symtree->n.sym != cd->omp_udr->omp_orig)
14059 4 : gfc_error ("Variable other than OMP_PRIV or OMP_ORIG used in "
14060 : "INITIALIZER clause of !$OMP DECLARE REDUCTION at %L",
14061 : &(*e)->where);
14062 : }
14063 : else
14064 : {
14065 1737 : if ((*e)->symtree->n.sym != cd->omp_udr->omp_out
14066 619 : && (*e)->symtree->n.sym != cd->omp_udr->omp_in)
14067 6 : gfc_error ("Variable other than OMP_OUT or OMP_IN used in "
14068 : "combiner of !$OMP DECLARE REDUCTION at %L",
14069 : &(*e)->where);
14070 : }
14071 : }
14072 3706 : return 0;
14073 : }
14074 :
14075 : /* Resolve !$omp declare reduction constructs. */
14076 :
14077 : static void
14078 626 : gfc_resolve_omp_udr (gfc_omp_udr *omp_udr)
14079 : {
14080 626 : gfc_actual_arglist *a;
14081 626 : const char *predef_name = NULL;
14082 :
14083 626 : switch (omp_udr->rop)
14084 : {
14085 625 : case OMP_REDUCTION_PLUS:
14086 625 : case OMP_REDUCTION_TIMES:
14087 625 : case OMP_REDUCTION_MINUS:
14088 625 : case OMP_REDUCTION_AND:
14089 625 : case OMP_REDUCTION_OR:
14090 625 : case OMP_REDUCTION_EQV:
14091 625 : case OMP_REDUCTION_NEQV:
14092 625 : case OMP_REDUCTION_MAX:
14093 625 : case OMP_REDUCTION_USER:
14094 625 : break;
14095 1 : default:
14096 1 : gfc_error ("Invalid operator for !$OMP DECLARE REDUCTION %s at %L",
14097 : omp_udr->name, &omp_udr->where);
14098 26 : return;
14099 : }
14100 :
14101 625 : if (gfc_omp_udr_predef (omp_udr->rop, omp_udr->name,
14102 : &omp_udr->ts, &predef_name))
14103 : {
14104 19 : if (predef_name)
14105 19 : gfc_error ("Redefinition of predefined %qs in "
14106 : "!$OMP DECLARE REDUCTION at %L",
14107 : predef_name, &omp_udr->where);
14108 : else
14109 0 : gfc_error ("Redefinition of predefined %qs in "
14110 : "!$OMP DECLARE REDUCTION at %L", omp_udr->name,
14111 : &omp_udr->where);
14112 19 : return;
14113 : }
14114 :
14115 606 : if (omp_udr->ts.type == BT_CHARACTER
14116 62 : && omp_udr->ts.u.cl->length
14117 32 : && omp_udr->ts.u.cl->length->expr_type != EXPR_CONSTANT)
14118 : {
14119 1 : gfc_error ("CHARACTER length in !$OMP DECLARE REDUCTION %qs not "
14120 : "constant at %L", omp_udr->name, &omp_udr->where);
14121 1 : return;
14122 : }
14123 :
14124 605 : struct omp_udr_callback_data cd;
14125 605 : cd.omp_udr = omp_udr;
14126 605 : cd.is_initializer = false;
14127 605 : gfc_code_walker (&omp_udr->combiner_ns->code, gfc_dummy_code_callback,
14128 : omp_udr_callback, &cd);
14129 605 : if (omp_udr->combiner_ns->code->op == EXEC_CALL)
14130 : {
14131 346 : for (a = omp_udr->combiner_ns->code->ext.actual; a; a = a->next)
14132 237 : if (a->expr == NULL)
14133 : break;
14134 110 : if (a)
14135 1 : gfc_error ("Subroutine call with alternate returns in combiner "
14136 : "of !$OMP DECLARE REDUCTION at %L",
14137 : &omp_udr->combiner_ns->code->loc);
14138 : }
14139 605 : if (omp_udr->initializer_ns)
14140 : {
14141 377 : cd.is_initializer = true;
14142 377 : gfc_code_walker (&omp_udr->initializer_ns->code, gfc_dummy_code_callback,
14143 : omp_udr_callback, &cd);
14144 377 : if (omp_udr->initializer_ns->code->op == EXEC_CALL)
14145 : {
14146 377 : for (a = omp_udr->initializer_ns->code->ext.actual; a; a = a->next)
14147 243 : if (a->expr == NULL)
14148 : break;
14149 135 : if (a)
14150 1 : gfc_error ("Subroutine call with alternate returns in "
14151 : "INITIALIZER clause of !$OMP DECLARE REDUCTION "
14152 : "at %L", &omp_udr->initializer_ns->code->loc);
14153 136 : for (a = omp_udr->initializer_ns->code->ext.actual; a; a = a->next)
14154 135 : if (a->expr
14155 135 : && a->expr->expr_type == EXPR_VARIABLE
14156 135 : && a->expr->symtree->n.sym == omp_udr->omp_priv
14157 134 : && a->expr->ref == NULL)
14158 : break;
14159 135 : if (a == NULL)
14160 1 : gfc_error ("One of actual subroutine arguments in INITIALIZER "
14161 : "clause of !$OMP DECLARE REDUCTION must be OMP_PRIV "
14162 : "at %L", &omp_udr->initializer_ns->code->loc);
14163 : }
14164 : }
14165 228 : else if (omp_udr->ts.type == BT_DERIVED
14166 228 : && !gfc_has_default_initializer (omp_udr->ts.u.derived))
14167 : {
14168 4 : gfc_error ("Missing INITIALIZER clause for !$OMP DECLARE REDUCTION "
14169 : "of derived type without default initializer at %L",
14170 : &omp_udr->where);
14171 4 : return;
14172 : }
14173 : }
14174 :
14175 : void
14176 354667 : gfc_resolve_omp_udrs (gfc_symtree *st)
14177 : {
14178 354667 : gfc_omp_udr *omp_udr;
14179 :
14180 354667 : if (st == NULL)
14181 : return;
14182 527 : gfc_resolve_omp_udrs (st->left);
14183 527 : gfc_resolve_omp_udrs (st->right);
14184 1153 : for (omp_udr = st->n.omp_udr; omp_udr; omp_udr = omp_udr->next)
14185 626 : gfc_resolve_omp_udr (omp_udr);
14186 : }
14187 :
14188 : /* Resolve !$omp declare mapper constructs. */
14189 :
14190 : static void
14191 23 : gfc_resolve_omp_udm (gfc_omp_udm *omp_udm)
14192 : {
14193 23 : resolve_omp_clauses (NULL, omp_udm->clauses, omp_udm->mapper_ns);
14194 :
14195 23 : gfc_omp_namelist *n;
14196 25 : for (n = omp_udm->clauses->lists[OMP_LIST_MAP]; n; n = n->next)
14197 23 : if (n->sym == omp_udm->var_sym)
14198 : break;
14199 23 : if (!n)
14200 2 : gfc_error ("At least one %<map%> clause in !$OMP DECLARE MAPPER at %L must "
14201 : "map %qs or an element of it",
14202 2 : &omp_udm->where, omp_udm->var_sym->name);
14203 23 : }
14204 :
14205 : void
14206 353657 : gfc_resolve_omp_udms (gfc_symtree *st)
14207 : {
14208 353657 : gfc_omp_udm *omp_udm;
14209 :
14210 353657 : if (st == NULL)
14211 : return;
14212 22 : gfc_resolve_omp_udms (st->left);
14213 22 : gfc_resolve_omp_udms (st->right);
14214 45 : for (omp_udm = st->n.omp_udm; omp_udm; omp_udm = omp_udm->next)
14215 23 : gfc_resolve_omp_udm (omp_udm);
14216 : }
|
