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 55276 : gfc_match_omp_eos (void)
135 : {
136 55276 : locus old_loc;
137 55276 : char c;
138 :
139 55276 : old_loc = gfc_current_locus;
140 55276 : gfc_gobble_whitespace ();
141 :
142 55276 : if (gfc_matching_omp_context_selector)
143 : {
144 269 : if (gfc_peek_ascii_char () == ')')
145 : return MATCH_YES;
146 : }
147 : else
148 : {
149 55007 : c = gfc_next_ascii_char ();
150 55007 : 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 53298 : case '\n':
159 53298 : return MATCH_YES;
160 : }
161 : }
162 :
163 1710 : gfc_current_locus = old_loc;
164 1710 : return MATCH_NO;
165 : }
166 :
167 : match
168 13157 : gfc_match_omp_eos_error (void)
169 : {
170 13157 : 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 61384 : gfc_free_omp_clauses (gfc_omp_clauses *c)
182 : {
183 61384 : if (c == NULL)
184 : return;
185 :
186 34555 : gfc_free_expr (c->if_expr);
187 380105 : for (int i = 0; i < OMP_IF_LAST; i++)
188 345550 : gfc_free_expr (c->if_exprs[i]);
189 34555 : gfc_free_expr (c->self_expr);
190 34555 : gfc_free_expr (c->final_expr);
191 34555 : gfc_free_expr (c->num_threads);
192 34555 : gfc_free_expr (c->chunk_size);
193 34555 : gfc_free_expr (c->safelen_expr);
194 34555 : gfc_free_expr (c->simdlen_expr);
195 34555 : gfc_free_expr (c->num_teams_lower);
196 34555 : gfc_free_expr (c->num_teams_upper);
197 34555 : gfc_free_expr (c->device);
198 34555 : gfc_free_expr (c->dyn_groupprivate);
199 34555 : gfc_free_expr (c->thread_limit);
200 34555 : gfc_free_expr (c->dist_chunk_size);
201 34555 : gfc_free_expr (c->grainsize);
202 34555 : gfc_free_expr (c->hint);
203 34555 : gfc_free_expr (c->num_tasks);
204 34555 : gfc_free_expr (c->priority);
205 34555 : gfc_free_expr (c->detach);
206 34555 : gfc_free_expr (c->novariants);
207 34555 : gfc_free_expr (c->nocontext);
208 34555 : gfc_free_expr (c->async_expr);
209 34555 : gfc_free_expr (c->gang_num_expr);
210 34555 : gfc_free_expr (c->gang_static_expr);
211 34555 : gfc_free_expr (c->worker_expr);
212 34555 : gfc_free_expr (c->vector_expr);
213 34555 : gfc_free_expr (c->num_gangs_expr);
214 34555 : gfc_free_expr (c->num_workers_expr);
215 34555 : gfc_free_expr (c->vector_length_expr);
216 1382200 : for (enum gfc_omp_list_type t = OMP_LIST_FIRST; t < OMP_LIST_NUM;
217 1347645 : t = gfc_omp_list_type (t + 1))
218 1347645 : gfc_free_omp_namelist (c->lists[t], t);
219 34555 : gfc_free_expr_list (c->wait_list);
220 34555 : gfc_free_expr_list (c->tile_list);
221 34555 : gfc_free_expr_list (c->sizes_list);
222 34555 : free (const_cast<char *> (c->critical_name));
223 34555 : 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 34555 : 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 104612 : gfc_free_expr_list (gfc_expr_list *list)
255 : {
256 104612 : gfc_expr_list *n;
257 :
258 106015 : for (; list; list = n)
259 : {
260 1403 : n = list->next;
261 1403 : free (list);
262 : }
263 104612 : }
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 525405 : gfc_free_omp_declare_simd_list (gfc_omp_declare_simd *list)
279 : {
280 525641 : 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 525405 : }
287 :
288 : static void
289 727 : gfc_free_omp_trait_property_list (gfc_omp_trait_property *list)
290 : {
291 1134 : while (list)
292 : {
293 407 : gfc_omp_trait_property *current = list;
294 407 : list = list->next;
295 407 : switch (current->property_kind)
296 : {
297 24 : case OMP_TRAIT_PROPERTY_ID:
298 24 : free (current->name);
299 24 : break;
300 261 : case OMP_TRAIT_PROPERTY_NAME_LIST:
301 261 : if (current->is_name)
302 168 : free (current->name);
303 : break;
304 15 : case OMP_TRAIT_PROPERTY_CLAUSE_LIST:
305 15 : gfc_free_omp_clauses (current->clauses);
306 15 : break;
307 : default:
308 : break;
309 : }
310 407 : free (current);
311 : }
312 727 : }
313 :
314 : static void
315 599 : gfc_free_omp_selector_list (gfc_omp_selector *list)
316 : {
317 1326 : while (list)
318 : {
319 727 : gfc_omp_selector *current = list;
320 727 : list = list->next;
321 727 : gfc_free_omp_trait_property_list (current->properties);
322 727 : free (current);
323 : }
324 599 : }
325 :
326 : static void
327 668 : gfc_free_omp_set_selector_list (gfc_omp_set_selector *list)
328 : {
329 1267 : while (list)
330 : {
331 599 : gfc_omp_set_selector *current = list;
332 599 : list = list->next;
333 599 : gfc_free_omp_selector_list (current->trait_selectors);
334 599 : free (current);
335 : }
336 668 : }
337 :
338 : /* Free an !$omp declare variant construct list. */
339 :
340 : void
341 525405 : gfc_free_omp_declare_variant_list (gfc_omp_declare_variant *list)
342 : {
343 525859 : while (list)
344 : {
345 454 : gfc_omp_declare_variant *current = list;
346 454 : list = list->next;
347 454 : gfc_free_omp_set_selector_list (current->set_selectors);
348 454 : gfc_free_omp_namelist (current->adjust_args_list, OMP_LIST_NONE);
349 454 : free (current);
350 : }
351 525405 : }
352 :
353 : /* Free an !$omp declare reduction. */
354 :
355 : void
356 1118 : gfc_free_omp_udr (gfc_omp_udr *omp_udr)
357 : {
358 1118 : if (omp_udr)
359 : {
360 607 : gfc_free_omp_udr (omp_udr->next);
361 607 : gfc_free_namespace (omp_udr->combiner_ns);
362 607 : if (omp_udr->initializer_ns)
363 377 : gfc_free_namespace (omp_udr->initializer_ns);
364 607 : free (omp_udr);
365 : }
366 1118 : }
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 13 : gfc_free_omp_udm (gfc_omp_udm *omp_udm)
386 : {
387 13 : if (omp_udm)
388 : {
389 6 : gfc_free_omp_udm (omp_udm->next);
390 6 : gfc_free_namespace (omp_udm->mapper_ns);
391 6 : free (omp_udm);
392 : }
393 13 : }
394 :
395 : static gfc_omp_udr *
396 4710 : gfc_find_omp_udr (gfc_namespace *ns, const char *name, gfc_typespec *ts)
397 : {
398 4710 : gfc_symtree *st;
399 :
400 4710 : if (ns == NULL)
401 467 : ns = gfc_current_ns;
402 5658 : do
403 : {
404 5658 : gfc_omp_udr *omp_udr;
405 :
406 5658 : st = gfc_find_symtree (ns->omp_udr_root, name);
407 5658 : if (st != NULL)
408 : {
409 934 : for (omp_udr = st->n.omp_udr; omp_udr; omp_udr = omp_udr->next)
410 934 : if (ts == NULL)
411 : return omp_udr;
412 567 : else if (gfc_compare_types (&omp_udr->ts, ts))
413 : {
414 479 : 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 443 : 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 31592 : 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 31592 : gfc_omp_namelist *head, *tail, *p;
457 31592 : locus old_loc, cur_loc;
458 31592 : char n[GFC_MAX_SYMBOL_LEN+1];
459 31592 : gfc_symbol *sym;
460 31592 : match m;
461 31592 : gfc_symtree *st;
462 :
463 31592 : head = tail = NULL;
464 :
465 31592 : old_loc = gfc_current_locus;
466 31592 : if (has_all_memory)
467 708 : *has_all_memory = false;
468 31592 : m = gfc_match (str);
469 31592 : if (m != MATCH_YES)
470 : return m;
471 :
472 38296 : for (;;)
473 : {
474 38296 : gfc_gobble_whitespace ();
475 38296 : cur_loc = gfc_current_locus;
476 :
477 38296 : m = gfc_match_name (n);
478 38296 : 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 38019 : if (m == MATCH_YES)
501 : {
502 38019 : gfc_symtree *st;
503 38019 : if ((m = gfc_get_ha_sym_tree (n, &st) ? MATCH_ERROR : MATCH_YES)
504 : == MATCH_YES)
505 38019 : sym = st->n.sym;
506 : }
507 38273 : switch (m)
508 : {
509 38019 : case MATCH_YES:
510 38019 : gfc_expr *expr;
511 38019 : expr = NULL;
512 38019 : gfc_gobble_whitespace ();
513 23399 : if ((allow_sections && gfc_peek_ascii_char () == '(')
514 57116 : || (allow_derived && gfc_peek_ascii_char () == '%'))
515 : {
516 6530 : gfc_current_locus = cur_loc;
517 6530 : m = gfc_match_variable (&expr, 0);
518 6530 : switch (m)
519 : {
520 4 : case MATCH_ERROR:
521 12 : goto cleanup;
522 0 : case MATCH_NO:
523 0 : goto syntax;
524 6526 : default:
525 6526 : break;
526 : }
527 6526 : 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 38010 : gfc_set_sym_referenced (sym);
535 38010 : p = gfc_get_omp_namelist ();
536 38010 : if (head == NULL)
537 : head = tail = p;
538 10113 : else if (reverse_order)
539 : {
540 57 : p->next = head;
541 57 : head = p;
542 : }
543 : else
544 : {
545 10056 : tail->next = p;
546 10056 : tail = tail->next;
547 : }
548 38010 : p->sym = sym;
549 38010 : p->expr = expr;
550 38010 : p->where = gfc_get_location_range (NULL, 0, &cur_loc, 1,
551 : &gfc_current_locus);
552 38010 : 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 specificed implicitly via the named "
557 : "common block", sym->name, &cur_loc,
558 3 : sym->common_head->name);
559 3 : goto cleanup;
560 : }
561 38007 : goto next_item;
562 254 : case MATCH_NO:
563 254 : break;
564 0 : case MATCH_ERROR:
565 0 : goto cleanup;
566 : }
567 :
568 254 : if (!allow_common)
569 10 : 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 38251 : if (end_colon && gfc_match_char (':') == MATCH_YES)
607 : {
608 793 : *end_colon = true;
609 793 : break;
610 : }
611 37458 : if (gfc_match_char (')') == MATCH_YES)
612 : break;
613 10182 : if (gfc_match_char (',') != MATCH_YES)
614 19 : goto syntax;
615 : }
616 :
617 38076 : while (*list)
618 10007 : list = &(*list)->next;
619 :
620 28069 : *list = head;
621 28069 : if (headp)
622 22200 : *headp = list;
623 : return MATCH_YES;
624 :
625 48 : syntax:
626 48 : gfc_error ("Syntax error in OpenMP variable list at %C");
627 :
628 64 : cleanup:
629 64 : gfc_free_omp_namelist (head, OMP_LIST_NONE);
630 64 : gfc_current_locus = old_loc;
631 64 : 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 362 : gfc_match_omp_to_link (const char *str, gfc_omp_namelist **list)
639 : {
640 362 : gfc_omp_namelist *head, *tail, *p;
641 362 : locus old_loc, cur_loc;
642 362 : char n[GFC_MAX_SYMBOL_LEN+1];
643 362 : gfc_symbol *sym;
644 362 : match m;
645 362 : gfc_symtree *st;
646 :
647 362 : head = tail = NULL;
648 :
649 362 : old_loc = gfc_current_locus;
650 :
651 362 : m = gfc_match (str);
652 362 : if (m != MATCH_YES)
653 : return m;
654 :
655 548 : for (;;)
656 : {
657 548 : cur_loc = gfc_current_locus;
658 548 : m = gfc_match_symbol (&sym, 1);
659 548 : switch (m)
660 : {
661 507 : case MATCH_YES:
662 507 : p = gfc_get_omp_namelist ();
663 507 : if (head == NULL)
664 : head = tail = p;
665 : else
666 : {
667 194 : tail->next = p;
668 194 : tail = tail->next;
669 : }
670 507 : tail->sym = sym;
671 507 : tail->where = cur_loc;
672 507 : 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 548 : next_item:
703 548 : if (gfc_match_char (')') == MATCH_YES)
704 : break;
705 198 : if (gfc_match_char (',') != MATCH_YES)
706 0 : goto syntax;
707 : }
708 :
709 361 : while (*list)
710 11 : list = &(*list)->next;
711 :
712 350 : *list = head;
713 350 : 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 819 : match_omp_oacc_expr_list (const char *str, gfc_expr_list **list,
838 : bool allow_asterisk, bool is_omp)
839 : {
840 819 : gfc_expr_list *head, *tail, *p;
841 819 : locus old_loc;
842 819 : gfc_expr *expr;
843 819 : match m;
844 :
845 819 : head = tail = NULL;
846 :
847 819 : old_loc = gfc_current_locus;
848 :
849 819 : m = gfc_match (str);
850 819 : 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 32195 : omp_mask::omp_mask (omp_mask1 m) : mask1 (((uint64_t) 1) << m), mask2 (0)
1229 : {
1230 : }
1231 :
1232 2206 : omp_mask::omp_mask (omp_mask2 m) : mask1 (0), mask2 (((uint64_t) 1) << m)
1233 : {
1234 : }
1235 :
1236 33094 : omp_mask::omp_mask (uint64_t m1, uint64_t m2) : mask1 (m1), mask2 (m2)
1237 : {
1238 : }
1239 :
1240 : omp_mask
1241 32143 : omp_mask::operator| (omp_mask1 m) const
1242 : {
1243 32143 : return omp_mask (mask1 | (((uint64_t) 1) << m), mask2);
1244 : }
1245 :
1246 : omp_mask
1247 16779 : omp_mask::operator| (omp_mask2 m) const
1248 : {
1249 16779 : return omp_mask (mask1, mask2 | (((uint64_t) 1) << m));
1250 : }
1251 :
1252 : omp_mask
1253 4357 : omp_mask::operator| (omp_mask m) const
1254 : {
1255 4357 : return omp_mask (mask1 | m.mask1, mask2 | m.mask2);
1256 : }
1257 :
1258 : omp_mask
1259 2018 : omp_mask::operator& (const omp_inv_mask &m) const
1260 : {
1261 2018 : return omp_mask (mask1 & ~m.mask1, mask2 & ~m.mask2);
1262 : }
1263 :
1264 : bool
1265 125439 : omp_mask::operator& (omp_mask1 m) const
1266 : {
1267 125439 : return (mask1 & (((uint64_t) 1) << m)) != 0;
1268 : }
1269 :
1270 : bool
1271 88268 : omp_mask::operator& (omp_mask2 m) const
1272 : {
1273 88268 : return (mask2 & (((uint64_t) 1) << m)) != 0;
1274 : }
1275 :
1276 : omp_inv_mask
1277 2018 : omp_mask::operator~ () const
1278 : {
1279 2018 : return omp_inv_mask (*this);
1280 : }
1281 :
1282 2018 : 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 1114 : gfc_match_iterator (gfc_namespace **ns, bool permit_var)
1309 : {
1310 1114 : locus old_loc = gfc_current_locus;
1311 :
1312 1114 : if (gfc_match ("iterator ( ") != MATCH_YES)
1313 : return MATCH_NO;
1314 :
1315 80 : gfc_typespec ts;
1316 80 : gfc_symbol *last = NULL;
1317 80 : gfc_expr *begin, *end, *step;
1318 80 : *ns = gfc_build_block_ns (gfc_current_ns);
1319 86 : char name[GFC_MAX_SYMBOL_LEN + 1];
1320 92 : while (true)
1321 : {
1322 86 : locus prev_loc = gfc_current_locus;
1323 86 : if (gfc_match_type_spec (&ts) == MATCH_YES
1324 86 : && 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 81 : ts.type = BT_INTEGER;
1336 81 : ts.kind = gfc_default_integer_kind;
1337 81 : gfc_current_locus = prev_loc;
1338 : }
1339 84 : prev_loc = gfc_current_locus;
1340 84 : if (gfc_match_name (name) != MATCH_YES)
1341 : {
1342 4 : gfc_error ("Expected identifier at %C");
1343 4 : goto failed;
1344 : }
1345 80 : 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 78 : gfc_symbol *sym = gfc_new_symbol (name, *ns);
1352 78 : if (last)
1353 4 : last->tlink = sym;
1354 : else
1355 74 : (*ns)->omp_affinity_iterators = sym;
1356 78 : last = sym;
1357 78 : sym->declared_at = prev_loc;
1358 78 : sym->ts = ts;
1359 78 : sym->attr.flavor = FL_VARIABLE;
1360 78 : sym->attr.artificial = 1;
1361 78 : sym->attr.referenced = 1;
1362 78 : sym->refs++;
1363 78 : gfc_symtree *st = gfc_new_symtree (&(*ns)->sym_root, name);
1364 78 : st->n.sym = sym;
1365 :
1366 78 : prev_loc = gfc_current_locus;
1367 78 : if (gfc_match (" = ") != MATCH_YES)
1368 3 : goto failed;
1369 75 : permit_var = false;
1370 75 : begin = end = step = NULL;
1371 75 : if (gfc_match ("%e : ", &begin) != MATCH_YES
1372 75 : || 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 72 : 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 67 : gfc_expr *e = gfc_get_expr ();
1391 67 : e->where = prev_loc;
1392 67 : e->expr_type = EXPR_ARRAY;
1393 67 : e->ts = ts;
1394 67 : e->rank = 1;
1395 67 : e->shape = gfc_get_shape (1);
1396 116 : mpz_init_set_ui (e->shape[0], step ? 3 : 2);
1397 67 : gfc_constructor_append_expr (&e->value.constructor, begin, &begin->where);
1398 67 : gfc_constructor_append_expr (&e->value.constructor, end, &end->where);
1399 67 : if (step)
1400 18 : gfc_constructor_append_expr (&e->value.constructor, step, &step->where);
1401 67 : sym->value = e;
1402 :
1403 67 : if (gfc_match (") ") == MATCH_YES)
1404 : break;
1405 6 : if (gfc_match (", ") != MATCH_YES)
1406 0 : goto failed;
1407 6 : }
1408 61 : 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 1715 : gfc_match_motion_var_list (const char *str, gfc_omp_namelist **list,
1436 : gfc_omp_namelist ***headp)
1437 : {
1438 1715 : match m = gfc_match (str);
1439 1715 : if (m != MATCH_YES)
1440 : return m;
1441 :
1442 1715 : match m_present = gfc_match (" present : ");
1443 :
1444 1715 : m = gfc_match_omp_variable_list ("", list, false, NULL, headp, true, true);
1445 1715 : if (m != MATCH_YES)
1446 : return m;
1447 1715 : if (m_present == MATCH_YES)
1448 : {
1449 5 : gfc_omp_namelist *n;
1450 10 : for (n = **headp; n; n = n->next)
1451 5 : n->u.present_modifier = true;
1452 : }
1453 : return MATCH_YES;
1454 : }
1455 :
1456 : /* reduction ( reduction-modifier, reduction-operator : variable-list )
1457 : in_reduction ( reduction-operator : variable-list )
1458 : task_reduction ( reduction-operator : variable-list ) */
1459 :
1460 : static match
1461 4357 : gfc_match_omp_clause_reduction (char pc, gfc_omp_clauses *c, bool openacc,
1462 : bool allow_derived, bool openmp_target = false)
1463 : {
1464 4357 : if (pc == 'r' && gfc_match ("reduction ( ") != MATCH_YES)
1465 : return MATCH_NO;
1466 4357 : else if (pc == 'i' && gfc_match ("in_reduction ( ") != MATCH_YES)
1467 : return MATCH_NO;
1468 4245 : else if (pc == 't' && gfc_match ("task_reduction ( ") != MATCH_YES)
1469 : return MATCH_NO;
1470 :
1471 4245 : locus old_loc = gfc_current_locus;
1472 4245 : enum gfc_omp_list_type list_idx = OMP_LIST_NONE;
1473 :
1474 4245 : if (pc == 'r' && !openacc)
1475 : {
1476 2118 : if (gfc_match ("inscan") == MATCH_YES)
1477 : list_idx = OMP_LIST_REDUCTION_INSCAN;
1478 2048 : else if (gfc_match ("task") == MATCH_YES)
1479 : list_idx = OMP_LIST_REDUCTION_TASK;
1480 1943 : else if (gfc_match ("default") == MATCH_YES)
1481 : list_idx = OMP_LIST_REDUCTION;
1482 231 : if (list_idx != OMP_LIST_NONE && gfc_match (", ") != MATCH_YES)
1483 : {
1484 1 : gfc_error ("Comma expected at %C");
1485 1 : gfc_current_locus = old_loc;
1486 1 : return MATCH_NO;
1487 : }
1488 2117 : if (list_idx == OMP_LIST_NONE)
1489 3831 : list_idx = OMP_LIST_REDUCTION;
1490 : }
1491 2127 : else if (pc == 'i')
1492 : list_idx = OMP_LIST_IN_REDUCTION;
1493 2009 : else if (pc == 't')
1494 : list_idx = OMP_LIST_TASK_REDUCTION;
1495 : else
1496 3831 : list_idx = OMP_LIST_REDUCTION;
1497 :
1498 4244 : gfc_omp_reduction_op rop = OMP_REDUCTION_NONE;
1499 4244 : char buffer[GFC_MAX_SYMBOL_LEN + 3];
1500 4244 : if (gfc_match_char ('+') == MATCH_YES)
1501 : rop = OMP_REDUCTION_PLUS;
1502 2223 : else if (gfc_match_char ('*') == MATCH_YES)
1503 : rop = OMP_REDUCTION_TIMES;
1504 1991 : else if (gfc_match_char ('-') == MATCH_YES)
1505 : {
1506 171 : if (!openacc)
1507 16 : gfc_warning (OPT_Wdeprecated_openmp,
1508 : "%<-%> operator at %C for reductions deprecated in "
1509 : "OpenMP 5.2");
1510 : rop = OMP_REDUCTION_MINUS;
1511 : }
1512 1820 : else if (gfc_match (".and.") == MATCH_YES)
1513 : rop = OMP_REDUCTION_AND;
1514 1714 : else if (gfc_match (".or.") == MATCH_YES)
1515 : rop = OMP_REDUCTION_OR;
1516 929 : else if (gfc_match (".eqv.") == MATCH_YES)
1517 : rop = OMP_REDUCTION_EQV;
1518 831 : else if (gfc_match (".neqv.") == MATCH_YES)
1519 : rop = OMP_REDUCTION_NEQV;
1520 736 : if (rop != OMP_REDUCTION_NONE)
1521 3508 : snprintf (buffer, sizeof buffer, "operator %s",
1522 : gfc_op2string ((gfc_intrinsic_op) rop));
1523 736 : else if (gfc_match_defined_op_name (buffer + 1, 1) == MATCH_YES)
1524 : {
1525 38 : buffer[0] = '.';
1526 38 : strcat (buffer, ".");
1527 : }
1528 698 : else if (gfc_match_name (buffer) == MATCH_YES)
1529 : {
1530 697 : gfc_symbol *sym;
1531 697 : const char *n = buffer;
1532 :
1533 697 : gfc_find_symbol (buffer, NULL, 1, &sym);
1534 697 : if (sym != NULL)
1535 : {
1536 216 : if (sym->attr.intrinsic)
1537 139 : n = sym->name;
1538 77 : else if ((sym->attr.flavor != FL_UNKNOWN
1539 75 : && sym->attr.flavor != FL_PROCEDURE)
1540 75 : || sym->attr.external
1541 64 : || sym->attr.generic
1542 64 : || sym->attr.entry
1543 64 : || sym->attr.result
1544 64 : || sym->attr.dummy
1545 64 : || sym->attr.subroutine
1546 63 : || sym->attr.pointer
1547 63 : || sym->attr.target
1548 63 : || sym->attr.cray_pointer
1549 63 : || sym->attr.cray_pointee
1550 63 : || (sym->attr.proc != PROC_UNKNOWN
1551 1 : && sym->attr.proc != PROC_INTRINSIC)
1552 62 : || sym->attr.if_source != IFSRC_UNKNOWN
1553 62 : || sym == sym->ns->proc_name)
1554 : {
1555 : sym = NULL;
1556 : n = NULL;
1557 : }
1558 : else
1559 62 : n = sym->name;
1560 : }
1561 201 : if (n == NULL)
1562 : rop = OMP_REDUCTION_NONE;
1563 682 : else if (strcmp (n, "max") == 0)
1564 : rop = OMP_REDUCTION_MAX;
1565 517 : else if (strcmp (n, "min") == 0)
1566 : rop = OMP_REDUCTION_MIN;
1567 376 : else if (strcmp (n, "iand") == 0)
1568 : rop = OMP_REDUCTION_IAND;
1569 321 : else if (strcmp (n, "ior") == 0)
1570 : rop = OMP_REDUCTION_IOR;
1571 255 : else if (strcmp (n, "ieor") == 0)
1572 : rop = OMP_REDUCTION_IEOR;
1573 : if (rop != OMP_REDUCTION_NONE
1574 477 : && sym != NULL
1575 200 : && ! sym->attr.intrinsic
1576 61 : && ! sym->attr.use_assoc
1577 61 : && ((sym->attr.flavor == FL_UNKNOWN
1578 2 : && !gfc_add_flavor (&sym->attr, FL_PROCEDURE,
1579 : sym->name, NULL))
1580 61 : || !gfc_add_intrinsic (&sym->attr, NULL)))
1581 : rop = OMP_REDUCTION_NONE;
1582 : }
1583 : else
1584 1 : buffer[0] = '\0';
1585 4244 : gfc_omp_udr *udr = (buffer[0] ? gfc_find_omp_udr (gfc_current_ns, buffer, NULL)
1586 : : NULL);
1587 4244 : gfc_omp_namelist **head = NULL;
1588 4244 : if (rop == OMP_REDUCTION_NONE && udr)
1589 250 : rop = OMP_REDUCTION_USER;
1590 :
1591 4244 : if (gfc_match_omp_variable_list (" :", &c->lists[list_idx], false, NULL,
1592 : &head, openacc, allow_derived) != MATCH_YES)
1593 : {
1594 9 : gfc_current_locus = old_loc;
1595 9 : return MATCH_NO;
1596 : }
1597 4235 : gfc_omp_namelist *n;
1598 4235 : if (rop == OMP_REDUCTION_NONE)
1599 : {
1600 6 : n = *head;
1601 6 : *head = NULL;
1602 6 : gfc_error_now ("!$OMP DECLARE REDUCTION %s not found at %L",
1603 : buffer, &old_loc);
1604 6 : gfc_free_omp_namelist (n, OMP_LIST_NONE);
1605 : }
1606 : else
1607 9110 : for (n = *head; n; n = n->next)
1608 : {
1609 4881 : n->u.reduction_op = rop;
1610 4881 : if (udr)
1611 : {
1612 473 : n->u2.udr = gfc_get_omp_namelist_udr ();
1613 473 : n->u2.udr->udr = udr;
1614 : }
1615 4881 : if (openmp_target && list_idx == OMP_LIST_IN_REDUCTION)
1616 : {
1617 40 : gfc_omp_namelist *p = gfc_get_omp_namelist (), **tl;
1618 40 : p->sym = n->sym;
1619 40 : p->where = n->where;
1620 40 : p->u.map.op = OMP_MAP_ALWAYS_TOFROM;
1621 :
1622 40 : tl = &c->lists[OMP_LIST_MAP];
1623 52 : while (*tl)
1624 12 : tl = &((*tl)->next);
1625 40 : *tl = p;
1626 40 : p->next = NULL;
1627 : }
1628 : }
1629 : return MATCH_YES;
1630 : }
1631 :
1632 : static match
1633 40 : gfc_omp_absent_contains_clause (gfc_omp_assumptions **assume, bool is_absent)
1634 : {
1635 40 : if (*assume == NULL)
1636 15 : *assume = gfc_get_omp_assumptions ();
1637 62 : do
1638 : {
1639 51 : gfc_statement st = ST_NONE;
1640 51 : gfc_gobble_whitespace ();
1641 51 : locus old_loc = gfc_current_locus;
1642 51 : char c = gfc_peek_ascii_char ();
1643 51 : enum gfc_omp_directive_kind kind
1644 : = GFC_OMP_DIR_DECLARATIVE; /* Silence warning. */
1645 1585 : for (size_t i = 0; i < ARRAY_SIZE (gfc_omp_directives); i++)
1646 : {
1647 1585 : if (gfc_omp_directives[i].name[0] > c)
1648 : break;
1649 1534 : if (gfc_omp_directives[i].name[0] != c)
1650 1182 : continue;
1651 352 : if (gfc_match (gfc_omp_directives[i].name) == MATCH_YES)
1652 : {
1653 51 : st = gfc_omp_directives[i].st;
1654 51 : kind = gfc_omp_directives[i].kind;
1655 : }
1656 : }
1657 51 : gfc_gobble_whitespace ();
1658 51 : c = gfc_peek_ascii_char ();
1659 51 : if (st == ST_NONE || (c != ',' && c != ')'))
1660 : {
1661 0 : if (st == ST_NONE)
1662 0 : gfc_error ("Unknown directive at %L", &old_loc);
1663 : else
1664 0 : gfc_error ("Invalid combined or composite directive at %L",
1665 : &old_loc);
1666 4 : return MATCH_ERROR;
1667 : }
1668 51 : if (kind == GFC_OMP_DIR_DECLARATIVE
1669 51 : || kind == GFC_OMP_DIR_INFORMATIONAL
1670 : || kind == GFC_OMP_DIR_META)
1671 : {
1672 5 : gfc_error ("Invalid %qs directive at %L in %s clause: declarative, "
1673 : "informational, and meta directives not permitted",
1674 : gfc_ascii_statement (st, true), &old_loc,
1675 : is_absent ? "ABSENT" : "CONTAINS");
1676 4 : return MATCH_ERROR;
1677 : }
1678 47 : if (is_absent)
1679 : {
1680 : /* Use exponential allocation; equivalent to pow2p(x). */
1681 33 : int i = (*assume)->n_absent;
1682 33 : int size = ((i == 0) ? 4
1683 10 : : pow2p_hwi (i) == 1 ? i*2 : 0);
1684 8 : if (size != 0)
1685 31 : (*assume)->absent = XRESIZEVEC (gfc_statement,
1686 : (*assume)->absent, size);
1687 33 : (*assume)->absent[(*assume)->n_absent++] = st;
1688 : }
1689 : else
1690 : {
1691 14 : int i = (*assume)->n_contains;
1692 14 : int size = ((i == 0) ? 4
1693 4 : : pow2p_hwi (i) == 1 ? i*2 : 0);
1694 4 : if (size != 0)
1695 14 : (*assume)->contains = XRESIZEVEC (gfc_statement,
1696 : (*assume)->contains, size);
1697 14 : (*assume)->contains[(*assume)->n_contains++] = st;
1698 : }
1699 47 : gfc_gobble_whitespace ();
1700 47 : if (gfc_match(",") == MATCH_YES)
1701 11 : continue;
1702 36 : if (gfc_match(")") == MATCH_YES)
1703 : break;
1704 0 : gfc_error ("Expected %<,%> or %<)%> at %C");
1705 0 : return MATCH_ERROR;
1706 : }
1707 : while (true);
1708 :
1709 36 : return MATCH_YES;
1710 : }
1711 :
1712 : /* Check 'check' argument for duplicated statements in absent and/or contains
1713 : clauses. If 'merge', merge them from check to 'merge'. */
1714 :
1715 : static match
1716 43 : omp_verify_merge_absent_contains (gfc_statement st, gfc_omp_assumptions *check,
1717 : gfc_omp_assumptions *merge, locus *loc)
1718 : {
1719 43 : if (check == NULL)
1720 : return MATCH_YES;
1721 43 : bitmap_head absent_head, contains_head;
1722 43 : bitmap_obstack_initialize (NULL);
1723 43 : bitmap_initialize (&absent_head, &bitmap_default_obstack);
1724 43 : bitmap_initialize (&contains_head, &bitmap_default_obstack);
1725 :
1726 43 : match m = MATCH_YES;
1727 76 : for (int i = 0; i < check->n_absent; i++)
1728 33 : if (!bitmap_set_bit (&absent_head, check->absent[i]))
1729 : {
1730 2 : gfc_error ("%qs directive mentioned multiple times in %s clause in %s "
1731 : "directive at %L",
1732 2 : gfc_ascii_statement (check->absent[i], true),
1733 : "ABSENT", gfc_ascii_statement (st), loc);
1734 2 : m = MATCH_ERROR;
1735 : }
1736 57 : for (int i = 0; i < check->n_contains; i++)
1737 : {
1738 14 : if (!bitmap_set_bit (&contains_head, check->contains[i]))
1739 : {
1740 2 : gfc_error ("%qs directive mentioned multiple times in %s clause in %s "
1741 : "directive at %L",
1742 2 : gfc_ascii_statement (check->contains[i], true),
1743 : "CONTAINS", gfc_ascii_statement (st), loc);
1744 2 : m = MATCH_ERROR;
1745 : }
1746 14 : if (bitmap_bit_p (&absent_head, check->contains[i]))
1747 : {
1748 2 : gfc_error ("%qs directive mentioned both times in ABSENT and CONTAINS "
1749 : "clauses in %s directive at %L",
1750 2 : gfc_ascii_statement (check->absent[i], true),
1751 : gfc_ascii_statement (st), loc);
1752 2 : m = MATCH_ERROR;
1753 : }
1754 : }
1755 :
1756 43 : if (m == MATCH_ERROR)
1757 : return MATCH_ERROR;
1758 37 : if (merge == NULL)
1759 : return MATCH_YES;
1760 2 : if (merge->absent == NULL && check->absent)
1761 : {
1762 1 : merge->n_absent = check->n_absent;
1763 1 : merge->absent = check->absent;
1764 1 : check->absent = NULL;
1765 : }
1766 1 : else if (merge->absent && check->absent)
1767 : {
1768 0 : check->absent = XRESIZEVEC (gfc_statement, check->absent,
1769 : merge->n_absent + check->n_absent);
1770 0 : for (int i = 0; i < merge->n_absent; i++)
1771 0 : if (!bitmap_bit_p (&absent_head, merge->absent[i]))
1772 0 : check->absent[check->n_absent++] = merge->absent[i];
1773 0 : free (merge->absent);
1774 0 : merge->absent = check->absent;
1775 0 : merge->n_absent = check->n_absent;
1776 0 : check->absent = NULL;
1777 : }
1778 2 : if (merge->contains == NULL && check->contains)
1779 : {
1780 0 : merge->n_contains = check->n_contains;
1781 0 : merge->contains = check->contains;
1782 0 : check->contains = NULL;
1783 : }
1784 2 : else if (merge->contains && check->contains)
1785 : {
1786 0 : check->contains = XRESIZEVEC (gfc_statement, check->contains,
1787 : merge->n_contains + check->n_contains);
1788 0 : for (int i = 0; i < merge->n_contains; i++)
1789 0 : if (!bitmap_bit_p (&contains_head, merge->contains[i]))
1790 0 : check->contains[check->n_contains++] = merge->contains[i];
1791 0 : free (merge->contains);
1792 0 : merge->contains = check->contains;
1793 0 : merge->n_contains = check->n_contains;
1794 0 : check->contains = NULL;
1795 : }
1796 : return MATCH_YES;
1797 : }
1798 :
1799 : /* OpenMP 5.0
1800 : uses_allocators ( allocator-list )
1801 :
1802 : allocator:
1803 : predefined-allocator
1804 : variable ( traits-array )
1805 :
1806 : OpenMP 5.2 deprecated, 6.0 deleted: 'variable ( traits-array )'
1807 :
1808 : OpenMP 5.2:
1809 : uses_allocators ( [modifier-list :] allocator-list )
1810 :
1811 : OpenMP 6.0:
1812 : uses_allocators ( [modifier-list :] allocator-list [; ...])
1813 :
1814 : allocator:
1815 : variable or predefined-allocator
1816 : modifier:
1817 : traits ( traits-array )
1818 : memspace ( mem-space-handle ) */
1819 :
1820 : static match
1821 56 : gfc_match_omp_clause_uses_allocators (gfc_omp_clauses *c)
1822 : {
1823 60 : parse_next:
1824 60 : gfc_symbol *memspace_sym = NULL;
1825 60 : gfc_symbol *traits_sym = NULL;
1826 60 : gfc_omp_namelist *head = NULL;
1827 60 : gfc_omp_namelist *p, *tail, **list;
1828 60 : int ntraits, nmemspace;
1829 60 : bool has_modifiers;
1830 60 : locus old_loc, cur_loc;
1831 :
1832 60 : gfc_gobble_whitespace ();
1833 60 : old_loc = gfc_current_locus;
1834 60 : ntraits = nmemspace = 0;
1835 92 : do
1836 : {
1837 76 : cur_loc = gfc_current_locus;
1838 76 : if (gfc_match ("traits ( %S ) ", &traits_sym) == MATCH_YES)
1839 24 : ntraits++;
1840 52 : else if (gfc_match ("memspace ( %S ) ", &memspace_sym) == MATCH_YES)
1841 23 : nmemspace++;
1842 76 : if (ntraits > 1 || nmemspace > 1)
1843 : {
1844 2 : gfc_error ("Duplicate %s modifier at %L in USES_ALLOCATORS clause",
1845 : ntraits > 1 ? "TRAITS" : "MEMSPACE", &cur_loc);
1846 2 : return MATCH_ERROR;
1847 : }
1848 74 : if (gfc_match (", ") == MATCH_YES)
1849 16 : continue;
1850 58 : if (gfc_match (": ") != MATCH_YES)
1851 : {
1852 : /* Assume no modifier. */
1853 31 : memspace_sym = traits_sym = NULL;
1854 31 : gfc_current_locus = old_loc;
1855 31 : break;
1856 : }
1857 : break;
1858 : } while (true);
1859 :
1860 85 : has_modifiers = traits_sym != NULL || memspace_sym != NULL;
1861 150 : do
1862 : {
1863 104 : p = gfc_get_omp_namelist ();
1864 104 : p->where = gfc_current_locus;
1865 104 : if (head == NULL)
1866 : head = tail = p;
1867 : else
1868 : {
1869 46 : tail->next = p;
1870 46 : tail = tail->next;
1871 : }
1872 104 : if (gfc_match ("%S ", &p->sym) != MATCH_YES)
1873 0 : goto error;
1874 104 : if (!has_modifiers)
1875 : {
1876 72 : if (gfc_match ("( %S ) ", &p->u2.traits_sym) == MATCH_YES)
1877 17 : gfc_warning (OPT_Wdeprecated_openmp,
1878 : "The specification of arguments to "
1879 : "%<uses_allocators%> at %L where each item is of "
1880 : "the form %<allocator(traits)%> is deprecated since "
1881 : "OpenMP 5.2; instead use %<uses_allocators(traits(%s"
1882 17 : "): %s)%>", &p->where, p->u2.traits_sym->name,
1883 17 : p->sym->name);
1884 : }
1885 32 : else if (gfc_peek_ascii_char () == '(')
1886 : {
1887 0 : gfc_error ("Unexpected %<(%> at %C");
1888 0 : goto error;
1889 : }
1890 : else
1891 : {
1892 32 : p->u.memspace_sym = memspace_sym;
1893 32 : p->u2.traits_sym = traits_sym;
1894 : }
1895 104 : gfc_gobble_whitespace ();
1896 104 : const char c = gfc_peek_ascii_char ();
1897 104 : if (c == ';' || c == ')')
1898 : break;
1899 48 : if (c != ',')
1900 : {
1901 2 : gfc_error ("Expected %<,%>, %<)%> or %<;%> at %C");
1902 2 : goto error;
1903 : }
1904 46 : gfc_match_char (',');
1905 46 : gfc_gobble_whitespace ();
1906 46 : } while (true);
1907 :
1908 56 : list = &c->lists[OMP_LIST_USES_ALLOCATORS];
1909 74 : while (*list)
1910 18 : list = &(*list)->next;
1911 56 : *list = head;
1912 :
1913 56 : if (gfc_match_char (';') == MATCH_YES)
1914 4 : goto parse_next;
1915 :
1916 52 : gfc_match_char (')');
1917 52 : return MATCH_YES;
1918 :
1919 2 : error:
1920 2 : gfc_free_omp_namelist (head, OMP_LIST_USES_ALLOCATORS);
1921 2 : return MATCH_ERROR;
1922 : }
1923 :
1924 :
1925 : /* Match the 'prefer_type' modifier of the interop 'init' clause:
1926 : with either OpenMP 5.1's
1927 : prefer_type ( <const-int-expr|string literal> [, ...]
1928 : or
1929 : prefer_type ( '{' <fr(...) | attr (...)>, ...] '}' [, '{' ... '}' ] )
1930 : where 'fr' takes a constant expression or a string literal
1931 : and 'attr takes a list of string literals, starting with 'ompx_')
1932 :
1933 : For the foreign runtime identifiers, string values are converted to
1934 : their integer value; unknown string or integer values are set to
1935 : GOMP_INTEROP_IFR_KNOWN.
1936 :
1937 : Data format:
1938 : For the foreign runtime identifiers, string values are converted to
1939 : their integer value; unknown string or integer values are set to 0.
1940 :
1941 : Each item (a) GOMP_INTEROP_IFR_SEPARATOR
1942 : (b) for any 'fr', its integer value.
1943 : Note: Spec only permits 1 'fr' entry (6.0; changed after TR13)
1944 : (c) GOMP_INTEROP_IFR_SEPARATOR
1945 : (d) list of \0-terminated non-empty strings for 'attr'
1946 : (e) '\0'
1947 : Tailing '\0'. */
1948 :
1949 : static match
1950 82 : gfc_match_omp_prefer_type (char **type_str, int *type_str_len)
1951 : {
1952 82 : gfc_expr *e;
1953 82 : std::string type_string, attr_string;
1954 : /* New syntax. */
1955 82 : if (gfc_peek_ascii_char () == '{')
1956 115 : do
1957 : {
1958 85 : attr_string.clear ();
1959 85 : type_string += (char) GOMP_INTEROP_IFR_SEPARATOR;
1960 85 : if (gfc_match ("{ ") != MATCH_YES)
1961 : {
1962 1 : gfc_error ("Expected %<{%> at %C");
1963 1 : return MATCH_ERROR;
1964 : }
1965 : bool fr_found = false;
1966 148 : do
1967 : {
1968 116 : if (gfc_match ("fr ( ") == MATCH_YES)
1969 : {
1970 62 : if (fr_found)
1971 : {
1972 1 : gfc_error ("Duplicated %<fr%> preference-selector-name "
1973 : "at %C");
1974 1 : return MATCH_ERROR;
1975 : }
1976 61 : fr_found = true;
1977 61 : do
1978 : {
1979 61 : bool found_literal = false;
1980 61 : match m = MATCH_YES;
1981 61 : if (gfc_match_literal_constant (&e, false) == MATCH_YES)
1982 : found_literal = true;
1983 : else
1984 12 : m = gfc_match_expr (&e);
1985 12 : if (m != MATCH_YES
1986 61 : || !gfc_resolve_expr (e)
1987 61 : || e->rank != 0
1988 60 : || e->expr_type != EXPR_CONSTANT
1989 59 : || (e->ts.type != BT_INTEGER
1990 43 : && (!found_literal || e->ts.type != BT_CHARACTER))
1991 58 : || (e->ts.type == BT_INTEGER
1992 16 : && !mpz_fits_sint_p (e->value.integer))
1993 70 : || (e->ts.type == BT_CHARACTER
1994 42 : && (e->ts.kind != gfc_default_character_kind
1995 41 : || e->value.character.length == 0)))
1996 : {
1997 5 : gfc_error ("Expected constant scalar integer expression"
1998 : " or non-empty default-kind character "
1999 5 : "literal at %L", &e->where);
2000 5 : gfc_free_expr (e);
2001 5 : return MATCH_ERROR;
2002 : }
2003 56 : gfc_gobble_whitespace ();
2004 56 : int val;
2005 56 : if (e->ts.type == BT_INTEGER)
2006 : {
2007 16 : val = mpz_get_si (e->value.integer);
2008 16 : if (val < 1 || val > GOMP_INTEROP_IFR_LAST)
2009 : {
2010 0 : gfc_warning_now (OPT_Wopenmp,
2011 : "Unknown foreign runtime "
2012 : "identifier %qd at %L",
2013 : val, &e->where);
2014 0 : val = GOMP_INTEROP_IFR_UNKNOWN;
2015 : }
2016 : }
2017 : else
2018 : {
2019 40 : char *str = XALLOCAVEC (char,
2020 : e->value.character.length+1);
2021 229 : for (int i = 0; i < e->value.character.length + 1; i++)
2022 189 : str[i] = e->value.character.string[i];
2023 40 : if (memchr (str, '\0', e->value.character.length) != 0)
2024 : {
2025 0 : gfc_error ("Unexpected null character in character "
2026 : "literal at %L", &e->where);
2027 0 : return MATCH_ERROR;
2028 : }
2029 40 : val = omp_get_fr_id_from_name (str);
2030 40 : if (val == GOMP_INTEROP_IFR_UNKNOWN)
2031 2 : gfc_warning_now (OPT_Wopenmp,
2032 : "Unknown foreign runtime identifier "
2033 2 : "%qs at %L", str, &e->where);
2034 : }
2035 :
2036 56 : type_string += (char) val;
2037 56 : if (gfc_match (") ") == MATCH_YES)
2038 : break;
2039 4 : gfc_error ("Expected %<)%> at %C");
2040 4 : return MATCH_ERROR;
2041 : }
2042 : while (true);
2043 : }
2044 54 : else if (gfc_match ("attr ( ") == MATCH_YES)
2045 : {
2046 60 : do
2047 : {
2048 57 : if (gfc_match_literal_constant (&e, false) != MATCH_YES
2049 56 : || !gfc_resolve_expr (e)
2050 56 : || e->expr_type != EXPR_CONSTANT
2051 56 : || e->rank != 0
2052 56 : || e->ts.type != BT_CHARACTER
2053 113 : || e->ts.kind != gfc_default_character_kind)
2054 : {
2055 1 : gfc_error ("Expected default-kind character literal "
2056 1 : "at %L", &e->where);
2057 1 : gfc_free_expr (e);
2058 1 : return MATCH_ERROR;
2059 : }
2060 56 : gfc_gobble_whitespace ();
2061 56 : char *str = XALLOCAVEC (char, e->value.character.length+1);
2062 564 : for (int i = 0; i < e->value.character.length + 1; i++)
2063 508 : str[i] = e->value.character.string[i];
2064 56 : if (!startswith (str, "ompx_"))
2065 : {
2066 1 : gfc_error ("Character literal at %L must start with "
2067 : "%<ompx_%>", &e->where);
2068 1 : gfc_free_expr (e);
2069 1 : return MATCH_ERROR;
2070 : }
2071 55 : if (memchr (str, '\0', e->value.character.length) != 0
2072 55 : || memchr (str, ',', e->value.character.length) != 0)
2073 : {
2074 1 : gfc_error ("Unexpected null or %<,%> character in "
2075 : "character literal at %L", &e->where);
2076 1 : return MATCH_ERROR;
2077 : }
2078 54 : attr_string += str;
2079 54 : attr_string += '\0';
2080 54 : if (gfc_match (", ") == MATCH_YES)
2081 3 : continue;
2082 51 : if (gfc_match (") ") == MATCH_YES)
2083 : break;
2084 0 : gfc_error ("Expected %<,%> or %<)%> at %C");
2085 0 : return MATCH_ERROR;
2086 3 : }
2087 : while (true);
2088 : }
2089 : else
2090 : {
2091 0 : gfc_error ("Expected %<fr(%> or %<attr(%> at %C");
2092 0 : return MATCH_ERROR;
2093 : }
2094 103 : if (gfc_match (", ") == MATCH_YES)
2095 32 : continue;
2096 71 : if (gfc_match ("} ") == MATCH_YES)
2097 : break;
2098 2 : gfc_error ("Expected %<,%> or %<}%> at %C");
2099 2 : return MATCH_ERROR;
2100 32 : }
2101 : while (true);
2102 69 : type_string += (char) GOMP_INTEROP_IFR_SEPARATOR;
2103 69 : type_string += attr_string;
2104 69 : type_string += '\0';
2105 69 : if (gfc_match (", ") == MATCH_YES)
2106 30 : continue;
2107 39 : if (gfc_match (") ") == MATCH_YES)
2108 : break;
2109 1 : gfc_error ("Expected %<,%> or %<)%> at %C");
2110 1 : return MATCH_ERROR;
2111 30 : }
2112 : while (true);
2113 : else
2114 75 : do
2115 : {
2116 51 : type_string += (char) GOMP_INTEROP_IFR_SEPARATOR;
2117 51 : bool found_literal = false;
2118 51 : match m = MATCH_YES;
2119 51 : if (gfc_match_literal_constant (&e, false) == MATCH_YES)
2120 : found_literal = true;
2121 : else
2122 19 : m = gfc_match_expr (&e);
2123 19 : if (m != MATCH_YES
2124 51 : || !gfc_resolve_expr (e)
2125 51 : || e->rank != 0
2126 50 : || e->expr_type != EXPR_CONSTANT
2127 49 : || (e->ts.type != BT_INTEGER
2128 28 : && (!found_literal || e->ts.type != BT_CHARACTER))
2129 48 : || (e->ts.type == BT_INTEGER
2130 21 : && !mpz_fits_sint_p (e->value.integer))
2131 67 : || (e->ts.type == BT_CHARACTER
2132 27 : && (e->ts.kind != gfc_default_character_kind
2133 27 : || e->value.character.length == 0)))
2134 : {
2135 3 : gfc_error ("Expected constant scalar integer expression or "
2136 3 : "non-empty default-kind character literal at %L", &e->where);
2137 3 : gfc_free_expr (e);
2138 3 : return MATCH_ERROR;
2139 : }
2140 48 : gfc_gobble_whitespace ();
2141 48 : int val;
2142 48 : if (e->ts.type == BT_INTEGER)
2143 : {
2144 21 : val = mpz_get_si (e->value.integer);
2145 21 : if (val < 1 || val > GOMP_INTEROP_IFR_LAST)
2146 : {
2147 3 : gfc_warning_now (OPT_Wopenmp,
2148 : "Unknown foreign runtime identifier %qd at %L",
2149 : val, &e->where);
2150 3 : val = 0;
2151 : }
2152 : }
2153 : else
2154 : {
2155 27 : char *str = XALLOCAVEC (char, e->value.character.length+1);
2156 169 : for (int i = 0; i < e->value.character.length + 1; i++)
2157 142 : str[i] = e->value.character.string[i];
2158 27 : if (memchr (str, '\0', e->value.character.length) != 0)
2159 : {
2160 0 : gfc_error ("Unexpected null character in character "
2161 : "literal at %L", &e->where);
2162 0 : return MATCH_ERROR;
2163 : }
2164 27 : val = omp_get_fr_id_from_name (str);
2165 27 : if (val == GOMP_INTEROP_IFR_UNKNOWN)
2166 5 : gfc_warning_now (OPT_Wopenmp,
2167 : "Unknown foreign runtime identifier %qs at %L",
2168 5 : str, &e->where);
2169 : }
2170 48 : type_string += (char) val;
2171 48 : type_string += (char) GOMP_INTEROP_IFR_SEPARATOR;
2172 48 : type_string += '\0';
2173 48 : gfc_free_expr (e);
2174 48 : if (gfc_match (", ") == MATCH_YES)
2175 24 : continue;
2176 24 : if (gfc_match (") ") == MATCH_YES)
2177 : break;
2178 2 : gfc_error ("Expected %<,%> or %<)%> at %C");
2179 2 : return MATCH_ERROR;
2180 24 : }
2181 : while (true);
2182 60 : type_string += '\0';
2183 60 : *type_str_len = type_string.length();
2184 60 : *type_str = XNEWVEC (char, type_string.length ());
2185 60 : memcpy (*type_str, type_string.data (), type_string.length ());
2186 60 : return MATCH_YES;
2187 82 : }
2188 :
2189 :
2190 : /* Match OpenMP 5.1's 'init'-clause modifiers, used by the 'init' clause of
2191 : the 'interop' directive and the 'append_args' directive of 'declare variant'.
2192 : [prefer_type(...)][,][<target|targetsync>, ...])
2193 :
2194 : If is_init_clause, the modifier parsing ends with a ':'.
2195 : If not is_init_clause (i.e. append_args), the parsing ends with ')'. */
2196 :
2197 : static match
2198 164 : gfc_parser_omp_clause_init_modifiers (bool &target, bool &targetsync,
2199 : char **type_str, int &type_str_len,
2200 : bool is_init_clause)
2201 : {
2202 164 : target = false;
2203 164 : targetsync = false;
2204 164 : *type_str = NULL;
2205 164 : type_str_len = 0;
2206 286 : match m;
2207 :
2208 286 : do
2209 : {
2210 286 : if (gfc_match ("prefer_type ( ") == MATCH_YES)
2211 : {
2212 83 : if (*type_str)
2213 : {
2214 1 : gfc_error ("Duplicate %<prefer_type%> modifier at %C");
2215 1 : return MATCH_ERROR;
2216 : }
2217 82 : m = gfc_match_omp_prefer_type (type_str, &type_str_len);
2218 82 : if (m != MATCH_YES)
2219 : return m;
2220 60 : if (gfc_match (", ") == MATCH_YES)
2221 14 : continue;
2222 46 : if (is_init_clause)
2223 : {
2224 24 : if (gfc_match (": ") == MATCH_YES)
2225 : break;
2226 0 : gfc_error ("Expected %<,%> or %<:%> at %C");
2227 : }
2228 : else
2229 : {
2230 22 : if (gfc_match (") ") == MATCH_YES)
2231 : break;
2232 0 : gfc_error ("Expected %<,%> or %<)%> at %C");
2233 : }
2234 0 : return MATCH_ERROR;
2235 : }
2236 :
2237 203 : if (gfc_match ("prefer_type ") == MATCH_YES)
2238 : {
2239 2 : gfc_error ("Expected %<(%> after %<prefer_type%> at %C");
2240 2 : return MATCH_ERROR;
2241 : }
2242 :
2243 201 : if (gfc_match ("targetsync ") == MATCH_YES)
2244 : {
2245 57 : if (targetsync)
2246 : {
2247 3 : gfc_error ("Duplicate %<targetsync%> at %C");
2248 3 : return MATCH_ERROR;
2249 : }
2250 54 : targetsync = true;
2251 54 : if (gfc_match (", ") == MATCH_YES)
2252 13 : continue;
2253 41 : if (!is_init_clause)
2254 : {
2255 23 : if (gfc_match (") ") == MATCH_YES)
2256 : break;
2257 0 : gfc_error ("Expected %<,%> or %<)%> at %C");
2258 0 : return MATCH_ERROR;
2259 : }
2260 18 : if (gfc_match (": ") == MATCH_YES)
2261 : break;
2262 1 : gfc_error ("Expected %<,%> or %<:%> at %C");
2263 1 : return MATCH_ERROR;
2264 : }
2265 144 : if (gfc_match ("target ") == MATCH_YES)
2266 : {
2267 135 : if (target)
2268 : {
2269 3 : gfc_error ("Duplicate %<target%> at %C");
2270 3 : return MATCH_ERROR;
2271 : }
2272 132 : target = true;
2273 132 : if (gfc_match (", ") == MATCH_YES)
2274 95 : continue;
2275 37 : if (!is_init_clause)
2276 : {
2277 11 : if (gfc_match (") ") == MATCH_YES)
2278 : break;
2279 0 : gfc_error ("Expected %<,%> or %<)%> at %C");
2280 0 : return MATCH_ERROR;
2281 : }
2282 26 : if (gfc_match (": ") == MATCH_YES)
2283 : break;
2284 1 : gfc_error ("Expected %<,%> or %<:%> at %C");
2285 1 : return MATCH_ERROR;
2286 : }
2287 9 : gfc_error ("Expected %<prefer_type%>, %<target%>, or %<targetsync%> "
2288 : "at %C");
2289 9 : return MATCH_ERROR;
2290 : }
2291 : while (true);
2292 :
2293 122 : if (!target && !targetsync)
2294 : {
2295 4 : gfc_error ("Missing required %<target%> and/or %<targetsync%> "
2296 : "modifier at %C");
2297 4 : return MATCH_ERROR;
2298 : }
2299 : return MATCH_YES;
2300 : }
2301 :
2302 : /* Match OpenMP 5.1's 'init' clause for 'interop' objects:
2303 : init([prefer_type(...)][,][<target|targetsync>, ...] :] interop-obj-list) */
2304 :
2305 : static match
2306 108 : gfc_match_omp_init (gfc_omp_namelist **list)
2307 : {
2308 108 : bool target, targetsync;
2309 108 : char *type_str = NULL;
2310 108 : int type_str_len;
2311 108 : if (gfc_parser_omp_clause_init_modifiers (target, targetsync, &type_str,
2312 : type_str_len, true) == MATCH_ERROR)
2313 : return MATCH_ERROR;
2314 :
2315 64 : gfc_omp_namelist **head = NULL;
2316 64 : if (gfc_match_omp_variable_list ("", list, false, NULL, &head) != MATCH_YES)
2317 : return MATCH_ERROR;
2318 147 : for (gfc_omp_namelist *n = *head; n; n = n->next)
2319 : {
2320 84 : n->u.init.target = target;
2321 84 : n->u.init.targetsync = targetsync;
2322 84 : n->u.init.len = type_str_len;
2323 84 : n->u2.init_interop = type_str;
2324 : }
2325 : return MATCH_YES;
2326 : }
2327 :
2328 :
2329 : /* Match with duplicate check. Matches 'name'. If expr != NULL, it
2330 : then matches '(expr)', otherwise, if open_parens is true,
2331 : it matches a ' ( ' after 'name'.
2332 : dupl_message requires '%qs %L' - and is used by
2333 : gfc_match_dupl_memorder and gfc_match_dupl_atomic. */
2334 :
2335 : static match
2336 22380 : gfc_match_dupl_check (bool not_dupl, const char *name, bool open_parens = false,
2337 : gfc_expr **expr = NULL, const char *dupl_msg = NULL)
2338 : {
2339 22380 : match m;
2340 22380 : char c;
2341 22380 : locus old_loc = gfc_current_locus;
2342 22380 : if ((m = gfc_match (name)) != MATCH_YES)
2343 : return m;
2344 : /* Ensure that no partial string is matched. */
2345 17417 : if (gfc_current_form == FORM_FREE
2346 16919 : && gfc_match_eos () != MATCH_YES
2347 30200 : && ((c = gfc_peek_ascii_char ()) == '_' || ISALNUM (c)))
2348 : {
2349 8 : gfc_current_locus = old_loc;
2350 8 : return MATCH_NO;
2351 : }
2352 17409 : if (!not_dupl)
2353 : {
2354 44 : if (dupl_msg)
2355 2 : gfc_error (dupl_msg, name, &old_loc);
2356 : else
2357 42 : gfc_error ("Duplicated %qs clause at %L", name, &old_loc);
2358 44 : return MATCH_ERROR;
2359 : }
2360 17365 : if (open_parens || expr)
2361 : {
2362 9475 : if (gfc_match (" ( ") != MATCH_YES)
2363 : {
2364 22 : gfc_error ("Expected %<(%> after %qs at %C", name);
2365 22 : return MATCH_ERROR;
2366 : }
2367 9453 : if (expr)
2368 : {
2369 4419 : if (gfc_match ("%e )", expr) != MATCH_YES)
2370 : {
2371 9 : gfc_error ("Invalid expression after %<%s(%> at %C", name);
2372 9 : return MATCH_ERROR;
2373 : }
2374 : }
2375 : }
2376 : return MATCH_YES;
2377 : }
2378 :
2379 : static match
2380 211 : gfc_match_dupl_memorder (bool not_dupl, const char *name)
2381 : {
2382 0 : return gfc_match_dupl_check (not_dupl, name, false, NULL,
2383 : "Duplicated memory-order clause: unexpected %s "
2384 0 : "clause at %L");
2385 : }
2386 :
2387 : static match
2388 1175 : gfc_match_dupl_atomic (bool not_dupl, const char *name)
2389 : {
2390 0 : return gfc_match_dupl_check (not_dupl, name, false, NULL,
2391 : "Duplicated atomic clause: unexpected %s "
2392 0 : "clause at %L");
2393 : }
2394 :
2395 :
2396 : /* Search upwards though namespace NS and its parents to find an
2397 : !$omp declare mapper named MAPPER_ID, for typespec TS. */
2398 :
2399 : gfc_omp_udm *
2400 7295 : gfc_find_omp_udm (gfc_namespace *ns, const char *mapper_id, gfc_typespec *ts)
2401 : {
2402 7295 : gfc_symtree *st;
2403 :
2404 7295 : if (ns == NULL)
2405 0 : ns = gfc_current_ns;
2406 :
2407 11371 : do
2408 : {
2409 11371 : gfc_omp_udm *omp_udm;
2410 :
2411 11371 : st = gfc_find_symtree (ns->omp_udm_root, mapper_id);
2412 :
2413 11371 : if (st != NULL)
2414 : {
2415 8 : for (omp_udm = st->n.omp_udm; omp_udm; omp_udm = omp_udm->next)
2416 6 : if (gfc_compare_types (&omp_udm->ts, ts))
2417 : return omp_udm;
2418 : }
2419 :
2420 : /* Don't escape an interface block. */
2421 11367 : if (ns && !ns->has_import_set
2422 11367 : && ns->proc_name && ns->proc_name->attr.if_source == IFSRC_IFBODY)
2423 : break;
2424 :
2425 11367 : ns = ns->parent;
2426 : }
2427 11367 : while (ns != NULL);
2428 :
2429 : return NULL;
2430 : }
2431 :
2432 :
2433 : /* Match OpenMP and OpenACC directive clauses. MASK is a bitmask of
2434 : clauses that are allowed for a particular directive. */
2435 :
2436 : static match
2437 34401 : gfc_match_omp_clauses (gfc_omp_clauses **cp, const omp_mask mask,
2438 : bool first = true, bool needs_space = true,
2439 : bool openacc = false, bool openmp_target = false,
2440 : gfc_omp_map_op default_map_op = OMP_MAP_TOFROM)
2441 : {
2442 34401 : bool error = false;
2443 34401 : gfc_omp_clauses *c = gfc_get_omp_clauses ();
2444 34401 : locus old_loc;
2445 : /* Determine whether we're dealing with an OpenACC directive that permits
2446 : derived type member accesses. This in particular disallows
2447 : "!$acc declare" from using such accesses, because it's not clear if/how
2448 : that should work. */
2449 34401 : bool allow_derived = (openacc
2450 34401 : && ((mask & OMP_CLAUSE_ATTACH)
2451 5933 : || (mask & OMP_CLAUSE_DETACH)));
2452 :
2453 34401 : gcc_checking_assert (OMP_MASK1_LAST <= 64 && OMP_MASK2_LAST <= 64);
2454 34401 : *cp = NULL;
2455 126543 : while (1)
2456 : {
2457 80472 : match m = MATCH_NO;
2458 59841 : if ((first || (m = gfc_match_char (',')) != MATCH_YES)
2459 139957 : && (needs_space && gfc_match_space () != MATCH_YES))
2460 : break;
2461 75912 : needs_space = false;
2462 75912 : first = false;
2463 75912 : gfc_gobble_whitespace ();
2464 75912 : bool end_colon;
2465 75912 : gfc_omp_namelist **head;
2466 75912 : old_loc = gfc_current_locus;
2467 75912 : char pc = gfc_peek_ascii_char ();
2468 75912 : if (pc == '\n' && m == MATCH_YES)
2469 : {
2470 1 : gfc_error ("Clause expected at %C after trailing comma");
2471 1 : goto error;
2472 : }
2473 75911 : switch (pc)
2474 : {
2475 1312 : case 'a':
2476 1312 : end_colon = false;
2477 1312 : head = NULL;
2478 1336 : if ((mask & OMP_CLAUSE_ASSUMPTIONS)
2479 1312 : && gfc_match ("absent ( ") == MATCH_YES)
2480 : {
2481 27 : if (gfc_omp_absent_contains_clause (&c->assume, true)
2482 : != MATCH_YES)
2483 3 : goto error;
2484 24 : continue;
2485 : }
2486 1285 : if ((mask & OMP_CLAUSE_ALIGNED)
2487 1285 : && gfc_match_omp_variable_list ("aligned (",
2488 : &c->lists[OMP_LIST_ALIGNED],
2489 : false, &end_colon,
2490 : &head) == MATCH_YES)
2491 : {
2492 112 : gfc_expr *alignment = NULL;
2493 112 : gfc_omp_namelist *n;
2494 :
2495 112 : if (end_colon && gfc_match (" %e )", &alignment) != MATCH_YES)
2496 : {
2497 0 : gfc_free_omp_namelist (*head, OMP_LIST_ALIGNED);
2498 0 : gfc_current_locus = old_loc;
2499 0 : *head = NULL;
2500 0 : break;
2501 : }
2502 268 : for (n = *head; n; n = n->next)
2503 156 : if (n->next && alignment)
2504 42 : n->expr = gfc_copy_expr (alignment);
2505 : else
2506 114 : n->expr = alignment;
2507 112 : continue;
2508 112 : }
2509 1183 : if ((mask & OMP_CLAUSE_MEMORDER)
2510 1190 : && (m = gfc_match_dupl_memorder ((c->memorder
2511 17 : == OMP_MEMORDER_UNSET),
2512 : "acq_rel")) != MATCH_NO)
2513 : {
2514 10 : if (m == MATCH_ERROR)
2515 0 : goto error;
2516 10 : c->memorder = OMP_MEMORDER_ACQ_REL;
2517 10 : continue;
2518 : }
2519 1170 : if ((mask & OMP_CLAUSE_MEMORDER)
2520 1170 : && (m = gfc_match_dupl_memorder ((c->memorder
2521 7 : == OMP_MEMORDER_UNSET),
2522 : "acquire")) != MATCH_NO)
2523 : {
2524 7 : if (m == MATCH_ERROR)
2525 0 : goto error;
2526 7 : c->memorder = OMP_MEMORDER_ACQUIRE;
2527 7 : continue;
2528 : }
2529 1156 : if ((mask & OMP_CLAUSE_AFFINITY)
2530 1156 : && gfc_match ("affinity ( ") == MATCH_YES)
2531 : {
2532 41 : gfc_namespace *ns_iter = NULL, *ns_curr = gfc_current_ns;
2533 41 : m = gfc_match_iterator (&ns_iter, true);
2534 41 : if (m == MATCH_ERROR)
2535 : break;
2536 31 : if (m == MATCH_YES && gfc_match (" : ") != MATCH_YES)
2537 : {
2538 1 : gfc_error ("Expected %<:%> at %C");
2539 1 : break;
2540 : }
2541 30 : if (ns_iter)
2542 18 : gfc_current_ns = ns_iter;
2543 30 : head = NULL;
2544 30 : m = gfc_match_omp_variable_list ("", &c->lists[OMP_LIST_AFFINITY],
2545 : false, NULL, &head, true);
2546 30 : gfc_current_ns = ns_curr;
2547 30 : if (m == MATCH_ERROR)
2548 : break;
2549 27 : if (ns_iter)
2550 : {
2551 45 : for (gfc_omp_namelist *n = *head; n; n = n->next)
2552 : {
2553 27 : n->u2.ns = ns_iter;
2554 27 : ns_iter->refs++;
2555 : }
2556 : }
2557 27 : continue;
2558 27 : }
2559 1115 : if ((mask & OMP_CLAUSE_ALLOCATE)
2560 1115 : && gfc_match ("allocate ( ") == MATCH_YES)
2561 : {
2562 279 : gfc_expr *allocator = NULL;
2563 279 : gfc_expr *align = NULL;
2564 279 : old_loc = gfc_current_locus;
2565 279 : if ((m = gfc_match ("allocator ( %e )", &allocator)) == MATCH_YES)
2566 50 : gfc_match (" , align ( %e )", &align);
2567 229 : else if ((m = gfc_match ("align ( %e )", &align)) == MATCH_YES)
2568 29 : gfc_match (" , allocator ( %e )", &allocator);
2569 :
2570 279 : if (m == MATCH_YES)
2571 : {
2572 79 : if (gfc_match (" : ") != MATCH_YES)
2573 : {
2574 5 : gfc_error ("Expected %<:%> at %C");
2575 8 : goto error;
2576 : }
2577 : }
2578 : else
2579 : {
2580 200 : m = gfc_match_expr (&allocator);
2581 200 : if (m == MATCH_YES && gfc_match (" : ") != MATCH_YES)
2582 : {
2583 : /* If no ":" then there is no allocator, we backtrack
2584 : and read the variable list. */
2585 101 : gfc_free_expr (allocator);
2586 101 : allocator = NULL;
2587 101 : gfc_current_locus = old_loc;
2588 : }
2589 : }
2590 274 : gfc_omp_namelist **head = NULL;
2591 274 : m = gfc_match_omp_variable_list ("", &c->lists[OMP_LIST_ALLOCATE],
2592 : true, NULL, &head);
2593 :
2594 274 : if (m != MATCH_YES)
2595 : {
2596 3 : gfc_free_expr (allocator);
2597 3 : gfc_free_expr (align);
2598 3 : gfc_error ("Expected variable list at %C");
2599 3 : goto error;
2600 : }
2601 :
2602 725 : for (gfc_omp_namelist *n = *head; n; n = n->next)
2603 : {
2604 454 : n->u2.allocator = allocator;
2605 454 : n->u.align = (align) ? gfc_copy_expr (align) : NULL;
2606 : }
2607 271 : gfc_free_expr (align);
2608 271 : continue;
2609 271 : }
2610 896 : if ((mask & OMP_CLAUSE_AT)
2611 836 : && (m = gfc_match_dupl_check (c->at == OMP_AT_UNSET, "at", true))
2612 : != MATCH_NO)
2613 : {
2614 66 : if (m == MATCH_ERROR)
2615 2 : goto error;
2616 64 : if (gfc_match ("compilation )") == MATCH_YES)
2617 15 : c->at = OMP_AT_COMPILATION;
2618 49 : else if (gfc_match ("execution )") == MATCH_YES)
2619 45 : c->at = OMP_AT_EXECUTION;
2620 : else
2621 : {
2622 4 : gfc_error ("Expected COMPILATION or EXECUTION in AT clause "
2623 : "at %C");
2624 4 : goto error;
2625 : }
2626 60 : continue;
2627 : }
2628 1413 : if ((mask & OMP_CLAUSE_ASYNC)
2629 770 : && (m = gfc_match_dupl_check (!c->async, "async")) != MATCH_NO)
2630 : {
2631 643 : if (m == MATCH_ERROR)
2632 0 : goto error;
2633 643 : c->async = true;
2634 643 : m = gfc_match (" ( %e )", &c->async_expr);
2635 643 : if (m == MATCH_ERROR)
2636 : {
2637 0 : gfc_current_locus = old_loc;
2638 0 : break;
2639 : }
2640 643 : else if (m == MATCH_NO)
2641 : {
2642 133 : c->async_expr
2643 133 : = gfc_get_constant_expr (BT_INTEGER,
2644 : gfc_default_integer_kind,
2645 : &gfc_current_locus);
2646 133 : mpz_set_si (c->async_expr->value.integer, GOMP_ASYNC_NOVAL);
2647 : }
2648 643 : continue;
2649 : }
2650 190 : if ((mask & OMP_CLAUSE_AUTO)
2651 127 : && (m = gfc_match_dupl_check (!c->par_auto, "auto"))
2652 : != MATCH_NO)
2653 : {
2654 63 : if (m == MATCH_ERROR)
2655 0 : goto error;
2656 63 : c->par_auto = true;
2657 63 : continue;
2658 : }
2659 125 : if ((mask & OMP_CLAUSE_ATTACH)
2660 62 : && gfc_match ("attach ( ") == MATCH_YES
2661 125 : && gfc_match_omp_map_clause (&c->lists[OMP_LIST_MAP],
2662 : OMP_MAP_ATTACH, false,
2663 : allow_derived))
2664 61 : continue;
2665 : break;
2666 36 : case 'b':
2667 70 : if ((mask & OMP_CLAUSE_BIND)
2668 36 : && (m = gfc_match_dupl_check (c->bind == OMP_BIND_UNSET, "bind",
2669 : true)) != MATCH_NO)
2670 : {
2671 36 : if (m == MATCH_ERROR)
2672 1 : goto error;
2673 35 : if (gfc_match ("teams )") == MATCH_YES)
2674 11 : c->bind = OMP_BIND_TEAMS;
2675 24 : else if (gfc_match ("parallel )") == MATCH_YES)
2676 15 : c->bind = OMP_BIND_PARALLEL;
2677 9 : else if (gfc_match ("thread )") == MATCH_YES)
2678 8 : c->bind = OMP_BIND_THREAD;
2679 : else
2680 : {
2681 1 : gfc_error ("Expected TEAMS, PARALLEL or THREAD as binding in "
2682 : "BIND at %C");
2683 1 : break;
2684 : }
2685 34 : continue;
2686 : }
2687 : break;
2688 7110 : case 'c':
2689 7383 : if ((mask & OMP_CLAUSE_CAPTURE)
2690 7110 : && (m = gfc_match_dupl_check (!c->capture, "capture"))
2691 : != MATCH_NO)
2692 : {
2693 274 : if (m == MATCH_ERROR)
2694 1 : goto error;
2695 273 : c->capture = true;
2696 273 : continue;
2697 : }
2698 6836 : if (mask & OMP_CLAUSE_COLLAPSE)
2699 : {
2700 1996 : gfc_expr *cexpr = NULL;
2701 1996 : if ((m = gfc_match_dupl_check (!c->collapse, "collapse", true,
2702 : &cexpr)) != MATCH_NO)
2703 : {
2704 1506 : int collapse;
2705 1506 : if (m == MATCH_ERROR)
2706 0 : goto error;
2707 1506 : if (gfc_extract_int (cexpr, &collapse, -1))
2708 4 : collapse = 1;
2709 1502 : else if (collapse <= 0)
2710 : {
2711 8 : gfc_error_now ("COLLAPSE clause argument not constant "
2712 : "positive integer at %C");
2713 8 : collapse = 1;
2714 : }
2715 1506 : gfc_free_expr (cexpr);
2716 1506 : c->collapse = collapse;
2717 1506 : continue;
2718 1506 : }
2719 : }
2720 5496 : if ((mask & OMP_CLAUSE_COMPARE)
2721 5330 : && (m = gfc_match_dupl_check (!c->compare, "compare"))
2722 : != MATCH_NO)
2723 : {
2724 167 : if (m == MATCH_ERROR)
2725 1 : goto error;
2726 166 : c->compare = true;
2727 166 : continue;
2728 : }
2729 5175 : if ((mask & OMP_CLAUSE_ASSUMPTIONS)
2730 5163 : && gfc_match ("contains ( ") == MATCH_YES)
2731 : {
2732 13 : if (gfc_omp_absent_contains_clause (&c->assume, false)
2733 : != MATCH_YES)
2734 1 : goto error;
2735 12 : continue;
2736 : }
2737 7266 : if ((mask & OMP_CLAUSE_COPY)
2738 3723 : && gfc_match ("copy ( ") == MATCH_YES
2739 7267 : && gfc_match_omp_map_clause (&c->lists[OMP_LIST_MAP],
2740 : OMP_MAP_TOFROM, true,
2741 : allow_derived))
2742 2116 : continue;
2743 3034 : if (mask & OMP_CLAUSE_COPYIN)
2744 : {
2745 2628 : if (openacc)
2746 : {
2747 2529 : if (gfc_match ("copyin ( ") == MATCH_YES)
2748 : {
2749 1458 : bool readonly = gfc_match ("readonly : ") == MATCH_YES;
2750 1458 : head = NULL;
2751 1458 : if (gfc_match_omp_variable_list ("",
2752 : &c->lists[OMP_LIST_MAP],
2753 : true, NULL, &head, true,
2754 : allow_derived)
2755 : == MATCH_YES)
2756 : {
2757 1452 : gfc_omp_namelist *n;
2758 3349 : for (n = *head; n; n = n->next)
2759 : {
2760 1897 : n->u.map.op = OMP_MAP_TO;
2761 1897 : n->u.map.readonly = readonly;
2762 : }
2763 1452 : continue;
2764 1452 : }
2765 : }
2766 : }
2767 99 : else if (gfc_match_omp_variable_list ("copyin (",
2768 : &c->lists[OMP_LIST_COPYIN],
2769 : true) == MATCH_YES)
2770 97 : continue;
2771 : }
2772 2556 : if ((mask & OMP_CLAUSE_COPYOUT)
2773 1216 : && gfc_match ("copyout ( ") == MATCH_YES
2774 2556 : && gfc_match_omp_map_clause (&c->lists[OMP_LIST_MAP],
2775 : OMP_MAP_FROM, true, allow_derived))
2776 1071 : continue;
2777 498 : if ((mask & OMP_CLAUSE_COPYPRIVATE)
2778 414 : && gfc_match_omp_variable_list ("copyprivate (",
2779 : &c->lists[OMP_LIST_COPYPRIVATE],
2780 : true) == MATCH_YES)
2781 84 : continue;
2782 651 : if ((mask & OMP_CLAUSE_CREATE)
2783 328 : && gfc_match ("create ( ") == MATCH_YES
2784 651 : && gfc_match_omp_map_clause (&c->lists[OMP_LIST_MAP],
2785 : OMP_MAP_ALLOC, true, allow_derived))
2786 321 : continue;
2787 : break;
2788 3739 : case 'd':
2789 3739 : if ((mask & OMP_CLAUSE_DEFAULTMAP)
2790 3739 : && gfc_match ("defaultmap ( ") == MATCH_YES)
2791 : {
2792 180 : enum gfc_omp_defaultmap behavior;
2793 180 : gfc_omp_defaultmap_category category
2794 : = OMP_DEFAULTMAP_CAT_UNCATEGORIZED;
2795 180 : if (gfc_match ("alloc ") == MATCH_YES)
2796 : behavior = OMP_DEFAULTMAP_ALLOC;
2797 174 : else if (gfc_match ("tofrom ") == MATCH_YES)
2798 : behavior = OMP_DEFAULTMAP_TOFROM;
2799 142 : else if (gfc_match ("to ") == MATCH_YES)
2800 : behavior = OMP_DEFAULTMAP_TO;
2801 132 : else if (gfc_match ("from ") == MATCH_YES)
2802 : behavior = OMP_DEFAULTMAP_FROM;
2803 129 : else if (gfc_match ("firstprivate ") == MATCH_YES)
2804 : behavior = OMP_DEFAULTMAP_FIRSTPRIVATE;
2805 94 : else if (gfc_match ("present ") == MATCH_YES)
2806 : behavior = OMP_DEFAULTMAP_PRESENT;
2807 90 : else if (gfc_match ("none ") == MATCH_YES)
2808 : behavior = OMP_DEFAULTMAP_NONE;
2809 10 : else if (gfc_match ("default ") == MATCH_YES)
2810 : behavior = OMP_DEFAULTMAP_DEFAULT;
2811 : else
2812 : {
2813 1 : gfc_error ("Expected ALLOC, TO, FROM, TOFROM, FIRSTPRIVATE, "
2814 : "PRESENT, NONE or DEFAULT at %C");
2815 1 : break;
2816 : }
2817 179 : if (')' == gfc_peek_ascii_char ())
2818 : ;
2819 102 : else if (gfc_match (": ") != MATCH_YES)
2820 : break;
2821 : else
2822 : {
2823 102 : if (gfc_match ("scalar ") == MATCH_YES)
2824 : category = OMP_DEFAULTMAP_CAT_SCALAR;
2825 67 : else if (gfc_match ("aggregate ") == MATCH_YES)
2826 : category = OMP_DEFAULTMAP_CAT_AGGREGATE;
2827 43 : else if (gfc_match ("allocatable ") == MATCH_YES)
2828 : category = OMP_DEFAULTMAP_CAT_ALLOCATABLE;
2829 31 : else if (gfc_match ("pointer ") == MATCH_YES)
2830 : category = OMP_DEFAULTMAP_CAT_POINTER;
2831 14 : else if (gfc_match ("all ") == MATCH_YES)
2832 : category = OMP_DEFAULTMAP_CAT_ALL;
2833 : else
2834 : {
2835 1 : gfc_error ("Expected SCALAR, AGGREGATE, ALLOCATABLE, "
2836 : "POINTER or ALL at %C");
2837 1 : break;
2838 : }
2839 : }
2840 1193 : for (int i = 0; i < OMP_DEFAULTMAP_CAT_NUM; ++i)
2841 : {
2842 1028 : if (i != category
2843 1028 : && category != OMP_DEFAULTMAP_CAT_UNCATEGORIZED
2844 486 : && category != OMP_DEFAULTMAP_CAT_ALL
2845 486 : && i != OMP_DEFAULTMAP_CAT_UNCATEGORIZED
2846 341 : && i != OMP_DEFAULTMAP_CAT_ALL)
2847 254 : continue;
2848 774 : if (c->defaultmap[i] != OMP_DEFAULTMAP_UNSET)
2849 : {
2850 13 : const char *pcategory = NULL;
2851 13 : switch (i)
2852 : {
2853 : case OMP_DEFAULTMAP_CAT_UNCATEGORIZED: break;
2854 : case OMP_DEFAULTMAP_CAT_ALL: pcategory = "ALL"; break;
2855 1 : case OMP_DEFAULTMAP_CAT_SCALAR: pcategory = "SCALAR"; break;
2856 2 : case OMP_DEFAULTMAP_CAT_AGGREGATE:
2857 2 : pcategory = "AGGREGATE";
2858 2 : break;
2859 1 : case OMP_DEFAULTMAP_CAT_ALLOCATABLE:
2860 1 : pcategory = "ALLOCATABLE";
2861 1 : break;
2862 2 : case OMP_DEFAULTMAP_CAT_POINTER:
2863 2 : pcategory = "POINTER";
2864 2 : break;
2865 : default: gcc_unreachable ();
2866 : }
2867 6 : if (i == OMP_DEFAULTMAP_CAT_UNCATEGORIZED)
2868 4 : gfc_error ("DEFAULTMAP at %C but prior DEFAULTMAP with "
2869 : "unspecified category");
2870 : else
2871 9 : gfc_error ("DEFAULTMAP at %C but prior DEFAULTMAP for "
2872 : "category %s", pcategory);
2873 13 : goto error;
2874 : }
2875 : }
2876 165 : c->defaultmap[category] = behavior;
2877 165 : if (gfc_match (")") != MATCH_YES)
2878 : break;
2879 165 : continue;
2880 165 : }
2881 4526 : if ((mask & OMP_CLAUSE_DEFAULT)
2882 3559 : && (m = gfc_match_dupl_check (c->default_sharing
2883 : == OMP_DEFAULT_UNKNOWN, "default",
2884 : true)) != MATCH_NO)
2885 : {
2886 1012 : if (m == MATCH_ERROR)
2887 6 : goto error;
2888 1006 : if (gfc_match ("none") == MATCH_YES)
2889 596 : c->default_sharing = OMP_DEFAULT_NONE;
2890 410 : else if (openacc)
2891 : {
2892 225 : if (gfc_match ("present") == MATCH_YES)
2893 195 : c->default_sharing = OMP_DEFAULT_PRESENT;
2894 : }
2895 : else
2896 : {
2897 185 : if (gfc_match ("firstprivate") == MATCH_YES)
2898 8 : c->default_sharing = OMP_DEFAULT_FIRSTPRIVATE;
2899 177 : else if (gfc_match ("private") == MATCH_YES)
2900 24 : c->default_sharing = OMP_DEFAULT_PRIVATE;
2901 153 : else if (gfc_match ("shared") == MATCH_YES)
2902 153 : c->default_sharing = OMP_DEFAULT_SHARED;
2903 : }
2904 1006 : if (c->default_sharing == OMP_DEFAULT_UNKNOWN)
2905 : {
2906 30 : if (openacc)
2907 30 : gfc_error ("Expected NONE or PRESENT in DEFAULT clause "
2908 : "at %C");
2909 : else
2910 0 : gfc_error ("Expected NONE, FIRSTPRIVATE, PRIVATE or SHARED "
2911 : "in DEFAULT clause at %C");
2912 30 : goto error;
2913 : }
2914 976 : if (gfc_match (" )") != MATCH_YES)
2915 9 : goto error;
2916 967 : continue;
2917 : }
2918 2855 : if ((mask & OMP_CLAUSE_DELETE)
2919 345 : && gfc_match ("delete ( ") == MATCH_YES
2920 2855 : && gfc_match_omp_map_clause (&c->lists[OMP_LIST_MAP],
2921 : OMP_MAP_RELEASE, true,
2922 : allow_derived))
2923 308 : continue;
2924 : /* DOACROSS: match 'doacross' and 'depend' with sink/source.
2925 : DEPEND: match 'depend' but not sink/source. */
2926 2239 : m = MATCH_NO;
2927 2239 : if (((mask & OMP_CLAUSE_DOACROSS)
2928 383 : && gfc_match ("doacross ( ") == MATCH_YES)
2929 2595 : || (((mask & OMP_CLAUSE_DEPEND) || (mask & OMP_CLAUSE_DOACROSS))
2930 1598 : && (m = gfc_match ("depend ( ")) == MATCH_YES))
2931 : {
2932 1100 : bool has_omp_all_memory;
2933 1100 : bool is_depend = m == MATCH_YES;
2934 1100 : gfc_namespace *ns_iter = NULL, *ns_curr = gfc_current_ns;
2935 1100 : match m_it = MATCH_NO;
2936 1100 : if (is_depend)
2937 1073 : m_it = gfc_match_iterator (&ns_iter, false);
2938 1073 : if (m_it == MATCH_ERROR)
2939 : break;
2940 1095 : if (m_it == MATCH_YES && gfc_match (" , ") != MATCH_YES)
2941 : break;
2942 1095 : m = MATCH_YES;
2943 1095 : gfc_omp_depend_doacross_op depend_op = OMP_DEPEND_OUT;
2944 1095 : if (gfc_match ("inoutset") == MATCH_YES)
2945 : depend_op = OMP_DEPEND_INOUTSET;
2946 1083 : else if (gfc_match ("inout") == MATCH_YES)
2947 : depend_op = OMP_DEPEND_INOUT;
2948 991 : else if (gfc_match ("in") == MATCH_YES)
2949 : depend_op = OMP_DEPEND_IN;
2950 704 : else if (gfc_match ("out") == MATCH_YES)
2951 : depend_op = OMP_DEPEND_OUT;
2952 442 : else if (gfc_match ("mutexinoutset") == MATCH_YES)
2953 : depend_op = OMP_DEPEND_MUTEXINOUTSET;
2954 424 : else if (gfc_match ("depobj") == MATCH_YES)
2955 : depend_op = OMP_DEPEND_DEPOBJ;
2956 387 : else if (gfc_match ("source") == MATCH_YES)
2957 : {
2958 143 : if (m_it == MATCH_YES)
2959 : {
2960 1 : gfc_error ("ITERATOR may not be combined with SOURCE "
2961 : "at %C");
2962 17 : goto error;
2963 : }
2964 142 : if (!(mask & OMP_CLAUSE_DOACROSS))
2965 : {
2966 1 : gfc_error ("SOURCE at %C not permitted as dependence-type"
2967 : " for this directive");
2968 1 : goto error;
2969 : }
2970 141 : if (c->doacross_source)
2971 : {
2972 0 : gfc_error ("Duplicated clause with SOURCE dependence-type"
2973 : " at %C");
2974 0 : goto error;
2975 : }
2976 141 : gfc_gobble_whitespace ();
2977 141 : m = gfc_match (": ");
2978 141 : if (m != MATCH_YES && !is_depend)
2979 : {
2980 1 : gfc_error ("Expected %<:%> at %C");
2981 1 : goto error;
2982 : }
2983 140 : if (gfc_match (")") != MATCH_YES
2984 146 : && !(m == MATCH_YES
2985 6 : && gfc_match ("omp_cur_iteration )") == MATCH_YES))
2986 : {
2987 2 : gfc_error ("Expected %<)%> or %<omp_cur_iteration)%> "
2988 : "at %C");
2989 2 : goto error;
2990 : }
2991 138 : if (is_depend)
2992 130 : gfc_warning (OPT_Wdeprecated_openmp,
2993 : "%<source%> modifier with %<depend%> clause "
2994 : "at %L deprecated since OpenMP 5.2, use with "
2995 : "%<doacross%>", &old_loc);
2996 138 : c->doacross_source = true;
2997 138 : c->depend_source = is_depend;
2998 1078 : continue;
2999 : }
3000 244 : else if (gfc_match ("sink ") == MATCH_YES)
3001 : {
3002 244 : if (!(mask & OMP_CLAUSE_DOACROSS))
3003 : {
3004 2 : gfc_error ("SINK at %C not permitted as dependence-type "
3005 : "for this directive");
3006 2 : goto error;
3007 : }
3008 242 : if (gfc_match (": ") != MATCH_YES)
3009 : {
3010 1 : gfc_error ("Expected %<:%> at %C");
3011 1 : goto error;
3012 : }
3013 241 : if (m_it == MATCH_YES)
3014 : {
3015 0 : gfc_error ("ITERATOR may not be combined with SINK "
3016 : "at %C");
3017 0 : goto error;
3018 : }
3019 241 : if (is_depend)
3020 226 : gfc_warning (OPT_Wdeprecated_openmp,
3021 : "%<sink%> modifier with %<depend%> clause at "
3022 : "%L deprecated since OpenMP 5.2, use with "
3023 : "%<doacross%>", &old_loc);
3024 241 : m = gfc_match_omp_doacross_sink (&c->lists[OMP_LIST_DEPEND],
3025 : is_depend);
3026 241 : if (m == MATCH_YES)
3027 238 : continue;
3028 3 : goto error;
3029 : }
3030 : else
3031 : m = MATCH_NO;
3032 708 : if (!(mask & OMP_CLAUSE_DEPEND))
3033 : {
3034 0 : gfc_error ("Expected dependence-type SINK or SOURCE at %C");
3035 0 : goto error;
3036 : }
3037 708 : head = NULL;
3038 708 : if (ns_iter)
3039 40 : gfc_current_ns = ns_iter;
3040 708 : if (m == MATCH_YES)
3041 708 : m = gfc_match_omp_variable_list (" : ",
3042 : &c->lists[OMP_LIST_DEPEND],
3043 : false, NULL, &head, true,
3044 : false, &has_omp_all_memory);
3045 708 : if (m != MATCH_YES)
3046 2 : goto error;
3047 706 : gfc_current_ns = ns_curr;
3048 706 : if (has_omp_all_memory && depend_op != OMP_DEPEND_INOUT
3049 21 : && depend_op != OMP_DEPEND_OUT)
3050 : {
3051 4 : gfc_error ("%<omp_all_memory%> used with DEPEND kind "
3052 : "other than OUT or INOUT at %C");
3053 4 : goto error;
3054 : }
3055 702 : gfc_omp_namelist *n;
3056 1435 : for (n = *head; n; n = n->next)
3057 : {
3058 733 : n->u.depend_doacross_op = depend_op;
3059 733 : n->u2.ns = ns_iter;
3060 733 : if (ns_iter)
3061 39 : ns_iter->refs++;
3062 : }
3063 702 : continue;
3064 702 : }
3065 1160 : if ((mask & OMP_CLAUSE_DESTROY)
3066 1139 : && gfc_match_omp_variable_list ("destroy (",
3067 : &c->lists[OMP_LIST_DESTROY],
3068 : true) == MATCH_YES)
3069 21 : continue;
3070 1244 : if ((mask & OMP_CLAUSE_DETACH)
3071 164 : && !openacc
3072 127 : && !c->detach
3073 1244 : && gfc_match_omp_detach (&c->detach) == MATCH_YES)
3074 126 : continue;
3075 1029 : if ((mask & OMP_CLAUSE_DETACH)
3076 38 : && openacc
3077 37 : && gfc_match ("detach ( ") == MATCH_YES
3078 1029 : && gfc_match_omp_map_clause (&c->lists[OMP_LIST_MAP],
3079 : OMP_MAP_DETACH, false,
3080 : allow_derived))
3081 37 : continue;
3082 991 : if ((mask & OMP_CLAUSE_DEVICEPTR)
3083 87 : && gfc_match ("deviceptr ( ") == MATCH_YES
3084 993 : && gfc_match_omp_map_clause (&c->lists[OMP_LIST_MAP],
3085 : OMP_MAP_FORCE_DEVICEPTR, false,
3086 : allow_derived))
3087 36 : continue;
3088 1010 : if ((mask & OMP_CLAUSE_DEVICE_TYPE)
3089 919 : && gfc_match_dupl_check (c->device_type == OMP_DEVICE_TYPE_UNSET,
3090 : "device_type", true) == MATCH_YES)
3091 : {
3092 92 : if (gfc_match ("host") == MATCH_YES)
3093 32 : c->device_type = OMP_DEVICE_TYPE_HOST;
3094 60 : else if (gfc_match ("nohost") == MATCH_YES)
3095 21 : c->device_type = OMP_DEVICE_TYPE_NOHOST;
3096 39 : else if (gfc_match ("any") == MATCH_YES)
3097 38 : c->device_type = OMP_DEVICE_TYPE_ANY;
3098 : else
3099 : {
3100 1 : gfc_error ("Expected HOST, NOHOST or ANY at %C");
3101 1 : break;
3102 : }
3103 91 : if (gfc_match (" )") != MATCH_YES)
3104 : break;
3105 91 : continue;
3106 : }
3107 875 : if ((mask & OMP_CLAUSE_DEVICE_RESIDENT)
3108 876 : && gfc_match_omp_variable_list
3109 49 : ("device_resident (",
3110 : &c->lists[OMP_LIST_DEVICE_RESIDENT], true) == MATCH_YES)
3111 48 : continue;
3112 1091 : if ((mask & OMP_CLAUSE_DEVICE)
3113 703 : && openacc
3114 314 : && gfc_match ("device ( ") == MATCH_YES
3115 1092 : && gfc_match_omp_map_clause (&c->lists[OMP_LIST_MAP],
3116 : OMP_MAP_FORCE_TO, true,
3117 : /* allow_derived = */ true))
3118 312 : continue;
3119 467 : if ((mask & OMP_CLAUSE_DEVICE)
3120 391 : && !openacc
3121 856 : && ((m = gfc_match_dupl_check (!c->device, "device", true))
3122 : != MATCH_NO))
3123 : {
3124 349 : if (m == MATCH_ERROR)
3125 0 : goto error;
3126 349 : c->ancestor = false;
3127 349 : if (gfc_match ("device_num : ") == MATCH_YES)
3128 : {
3129 18 : if (gfc_match ("%e )", &c->device) != MATCH_YES)
3130 : {
3131 1 : gfc_error ("Expected integer expression at %C");
3132 1 : break;
3133 : }
3134 : }
3135 331 : else if (gfc_match ("ancestor : ") == MATCH_YES)
3136 : {
3137 45 : bool has_requires = false;
3138 45 : c->ancestor = true;
3139 82 : for (gfc_namespace *ns = gfc_current_ns; ns; ns = ns->parent)
3140 80 : if (ns->omp_requires & OMP_REQ_REVERSE_OFFLOAD)
3141 : {
3142 : has_requires = true;
3143 : break;
3144 : }
3145 45 : if (!has_requires)
3146 : {
3147 2 : gfc_error ("%<ancestor%> device modifier not "
3148 : "preceded by %<requires%> directive "
3149 : "with %<reverse_offload%> clause at %C");
3150 5 : break;
3151 : }
3152 43 : locus old_loc2 = gfc_current_locus;
3153 43 : if (gfc_match ("%e )", &c->device) == MATCH_YES)
3154 : {
3155 43 : int device = 0;
3156 43 : if (!gfc_extract_int (c->device, &device) && device != 1)
3157 : {
3158 1 : gfc_current_locus = old_loc2;
3159 1 : gfc_error ("the %<device%> clause expression must "
3160 : "evaluate to %<1%> at %C");
3161 1 : break;
3162 : }
3163 : }
3164 : else
3165 : {
3166 0 : gfc_error ("Expected integer expression at %C");
3167 0 : break;
3168 : }
3169 : }
3170 286 : else if (gfc_match ("%e )", &c->device) != MATCH_YES)
3171 : {
3172 13 : gfc_error ("Expected integer expression or a single device-"
3173 : "modifier %<device_num%> or %<ancestor%> at %C");
3174 13 : break;
3175 : }
3176 332 : continue;
3177 332 : }
3178 118 : if ((mask & OMP_CLAUSE_DIST_SCHEDULE)
3179 97 : && c->dist_sched_kind == OMP_SCHED_NONE
3180 215 : && gfc_match ("dist_schedule ( static") == MATCH_YES)
3181 : {
3182 97 : m = MATCH_NO;
3183 97 : c->dist_sched_kind = OMP_SCHED_STATIC;
3184 97 : m = gfc_match (" , %e )", &c->dist_chunk_size);
3185 97 : if (m != MATCH_YES)
3186 14 : m = gfc_match_char (')');
3187 14 : if (m != MATCH_YES)
3188 : {
3189 0 : c->dist_sched_kind = OMP_SCHED_NONE;
3190 0 : gfc_current_locus = old_loc;
3191 : }
3192 : else
3193 97 : continue;
3194 : }
3195 32 : if ((mask & OMP_CLAUSE_DYN_GROUPPRIVATE)
3196 21 : && gfc_match_dupl_check (!c->dyn_groupprivate,
3197 : "dyn_groupprivate", true) == MATCH_YES)
3198 : {
3199 12 : if (gfc_match ("fallback ( abort ) : ") == MATCH_YES)
3200 1 : c->fallback = OMP_FALLBACK_ABORT;
3201 11 : else if (gfc_match ("fallback ( default_mem ) : ") == MATCH_YES)
3202 1 : c->fallback = OMP_FALLBACK_DEFAULT_MEM;
3203 10 : else if (gfc_match ("fallback ( null ) : ") == MATCH_YES)
3204 1 : c->fallback = OMP_FALLBACK_NULL;
3205 12 : if (gfc_match_expr (&c->dyn_groupprivate) != MATCH_YES)
3206 0 : return MATCH_ERROR;
3207 12 : if (gfc_match (" )") != MATCH_YES)
3208 1 : goto error;
3209 11 : continue;
3210 : }
3211 : break;
3212 90 : case 'e':
3213 90 : if ((mask & OMP_CLAUSE_ENTER))
3214 : {
3215 90 : m = gfc_match_omp_to_link ("enter (", &c->lists[OMP_LIST_ENTER]);
3216 90 : if (m == MATCH_ERROR)
3217 0 : goto error;
3218 90 : if (m == MATCH_YES)
3219 90 : continue;
3220 : }
3221 : break;
3222 2283 : case 'f':
3223 2332 : if ((mask & OMP_CLAUSE_FAIL)
3224 2283 : && (m = gfc_match_dupl_check (c->fail == OMP_MEMORDER_UNSET,
3225 : "fail", true)) != MATCH_NO)
3226 : {
3227 58 : if (m == MATCH_ERROR)
3228 3 : goto error;
3229 55 : if (gfc_match ("seq_cst") == MATCH_YES)
3230 6 : c->fail = OMP_MEMORDER_SEQ_CST;
3231 49 : else if (gfc_match ("acquire") == MATCH_YES)
3232 14 : c->fail = OMP_MEMORDER_ACQUIRE;
3233 35 : else if (gfc_match ("relaxed") == MATCH_YES)
3234 30 : c->fail = OMP_MEMORDER_RELAXED;
3235 : else
3236 : {
3237 5 : gfc_error ("Expected SEQ_CST, ACQUIRE or RELAXED at %C");
3238 5 : break;
3239 : }
3240 50 : if (gfc_match (" )") != MATCH_YES)
3241 1 : goto error;
3242 49 : continue;
3243 : }
3244 2268 : if ((mask & OMP_CLAUSE_FILTER)
3245 2225 : && (m = gfc_match_dupl_check (!c->filter, "filter", true,
3246 : &c->filter)) != MATCH_NO)
3247 : {
3248 44 : if (m == MATCH_ERROR)
3249 1 : goto error;
3250 43 : continue;
3251 : }
3252 2245 : if ((mask & OMP_CLAUSE_FINAL)
3253 2181 : && (m = gfc_match_dupl_check (!c->final_expr, "final", true,
3254 : &c->final_expr)) != MATCH_NO)
3255 : {
3256 64 : if (m == MATCH_ERROR)
3257 0 : goto error;
3258 64 : continue;
3259 : }
3260 2143 : if ((mask & OMP_CLAUSE_FINALIZE)
3261 2117 : && (m = gfc_match_dupl_check (!c->finalize, "finalize"))
3262 : != MATCH_NO)
3263 : {
3264 26 : if (m == MATCH_ERROR)
3265 0 : goto error;
3266 26 : c->finalize = true;
3267 26 : continue;
3268 : }
3269 3105 : if ((mask & OMP_CLAUSE_FIRSTPRIVATE)
3270 2091 : && gfc_match_omp_variable_list ("firstprivate (",
3271 : &c->lists[OMP_LIST_FIRSTPRIVATE],
3272 : true) == MATCH_YES)
3273 1014 : continue;
3274 2076 : if ((mask & OMP_CLAUSE_FROM)
3275 1077 : && gfc_match_motion_var_list ("from (", &c->lists[OMP_LIST_FROM],
3276 : &head) == MATCH_YES)
3277 999 : continue;
3278 143 : if ((mask & OMP_CLAUSE_FULL)
3279 78 : && (m = gfc_match_dupl_check (!c->full, "full")) != MATCH_NO)
3280 : {
3281 65 : if (m == MATCH_ERROR)
3282 0 : goto error;
3283 65 : c->full = true;
3284 65 : continue;
3285 : }
3286 : break;
3287 1231 : case 'g':
3288 2423 : if ((mask & OMP_CLAUSE_GANG)
3289 1231 : && (m = gfc_match_dupl_check (!c->gang, "gang")) != MATCH_NO)
3290 : {
3291 1197 : if (m == MATCH_ERROR)
3292 0 : goto error;
3293 1197 : c->gang = true;
3294 1197 : m = match_oacc_clause_gwv (c, GOMP_DIM_GANG);
3295 1197 : if (m == MATCH_ERROR)
3296 : {
3297 5 : gfc_current_locus = old_loc;
3298 5 : break;
3299 : }
3300 1192 : continue;
3301 : }
3302 68 : if ((mask & OMP_CLAUSE_GRAINSIZE)
3303 34 : && (m = gfc_match_dupl_check (!c->grainsize, "grainsize", true))
3304 : != MATCH_NO)
3305 : {
3306 34 : if (m == MATCH_ERROR)
3307 0 : goto error;
3308 34 : if (gfc_match ("strict : ") == MATCH_YES)
3309 1 : c->grainsize_strict = true;
3310 34 : if (gfc_match (" %e )", &c->grainsize) != MATCH_YES)
3311 0 : goto error;
3312 34 : continue;
3313 : }
3314 : break;
3315 465 : case 'h':
3316 513 : if ((mask & OMP_CLAUSE_HAS_DEVICE_ADDR)
3317 513 : && gfc_match_omp_variable_list
3318 48 : ("has_device_addr (", &c->lists[OMP_LIST_HAS_DEVICE_ADDR],
3319 : false, NULL, NULL, true) == MATCH_YES)
3320 48 : continue;
3321 460 : if ((mask & OMP_CLAUSE_HINT)
3322 417 : && (m = gfc_match_dupl_check (!c->hint, "hint", true, &c->hint))
3323 : != MATCH_NO)
3324 : {
3325 43 : if (m == MATCH_ERROR)
3326 0 : goto error;
3327 43 : continue;
3328 : }
3329 374 : if ((mask & OMP_CLAUSE_ASSUMPTIONS)
3330 374 : && gfc_match ("holds ( ") == MATCH_YES)
3331 : {
3332 19 : gfc_expr *e;
3333 19 : if (gfc_match ("%e )", &e) != MATCH_YES)
3334 0 : goto error;
3335 19 : if (c->assume == NULL)
3336 12 : c->assume = gfc_get_omp_assumptions ();
3337 19 : gfc_expr_list *el = XCNEW (gfc_expr_list);
3338 19 : el->expr = e;
3339 19 : el->next = c->assume->holds;
3340 19 : c->assume->holds = el;
3341 19 : continue;
3342 19 : }
3343 709 : if ((mask & OMP_CLAUSE_HOST)
3344 355 : && gfc_match ("host ( ") == MATCH_YES
3345 710 : && gfc_match_omp_map_clause (&c->lists[OMP_LIST_MAP],
3346 : OMP_MAP_FORCE_FROM, true,
3347 : /* allow_derived = */ true))
3348 354 : continue;
3349 : break;
3350 2119 : case 'i':
3351 2142 : if ((mask & OMP_CLAUSE_IF_PRESENT)
3352 2119 : && (m = gfc_match_dupl_check (!c->if_present, "if_present"))
3353 : != MATCH_NO)
3354 : {
3355 23 : if (m == MATCH_ERROR)
3356 0 : goto error;
3357 23 : c->if_present = true;
3358 23 : continue;
3359 : }
3360 2096 : if ((mask & OMP_CLAUSE_IF)
3361 2096 : && (m = gfc_match_dupl_check (!c->if_expr, "if", true))
3362 : != MATCH_NO)
3363 : {
3364 1347 : if (m == MATCH_ERROR)
3365 12 : goto error;
3366 1335 : if (!openacc)
3367 : {
3368 : /* This should match the enum gfc_omp_if_kind order. */
3369 : static const char *ifs[OMP_IF_LAST] = {
3370 : "cancel : %e )",
3371 : "parallel : %e )",
3372 : "simd : %e )",
3373 : "task : %e )",
3374 : "taskloop : %e )",
3375 : "target : %e )",
3376 : "target data : %e )",
3377 : "target update : %e )",
3378 : "target enter data : %e )",
3379 : "target exit data : %e )" };
3380 : int i;
3381 4841 : for (i = 0; i < OMP_IF_LAST; i++)
3382 4443 : if (c->if_exprs[i] == NULL
3383 4443 : && gfc_match (ifs[i], &c->if_exprs[i]) == MATCH_YES)
3384 : break;
3385 536 : if (i < OMP_IF_LAST)
3386 138 : continue;
3387 : }
3388 1197 : if (gfc_match (" %e )", &c->if_expr) == MATCH_YES)
3389 1192 : continue;
3390 5 : goto error;
3391 : }
3392 866 : if ((mask & OMP_CLAUSE_IN_REDUCTION)
3393 749 : && gfc_match_omp_clause_reduction (pc, c, openacc, allow_derived,
3394 : openmp_target) == MATCH_YES)
3395 117 : continue;
3396 657 : if ((mask & OMP_CLAUSE_INBRANCH)
3397 632 : && (m = gfc_match_dupl_check (!c->inbranch && !c->notinbranch,
3398 : "inbranch")) != MATCH_NO)
3399 : {
3400 25 : if (m == MATCH_ERROR)
3401 0 : goto error;
3402 25 : c->inbranch = true;
3403 25 : continue;
3404 : }
3405 849 : if ((mask & OMP_CLAUSE_INDEPENDENT)
3406 607 : && (m = gfc_match_dupl_check (!c->independent, "independent"))
3407 : != MATCH_NO)
3408 : {
3409 242 : if (m == MATCH_ERROR)
3410 0 : goto error;
3411 242 : c->independent = true;
3412 242 : continue;
3413 : }
3414 365 : if ((mask & OMP_CLAUSE_INDIRECT)
3415 365 : && (m = gfc_match_dupl_check (!c->indirect, "indirect"))
3416 : != MATCH_NO)
3417 : {
3418 61 : if (m == MATCH_ERROR)
3419 5 : goto error;
3420 60 : gfc_expr *indirect_expr = NULL;
3421 60 : m = gfc_match (" ( %e )", &indirect_expr);
3422 60 : if (m == MATCH_YES)
3423 : {
3424 13 : if (!gfc_resolve_expr (indirect_expr)
3425 13 : || indirect_expr->ts.type != BT_LOGICAL
3426 23 : || indirect_expr->expr_type != EXPR_CONSTANT)
3427 : {
3428 4 : gfc_error ("INDIRECT clause at %C requires a constant "
3429 : "logical expression");
3430 4 : gfc_free_expr (indirect_expr);
3431 4 : goto error;
3432 : }
3433 9 : c->indirect = indirect_expr->value.logical;
3434 9 : gfc_free_expr (indirect_expr);
3435 : }
3436 : else
3437 47 : c->indirect = 1;
3438 56 : continue;
3439 56 : }
3440 304 : if ((mask & OMP_CLAUSE_INIT)
3441 304 : && gfc_match ("init ( ") == MATCH_YES)
3442 : {
3443 108 : m = gfc_match_omp_init (&c->lists[OMP_LIST_INIT]);
3444 108 : if (m == MATCH_YES)
3445 63 : continue;
3446 45 : goto error;
3447 : }
3448 196 : if ((mask & OMP_CLAUSE_INTEROP)
3449 196 : && (m = gfc_match_dupl_check (!c->lists[OMP_LIST_INTEROP],
3450 : "interop", true)) != MATCH_NO)
3451 : {
3452 : /* Note: the interop objects are saved in reverse order to match
3453 : the order in C/C++. */
3454 125 : if (m == MATCH_YES
3455 63 : && (gfc_match_omp_variable_list ("",
3456 : &c->lists[OMP_LIST_INTEROP],
3457 : false, NULL, NULL, false,
3458 : false, NULL, false, true)
3459 : == MATCH_YES))
3460 62 : continue;
3461 1 : goto error;
3462 : }
3463 253 : if ((mask & OMP_CLAUSE_IS_DEVICE_PTR)
3464 253 : && gfc_match_omp_variable_list
3465 120 : ("is_device_ptr (",
3466 : &c->lists[OMP_LIST_IS_DEVICE_PTR], false) == MATCH_YES)
3467 120 : continue;
3468 : break;
3469 2334 : case 'l':
3470 2334 : if ((mask & OMP_CLAUSE_LASTPRIVATE)
3471 2334 : && gfc_match ("lastprivate ( ") == MATCH_YES)
3472 : {
3473 1431 : bool conditional = gfc_match ("conditional : ") == MATCH_YES;
3474 1431 : head = NULL;
3475 1431 : if (gfc_match_omp_variable_list ("",
3476 : &c->lists[OMP_LIST_LASTPRIVATE],
3477 : false, NULL, &head) == MATCH_YES)
3478 : {
3479 1431 : gfc_omp_namelist *n;
3480 3737 : for (n = *head; n; n = n->next)
3481 2306 : n->u.lastprivate_conditional = conditional;
3482 1431 : continue;
3483 1431 : }
3484 0 : gfc_current_locus = old_loc;
3485 0 : break;
3486 : }
3487 903 : end_colon = false;
3488 903 : head = NULL;
3489 903 : if ((mask & OMP_CLAUSE_LINEAR)
3490 903 : && gfc_match ("linear (") == MATCH_YES)
3491 : {
3492 836 : bool old_linear_modifier = false;
3493 836 : gfc_omp_linear_op linear_op = OMP_LINEAR_DEFAULT;
3494 836 : gfc_expr *step = NULL;
3495 836 : locus saved_loc = gfc_current_locus;
3496 :
3497 836 : if (gfc_match_omp_variable_list (" ref (",
3498 : &c->lists[OMP_LIST_LINEAR],
3499 : false, NULL, &head)
3500 : == MATCH_YES)
3501 : {
3502 : linear_op = OMP_LINEAR_REF;
3503 : old_linear_modifier = true;
3504 : }
3505 808 : else if (gfc_match_omp_variable_list (" val (",
3506 : &c->lists[OMP_LIST_LINEAR],
3507 : false, NULL, &head)
3508 : == MATCH_YES)
3509 : {
3510 : linear_op = OMP_LINEAR_VAL;
3511 : old_linear_modifier = true;
3512 : }
3513 797 : else if (gfc_match_omp_variable_list (" uval (",
3514 : &c->lists[OMP_LIST_LINEAR],
3515 : false, NULL, &head)
3516 : == MATCH_YES)
3517 : {
3518 : linear_op = OMP_LINEAR_UVAL;
3519 : old_linear_modifier = true;
3520 : }
3521 788 : else if (gfc_match_omp_variable_list ("",
3522 : &c->lists[OMP_LIST_LINEAR],
3523 : false, &end_colon, &head)
3524 : == MATCH_YES)
3525 : linear_op = OMP_LINEAR_DEFAULT;
3526 : else
3527 : {
3528 2 : gfc_current_locus = old_loc;
3529 2 : break;
3530 : }
3531 : if (linear_op != OMP_LINEAR_DEFAULT)
3532 : {
3533 48 : if (gfc_match (" :") == MATCH_YES)
3534 31 : end_colon = true;
3535 17 : else if (gfc_match (" )") != MATCH_YES)
3536 : {
3537 0 : gfc_free_omp_namelist (*head, OMP_LIST_LINEAR);
3538 0 : gfc_current_locus = old_loc;
3539 0 : *head = NULL;
3540 0 : break;
3541 : }
3542 : }
3543 834 : gfc_gobble_whitespace ();
3544 834 : if (old_linear_modifier && end_colon)
3545 : {
3546 31 : if (gfc_match (" %e )", &step) != MATCH_YES)
3547 : {
3548 1 : gfc_free_omp_namelist (*head, OMP_LIST_LINEAR);
3549 1 : gfc_current_locus = old_loc;
3550 1 : *head = NULL;
3551 5 : goto error;
3552 : }
3553 : }
3554 833 : if (old_linear_modifier)
3555 : {
3556 47 : char var_names[512]{};
3557 47 : int count, offset = 0;
3558 106 : for (gfc_omp_namelist *n = *head; n; n = n->next)
3559 : {
3560 59 : if (!n->next)
3561 47 : count = snprintf (var_names + offset,
3562 47 : sizeof (var_names) - offset,
3563 47 : "%s", n->sym->name);
3564 : else
3565 12 : count = snprintf (var_names + offset,
3566 12 : sizeof (var_names) - offset,
3567 12 : "%s, ", n->sym->name);
3568 59 : if (count < 0 || count >= ((int)sizeof (var_names))
3569 59 : - offset)
3570 : {
3571 0 : snprintf (var_names, 512, "%s, ..., ",
3572 0 : (*head)->sym->name);
3573 0 : while (n->next)
3574 : n = n->next;
3575 0 : offset = strlen (var_names);
3576 0 : snprintf (var_names + offset,
3577 0 : sizeof (var_names) - offset,
3578 0 : "%s", n->sym->name);
3579 0 : break;
3580 : }
3581 59 : offset += count;
3582 : }
3583 47 : char *var_names_for_warn = var_names;
3584 47 : const char *op_name;
3585 47 : switch (linear_op)
3586 : {
3587 : case OMP_LINEAR_REF: op_name = "ref"; break;
3588 10 : case OMP_LINEAR_VAL: op_name = "val"; break;
3589 9 : case OMP_LINEAR_UVAL: op_name = "uval"; break;
3590 0 : default: gcc_unreachable ();
3591 : }
3592 47 : gfc_warning (OPT_Wdeprecated_openmp,
3593 : "Specification of the list items as "
3594 : "arguments to the modifiers at %L is "
3595 : "deprecated; since OpenMP 5.2, use "
3596 : "%<linear(%s : %s%s)%>", &saved_loc,
3597 : var_names_for_warn, op_name,
3598 47 : step == nullptr ? "" : ", step(...)");
3599 : }
3600 786 : else if (end_colon)
3601 : {
3602 713 : bool has_error = false;
3603 : bool has_modifiers = false;
3604 : bool has_step = false;
3605 713 : bool duplicate_step = false;
3606 713 : bool duplicate_mod = false;
3607 713 : while (true)
3608 : {
3609 713 : old_loc = gfc_current_locus;
3610 713 : bool close_paren = gfc_match ("val )") == MATCH_YES;
3611 713 : if (close_paren || gfc_match ("val , ") == MATCH_YES)
3612 : {
3613 17 : if (linear_op != OMP_LINEAR_DEFAULT)
3614 : {
3615 : duplicate_mod = true;
3616 : break;
3617 : }
3618 16 : linear_op = OMP_LINEAR_VAL;
3619 16 : has_modifiers = true;
3620 16 : if (close_paren)
3621 : break;
3622 10 : continue;
3623 : }
3624 696 : close_paren = gfc_match ("uval )") == MATCH_YES;
3625 696 : if (close_paren || gfc_match ("uval , ") == MATCH_YES)
3626 : {
3627 7 : if (linear_op != OMP_LINEAR_DEFAULT)
3628 : {
3629 : duplicate_mod = true;
3630 : break;
3631 : }
3632 7 : linear_op = OMP_LINEAR_UVAL;
3633 7 : has_modifiers = true;
3634 7 : if (close_paren)
3635 : break;
3636 2 : continue;
3637 : }
3638 689 : close_paren = gfc_match ("ref )") == MATCH_YES;
3639 689 : if (close_paren || gfc_match ("ref , ") == MATCH_YES)
3640 : {
3641 16 : if (linear_op != OMP_LINEAR_DEFAULT)
3642 : {
3643 : duplicate_mod = true;
3644 : break;
3645 : }
3646 15 : linear_op = OMP_LINEAR_REF;
3647 15 : has_modifiers = true;
3648 15 : if (close_paren)
3649 : break;
3650 7 : continue;
3651 : }
3652 673 : close_paren = (gfc_match ("step ( %e ) )", &step)
3653 : == MATCH_YES);
3654 684 : if (close_paren
3655 673 : || gfc_match ("step ( %e ) , ", &step) == MATCH_YES)
3656 : {
3657 38 : if (has_step)
3658 : {
3659 : duplicate_step = true;
3660 : break;
3661 : }
3662 37 : has_modifiers = has_step = true;
3663 37 : if (close_paren)
3664 : break;
3665 11 : continue;
3666 : }
3667 635 : if (!has_modifiers
3668 635 : && gfc_match ("%e )", &step) == MATCH_YES)
3669 : {
3670 635 : if ((step->expr_type == EXPR_FUNCTION
3671 634 : || step->expr_type == EXPR_VARIABLE)
3672 31 : && strcmp (step->symtree->name, "step") == 0)
3673 : {
3674 1 : gfc_current_locus = old_loc;
3675 1 : gfc_match ("step (");
3676 1 : has_error = true;
3677 : }
3678 : break;
3679 : }
3680 : has_error = true;
3681 : break;
3682 : }
3683 49 : if (duplicate_mod || duplicate_step)
3684 : {
3685 3 : gfc_error ("Multiple %qs modifiers specified at %C",
3686 : duplicate_mod ? "linear" : "step");
3687 3 : has_error = true;
3688 : }
3689 683 : if (has_error)
3690 : {
3691 4 : gfc_free_omp_namelist (*head, OMP_LIST_LINEAR);
3692 4 : *head = NULL;
3693 4 : goto error;
3694 : }
3695 : }
3696 829 : if (step == NULL)
3697 : {
3698 130 : step = gfc_get_constant_expr (BT_INTEGER,
3699 : gfc_default_integer_kind,
3700 : &old_loc);
3701 130 : mpz_set_si (step->value.integer, 1);
3702 : }
3703 829 : (*head)->expr = step;
3704 829 : if (linear_op != OMP_LINEAR_DEFAULT || old_linear_modifier)
3705 176 : for (gfc_omp_namelist *n = *head; n; n = n->next)
3706 : {
3707 94 : n->u.linear.op = linear_op;
3708 94 : n->u.linear.old_modifier = old_linear_modifier;
3709 : }
3710 829 : continue;
3711 829 : }
3712 71 : if ((mask & OMP_CLAUSE_LINK)
3713 67 : && openacc
3714 75 : && (gfc_match_oacc_clause_link ("link (",
3715 : &c->lists[OMP_LIST_LINK])
3716 : == MATCH_YES))
3717 4 : continue;
3718 110 : else if ((mask & OMP_CLAUSE_LINK)
3719 63 : && !openacc
3720 122 : && (gfc_match_omp_to_link ("link (",
3721 : &c->lists[OMP_LIST_LINK])
3722 : == MATCH_YES))
3723 47 : continue;
3724 28 : if ((mask & OMP_CLAUSE_LOCAL)
3725 16 : && (gfc_match_omp_to_link ("local (", &c->lists[OMP_LIST_LOCAL])
3726 : == MATCH_YES))
3727 12 : continue;
3728 : break;
3729 5832 : case 'm':
3730 5832 : if ((mask & OMP_CLAUSE_MAP)
3731 5832 : && gfc_match ("map ( ") == MATCH_YES)
3732 : {
3733 5740 : locus old_loc2 = gfc_current_locus;
3734 5740 : int always_modifier = 0;
3735 5740 : int close_modifier = 0;
3736 5740 : int present_modifier = 0;
3737 5740 : int mapper_modifier = 0;
3738 5740 : locus second_always_locus = old_loc2;
3739 5740 : locus second_close_locus = old_loc2;
3740 5740 : locus second_mapper_locus = old_loc2;
3741 5740 : locus second_present_locus = old_loc2;
3742 5740 : char mapper_id[GFC_MAX_SYMBOL_LEN + 1] = { '\0' };
3743 :
3744 6310 : for (;;)
3745 : {
3746 6025 : locus current_locus = gfc_current_locus;
3747 6025 : if (gfc_match ("always ") == MATCH_YES)
3748 : {
3749 148 : if (always_modifier++ == 1)
3750 5 : second_always_locus = current_locus;
3751 : }
3752 5877 : else if (gfc_match ("close ") == MATCH_YES)
3753 : {
3754 69 : if (close_modifier++ == 1)
3755 5 : second_close_locus = current_locus;
3756 : }
3757 5808 : else if (gfc_match ("present ") == MATCH_YES)
3758 : {
3759 67 : if (present_modifier++ == 1)
3760 4 : second_present_locus = current_locus;
3761 : }
3762 5741 : else if (gfc_match ("mapper ( ") == MATCH_YES)
3763 : {
3764 1 : if (mapper_modifier++ == 1)
3765 0 : second_mapper_locus = current_locus;
3766 1 : m = gfc_match (" %n ) ", mapper_id);
3767 1 : if (m != MATCH_YES)
3768 0 : goto error;
3769 : }
3770 : else
3771 : break;
3772 285 : if (gfc_match (", ") != MATCH_YES)
3773 62 : gfc_warning (OPT_Wdeprecated_openmp,
3774 : "The specification of modifiers without "
3775 : "comma separators for the %<map%> clause "
3776 : "at %C has been deprecated since "
3777 : "OpenMP 5.2");
3778 285 : }
3779 :
3780 5740 : gfc_omp_map_op map_op = default_map_op;
3781 5740 : int always_present_modifier
3782 5740 : = always_modifier && present_modifier;
3783 :
3784 5740 : if (gfc_match ("alloc : ") == MATCH_YES)
3785 799 : map_op = (present_modifier ? OMP_MAP_PRESENT_ALLOC
3786 : : OMP_MAP_ALLOC);
3787 4941 : else if (gfc_match ("tofrom : ") == MATCH_YES)
3788 948 : map_op = (always_present_modifier ? OMP_MAP_ALWAYS_PRESENT_TOFROM
3789 944 : : present_modifier ? OMP_MAP_PRESENT_TOFROM
3790 939 : : always_modifier ? OMP_MAP_ALWAYS_TOFROM
3791 : : OMP_MAP_TOFROM);
3792 3993 : else if (gfc_match ("to : ") == MATCH_YES)
3793 1772 : map_op = (always_present_modifier ? OMP_MAP_ALWAYS_PRESENT_TO
3794 1766 : : present_modifier ? OMP_MAP_PRESENT_TO
3795 1754 : : always_modifier ? OMP_MAP_ALWAYS_TO
3796 : : OMP_MAP_TO);
3797 2221 : else if (gfc_match ("from : ") == MATCH_YES)
3798 1616 : map_op = (always_present_modifier ? OMP_MAP_ALWAYS_PRESENT_FROM
3799 1612 : : present_modifier ? OMP_MAP_PRESENT_FROM
3800 1607 : : always_modifier ? OMP_MAP_ALWAYS_FROM
3801 : : OMP_MAP_FROM);
3802 605 : else if (gfc_match ("release : ") == MATCH_YES)
3803 : map_op = OMP_MAP_RELEASE;
3804 552 : else if (gfc_match ("delete : ") == MATCH_YES)
3805 : map_op = OMP_MAP_DELETE;
3806 : else
3807 : {
3808 475 : gfc_current_locus = old_loc2;
3809 475 : always_modifier = 0;
3810 475 : close_modifier = 0;
3811 475 : mapper_modifier = 0;
3812 : }
3813 :
3814 1552 : if (always_modifier > 1)
3815 : {
3816 5 : gfc_error ("too many %<always%> modifiers at %L",
3817 : &second_always_locus);
3818 21 : break;
3819 : }
3820 5735 : if (close_modifier > 1)
3821 : {
3822 4 : gfc_error ("too many %<close%> modifiers at %L",
3823 : &second_close_locus);
3824 4 : break;
3825 : }
3826 5731 : if (present_modifier > 1)
3827 : {
3828 4 : gfc_error ("too many %<present%> modifiers at %L",
3829 : &second_present_locus);
3830 4 : break;
3831 : }
3832 5727 : if (mapper_modifier > 1)
3833 : {
3834 0 : gfc_error ("too many %<mapper%> modifiers at %L",
3835 : &second_mapper_locus);
3836 0 : break;
3837 : }
3838 :
3839 5727 : head = NULL;
3840 5727 : if (gfc_match_omp_variable_list ("", &c->lists[OMP_LIST_MAP],
3841 : false, NULL, &head,
3842 : true, true) == MATCH_YES)
3843 : {
3844 5724 : gfc_omp_namelist *n;
3845 13019 : for (n = *head; n; n = n->next)
3846 : {
3847 7295 : n->u.map.op = map_op;
3848 :
3849 7295 : gfc_typespec *ts;
3850 7295 : if (n->expr)
3851 2383 : ts = &n->expr->ts;
3852 : else
3853 4912 : ts = &n->sym->ts;
3854 :
3855 7295 : gfc_omp_udm *udm
3856 7295 : = gfc_find_omp_udm (gfc_current_ns, mapper_id, ts);
3857 7295 : if (udm)
3858 : {
3859 4 : n->u2.udm.udm = udm;
3860 : }
3861 : }
3862 5724 : continue;
3863 5724 : }
3864 3 : gfc_current_locus = old_loc;
3865 3 : break;
3866 : }
3867 126 : if ((mask & OMP_CLAUSE_MERGEABLE)
3868 92 : && (m = gfc_match_dupl_check (!c->mergeable, "mergeable"))
3869 : != MATCH_NO)
3870 : {
3871 34 : if (m == MATCH_ERROR)
3872 0 : goto error;
3873 34 : c->mergeable = true;
3874 34 : continue;
3875 : }
3876 111 : if ((mask & OMP_CLAUSE_MESSAGE)
3877 58 : && (m = gfc_match_dupl_check (!c->message, "message", true,
3878 : &c->message)) != MATCH_NO)
3879 : {
3880 58 : if (m == MATCH_ERROR)
3881 5 : goto error;
3882 53 : continue;
3883 : }
3884 : break;
3885 2910 : case 'n':
3886 2962 : if ((mask & OMP_CLAUSE_NO_CREATE)
3887 1343 : && gfc_match ("no_create ( ") == MATCH_YES
3888 2962 : && gfc_match_omp_map_clause (&c->lists[OMP_LIST_MAP],
3889 : OMP_MAP_IF_PRESENT, true,
3890 : allow_derived))
3891 52 : continue;
3892 2859 : if ((mask & OMP_CLAUSE_ASSUMPTIONS)
3893 2884 : && (m = gfc_match_dupl_check (!c->assume
3894 26 : || !c->assume->no_openmp_constructs,
3895 : "no_openmp_constructs")) != MATCH_NO)
3896 : {
3897 2 : if (m == MATCH_ERROR)
3898 1 : goto error;
3899 1 : if (c->assume == NULL)
3900 0 : c->assume = gfc_get_omp_assumptions ();
3901 1 : c->assume->no_openmp_constructs = true;
3902 1 : continue;
3903 : }
3904 2869 : if ((mask & OMP_CLAUSE_ASSUMPTIONS)
3905 2880 : && (m = gfc_match_dupl_check (!c->assume
3906 24 : || !c->assume->no_openmp_routines,
3907 : "no_openmp_routines")) != MATCH_NO)
3908 : {
3909 13 : if (m == MATCH_ERROR)
3910 0 : goto error;
3911 13 : if (c->assume == NULL)
3912 12 : c->assume = gfc_get_omp_assumptions ();
3913 13 : c->assume->no_openmp_routines = true;
3914 13 : continue;
3915 : }
3916 2847 : if ((mask & OMP_CLAUSE_ASSUMPTIONS)
3917 2853 : && (m = gfc_match_dupl_check (!c->assume || !c->assume->no_openmp,
3918 : "no_openmp")) != MATCH_NO)
3919 : {
3920 4 : if (m == MATCH_ERROR)
3921 0 : goto error;
3922 4 : if (c->assume == NULL)
3923 4 : c->assume = gfc_get_omp_assumptions ();
3924 4 : c->assume->no_openmp = true;
3925 4 : continue;
3926 : }
3927 2845 : if ((mask & OMP_CLAUSE_ASSUMPTIONS)
3928 2846 : && (m = gfc_match_dupl_check (!c->assume
3929 7 : || !c->assume->no_parallelism,
3930 : "no_parallelism")) != MATCH_NO)
3931 : {
3932 6 : if (m == MATCH_ERROR)
3933 0 : goto error;
3934 6 : if (c->assume == NULL)
3935 6 : c->assume = gfc_get_omp_assumptions ();
3936 6 : c->assume->no_parallelism = true;
3937 6 : continue;
3938 : }
3939 :
3940 2843 : if ((mask & OMP_CLAUSE_NOVARIANTS)
3941 2833 : && (m = gfc_match_dupl_check (!c->novariants, "novariants", true,
3942 : &c->novariants))
3943 : != MATCH_NO)
3944 : {
3945 12 : if (m == MATCH_ERROR)
3946 2 : goto error;
3947 10 : continue;
3948 : }
3949 2834 : if ((mask & OMP_CLAUSE_NOCONTEXT)
3950 2821 : && (m = gfc_match_dupl_check (!c->nocontext, "nocontext", true,
3951 : &c->nocontext))
3952 : != MATCH_NO)
3953 : {
3954 15 : if (m == MATCH_ERROR)
3955 2 : goto error;
3956 13 : continue;
3957 : }
3958 2820 : if ((mask & OMP_CLAUSE_NOGROUP)
3959 2806 : && (m = gfc_match_dupl_check (!c->nogroup, "nogroup"))
3960 : != MATCH_NO)
3961 : {
3962 14 : if (m == MATCH_ERROR)
3963 0 : goto error;
3964 14 : c->nogroup = true;
3965 14 : continue;
3966 : }
3967 2942 : if ((mask & OMP_CLAUSE_NOHOST)
3968 2792 : && (m = gfc_match_dupl_check (!c->nohost, "nohost")) != MATCH_NO)
3969 : {
3970 151 : if (m == MATCH_ERROR)
3971 1 : goto error;
3972 150 : c->nohost = true;
3973 150 : continue;
3974 : }
3975 2683 : if ((mask & OMP_CLAUSE_NOTEMPORAL)
3976 2641 : && gfc_match_omp_variable_list ("nontemporal (",
3977 : &c->lists[OMP_LIST_NONTEMPORAL],
3978 : true) == MATCH_YES)
3979 42 : continue;
3980 2623 : if ((mask & OMP_CLAUSE_NOTINBRANCH)
3981 2600 : && (m = gfc_match_dupl_check (!c->notinbranch && !c->inbranch,
3982 : "notinbranch")) != MATCH_NO)
3983 : {
3984 25 : if (m == MATCH_ERROR)
3985 1 : goto error;
3986 24 : c->notinbranch = true;
3987 24 : continue;
3988 : }
3989 2703 : if ((mask & OMP_CLAUSE_NOWAIT)
3990 2574 : && (m = gfc_match_dupl_check (!c->nowait, "nowait")) != MATCH_NO)
3991 : {
3992 132 : if (m == MATCH_ERROR)
3993 3 : goto error;
3994 129 : c->nowait = true;
3995 129 : continue;
3996 : }
3997 3124 : if ((mask & OMP_CLAUSE_NUM_GANGS)
3998 2442 : && (m = gfc_match_dupl_check (!c->num_gangs_expr, "num_gangs",
3999 : true)) != MATCH_NO)
4000 : {
4001 686 : if (m == MATCH_ERROR)
4002 2 : goto error;
4003 684 : if (gfc_match (" %e )", &c->num_gangs_expr) != MATCH_YES)
4004 2 : goto error;
4005 682 : continue;
4006 : }
4007 1782 : if ((mask & OMP_CLAUSE_NUM_TASKS)
4008 1756 : && (m = gfc_match_dupl_check (!c->num_tasks, "num_tasks", true))
4009 : != MATCH_NO)
4010 : {
4011 26 : if (m == MATCH_ERROR)
4012 0 : goto error;
4013 26 : if (gfc_match ("strict : ") == MATCH_YES)
4014 1 : c->num_tasks_strict = true;
4015 26 : if (gfc_match (" %e )", &c->num_tasks) != MATCH_YES)
4016 0 : goto error;
4017 26 : continue;
4018 : }
4019 1857 : if ((mask & OMP_CLAUSE_NUM_TEAMS)
4020 1730 : && (m = gfc_match_dupl_check (!c->num_teams_upper, "num_teams",
4021 : true)) != MATCH_NO)
4022 : {
4023 127 : if (m == MATCH_ERROR)
4024 0 : goto error;
4025 127 : if (gfc_match ("%e ", &c->num_teams_upper) != MATCH_YES)
4026 0 : goto error;
4027 127 : if (gfc_peek_ascii_char () == ':')
4028 : {
4029 21 : c->num_teams_lower = c->num_teams_upper;
4030 21 : c->num_teams_upper = NULL;
4031 21 : if (gfc_match (": %e ", &c->num_teams_upper) != MATCH_YES)
4032 0 : goto error;
4033 : }
4034 127 : if (gfc_match (") ") != MATCH_YES)
4035 0 : goto error;
4036 127 : continue;
4037 : }
4038 2565 : if ((mask & OMP_CLAUSE_NUM_THREADS)
4039 1603 : && (m = gfc_match_dupl_check (!c->num_threads, "num_threads", true,
4040 : &c->num_threads)) != MATCH_NO)
4041 : {
4042 962 : if (m == MATCH_ERROR)
4043 0 : goto error;
4044 962 : continue;
4045 : }
4046 1240 : if ((mask & OMP_CLAUSE_NUM_WORKERS)
4047 641 : && (m = gfc_match_dupl_check (!c->num_workers_expr, "num_workers",
4048 : true, &c->num_workers_expr))
4049 : != MATCH_NO)
4050 : {
4051 603 : if (m == MATCH_ERROR)
4052 4 : goto error;
4053 599 : continue;
4054 : }
4055 : break;
4056 591 : case 'o':
4057 591 : if ((mask & OMP_CLAUSE_ORDERED)
4058 591 : && (m = gfc_match_dupl_check (!c->ordered, "ordered"))
4059 : != MATCH_NO)
4060 : {
4061 343 : if (m == MATCH_ERROR)
4062 0 : goto error;
4063 343 : gfc_expr *cexpr = NULL;
4064 343 : m = gfc_match (" ( %e )", &cexpr);
4065 :
4066 343 : c->ordered = true;
4067 343 : if (m == MATCH_YES)
4068 : {
4069 144 : int ordered = 0;
4070 144 : if (gfc_extract_int (cexpr, &ordered, -1))
4071 0 : ordered = 0;
4072 144 : else if (ordered <= 0)
4073 : {
4074 0 : gfc_error_now ("ORDERED clause argument not"
4075 : " constant positive integer at %C");
4076 0 : ordered = 0;
4077 : }
4078 144 : c->orderedc = ordered;
4079 144 : gfc_free_expr (cexpr);
4080 144 : continue;
4081 144 : }
4082 :
4083 199 : continue;
4084 199 : }
4085 482 : if ((mask & OMP_CLAUSE_ORDER)
4086 248 : && (m = gfc_match_dupl_check (!c->order_concurrent, "order", true))
4087 : != MATCH_NO)
4088 : {
4089 247 : if (m == MATCH_ERROR)
4090 10 : goto error;
4091 237 : if (gfc_match (" reproducible : concurrent )") == MATCH_YES)
4092 55 : c->order_reproducible = true;
4093 182 : else if (gfc_match (" concurrent )") == MATCH_YES)
4094 : ;
4095 50 : else if (gfc_match (" unconstrained : concurrent )") == MATCH_YES)
4096 47 : c->order_unconstrained = true;
4097 : else
4098 : {
4099 3 : gfc_error ("Expected ORDER(CONCURRENT) at %C "
4100 : "with optional %<reproducible%> or "
4101 : "%<unconstrained%> modifier");
4102 3 : goto error;
4103 : }
4104 234 : c->order_concurrent = true;
4105 234 : continue;
4106 : }
4107 : break;
4108 3101 : case 'p':
4109 3101 : if (mask & OMP_CLAUSE_PARTIAL)
4110 : {
4111 276 : if ((m = gfc_match_dupl_check (!c->partial, "partial"))
4112 : != MATCH_NO)
4113 : {
4114 276 : int expr;
4115 276 : if (m == MATCH_ERROR)
4116 0 : goto error;
4117 :
4118 276 : c->partial = -1;
4119 :
4120 276 : gfc_expr *cexpr = NULL;
4121 276 : m = gfc_match (" ( %e )", &cexpr);
4122 276 : if (m == MATCH_NO)
4123 : ;
4124 251 : else if (m == MATCH_YES
4125 251 : && !gfc_extract_int (cexpr, &expr, -1)
4126 502 : && expr > 0)
4127 247 : c->partial = expr;
4128 : else
4129 4 : gfc_error_now ("PARTIAL clause argument not constant "
4130 : "positive integer at %C");
4131 276 : gfc_free_expr (cexpr);
4132 276 : continue;
4133 276 : }
4134 : }
4135 2894 : if ((mask & OMP_CLAUSE_COPY)
4136 877 : && gfc_match ("pcopy ( ") == MATCH_YES
4137 2895 : && gfc_match_omp_map_clause (&c->lists[OMP_LIST_MAP],
4138 : OMP_MAP_TOFROM, true, allow_derived))
4139 69 : continue;
4140 2830 : if ((mask & OMP_CLAUSE_COPYIN)
4141 1910 : && gfc_match ("pcopyin ( ") == MATCH_YES
4142 2830 : && gfc_match_omp_map_clause (&c->lists[OMP_LIST_MAP],
4143 : OMP_MAP_TO, true, allow_derived))
4144 74 : continue;
4145 2755 : if ((mask & OMP_CLAUSE_COPYOUT)
4146 735 : && gfc_match ("pcopyout ( ") == MATCH_YES
4147 2755 : && gfc_match_omp_map_clause (&c->lists[OMP_LIST_MAP],
4148 : OMP_MAP_FROM, true, allow_derived))
4149 73 : continue;
4150 2624 : if ((mask & OMP_CLAUSE_CREATE)
4151 672 : && gfc_match ("pcreate ( ") == MATCH_YES
4152 2624 : && gfc_match_omp_map_clause (&c->lists[OMP_LIST_MAP],
4153 : OMP_MAP_ALLOC, true, allow_derived))
4154 15 : continue;
4155 3010 : if ((mask & OMP_CLAUSE_PRESENT)
4156 647 : && gfc_match ("present ( ") == MATCH_YES
4157 3012 : && gfc_match_omp_map_clause (&c->lists[OMP_LIST_MAP],
4158 : OMP_MAP_FORCE_PRESENT, false,
4159 : allow_derived))
4160 416 : continue;
4161 2201 : if ((mask & OMP_CLAUSE_COPY)
4162 231 : && gfc_match ("present_or_copy ( ") == MATCH_YES
4163 2201 : && gfc_match_omp_map_clause (&c->lists[OMP_LIST_MAP],
4164 : OMP_MAP_TOFROM, true,
4165 : allow_derived))
4166 23 : continue;
4167 2195 : if ((mask & OMP_CLAUSE_COPYIN)
4168 1309 : && gfc_match ("present_or_copyin ( ") == MATCH_YES
4169 2195 : && gfc_match_omp_map_clause (&c->lists[OMP_LIST_MAP],
4170 : OMP_MAP_TO, true, allow_derived))
4171 40 : continue;
4172 2150 : if ((mask & OMP_CLAUSE_COPYOUT)
4173 173 : && gfc_match ("present_or_copyout ( ") == MATCH_YES
4174 2150 : && gfc_match_omp_map_clause (&c->lists[OMP_LIST_MAP],
4175 : OMP_MAP_FROM, true, allow_derived))
4176 35 : continue;
4177 2108 : if ((mask & OMP_CLAUSE_CREATE)
4178 143 : && gfc_match ("present_or_create ( ") == MATCH_YES
4179 2108 : && gfc_match_omp_map_clause (&c->lists[OMP_LIST_MAP],
4180 : OMP_MAP_ALLOC, true, allow_derived))
4181 28 : continue;
4182 2086 : if ((mask & OMP_CLAUSE_PRIORITY)
4183 2052 : && (m = gfc_match_dupl_check (!c->priority, "priority", true,
4184 : &c->priority)) != MATCH_NO)
4185 : {
4186 34 : if (m == MATCH_ERROR)
4187 0 : goto error;
4188 34 : continue;
4189 : }
4190 3959 : if ((mask & OMP_CLAUSE_PRIVATE)
4191 2018 : && gfc_match_omp_variable_list ("private (",
4192 : &c->lists[OMP_LIST_PRIVATE],
4193 : true) == MATCH_YES)
4194 1941 : continue;
4195 141 : if ((mask & OMP_CLAUSE_PROC_BIND)
4196 141 : && (m = gfc_match_dupl_check ((c->proc_bind
4197 64 : == OMP_PROC_BIND_UNKNOWN),
4198 : "proc_bind", true)) != MATCH_NO)
4199 : {
4200 64 : if (m == MATCH_ERROR)
4201 0 : goto error;
4202 64 : if (gfc_match ("primary )") == MATCH_YES)
4203 1 : c->proc_bind = OMP_PROC_BIND_PRIMARY;
4204 63 : else if (gfc_match ("master )") == MATCH_YES)
4205 : {
4206 9 : gfc_warning (OPT_Wdeprecated_openmp,
4207 : "%<master%> affinity policy at %C deprecated "
4208 : "since OpenMP 5.1, use %<primary%>");
4209 9 : c->proc_bind = OMP_PROC_BIND_MASTER;
4210 : }
4211 54 : else if (gfc_match ("spread )") == MATCH_YES)
4212 53 : c->proc_bind = OMP_PROC_BIND_SPREAD;
4213 1 : else if (gfc_match ("close )") == MATCH_YES)
4214 1 : c->proc_bind = OMP_PROC_BIND_CLOSE;
4215 : else
4216 0 : goto error;
4217 64 : continue;
4218 : }
4219 : break;
4220 4580 : case 'r':
4221 5070 : if ((mask & OMP_CLAUSE_ATOMIC)
4222 4580 : && (m = gfc_match_dupl_atomic ((c->atomic_op
4223 : == GFC_OMP_ATOMIC_UNSET),
4224 : "read")) != MATCH_NO)
4225 : {
4226 490 : if (m == MATCH_ERROR)
4227 0 : goto error;
4228 490 : c->atomic_op = GFC_OMP_ATOMIC_READ;
4229 490 : continue;
4230 : }
4231 8143 : if ((mask & OMP_CLAUSE_REDUCTION)
4232 4090 : && gfc_match_omp_clause_reduction (pc, c, openacc,
4233 : allow_derived) == MATCH_YES)
4234 4053 : continue;
4235 47 : if ((mask & OMP_CLAUSE_MEMORDER)
4236 65 : && (m = gfc_match_dupl_memorder ((c->memorder
4237 28 : == OMP_MEMORDER_UNSET),
4238 : "relaxed")) != MATCH_NO)
4239 : {
4240 10 : if (m == MATCH_ERROR)
4241 0 : goto error;
4242 10 : c->memorder = OMP_MEMORDER_RELAXED;
4243 10 : continue;
4244 : }
4245 44 : if ((mask & OMP_CLAUSE_MEMORDER)
4246 45 : && (m = gfc_match_dupl_memorder ((c->memorder
4247 18 : == OMP_MEMORDER_UNSET),
4248 : "release")) != MATCH_NO)
4249 : {
4250 18 : if (m == MATCH_ERROR)
4251 1 : goto error;
4252 17 : c->memorder = OMP_MEMORDER_RELEASE;
4253 17 : continue;
4254 : }
4255 : break;
4256 3036 : case 's':
4257 3129 : if ((mask & OMP_CLAUSE_SAFELEN)
4258 3036 : && (m = gfc_match_dupl_check (!c->safelen_expr, "safelen",
4259 : true, &c->safelen_expr))
4260 : != MATCH_NO)
4261 : {
4262 93 : if (m == MATCH_ERROR)
4263 0 : goto error;
4264 93 : continue;
4265 : }
4266 2943 : if ((mask & OMP_CLAUSE_SCHEDULE)
4267 2943 : && (m = gfc_match_dupl_check (c->sched_kind == OMP_SCHED_NONE,
4268 : "schedule", true)) != MATCH_NO)
4269 : {
4270 809 : if (m == MATCH_ERROR)
4271 0 : goto error;
4272 809 : int nmodifiers = 0;
4273 809 : locus old_loc2 = gfc_current_locus;
4274 827 : do
4275 : {
4276 818 : if (gfc_match ("simd") == MATCH_YES)
4277 : {
4278 18 : c->sched_simd = true;
4279 18 : nmodifiers++;
4280 : }
4281 800 : else if (gfc_match ("monotonic") == MATCH_YES)
4282 : {
4283 30 : c->sched_monotonic = true;
4284 30 : nmodifiers++;
4285 : }
4286 770 : else if (gfc_match ("nonmonotonic") == MATCH_YES)
4287 : {
4288 35 : c->sched_nonmonotonic = true;
4289 35 : nmodifiers++;
4290 : }
4291 : else
4292 : {
4293 735 : if (nmodifiers)
4294 0 : gfc_current_locus = old_loc2;
4295 : break;
4296 : }
4297 92 : if (nmodifiers == 1
4298 83 : && gfc_match (" , ") == MATCH_YES)
4299 9 : continue;
4300 74 : else if (gfc_match (" : ") == MATCH_YES)
4301 : break;
4302 0 : gfc_current_locus = old_loc2;
4303 0 : break;
4304 : }
4305 : while (1);
4306 809 : if (gfc_match ("static") == MATCH_YES)
4307 425 : c->sched_kind = OMP_SCHED_STATIC;
4308 384 : else if (gfc_match ("dynamic") == MATCH_YES)
4309 164 : c->sched_kind = OMP_SCHED_DYNAMIC;
4310 220 : else if (gfc_match ("guided") == MATCH_YES)
4311 127 : c->sched_kind = OMP_SCHED_GUIDED;
4312 93 : else if (gfc_match ("runtime") == MATCH_YES)
4313 85 : c->sched_kind = OMP_SCHED_RUNTIME;
4314 8 : else if (gfc_match ("auto") == MATCH_YES)
4315 8 : c->sched_kind = OMP_SCHED_AUTO;
4316 809 : if (c->sched_kind != OMP_SCHED_NONE)
4317 : {
4318 809 : m = MATCH_NO;
4319 809 : if (c->sched_kind != OMP_SCHED_RUNTIME
4320 809 : && c->sched_kind != OMP_SCHED_AUTO)
4321 716 : m = gfc_match (" , %e )", &c->chunk_size);
4322 716 : if (m != MATCH_YES)
4323 299 : m = gfc_match_char (')');
4324 299 : if (m != MATCH_YES)
4325 0 : c->sched_kind = OMP_SCHED_NONE;
4326 : }
4327 809 : if (c->sched_kind != OMP_SCHED_NONE)
4328 809 : continue;
4329 : else
4330 0 : gfc_current_locus = old_loc;
4331 : }
4332 2317 : if ((mask & OMP_CLAUSE_SELF)
4333 335 : && !(mask & OMP_CLAUSE_HOST) /* OpenACC compute construct */
4334 2374 : && (m = gfc_match_dupl_check (!c->self_expr, "self"))
4335 : != MATCH_NO)
4336 : {
4337 186 : if (m == MATCH_ERROR)
4338 3 : goto error;
4339 183 : m = gfc_match (" ( %e )", &c->self_expr);
4340 183 : if (m == MATCH_ERROR)
4341 : {
4342 0 : gfc_current_locus = old_loc;
4343 0 : break;
4344 : }
4345 183 : else if (m == MATCH_NO)
4346 9 : c->self_expr = gfc_get_logical_expr (gfc_default_logical_kind,
4347 : NULL, true);
4348 183 : continue;
4349 : }
4350 2042 : if ((mask & OMP_CLAUSE_SELF)
4351 149 : && (mask & OMP_CLAUSE_HOST) /* OpenACC 'update' directive */
4352 95 : && gfc_match ("self ( ") == MATCH_YES
4353 2043 : && gfc_match_omp_map_clause (&c->lists[OMP_LIST_MAP],
4354 : OMP_MAP_FORCE_FROM, true,
4355 : /* allow_derived = */ true))
4356 94 : continue;
4357 2202 : if ((mask & OMP_CLAUSE_SEQ)
4358 1854 : && (m = gfc_match_dupl_check (!c->seq, "seq")) != MATCH_NO)
4359 : {
4360 348 : if (m == MATCH_ERROR)
4361 0 : goto error;
4362 348 : c->seq = true;
4363 348 : continue;
4364 : }
4365 1647 : if ((mask & OMP_CLAUSE_MEMORDER)
4366 1647 : && (m = gfc_match_dupl_memorder ((c->memorder
4367 141 : == OMP_MEMORDER_UNSET),
4368 : "seq_cst")) != MATCH_NO)
4369 : {
4370 141 : if (m == MATCH_ERROR)
4371 0 : goto error;
4372 141 : c->memorder = OMP_MEMORDER_SEQ_CST;
4373 141 : continue;
4374 : }
4375 2340 : if ((mask & OMP_CLAUSE_SHARED)
4376 1365 : && gfc_match_omp_variable_list ("shared (",
4377 : &c->lists[OMP_LIST_SHARED],
4378 : true) == MATCH_YES)
4379 975 : continue;
4380 508 : if ((mask & OMP_CLAUSE_SIMDLEN)
4381 390 : && (m = gfc_match_dupl_check (!c->simdlen_expr, "simdlen", true,
4382 : &c->simdlen_expr)) != MATCH_NO)
4383 : {
4384 118 : if (m == MATCH_ERROR)
4385 0 : goto error;
4386 118 : continue;
4387 : }
4388 294 : if ((mask & OMP_CLAUSE_SIMD)
4389 272 : && (m = gfc_match_dupl_check (!c->simd, "simd")) != MATCH_NO)
4390 : {
4391 22 : if (m == MATCH_ERROR)
4392 0 : goto error;
4393 22 : c->simd = true;
4394 22 : continue;
4395 : }
4396 289 : if ((mask & OMP_CLAUSE_SEVERITY)
4397 250 : && (m = gfc_match_dupl_check (!c->severity, "severity", true))
4398 : != MATCH_NO)
4399 : {
4400 45 : if (m == MATCH_ERROR)
4401 2 : goto error;
4402 43 : if (gfc_match ("fatal )") == MATCH_YES)
4403 10 : c->severity = OMP_SEVERITY_FATAL;
4404 33 : else if (gfc_match ("warning )") == MATCH_YES)
4405 29 : c->severity = OMP_SEVERITY_WARNING;
4406 : else
4407 : {
4408 4 : gfc_error ("Expected FATAL or WARNING in SEVERITY clause "
4409 : "at %C");
4410 4 : goto error;
4411 : }
4412 39 : continue;
4413 : }
4414 205 : if ((mask & OMP_CLAUSE_SIZES)
4415 205 : && ((m = gfc_match_dupl_check (!c->sizes_list, "sizes"))
4416 : != MATCH_NO))
4417 : {
4418 203 : if (m == MATCH_ERROR)
4419 0 : goto error;
4420 203 : m = match_omp_oacc_expr_list (" (", &c->sizes_list, false, true);
4421 203 : if (m == MATCH_ERROR)
4422 7 : goto error;
4423 196 : if (m == MATCH_YES)
4424 195 : continue;
4425 1 : gfc_error ("Expected %<(%> after %qs at %C", "sizes");
4426 1 : goto error;
4427 : }
4428 : break;
4429 1203 : case 't':
4430 1268 : if ((mask & OMP_CLAUSE_TASK_REDUCTION)
4431 1203 : && gfc_match_omp_clause_reduction (pc, c, openacc,
4432 : allow_derived) == MATCH_YES)
4433 65 : continue;
4434 1210 : if ((mask & OMP_CLAUSE_THREAD_LIMIT)
4435 1138 : && (m = gfc_match_dupl_check (!c->thread_limit, "thread_limit",
4436 : true, &c->thread_limit))
4437 : != MATCH_NO)
4438 : {
4439 72 : if (m == MATCH_ERROR)
4440 0 : goto error;
4441 72 : continue;
4442 : }
4443 1079 : if ((mask & OMP_CLAUSE_THREADS)
4444 1066 : && (m = gfc_match_dupl_check (!c->threads, "threads"))
4445 : != MATCH_NO)
4446 : {
4447 13 : if (m == MATCH_ERROR)
4448 0 : goto error;
4449 13 : c->threads = true;
4450 13 : continue;
4451 : }
4452 1250 : if ((mask & OMP_CLAUSE_TILE)
4453 221 : && !c->tile_list
4454 1274 : && match_omp_oacc_expr_list ("tile (", &c->tile_list,
4455 : true, false) == MATCH_YES)
4456 197 : continue;
4457 856 : if ((mask & OMP_CLAUSE_TO) && (mask & OMP_CLAUSE_LINK))
4458 : {
4459 : /* Declare target: 'to' is an alias for 'enter';
4460 : 'to' is deprecated since 5.2. */
4461 116 : m = gfc_match_omp_to_link ("to (", &c->lists[OMP_LIST_TO]);
4462 116 : if (m == MATCH_ERROR)
4463 0 : goto error;
4464 116 : if (m == MATCH_YES)
4465 : {
4466 116 : gfc_warning (OPT_Wdeprecated_openmp,
4467 : "%<to%> clause with %<declare target%> at %L "
4468 : "deprecated since OpenMP 5.2, use %<enter%>",
4469 : &old_loc);
4470 116 : continue;
4471 : }
4472 : }
4473 1456 : else if ((mask & OMP_CLAUSE_TO)
4474 740 : && gfc_match_motion_var_list ("to (", &c->lists[OMP_LIST_TO],
4475 : &head) == MATCH_YES)
4476 716 : continue;
4477 : break;
4478 1516 : case 'u':
4479 1574 : if ((mask & OMP_CLAUSE_UNIFORM)
4480 1516 : && gfc_match_omp_variable_list ("uniform (",
4481 : &c->lists[OMP_LIST_UNIFORM],
4482 : false) == MATCH_YES)
4483 58 : continue;
4484 1599 : if ((mask & OMP_CLAUSE_UNTIED)
4485 1458 : && (m = gfc_match_dupl_check (!c->untied, "untied")) != MATCH_NO)
4486 : {
4487 141 : if (m == MATCH_ERROR)
4488 0 : goto error;
4489 141 : c->untied = true;
4490 141 : continue;
4491 : }
4492 1561 : if ((mask & OMP_CLAUSE_ATOMIC)
4493 1317 : && (m = gfc_match_dupl_atomic ((c->atomic_op
4494 : == GFC_OMP_ATOMIC_UNSET),
4495 : "update")) != MATCH_NO)
4496 : {
4497 245 : if (m == MATCH_ERROR)
4498 1 : goto error;
4499 244 : c->atomic_op = GFC_OMP_ATOMIC_UPDATE;
4500 244 : continue;
4501 : }
4502 1094 : if ((mask & OMP_CLAUSE_USE)
4503 1072 : && gfc_match_omp_variable_list ("use (",
4504 : &c->lists[OMP_LIST_USE],
4505 : true) == MATCH_YES)
4506 22 : continue;
4507 1110 : if ((mask & OMP_CLAUSE_USE_DEVICE)
4508 1050 : && gfc_match_omp_variable_list ("use_device (",
4509 : &c->lists[OMP_LIST_USE_DEVICE],
4510 : true) == MATCH_YES)
4511 60 : continue;
4512 1153 : if ((mask & OMP_CLAUSE_USE_DEVICE_PTR)
4513 1918 : && gfc_match_omp_variable_list
4514 928 : ("use_device_ptr (",
4515 : &c->lists[OMP_LIST_USE_DEVICE_PTR], false) == MATCH_YES)
4516 163 : continue;
4517 1592 : if ((mask & OMP_CLAUSE_USE_DEVICE_ADDR)
4518 1592 : && gfc_match_omp_variable_list
4519 765 : ("use_device_addr (", &c->lists[OMP_LIST_USE_DEVICE_ADDR],
4520 : false, NULL, NULL, true) == MATCH_YES)
4521 765 : continue;
4522 114 : if ((mask & OMP_CLAUSE_USES_ALLOCATORS)
4523 62 : && (gfc_match ("uses_allocators ( ") == MATCH_YES))
4524 : {
4525 56 : if (gfc_match_omp_clause_uses_allocators (c) != MATCH_YES)
4526 4 : goto error;
4527 52 : continue;
4528 : }
4529 : break;
4530 1570 : case 'v':
4531 : /* VECTOR_LENGTH must be matched before VECTOR, because the latter
4532 : doesn't unconditionally match '('. */
4533 2139 : if ((mask & OMP_CLAUSE_VECTOR_LENGTH)
4534 1570 : && (m = gfc_match_dupl_check (!c->vector_length_expr,
4535 : "vector_length", true,
4536 : &c->vector_length_expr))
4537 : != MATCH_NO)
4538 : {
4539 573 : if (m == MATCH_ERROR)
4540 4 : goto error;
4541 569 : continue;
4542 : }
4543 1989 : if ((mask & OMP_CLAUSE_VECTOR)
4544 997 : && (m = gfc_match_dupl_check (!c->vector, "vector")) != MATCH_NO)
4545 : {
4546 995 : if (m == MATCH_ERROR)
4547 0 : goto error;
4548 995 : c->vector = true;
4549 995 : m = match_oacc_clause_gwv (c, GOMP_DIM_VECTOR);
4550 995 : if (m == MATCH_ERROR)
4551 3 : goto error;
4552 992 : continue;
4553 : }
4554 : break;
4555 1482 : case 'w':
4556 1482 : if ((mask & OMP_CLAUSE_WAIT)
4557 1482 : && gfc_match ("wait") == MATCH_YES)
4558 : {
4559 192 : m = match_omp_oacc_expr_list (" (", &c->wait_list, false, false);
4560 192 : if (m == MATCH_ERROR)
4561 9 : goto error;
4562 183 : else if (m == MATCH_NO)
4563 : {
4564 47 : gfc_expr *expr
4565 47 : = gfc_get_constant_expr (BT_INTEGER,
4566 : gfc_default_integer_kind,
4567 : &gfc_current_locus);
4568 47 : mpz_set_si (expr->value.integer, GOMP_ASYNC_NOVAL);
4569 47 : gfc_expr_list **expr_list = &c->wait_list;
4570 56 : while (*expr_list)
4571 9 : expr_list = &(*expr_list)->next;
4572 47 : *expr_list = gfc_get_expr_list ();
4573 47 : (*expr_list)->expr = expr;
4574 47 : needs_space = true;
4575 : }
4576 183 : continue;
4577 183 : }
4578 1303 : if ((mask & OMP_CLAUSE_WEAK)
4579 1290 : && (m = gfc_match_dupl_check (!c->weak, "weak"))
4580 : != MATCH_NO)
4581 : {
4582 14 : if (m == MATCH_ERROR)
4583 1 : goto error;
4584 13 : c->weak = true;
4585 13 : continue;
4586 : }
4587 2137 : if ((mask & OMP_CLAUSE_WORKER)
4588 1276 : && (m = gfc_match_dupl_check (!c->worker, "worker")) != MATCH_NO)
4589 : {
4590 864 : if (m == MATCH_ERROR)
4591 0 : goto error;
4592 864 : c->worker = true;
4593 864 : m = match_oacc_clause_gwv (c, GOMP_DIM_WORKER);
4594 864 : if (m == MATCH_ERROR)
4595 3 : goto error;
4596 861 : continue;
4597 : }
4598 824 : if ((mask & OMP_CLAUSE_ATOMIC)
4599 412 : && (m = gfc_match_dupl_atomic ((c->atomic_op
4600 : == GFC_OMP_ATOMIC_UNSET),
4601 : "write")) != MATCH_NO)
4602 : {
4603 412 : if (m == MATCH_ERROR)
4604 0 : goto error;
4605 412 : c->atomic_op = GFC_OMP_ATOMIC_WRITE;
4606 412 : continue;
4607 : }
4608 : break;
4609 : }
4610 : break;
4611 46071 : }
4612 :
4613 34401 : end:
4614 34146 : if (error || gfc_match_omp_eos () != MATCH_YES)
4615 : {
4616 523 : if (!gfc_error_flag_test ())
4617 138 : gfc_error ("Failed to match clause at %C");
4618 523 : gfc_free_omp_clauses (c);
4619 523 : return MATCH_ERROR;
4620 : }
4621 :
4622 33878 : *cp = c;
4623 33878 : return MATCH_YES;
4624 :
4625 255 : error:
4626 255 : error = true;
4627 255 : goto end;
4628 : }
4629 :
4630 :
4631 : #define OACC_PARALLEL_CLAUSES \
4632 : (omp_mask (OMP_CLAUSE_IF) | OMP_CLAUSE_ASYNC | OMP_CLAUSE_NUM_GANGS \
4633 : | OMP_CLAUSE_NUM_WORKERS | OMP_CLAUSE_VECTOR_LENGTH | OMP_CLAUSE_REDUCTION \
4634 : | OMP_CLAUSE_COPY | OMP_CLAUSE_COPYIN | OMP_CLAUSE_COPYOUT \
4635 : | OMP_CLAUSE_CREATE | OMP_CLAUSE_NO_CREATE | OMP_CLAUSE_PRESENT \
4636 : | OMP_CLAUSE_DEVICEPTR | OMP_CLAUSE_PRIVATE | OMP_CLAUSE_FIRSTPRIVATE \
4637 : | OMP_CLAUSE_DEFAULT | OMP_CLAUSE_WAIT | OMP_CLAUSE_ATTACH \
4638 : | OMP_CLAUSE_SELF)
4639 : #define OACC_KERNELS_CLAUSES \
4640 : (omp_mask (OMP_CLAUSE_IF) | OMP_CLAUSE_ASYNC | OMP_CLAUSE_NUM_GANGS \
4641 : | OMP_CLAUSE_NUM_WORKERS | OMP_CLAUSE_VECTOR_LENGTH | OMP_CLAUSE_DEVICEPTR \
4642 : | OMP_CLAUSE_COPY | OMP_CLAUSE_COPYIN | OMP_CLAUSE_COPYOUT \
4643 : | OMP_CLAUSE_CREATE | OMP_CLAUSE_NO_CREATE | OMP_CLAUSE_PRESENT \
4644 : | OMP_CLAUSE_DEFAULT | OMP_CLAUSE_WAIT | OMP_CLAUSE_ATTACH \
4645 : | OMP_CLAUSE_SELF)
4646 : #define OACC_SERIAL_CLAUSES \
4647 : (omp_mask (OMP_CLAUSE_IF) | OMP_CLAUSE_ASYNC | OMP_CLAUSE_REDUCTION \
4648 : | OMP_CLAUSE_COPY | OMP_CLAUSE_COPYIN | OMP_CLAUSE_COPYOUT \
4649 : | OMP_CLAUSE_CREATE | OMP_CLAUSE_NO_CREATE | OMP_CLAUSE_PRESENT \
4650 : | OMP_CLAUSE_DEVICEPTR | OMP_CLAUSE_PRIVATE | OMP_CLAUSE_FIRSTPRIVATE \
4651 : | OMP_CLAUSE_DEFAULT | OMP_CLAUSE_WAIT | OMP_CLAUSE_ATTACH \
4652 : | OMP_CLAUSE_SELF)
4653 : #define OACC_DATA_CLAUSES \
4654 : (omp_mask (OMP_CLAUSE_IF) | OMP_CLAUSE_DEVICEPTR | OMP_CLAUSE_COPY \
4655 : | OMP_CLAUSE_COPYIN | OMP_CLAUSE_COPYOUT | OMP_CLAUSE_CREATE \
4656 : | OMP_CLAUSE_NO_CREATE | OMP_CLAUSE_PRESENT | OMP_CLAUSE_ATTACH \
4657 : | OMP_CLAUSE_DEFAULT)
4658 : #define OACC_LOOP_CLAUSES \
4659 : (omp_mask (OMP_CLAUSE_COLLAPSE) | OMP_CLAUSE_GANG | OMP_CLAUSE_WORKER \
4660 : | OMP_CLAUSE_VECTOR | OMP_CLAUSE_SEQ | OMP_CLAUSE_INDEPENDENT \
4661 : | OMP_CLAUSE_PRIVATE | OMP_CLAUSE_REDUCTION | OMP_CLAUSE_AUTO \
4662 : | OMP_CLAUSE_TILE)
4663 : #define OACC_PARALLEL_LOOP_CLAUSES \
4664 : (OACC_LOOP_CLAUSES | OACC_PARALLEL_CLAUSES)
4665 : #define OACC_KERNELS_LOOP_CLAUSES \
4666 : (OACC_LOOP_CLAUSES | OACC_KERNELS_CLAUSES)
4667 : #define OACC_SERIAL_LOOP_CLAUSES \
4668 : (OACC_LOOP_CLAUSES | OACC_SERIAL_CLAUSES)
4669 : #define OACC_HOST_DATA_CLAUSES \
4670 : (omp_mask (OMP_CLAUSE_USE_DEVICE) \
4671 : | OMP_CLAUSE_IF \
4672 : | OMP_CLAUSE_IF_PRESENT)
4673 : #define OACC_DECLARE_CLAUSES \
4674 : (omp_mask (OMP_CLAUSE_COPY) | OMP_CLAUSE_COPYIN | OMP_CLAUSE_COPYOUT \
4675 : | OMP_CLAUSE_CREATE | OMP_CLAUSE_DEVICEPTR | OMP_CLAUSE_DEVICE_RESIDENT \
4676 : | OMP_CLAUSE_PRESENT \
4677 : | OMP_CLAUSE_LINK)
4678 : #define OACC_UPDATE_CLAUSES \
4679 : (omp_mask (OMP_CLAUSE_IF) | OMP_CLAUSE_ASYNC | OMP_CLAUSE_HOST \
4680 : | OMP_CLAUSE_DEVICE | OMP_CLAUSE_WAIT | OMP_CLAUSE_IF_PRESENT \
4681 : | OMP_CLAUSE_SELF)
4682 : #define OACC_ENTER_DATA_CLAUSES \
4683 : (omp_mask (OMP_CLAUSE_IF) | OMP_CLAUSE_ASYNC | OMP_CLAUSE_WAIT \
4684 : | OMP_CLAUSE_COPYIN | OMP_CLAUSE_CREATE | OMP_CLAUSE_ATTACH)
4685 : #define OACC_EXIT_DATA_CLAUSES \
4686 : (omp_mask (OMP_CLAUSE_IF) | OMP_CLAUSE_ASYNC | OMP_CLAUSE_WAIT \
4687 : | OMP_CLAUSE_COPYOUT | OMP_CLAUSE_DELETE | OMP_CLAUSE_FINALIZE \
4688 : | OMP_CLAUSE_DETACH)
4689 : #define OACC_WAIT_CLAUSES \
4690 : omp_mask (OMP_CLAUSE_ASYNC) | OMP_CLAUSE_IF
4691 : #define OACC_ROUTINE_CLAUSES \
4692 : (omp_mask (OMP_CLAUSE_GANG) | OMP_CLAUSE_WORKER | OMP_CLAUSE_VECTOR \
4693 : | OMP_CLAUSE_SEQ \
4694 : | OMP_CLAUSE_NOHOST)
4695 :
4696 :
4697 : static match
4698 11804 : match_acc (gfc_exec_op op, const omp_mask mask)
4699 : {
4700 11804 : gfc_omp_clauses *c;
4701 11804 : if (gfc_match_omp_clauses (&c, mask, false, false, true) != MATCH_YES)
4702 : return MATCH_ERROR;
4703 11599 : new_st.op = op;
4704 11599 : new_st.ext.omp_clauses = c;
4705 11599 : return MATCH_YES;
4706 : }
4707 :
4708 : match
4709 1378 : gfc_match_oacc_parallel_loop (void)
4710 : {
4711 1378 : return match_acc (EXEC_OACC_PARALLEL_LOOP, OACC_PARALLEL_LOOP_CLAUSES);
4712 : }
4713 :
4714 :
4715 : match
4716 2974 : gfc_match_oacc_parallel (void)
4717 : {
4718 2974 : return match_acc (EXEC_OACC_PARALLEL, OACC_PARALLEL_CLAUSES);
4719 : }
4720 :
4721 :
4722 : match
4723 129 : gfc_match_oacc_kernels_loop (void)
4724 : {
4725 129 : return match_acc (EXEC_OACC_KERNELS_LOOP, OACC_KERNELS_LOOP_CLAUSES);
4726 : }
4727 :
4728 :
4729 : match
4730 906 : gfc_match_oacc_kernels (void)
4731 : {
4732 906 : return match_acc (EXEC_OACC_KERNELS, OACC_KERNELS_CLAUSES);
4733 : }
4734 :
4735 :
4736 : match
4737 230 : gfc_match_oacc_serial_loop (void)
4738 : {
4739 230 : return match_acc (EXEC_OACC_SERIAL_LOOP, OACC_SERIAL_LOOP_CLAUSES);
4740 : }
4741 :
4742 :
4743 : match
4744 359 : gfc_match_oacc_serial (void)
4745 : {
4746 359 : return match_acc (EXEC_OACC_SERIAL, OACC_SERIAL_CLAUSES);
4747 : }
4748 :
4749 :
4750 : match
4751 689 : gfc_match_oacc_data (void)
4752 : {
4753 689 : return match_acc (EXEC_OACC_DATA, OACC_DATA_CLAUSES);
4754 : }
4755 :
4756 :
4757 : match
4758 65 : gfc_match_oacc_host_data (void)
4759 : {
4760 65 : return match_acc (EXEC_OACC_HOST_DATA, OACC_HOST_DATA_CLAUSES);
4761 : }
4762 :
4763 :
4764 : match
4765 3585 : gfc_match_oacc_loop (void)
4766 : {
4767 3585 : return match_acc (EXEC_OACC_LOOP, OACC_LOOP_CLAUSES);
4768 : }
4769 :
4770 :
4771 : match
4772 178 : gfc_match_oacc_declare (void)
4773 : {
4774 178 : gfc_omp_clauses *c;
4775 178 : gfc_omp_namelist *n;
4776 178 : gfc_namespace *ns = gfc_current_ns;
4777 178 : gfc_oacc_declare *new_oc;
4778 178 : bool module_var = false;
4779 178 : locus where = gfc_current_locus;
4780 :
4781 178 : if (gfc_match_omp_clauses (&c, OACC_DECLARE_CLAUSES, false, false, true)
4782 : != MATCH_YES)
4783 : return MATCH_ERROR;
4784 :
4785 262 : for (n = c->lists[OMP_LIST_DEVICE_RESIDENT]; n != NULL; n = n->next)
4786 90 : n->sym->attr.oacc_declare_device_resident = 1;
4787 :
4788 192 : for (n = c->lists[OMP_LIST_LINK]; n != NULL; n = n->next)
4789 20 : n->sym->attr.oacc_declare_link = 1;
4790 :
4791 318 : for (n = c->lists[OMP_LIST_MAP]; n != NULL; n = n->next)
4792 : {
4793 156 : gfc_symbol *s = n->sym;
4794 :
4795 156 : if (gfc_current_ns->proc_name
4796 156 : && gfc_current_ns->proc_name->attr.flavor == FL_MODULE)
4797 : {
4798 52 : if (n->u.map.op != OMP_MAP_ALLOC && n->u.map.op != OMP_MAP_TO)
4799 : {
4800 6 : gfc_error ("Invalid clause in module with !$ACC DECLARE at %L",
4801 : &where);
4802 6 : return MATCH_ERROR;
4803 : }
4804 :
4805 : module_var = true;
4806 : }
4807 :
4808 150 : if (s->attr.use_assoc)
4809 : {
4810 0 : gfc_error ("Variable is USE-associated with !$ACC DECLARE at %L",
4811 : &where);
4812 0 : return MATCH_ERROR;
4813 : }
4814 :
4815 150 : if ((s->result == s && s->ns->contained != gfc_current_ns)
4816 150 : || ((s->attr.flavor == FL_UNKNOWN || s->attr.flavor == FL_VARIABLE)
4817 135 : && s->ns != gfc_current_ns))
4818 : {
4819 2 : gfc_error ("Variable %qs shall be declared in the same scoping unit "
4820 : "as !$ACC DECLARE at %L", s->name, &where);
4821 2 : return MATCH_ERROR;
4822 : }
4823 :
4824 148 : if ((s->attr.dimension || s->attr.codimension)
4825 76 : && s->attr.dummy && s->as->type != AS_EXPLICIT)
4826 : {
4827 2 : gfc_error ("Assumed-size dummy array with !$ACC DECLARE at %L",
4828 : &where);
4829 2 : return MATCH_ERROR;
4830 : }
4831 :
4832 146 : switch (n->u.map.op)
4833 : {
4834 49 : case OMP_MAP_FORCE_ALLOC:
4835 49 : case OMP_MAP_ALLOC:
4836 49 : s->attr.oacc_declare_create = 1;
4837 49 : break;
4838 :
4839 63 : case OMP_MAP_FORCE_TO:
4840 63 : case OMP_MAP_TO:
4841 63 : s->attr.oacc_declare_copyin = 1;
4842 63 : break;
4843 :
4844 1 : case OMP_MAP_FORCE_DEVICEPTR:
4845 1 : s->attr.oacc_declare_deviceptr = 1;
4846 1 : break;
4847 :
4848 : default:
4849 : break;
4850 : }
4851 : }
4852 :
4853 162 : new_oc = gfc_get_oacc_declare ();
4854 162 : new_oc->next = ns->oacc_declare;
4855 162 : new_oc->module_var = module_var;
4856 162 : new_oc->clauses = c;
4857 162 : new_oc->loc = gfc_current_locus;
4858 162 : ns->oacc_declare = new_oc;
4859 :
4860 162 : return MATCH_YES;
4861 : }
4862 :
4863 :
4864 : match
4865 760 : gfc_match_oacc_update (void)
4866 : {
4867 760 : gfc_omp_clauses *c;
4868 760 : locus here = gfc_current_locus;
4869 :
4870 760 : if (gfc_match_omp_clauses (&c, OACC_UPDATE_CLAUSES, false, false, true)
4871 : != MATCH_YES)
4872 : return MATCH_ERROR;
4873 :
4874 756 : if (!c->lists[OMP_LIST_MAP])
4875 : {
4876 1 : gfc_error ("%<acc update%> must contain at least one "
4877 : "%<device%> or %<host%> or %<self%> clause at %L", &here);
4878 1 : return MATCH_ERROR;
4879 : }
4880 :
4881 755 : new_st.op = EXEC_OACC_UPDATE;
4882 755 : new_st.ext.omp_clauses = c;
4883 755 : return MATCH_YES;
4884 : }
4885 :
4886 :
4887 : match
4888 877 : gfc_match_oacc_enter_data (void)
4889 : {
4890 877 : return match_acc (EXEC_OACC_ENTER_DATA, OACC_ENTER_DATA_CLAUSES);
4891 : }
4892 :
4893 :
4894 : match
4895 612 : gfc_match_oacc_exit_data (void)
4896 : {
4897 612 : return match_acc (EXEC_OACC_EXIT_DATA, OACC_EXIT_DATA_CLAUSES);
4898 : }
4899 :
4900 :
4901 : match
4902 203 : gfc_match_oacc_wait (void)
4903 : {
4904 203 : gfc_omp_clauses *c = gfc_get_omp_clauses ();
4905 203 : gfc_expr_list *wait_list = NULL, *el;
4906 203 : bool space = true;
4907 203 : match m;
4908 :
4909 203 : m = match_omp_oacc_expr_list (" (", &wait_list, true, false);
4910 203 : if (m == MATCH_ERROR)
4911 : return m;
4912 197 : else if (m == MATCH_YES)
4913 126 : space = false;
4914 :
4915 197 : if (gfc_match_omp_clauses (&c, OACC_WAIT_CLAUSES, space, space, true)
4916 : == MATCH_ERROR)
4917 : return MATCH_ERROR;
4918 :
4919 184 : if (wait_list)
4920 261 : for (el = wait_list; el; el = el->next)
4921 : {
4922 140 : if (el->expr == NULL)
4923 : {
4924 2 : gfc_error ("Invalid argument to !$ACC WAIT at %C");
4925 2 : return MATCH_ERROR;
4926 : }
4927 :
4928 138 : if (!gfc_resolve_expr (el->expr)
4929 138 : || el->expr->ts.type != BT_INTEGER || el->expr->rank != 0)
4930 : {
4931 3 : gfc_error ("WAIT clause at %L requires a scalar INTEGER expression",
4932 3 : &el->expr->where);
4933 :
4934 3 : return MATCH_ERROR;
4935 : }
4936 : }
4937 179 : c->wait_list = wait_list;
4938 179 : new_st.op = EXEC_OACC_WAIT;
4939 179 : new_st.ext.omp_clauses = c;
4940 179 : return MATCH_YES;
4941 : }
4942 :
4943 :
4944 : match
4945 97 : gfc_match_oacc_cache (void)
4946 : {
4947 97 : bool readonly = false;
4948 97 : gfc_omp_clauses *c = gfc_get_omp_clauses ();
4949 : /* The OpenACC cache directive explicitly only allows "array elements or
4950 : subarrays", which we're currently not checking here. Either check this
4951 : after the call of gfc_match_omp_variable_list, or add something like a
4952 : only_sections variant next to its allow_sections parameter. */
4953 97 : match m = gfc_match (" ( ");
4954 97 : if (m != MATCH_YES)
4955 : {
4956 0 : gfc_free_omp_clauses(c);
4957 0 : return m;
4958 : }
4959 :
4960 97 : if (gfc_match ("readonly : ") == MATCH_YES)
4961 8 : readonly = true;
4962 :
4963 97 : gfc_omp_namelist **head = NULL;
4964 97 : m = gfc_match_omp_variable_list ("", &c->lists[OMP_LIST_CACHE], true,
4965 : NULL, &head, true);
4966 97 : if (m != MATCH_YES)
4967 : {
4968 2 : gfc_free_omp_clauses(c);
4969 2 : return m;
4970 : }
4971 :
4972 95 : if (readonly)
4973 24 : for (gfc_omp_namelist *n = *head; n; n = n->next)
4974 16 : n->u.map.readonly = true;
4975 :
4976 95 : if (gfc_current_state() != COMP_DO
4977 56 : && gfc_current_state() != COMP_DO_CONCURRENT)
4978 : {
4979 2 : gfc_error ("ACC CACHE directive must be inside of loop %C");
4980 2 : gfc_free_omp_clauses(c);
4981 2 : return MATCH_ERROR;
4982 : }
4983 :
4984 93 : new_st.op = EXEC_OACC_CACHE;
4985 93 : new_st.ext.omp_clauses = c;
4986 93 : return MATCH_YES;
4987 : }
4988 :
4989 : /* Determine the OpenACC 'routine' directive's level of parallelism. */
4990 :
4991 : static oacc_routine_lop
4992 734 : gfc_oacc_routine_lop (gfc_omp_clauses *clauses)
4993 : {
4994 734 : oacc_routine_lop ret = OACC_ROUTINE_LOP_SEQ;
4995 :
4996 734 : if (clauses)
4997 : {
4998 584 : unsigned n_lop_clauses = 0;
4999 :
5000 584 : if (clauses->gang)
5001 : {
5002 164 : ++n_lop_clauses;
5003 164 : ret = OACC_ROUTINE_LOP_GANG;
5004 : }
5005 584 : if (clauses->worker)
5006 : {
5007 114 : ++n_lop_clauses;
5008 114 : ret = OACC_ROUTINE_LOP_WORKER;
5009 : }
5010 584 : if (clauses->vector)
5011 : {
5012 116 : ++n_lop_clauses;
5013 116 : ret = OACC_ROUTINE_LOP_VECTOR;
5014 : }
5015 584 : if (clauses->seq)
5016 : {
5017 206 : ++n_lop_clauses;
5018 206 : ret = OACC_ROUTINE_LOP_SEQ;
5019 : }
5020 :
5021 584 : if (n_lop_clauses > 1)
5022 47 : ret = OACC_ROUTINE_LOP_ERROR;
5023 : }
5024 :
5025 734 : return ret;
5026 : }
5027 :
5028 : match
5029 698 : gfc_match_oacc_routine (void)
5030 : {
5031 698 : locus old_loc;
5032 698 : match m;
5033 698 : gfc_intrinsic_sym *isym = NULL;
5034 698 : gfc_symbol *sym = NULL;
5035 698 : gfc_omp_clauses *c = NULL;
5036 698 : gfc_oacc_routine_name *n = NULL;
5037 698 : oacc_routine_lop lop = OACC_ROUTINE_LOP_NONE;
5038 698 : bool nohost;
5039 :
5040 698 : old_loc = gfc_current_locus;
5041 :
5042 698 : m = gfc_match (" (");
5043 :
5044 698 : if (gfc_current_ns->proc_name
5045 696 : && gfc_current_ns->proc_name->attr.if_source == IFSRC_IFBODY
5046 90 : && m == MATCH_YES)
5047 : {
5048 3 : gfc_error ("Only the !$ACC ROUTINE form without "
5049 : "list is allowed in interface block at %C");
5050 3 : goto cleanup;
5051 : }
5052 :
5053 608 : if (m == MATCH_YES)
5054 : {
5055 295 : char buffer[GFC_MAX_SYMBOL_LEN + 1];
5056 :
5057 295 : m = gfc_match_name (buffer);
5058 295 : if (m == MATCH_YES)
5059 : {
5060 294 : gfc_symtree *st = NULL;
5061 :
5062 : /* First look for an intrinsic symbol. */
5063 294 : isym = gfc_find_function (buffer);
5064 294 : if (!isym)
5065 294 : isym = gfc_find_subroutine (buffer);
5066 : /* If no intrinsic symbol found, search the current namespace. */
5067 294 : if (!isym)
5068 276 : st = gfc_find_symtree (gfc_current_ns->sym_root, buffer);
5069 276 : if (st)
5070 : {
5071 270 : sym = st->n.sym;
5072 : /* If the name in a 'routine' directive refers to the containing
5073 : subroutine or function, then make sure that we'll later handle
5074 : this accordingly. */
5075 270 : if (gfc_current_ns->proc_name != NULL
5076 270 : && strcmp (sym->name, gfc_current_ns->proc_name->name) == 0)
5077 294 : sym = NULL;
5078 : }
5079 :
5080 294 : if (isym == NULL && st == NULL)
5081 : {
5082 6 : gfc_error ("Invalid NAME %qs in !$ACC ROUTINE ( NAME ) at %C",
5083 : buffer);
5084 6 : gfc_current_locus = old_loc;
5085 9 : return MATCH_ERROR;
5086 : }
5087 : }
5088 : else
5089 : {
5090 1 : gfc_error ("Syntax error in !$ACC ROUTINE ( NAME ) at %C");
5091 1 : gfc_current_locus = old_loc;
5092 1 : return MATCH_ERROR;
5093 : }
5094 :
5095 288 : if (gfc_match_char (')') != MATCH_YES)
5096 : {
5097 2 : gfc_error ("Syntax error in !$ACC ROUTINE ( NAME ) at %C, expecting"
5098 : " %<)%> after NAME");
5099 2 : gfc_current_locus = old_loc;
5100 2 : return MATCH_ERROR;
5101 : }
5102 : }
5103 :
5104 686 : if (gfc_match_omp_eos () != MATCH_YES
5105 686 : && (gfc_match_omp_clauses (&c, OACC_ROUTINE_CLAUSES, false, false, true)
5106 : != MATCH_YES))
5107 : return MATCH_ERROR;
5108 :
5109 683 : lop = gfc_oacc_routine_lop (c);
5110 683 : if (lop == OACC_ROUTINE_LOP_ERROR)
5111 : {
5112 47 : gfc_error ("Multiple loop axes specified for routine at %C");
5113 47 : goto cleanup;
5114 : }
5115 636 : nohost = c ? c->nohost : false;
5116 :
5117 636 : if (isym != NULL)
5118 : {
5119 : /* Diagnose any OpenACC 'routine' directive that doesn't match the
5120 : (implicit) one with a 'seq' clause. */
5121 16 : if (c && (c->gang || c->worker || c->vector))
5122 : {
5123 10 : gfc_error ("Intrinsic symbol specified in !$ACC ROUTINE ( NAME )"
5124 : " at %C marked with incompatible GANG, WORKER, or VECTOR"
5125 : " clause");
5126 10 : goto cleanup;
5127 : }
5128 : /* ..., and no 'nohost' clause. */
5129 6 : if (nohost)
5130 : {
5131 2 : gfc_error ("Intrinsic symbol specified in !$ACC ROUTINE ( NAME )"
5132 : " at %C marked with incompatible NOHOST clause");
5133 2 : goto cleanup;
5134 : }
5135 : }
5136 620 : else if (sym != NULL)
5137 : {
5138 151 : bool add = true;
5139 :
5140 : /* For a repeated OpenACC 'routine' directive, diagnose if it doesn't
5141 : match the first one. */
5142 151 : for (gfc_oacc_routine_name *n_p = gfc_current_ns->oacc_routine_names;
5143 346 : n_p;
5144 195 : n_p = n_p->next)
5145 235 : if (n_p->sym == sym)
5146 : {
5147 51 : add = false;
5148 51 : bool nohost_p = n_p->clauses ? n_p->clauses->nohost : false;
5149 51 : if (lop != gfc_oacc_routine_lop (n_p->clauses)
5150 51 : || nohost != nohost_p)
5151 : {
5152 40 : gfc_error ("!$ACC ROUTINE already applied at %C");
5153 40 : goto cleanup;
5154 : }
5155 : }
5156 :
5157 111 : if (add)
5158 : {
5159 100 : sym->attr.oacc_routine_lop = lop;
5160 100 : sym->attr.oacc_routine_nohost = nohost;
5161 :
5162 100 : n = gfc_get_oacc_routine_name ();
5163 100 : n->sym = sym;
5164 100 : n->clauses = c;
5165 100 : n->next = gfc_current_ns->oacc_routine_names;
5166 100 : n->loc = old_loc;
5167 100 : gfc_current_ns->oacc_routine_names = n;
5168 : }
5169 : }
5170 469 : else if (gfc_current_ns->proc_name)
5171 : {
5172 : /* For a repeated OpenACC 'routine' directive, diagnose if it doesn't
5173 : match the first one. */
5174 468 : oacc_routine_lop lop_p = gfc_current_ns->proc_name->attr.oacc_routine_lop;
5175 468 : bool nohost_p = gfc_current_ns->proc_name->attr.oacc_routine_nohost;
5176 468 : if (lop_p != OACC_ROUTINE_LOP_NONE
5177 86 : && (lop != lop_p
5178 86 : || nohost != nohost_p))
5179 : {
5180 56 : gfc_error ("!$ACC ROUTINE already applied at %C");
5181 56 : goto cleanup;
5182 : }
5183 :
5184 412 : if (!gfc_add_omp_declare_target (&gfc_current_ns->proc_name->attr,
5185 : gfc_current_ns->proc_name->name,
5186 : &old_loc))
5187 1 : goto cleanup;
5188 411 : gfc_current_ns->proc_name->attr.oacc_routine_lop = lop;
5189 411 : gfc_current_ns->proc_name->attr.oacc_routine_nohost = nohost;
5190 : }
5191 : else
5192 : /* Something has gone wrong, possibly a syntax error. */
5193 1 : goto cleanup;
5194 :
5195 526 : if (gfc_pure (NULL) && c && (c->gang || c->worker || c->vector))
5196 : {
5197 6 : gfc_error ("!$ACC ROUTINE with GANG, WORKER, or VECTOR clause is not "
5198 : "permitted in PURE procedure at %C");
5199 6 : goto cleanup;
5200 : }
5201 :
5202 :
5203 520 : if (n)
5204 100 : n->clauses = c;
5205 420 : else if (gfc_current_ns->oacc_routine)
5206 0 : gfc_current_ns->oacc_routine_clauses = c;
5207 :
5208 520 : new_st.op = EXEC_OACC_ROUTINE;
5209 520 : new_st.ext.omp_clauses = c;
5210 520 : return MATCH_YES;
5211 :
5212 166 : cleanup:
5213 166 : gfc_current_locus = old_loc;
5214 166 : return MATCH_ERROR;
5215 : }
5216 :
5217 :
5218 : #define OMP_PARALLEL_CLAUSES \
5219 : (omp_mask (OMP_CLAUSE_PRIVATE) | OMP_CLAUSE_FIRSTPRIVATE \
5220 : | OMP_CLAUSE_SHARED | OMP_CLAUSE_COPYIN | OMP_CLAUSE_REDUCTION \
5221 : | OMP_CLAUSE_IF | OMP_CLAUSE_NUM_THREADS | OMP_CLAUSE_DEFAULT \
5222 : | OMP_CLAUSE_PROC_BIND | OMP_CLAUSE_ALLOCATE)
5223 : #define OMP_DECLARE_SIMD_CLAUSES \
5224 : (omp_mask (OMP_CLAUSE_SIMDLEN) | OMP_CLAUSE_LINEAR \
5225 : | OMP_CLAUSE_UNIFORM | OMP_CLAUSE_ALIGNED | OMP_CLAUSE_INBRANCH \
5226 : | OMP_CLAUSE_NOTINBRANCH)
5227 : #define OMP_DO_CLAUSES \
5228 : (omp_mask (OMP_CLAUSE_PRIVATE) | OMP_CLAUSE_FIRSTPRIVATE \
5229 : | OMP_CLAUSE_LASTPRIVATE | OMP_CLAUSE_REDUCTION \
5230 : | OMP_CLAUSE_SCHEDULE | OMP_CLAUSE_ORDERED | OMP_CLAUSE_COLLAPSE \
5231 : | OMP_CLAUSE_LINEAR | OMP_CLAUSE_ORDER | OMP_CLAUSE_ALLOCATE \
5232 : | OMP_CLAUSE_NOWAIT)
5233 : #define OMP_LOOP_CLAUSES \
5234 : (omp_mask (OMP_CLAUSE_BIND) | OMP_CLAUSE_COLLAPSE | OMP_CLAUSE_ORDER \
5235 : | OMP_CLAUSE_PRIVATE | OMP_CLAUSE_LASTPRIVATE | OMP_CLAUSE_REDUCTION)
5236 :
5237 : #define OMP_SCOPE_CLAUSES \
5238 : (omp_mask (OMP_CLAUSE_PRIVATE) |OMP_CLAUSE_FIRSTPRIVATE \
5239 : | OMP_CLAUSE_REDUCTION | OMP_CLAUSE_ALLOCATE | OMP_CLAUSE_NOWAIT)
5240 : #define OMP_SECTIONS_CLAUSES \
5241 : (omp_mask (OMP_CLAUSE_PRIVATE) | OMP_CLAUSE_FIRSTPRIVATE \
5242 : | OMP_CLAUSE_LASTPRIVATE | OMP_CLAUSE_REDUCTION \
5243 : | OMP_CLAUSE_ALLOCATE | OMP_CLAUSE_NOWAIT)
5244 : #define OMP_SIMD_CLAUSES \
5245 : (omp_mask (OMP_CLAUSE_PRIVATE) | OMP_CLAUSE_LASTPRIVATE \
5246 : | OMP_CLAUSE_REDUCTION | OMP_CLAUSE_COLLAPSE | OMP_CLAUSE_SAFELEN \
5247 : | OMP_CLAUSE_LINEAR | OMP_CLAUSE_ALIGNED | OMP_CLAUSE_SIMDLEN \
5248 : | OMP_CLAUSE_IF | OMP_CLAUSE_ORDER | OMP_CLAUSE_NOTEMPORAL)
5249 : #define OMP_TASK_CLAUSES \
5250 : (omp_mask (OMP_CLAUSE_PRIVATE) | OMP_CLAUSE_FIRSTPRIVATE \
5251 : | OMP_CLAUSE_SHARED | OMP_CLAUSE_IF | OMP_CLAUSE_DEFAULT \
5252 : | OMP_CLAUSE_UNTIED | OMP_CLAUSE_FINAL | OMP_CLAUSE_MERGEABLE \
5253 : | OMP_CLAUSE_DEPEND | OMP_CLAUSE_PRIORITY | OMP_CLAUSE_IN_REDUCTION \
5254 : | OMP_CLAUSE_DETACH | OMP_CLAUSE_AFFINITY | OMP_CLAUSE_ALLOCATE)
5255 : #define OMP_TASKLOOP_CLAUSES \
5256 : (omp_mask (OMP_CLAUSE_PRIVATE) | OMP_CLAUSE_FIRSTPRIVATE \
5257 : | OMP_CLAUSE_LASTPRIVATE | OMP_CLAUSE_SHARED | OMP_CLAUSE_IF \
5258 : | OMP_CLAUSE_DEFAULT | OMP_CLAUSE_UNTIED | OMP_CLAUSE_FINAL \
5259 : | OMP_CLAUSE_MERGEABLE | OMP_CLAUSE_PRIORITY | OMP_CLAUSE_GRAINSIZE \
5260 : | OMP_CLAUSE_NUM_TASKS | OMP_CLAUSE_COLLAPSE | OMP_CLAUSE_NOGROUP \
5261 : | OMP_CLAUSE_REDUCTION | OMP_CLAUSE_IN_REDUCTION | OMP_CLAUSE_ALLOCATE)
5262 : #define OMP_TASKGROUP_CLAUSES \
5263 : (omp_mask (OMP_CLAUSE_TASK_REDUCTION) | OMP_CLAUSE_ALLOCATE)
5264 : #define OMP_TARGET_CLAUSES \
5265 : (omp_mask (OMP_CLAUSE_DEVICE) | OMP_CLAUSE_MAP | OMP_CLAUSE_IF \
5266 : | OMP_CLAUSE_DEPEND | OMP_CLAUSE_NOWAIT | OMP_CLAUSE_PRIVATE \
5267 : | OMP_CLAUSE_FIRSTPRIVATE | OMP_CLAUSE_DEFAULTMAP \
5268 : | OMP_CLAUSE_IS_DEVICE_PTR | OMP_CLAUSE_IN_REDUCTION \
5269 : | OMP_CLAUSE_THREAD_LIMIT | OMP_CLAUSE_ALLOCATE \
5270 : | OMP_CLAUSE_HAS_DEVICE_ADDR | OMP_CLAUSE_USES_ALLOCATORS \
5271 : | OMP_CLAUSE_DYN_GROUPPRIVATE | OMP_CLAUSE_DEVICE_TYPE)
5272 : #define OMP_TARGET_DATA_CLAUSES \
5273 : (omp_mask (OMP_CLAUSE_DEVICE) | OMP_CLAUSE_MAP | OMP_CLAUSE_IF \
5274 : | OMP_CLAUSE_USE_DEVICE_PTR | OMP_CLAUSE_USE_DEVICE_ADDR)
5275 : #define OMP_TARGET_ENTER_DATA_CLAUSES \
5276 : (omp_mask (OMP_CLAUSE_DEVICE) | OMP_CLAUSE_MAP | OMP_CLAUSE_IF \
5277 : | OMP_CLAUSE_DEPEND | OMP_CLAUSE_NOWAIT)
5278 : #define OMP_TARGET_EXIT_DATA_CLAUSES \
5279 : (omp_mask (OMP_CLAUSE_DEVICE) | OMP_CLAUSE_MAP | OMP_CLAUSE_IF \
5280 : | OMP_CLAUSE_DEPEND | OMP_CLAUSE_NOWAIT)
5281 : #define OMP_TARGET_UPDATE_CLAUSES \
5282 : (omp_mask (OMP_CLAUSE_DEVICE) | OMP_CLAUSE_IF | OMP_CLAUSE_TO \
5283 : | OMP_CLAUSE_FROM | OMP_CLAUSE_DEPEND | OMP_CLAUSE_NOWAIT)
5284 : #define OMP_TEAMS_CLAUSES \
5285 : (omp_mask (OMP_CLAUSE_NUM_TEAMS) | OMP_CLAUSE_THREAD_LIMIT \
5286 : | OMP_CLAUSE_DEFAULT | OMP_CLAUSE_PRIVATE | OMP_CLAUSE_FIRSTPRIVATE \
5287 : | OMP_CLAUSE_SHARED | OMP_CLAUSE_REDUCTION | OMP_CLAUSE_ALLOCATE)
5288 : #define OMP_DISTRIBUTE_CLAUSES \
5289 : (omp_mask (OMP_CLAUSE_PRIVATE) | OMP_CLAUSE_FIRSTPRIVATE \
5290 : | OMP_CLAUSE_LASTPRIVATE | OMP_CLAUSE_COLLAPSE | OMP_CLAUSE_DIST_SCHEDULE \
5291 : | OMP_CLAUSE_ORDER | OMP_CLAUSE_ALLOCATE)
5292 : #define OMP_SINGLE_CLAUSES \
5293 : (omp_mask (OMP_CLAUSE_PRIVATE) | OMP_CLAUSE_FIRSTPRIVATE \
5294 : | OMP_CLAUSE_ALLOCATE | OMP_CLAUSE_NOWAIT | OMP_CLAUSE_COPYPRIVATE)
5295 : #define OMP_ORDERED_CLAUSES \
5296 : (omp_mask (OMP_CLAUSE_THREADS) | OMP_CLAUSE_SIMD)
5297 : #define OMP_DECLARE_TARGET_CLAUSES \
5298 : (omp_mask (OMP_CLAUSE_ENTER) | OMP_CLAUSE_LINK | OMP_CLAUSE_DEVICE_TYPE \
5299 : | OMP_CLAUSE_TO | OMP_CLAUSE_INDIRECT | OMP_CLAUSE_LOCAL)
5300 : #define OMP_ATOMIC_CLAUSES \
5301 : (omp_mask (OMP_CLAUSE_ATOMIC) | OMP_CLAUSE_CAPTURE | OMP_CLAUSE_HINT \
5302 : | OMP_CLAUSE_MEMORDER | OMP_CLAUSE_COMPARE | OMP_CLAUSE_FAIL \
5303 : | OMP_CLAUSE_WEAK)
5304 : #define OMP_MASKED_CLAUSES \
5305 : (omp_mask (OMP_CLAUSE_FILTER))
5306 : #define OMP_ERROR_CLAUSES \
5307 : (omp_mask (OMP_CLAUSE_AT) | OMP_CLAUSE_MESSAGE | OMP_CLAUSE_SEVERITY)
5308 : #define OMP_WORKSHARE_CLAUSES \
5309 : omp_mask (OMP_CLAUSE_NOWAIT)
5310 : #define OMP_UNROLL_CLAUSES \
5311 : (omp_mask (OMP_CLAUSE_FULL) | OMP_CLAUSE_PARTIAL)
5312 : #define OMP_TILE_CLAUSES \
5313 : (omp_mask (OMP_CLAUSE_SIZES))
5314 : #define OMP_ALLOCATORS_CLAUSES \
5315 : omp_mask (OMP_CLAUSE_ALLOCATE)
5316 : #define OMP_INTEROP_CLAUSES \
5317 : (omp_mask (OMP_CLAUSE_DEPEND) | OMP_CLAUSE_NOWAIT | OMP_CLAUSE_DEVICE \
5318 : | OMP_CLAUSE_INIT | OMP_CLAUSE_DESTROY | OMP_CLAUSE_USE)
5319 : #define OMP_DISPATCH_CLAUSES \
5320 : (omp_mask (OMP_CLAUSE_DEVICE) | OMP_CLAUSE_DEPEND | OMP_CLAUSE_NOVARIANTS \
5321 : | OMP_CLAUSE_NOCONTEXT | OMP_CLAUSE_IS_DEVICE_PTR | OMP_CLAUSE_NOWAIT \
5322 : | OMP_CLAUSE_HAS_DEVICE_ADDR | OMP_CLAUSE_INTEROP)
5323 :
5324 :
5325 : static match
5326 17067 : match_omp (gfc_exec_op op, const omp_mask mask)
5327 : {
5328 17067 : gfc_omp_clauses *c;
5329 17067 : if (gfc_match_omp_clauses (&c, mask, true, true, false,
5330 : op == EXEC_OMP_TARGET) != MATCH_YES)
5331 : return MATCH_ERROR;
5332 16819 : new_st.op = op;
5333 16819 : new_st.ext.omp_clauses = c;
5334 16819 : return MATCH_YES;
5335 : }
5336 :
5337 : /* Handles both declarative and (deprecated) executable ALLOCATE directive;
5338 : accepts optional list (for executable) and common blocks.
5339 : If no variables have been provided, the single omp namelist has sym == NULL.
5340 :
5341 : Note that the executable ALLOCATE directive permits structure elements only
5342 : in OpenMP 5.0 and 5.1 but not longer in 5.2. See also the comment on the
5343 : 'omp allocators' directive below. The accidental change was reverted for
5344 : OpenMP TR12, permitting them again. See also gfc_match_omp_allocators.
5345 :
5346 : Hence, structure elements are rejected for now, also to make resolving
5347 : OMP_LIST_ALLOCATE simpler (check for duplicates, same symbol in
5348 : Fortran allocate stmt). TODO: Permit structure elements. */
5349 :
5350 : match
5351 274 : gfc_match_omp_allocate (void)
5352 : {
5353 274 : match m;
5354 274 : bool first = true;
5355 274 : gfc_omp_namelist *vars = NULL;
5356 274 : gfc_expr *align = NULL;
5357 274 : gfc_expr *allocator = NULL;
5358 274 : locus loc = gfc_current_locus;
5359 :
5360 274 : m = gfc_match_omp_variable_list (" (", &vars, true, NULL, NULL, true, true,
5361 : NULL, true);
5362 :
5363 274 : if (m == MATCH_ERROR)
5364 : return m;
5365 :
5366 502 : while (true)
5367 : {
5368 502 : gfc_gobble_whitespace ();
5369 502 : if (gfc_match_omp_eos () == MATCH_YES)
5370 : break;
5371 234 : if (!first)
5372 28 : gfc_match (", ");
5373 234 : first = false;
5374 234 : if ((m = gfc_match_dupl_check (!align, "align", true, &align))
5375 : != MATCH_NO)
5376 : {
5377 62 : if (m == MATCH_ERROR)
5378 1 : goto error;
5379 61 : continue;
5380 : }
5381 172 : if ((m = gfc_match_dupl_check (!allocator, "allocator",
5382 : true, &allocator)) != MATCH_NO)
5383 : {
5384 171 : if (m == MATCH_ERROR)
5385 1 : goto error;
5386 170 : continue;
5387 : }
5388 1 : gfc_error ("Expected ALIGN or ALLOCATOR clause at %C");
5389 1 : return MATCH_ERROR;
5390 : }
5391 541 : for (gfc_omp_namelist *n = vars; n; n = n->next)
5392 276 : if (n->expr)
5393 : {
5394 3 : if ((n->expr->ref && n->expr->ref->type == REF_COMPONENT)
5395 3 : || (n->expr->ref->next && n->expr->ref->type == REF_COMPONENT))
5396 1 : gfc_error ("Sorry, structure-element list item at %L in ALLOCATE "
5397 : "directive is not yet supported", &n->expr->where);
5398 : else
5399 2 : gfc_error ("Unexpected expression as list item at %L in ALLOCATE "
5400 : "directive", &n->expr->where);
5401 :
5402 3 : gfc_free_omp_namelist (vars, OMP_LIST_ALLOCATE);
5403 3 : goto error;
5404 : }
5405 :
5406 265 : new_st.op = EXEC_OMP_ALLOCATE;
5407 265 : new_st.ext.omp_clauses = gfc_get_omp_clauses ();
5408 265 : if (vars == NULL)
5409 : {
5410 27 : vars = gfc_get_omp_namelist ();
5411 27 : vars->where = loc;
5412 27 : vars->u.align = align;
5413 27 : vars->u2.allocator = allocator;
5414 27 : new_st.ext.omp_clauses->lists[OMP_LIST_ALLOCATE] = vars;
5415 : }
5416 : else
5417 : {
5418 238 : new_st.ext.omp_clauses->lists[OMP_LIST_ALLOCATE] = vars;
5419 511 : for (; vars; vars = vars->next)
5420 : {
5421 273 : vars->u.align = (align) ? gfc_copy_expr (align) : NULL;
5422 273 : vars->u2.allocator = allocator;
5423 : }
5424 238 : gfc_free_expr (align);
5425 : }
5426 : return MATCH_YES;
5427 :
5428 5 : error:
5429 5 : gfc_free_expr (align);
5430 5 : gfc_free_expr (allocator);
5431 5 : return MATCH_ERROR;
5432 : }
5433 :
5434 : /* In line with OpenMP 5.2 derived-type components are rejected.
5435 : See also comment before gfc_match_omp_allocate. */
5436 :
5437 : match
5438 26 : gfc_match_omp_allocators (void)
5439 : {
5440 26 : return match_omp (EXEC_OMP_ALLOCATORS, OMP_ALLOCATORS_CLAUSES);
5441 : }
5442 :
5443 :
5444 : match
5445 23 : gfc_match_omp_assume (void)
5446 : {
5447 23 : gfc_omp_clauses *c;
5448 23 : locus loc = gfc_current_locus;
5449 23 : if ((gfc_match_omp_clauses (&c, omp_mask (OMP_CLAUSE_ASSUMPTIONS))
5450 : != MATCH_YES)
5451 23 : || (omp_verify_merge_absent_contains (ST_OMP_ASSUME, c->assume, NULL,
5452 : &loc) != MATCH_YES))
5453 7 : return MATCH_ERROR;
5454 16 : new_st.op = EXEC_OMP_ASSUME;
5455 16 : new_st.ext.omp_clauses = c;
5456 16 : return MATCH_YES;
5457 : }
5458 :
5459 :
5460 : match
5461 28 : gfc_match_omp_assumes (void)
5462 : {
5463 28 : gfc_omp_clauses *c;
5464 28 : locus loc = gfc_current_locus;
5465 28 : if (!gfc_current_ns->proc_name
5466 27 : || (gfc_current_ns->proc_name->attr.flavor != FL_MODULE
5467 23 : && !gfc_current_ns->proc_name->attr.subroutine
5468 10 : && !gfc_current_ns->proc_name->attr.function))
5469 : {
5470 2 : gfc_error ("!$OMP ASSUMES at %C must be in the specification part of a "
5471 : "subprogram or module");
5472 2 : return MATCH_ERROR;
5473 : }
5474 26 : if ((gfc_match_omp_clauses (&c, omp_mask (OMP_CLAUSE_ASSUMPTIONS))
5475 : != MATCH_YES)
5476 50 : || (omp_verify_merge_absent_contains (ST_OMP_ASSUMES, c->assume,
5477 24 : gfc_current_ns->omp_assumes, &loc)
5478 : != MATCH_YES))
5479 5 : return MATCH_ERROR;
5480 21 : if (gfc_current_ns->omp_assumes == NULL)
5481 : {
5482 19 : gfc_current_ns->omp_assumes = c->assume;
5483 19 : c->assume = NULL;
5484 : }
5485 2 : else if (gfc_current_ns->omp_assumes && c->assume)
5486 : {
5487 2 : gfc_current_ns->omp_assumes->no_openmp |= c->assume->no_openmp;
5488 2 : gfc_current_ns->omp_assumes->no_openmp_routines
5489 2 : |= c->assume->no_openmp_routines;
5490 2 : gfc_current_ns->omp_assumes->no_openmp_constructs
5491 2 : |= c->assume->no_openmp_constructs;
5492 2 : gfc_current_ns->omp_assumes->no_parallelism |= c->assume->no_parallelism;
5493 2 : if (gfc_current_ns->omp_assumes->holds && c->assume->holds)
5494 : {
5495 : gfc_expr_list *el = gfc_current_ns->omp_assumes->holds;
5496 1 : for ( ; el->next ; el = el->next)
5497 : ;
5498 1 : el->next = c->assume->holds;
5499 1 : }
5500 1 : else if (c->assume->holds)
5501 0 : gfc_current_ns->omp_assumes->holds = c->assume->holds;
5502 2 : c->assume->holds = NULL;
5503 : }
5504 21 : gfc_free_omp_clauses (c);
5505 21 : return MATCH_YES;
5506 : }
5507 :
5508 :
5509 : match
5510 162 : gfc_match_omp_critical (void)
5511 : {
5512 162 : char n[GFC_MAX_SYMBOL_LEN+1];
5513 162 : gfc_omp_clauses *c = NULL;
5514 :
5515 162 : if (gfc_match (" ( %n )", n) != MATCH_YES)
5516 115 : n[0] = '\0';
5517 :
5518 162 : if (gfc_match_omp_clauses (&c, omp_mask (OMP_CLAUSE_HINT),
5519 162 : /* first = */ n[0] == '\0') != MATCH_YES)
5520 : return MATCH_ERROR;
5521 :
5522 160 : new_st.op = EXEC_OMP_CRITICAL;
5523 160 : new_st.ext.omp_clauses = c;
5524 160 : if (n[0])
5525 47 : c->critical_name = xstrdup (n);
5526 : return MATCH_YES;
5527 : }
5528 :
5529 :
5530 : match
5531 160 : gfc_match_omp_end_critical (void)
5532 : {
5533 160 : char n[GFC_MAX_SYMBOL_LEN+1];
5534 :
5535 160 : if (gfc_match (" ( %n )", n) != MATCH_YES)
5536 113 : n[0] = '\0';
5537 160 : if (gfc_match_omp_eos () != MATCH_YES)
5538 : {
5539 1 : gfc_error ("Unexpected junk after $OMP CRITICAL statement at %C");
5540 1 : return MATCH_ERROR;
5541 : }
5542 :
5543 159 : new_st.op = EXEC_OMP_END_CRITICAL;
5544 159 : new_st.ext.omp_name = n[0] ? xstrdup (n) : NULL;
5545 159 : return MATCH_YES;
5546 : }
5547 :
5548 : /* depobj(depobj) depend(dep-type:loc)|destroy|update(dep-type)
5549 : dep-type = in/out/inout/mutexinoutset/depobj/source/sink
5550 : depend: !source, !sink
5551 : update: !source, !sink, !depobj
5552 : locator = exactly one list item .*/
5553 : match
5554 125 : gfc_match_omp_depobj (void)
5555 : {
5556 125 : gfc_omp_clauses *c = NULL;
5557 125 : gfc_expr *depobj;
5558 :
5559 125 : if (gfc_match (" ( %v ) ", &depobj) != MATCH_YES)
5560 : {
5561 2 : gfc_error ("Expected %<( depobj )%> at %C");
5562 2 : return MATCH_ERROR;
5563 : }
5564 123 : if (gfc_match ("update ( ") == MATCH_YES)
5565 : {
5566 12 : c = gfc_get_omp_clauses ();
5567 12 : if (gfc_match ("inoutset )") == MATCH_YES)
5568 2 : c->depobj_update = OMP_DEPEND_INOUTSET;
5569 10 : else if (gfc_match ("inout )") == MATCH_YES)
5570 1 : c->depobj_update = OMP_DEPEND_INOUT;
5571 9 : else if (gfc_match ("in )") == MATCH_YES)
5572 2 : c->depobj_update = OMP_DEPEND_IN;
5573 7 : else if (gfc_match ("out )") == MATCH_YES)
5574 2 : c->depobj_update = OMP_DEPEND_OUT;
5575 5 : else if (gfc_match ("mutexinoutset )") == MATCH_YES)
5576 2 : c->depobj_update = OMP_DEPEND_MUTEXINOUTSET;
5577 : else
5578 : {
5579 3 : gfc_error ("Expected IN, OUT, INOUT, INOUTSET or MUTEXINOUTSET "
5580 : "followed by %<)%> at %C");
5581 3 : goto error;
5582 : }
5583 : }
5584 111 : else if (gfc_match ("destroy ") == MATCH_YES)
5585 : {
5586 16 : gfc_expr *destroyobj = NULL;
5587 16 : c = gfc_get_omp_clauses ();
5588 16 : c->destroy = true;
5589 :
5590 16 : if (gfc_match (" ( %v ) ", &destroyobj) == MATCH_YES)
5591 : {
5592 3 : if (destroyobj->symtree != depobj->symtree)
5593 2 : gfc_warning (OPT_Wopenmp, "The same depend object should be used as"
5594 : " DEPOBJ argument at %L and as DESTROY argument at %L",
5595 : &depobj->where, &destroyobj->where);
5596 3 : gfc_free_expr (destroyobj);
5597 : }
5598 : }
5599 95 : else if (gfc_match_omp_clauses (&c, omp_mask (OMP_CLAUSE_DEPEND), true, false)
5600 : != MATCH_YES)
5601 2 : goto error;
5602 :
5603 118 : if (c->depobj_update == OMP_DEPEND_UNSET && !c->destroy)
5604 : {
5605 93 : if (!c->doacross_source && !c->lists[OMP_LIST_DEPEND])
5606 : {
5607 1 : gfc_error ("Expected DEPEND, UPDATE, or DESTROY clause at %C");
5608 1 : goto error;
5609 : }
5610 92 : if (c->lists[OMP_LIST_DEPEND]->u.depend_doacross_op == OMP_DEPEND_DEPOBJ)
5611 : {
5612 1 : gfc_error ("DEPEND clause at %L of OMP DEPOBJ construct shall not "
5613 : "have dependence-type DEPOBJ",
5614 : c->lists[OMP_LIST_DEPEND]
5615 : ? &c->lists[OMP_LIST_DEPEND]->where : &gfc_current_locus);
5616 1 : goto error;
5617 : }
5618 91 : if (c->lists[OMP_LIST_DEPEND]->next)
5619 : {
5620 1 : gfc_error ("DEPEND clause at %L of OMP DEPOBJ construct shall have "
5621 : "only a single locator",
5622 : &c->lists[OMP_LIST_DEPEND]->next->where);
5623 1 : goto error;
5624 : }
5625 : }
5626 :
5627 115 : c->depobj = depobj;
5628 115 : new_st.op = EXEC_OMP_DEPOBJ;
5629 115 : new_st.ext.omp_clauses = c;
5630 115 : return MATCH_YES;
5631 :
5632 8 : error:
5633 8 : gfc_free_expr (depobj);
5634 8 : gfc_free_omp_clauses (c);
5635 8 : return MATCH_ERROR;
5636 : }
5637 :
5638 : match
5639 160 : gfc_match_omp_dispatch (void)
5640 : {
5641 160 : return match_omp (EXEC_OMP_DISPATCH, OMP_DISPATCH_CLAUSES);
5642 : }
5643 :
5644 : match
5645 57 : gfc_match_omp_distribute (void)
5646 : {
5647 57 : return match_omp (EXEC_OMP_DISTRIBUTE, OMP_DISTRIBUTE_CLAUSES);
5648 : }
5649 :
5650 :
5651 : match
5652 44 : gfc_match_omp_distribute_parallel_do (void)
5653 : {
5654 44 : return match_omp (EXEC_OMP_DISTRIBUTE_PARALLEL_DO,
5655 44 : (OMP_DISTRIBUTE_CLAUSES | OMP_PARALLEL_CLAUSES
5656 44 : | OMP_DO_CLAUSES)
5657 44 : & ~(omp_mask (OMP_CLAUSE_ORDERED)
5658 44 : | OMP_CLAUSE_LINEAR | OMP_CLAUSE_NOWAIT));
5659 : }
5660 :
5661 :
5662 : match
5663 34 : gfc_match_omp_distribute_parallel_do_simd (void)
5664 : {
5665 34 : return match_omp (EXEC_OMP_DISTRIBUTE_PARALLEL_DO_SIMD,
5666 34 : (OMP_DISTRIBUTE_CLAUSES | OMP_PARALLEL_CLAUSES
5667 34 : | OMP_DO_CLAUSES | OMP_SIMD_CLAUSES)
5668 34 : & ~(omp_mask (OMP_CLAUSE_ORDERED) | OMP_CLAUSE_NOWAIT));
5669 : }
5670 :
5671 :
5672 : match
5673 52 : gfc_match_omp_distribute_simd (void)
5674 : {
5675 52 : return match_omp (EXEC_OMP_DISTRIBUTE_SIMD,
5676 52 : OMP_DISTRIBUTE_CLAUSES | OMP_SIMD_CLAUSES);
5677 : }
5678 :
5679 :
5680 : match
5681 1252 : gfc_match_omp_do (void)
5682 : {
5683 1252 : return match_omp (EXEC_OMP_DO, OMP_DO_CLAUSES);
5684 : }
5685 :
5686 :
5687 : match
5688 137 : gfc_match_omp_do_simd (void)
5689 : {
5690 137 : return match_omp (EXEC_OMP_DO_SIMD, OMP_DO_CLAUSES | OMP_SIMD_CLAUSES);
5691 : }
5692 :
5693 :
5694 : match
5695 70 : gfc_match_omp_loop (void)
5696 : {
5697 70 : return match_omp (EXEC_OMP_LOOP, OMP_LOOP_CLAUSES);
5698 : }
5699 :
5700 :
5701 : match
5702 35 : gfc_match_omp_teams_loop (void)
5703 : {
5704 35 : return match_omp (EXEC_OMP_TEAMS_LOOP, OMP_TEAMS_CLAUSES | OMP_LOOP_CLAUSES);
5705 : }
5706 :
5707 :
5708 : match
5709 18 : gfc_match_omp_target_teams_loop (void)
5710 : {
5711 18 : return match_omp (EXEC_OMP_TARGET_TEAMS_LOOP,
5712 18 : OMP_TARGET_CLAUSES | OMP_TEAMS_CLAUSES | OMP_LOOP_CLAUSES);
5713 : }
5714 :
5715 :
5716 : match
5717 31 : gfc_match_omp_parallel_loop (void)
5718 : {
5719 31 : return match_omp (EXEC_OMP_PARALLEL_LOOP,
5720 31 : OMP_PARALLEL_CLAUSES | OMP_LOOP_CLAUSES);
5721 : }
5722 :
5723 :
5724 : match
5725 16 : gfc_match_omp_target_parallel_loop (void)
5726 : {
5727 16 : return match_omp (EXEC_OMP_TARGET_PARALLEL_LOOP,
5728 16 : (OMP_TARGET_CLAUSES | OMP_PARALLEL_CLAUSES
5729 16 : | OMP_LOOP_CLAUSES));
5730 : }
5731 :
5732 :
5733 : match
5734 101 : gfc_match_omp_error (void)
5735 : {
5736 101 : locus loc = gfc_current_locus;
5737 101 : match m = match_omp (EXEC_OMP_ERROR, OMP_ERROR_CLAUSES);
5738 101 : if (m != MATCH_YES)
5739 : return m;
5740 :
5741 82 : gfc_omp_clauses *c = new_st.ext.omp_clauses;
5742 82 : if (c->severity == OMP_SEVERITY_UNSET)
5743 45 : c->severity = OMP_SEVERITY_FATAL;
5744 82 : if (new_st.ext.omp_clauses->at == OMP_AT_EXECUTION)
5745 : return MATCH_YES;
5746 37 : if (c->message
5747 37 : && (!gfc_resolve_expr (c->message)
5748 16 : || c->message->ts.type != BT_CHARACTER
5749 14 : || c->message->ts.kind != gfc_default_character_kind
5750 13 : || c->message->rank != 0))
5751 : {
5752 4 : gfc_error ("MESSAGE clause at %L requires a scalar default-kind "
5753 : "CHARACTER expression",
5754 4 : &new_st.ext.omp_clauses->message->where);
5755 4 : return MATCH_ERROR;
5756 : }
5757 33 : if (c->message && !gfc_is_constant_expr (c->message))
5758 : {
5759 2 : gfc_error ("Constant character expression required in MESSAGE clause "
5760 2 : "at %L", &new_st.ext.omp_clauses->message->where);
5761 2 : return MATCH_ERROR;
5762 : }
5763 31 : if (c->message)
5764 : {
5765 10 : const char *msg = G_("$OMP ERROR encountered at %L: %s");
5766 10 : gcc_assert (c->message->expr_type == EXPR_CONSTANT);
5767 10 : gfc_charlen_t slen = c->message->value.character.length;
5768 10 : int i = gfc_validate_kind (BT_CHARACTER, gfc_default_character_kind,
5769 : false);
5770 10 : size_t size = slen * gfc_character_kinds[i].bit_size / 8;
5771 10 : unsigned char *s = XCNEWVAR (unsigned char, size + 1);
5772 10 : gfc_encode_character (gfc_default_character_kind, slen,
5773 10 : c->message->value.character.string,
5774 : (unsigned char *) s, size);
5775 10 : s[size] = '\0';
5776 10 : if (c->severity == OMP_SEVERITY_WARNING)
5777 6 : gfc_warning_now (0, msg, &loc, s);
5778 : else
5779 4 : gfc_error_now (msg, &loc, s);
5780 10 : free (s);
5781 : }
5782 : else
5783 : {
5784 21 : const char *msg = G_("$OMP ERROR encountered at %L");
5785 21 : if (c->severity == OMP_SEVERITY_WARNING)
5786 7 : gfc_warning_now (0, msg, &loc);
5787 : else
5788 14 : gfc_error_now (msg, &loc);
5789 : }
5790 : return MATCH_YES;
5791 : }
5792 :
5793 : match
5794 86 : gfc_match_omp_flush (void)
5795 : {
5796 86 : gfc_omp_namelist *list = NULL;
5797 86 : gfc_omp_clauses *c = NULL;
5798 86 : gfc_gobble_whitespace ();
5799 86 : enum gfc_omp_memorder mo = OMP_MEMORDER_UNSET;
5800 86 : if (gfc_match_omp_eos () == MATCH_NO && gfc_peek_ascii_char () != '(')
5801 : {
5802 14 : if (gfc_match ("seq_cst") == MATCH_YES)
5803 : mo = OMP_MEMORDER_SEQ_CST;
5804 11 : else if (gfc_match ("acq_rel") == MATCH_YES)
5805 : mo = OMP_MEMORDER_ACQ_REL;
5806 8 : else if (gfc_match ("release") == MATCH_YES)
5807 : mo = OMP_MEMORDER_RELEASE;
5808 5 : else if (gfc_match ("acquire") == MATCH_YES)
5809 : mo = OMP_MEMORDER_ACQUIRE;
5810 : else
5811 : {
5812 2 : gfc_error ("Expected SEQ_CST, AQC_REL, RELEASE, or ACQUIRE at %C");
5813 2 : return MATCH_ERROR;
5814 : }
5815 12 : c = gfc_get_omp_clauses ();
5816 12 : c->memorder = mo;
5817 : }
5818 84 : gfc_match_omp_variable_list (" (", &list, true);
5819 84 : if (list && mo != OMP_MEMORDER_UNSET)
5820 : {
5821 4 : gfc_error ("List specified together with memory order clause in FLUSH "
5822 : "directive at %C");
5823 4 : gfc_free_omp_namelist (list, OMP_LIST_NONE);
5824 4 : gfc_free_omp_clauses (c);
5825 4 : return MATCH_ERROR;
5826 : }
5827 80 : if (gfc_match_omp_eos () != MATCH_YES)
5828 : {
5829 0 : gfc_error ("Unexpected junk after $OMP FLUSH statement at %C");
5830 0 : gfc_free_omp_namelist (list, OMP_LIST_NONE);
5831 0 : gfc_free_omp_clauses (c);
5832 0 : return MATCH_ERROR;
5833 : }
5834 80 : new_st.op = EXEC_OMP_FLUSH;
5835 80 : new_st.ext.omp_namelist = list;
5836 80 : new_st.ext.omp_clauses = c;
5837 80 : return MATCH_YES;
5838 : }
5839 :
5840 :
5841 : match
5842 188 : gfc_match_omp_declare_simd (void)
5843 : {
5844 188 : locus where = gfc_current_locus;
5845 188 : gfc_symbol *proc_name;
5846 188 : gfc_omp_clauses *c;
5847 188 : gfc_omp_declare_simd *ods;
5848 188 : bool needs_space = false;
5849 :
5850 188 : switch (gfc_match (" ( "))
5851 : {
5852 144 : case MATCH_YES:
5853 144 : if (gfc_match_symbol (&proc_name, /* host assoc = */ true) != MATCH_YES
5854 144 : || gfc_match (" ) ") != MATCH_YES)
5855 0 : return MATCH_ERROR;
5856 : break;
5857 44 : case MATCH_NO: proc_name = NULL; needs_space = true; break;
5858 : case MATCH_ERROR: return MATCH_ERROR;
5859 : }
5860 :
5861 188 : if (gfc_match_omp_clauses (&c, OMP_DECLARE_SIMD_CLAUSES, true,
5862 : needs_space) != MATCH_YES)
5863 : return MATCH_ERROR;
5864 :
5865 183 : if (gfc_current_ns->is_block_data)
5866 : {
5867 1 : gfc_free_omp_clauses (c);
5868 1 : return MATCH_YES;
5869 : }
5870 :
5871 182 : ods = gfc_get_omp_declare_simd ();
5872 182 : ods->where = where;
5873 182 : ods->proc_name = proc_name;
5874 182 : ods->clauses = c;
5875 182 : ods->next = gfc_current_ns->omp_declare_simd;
5876 182 : gfc_current_ns->omp_declare_simd = ods;
5877 182 : return MATCH_YES;
5878 : }
5879 :
5880 :
5881 : /* Find a matching "!$omp declare mapper" for typespec TS in symtree ST. */
5882 :
5883 : gfc_omp_udm *
5884 8 : gfc_omp_udm_find (gfc_symtree *st, gfc_typespec *ts)
5885 : {
5886 8 : gfc_omp_udm *omp_udm;
5887 :
5888 8 : if (st == NULL)
5889 : return NULL;
5890 :
5891 2 : for (omp_udm = st->n.omp_udm; omp_udm; omp_udm = omp_udm->next)
5892 2 : if ((omp_udm->ts.type == BT_DERIVED || omp_udm->ts.type == BT_CLASS)
5893 2 : && (ts->type == BT_DERIVED || ts->type == BT_CLASS)
5894 2 : && strcmp (omp_udm->ts.u.derived->name, ts->u.derived->name) == 0)
5895 : return omp_udm;
5896 :
5897 : return NULL;
5898 : }
5899 :
5900 :
5901 : /* Match !$omp declare mapper([ mapper-identifier : ] type :: var) clauses-list */
5902 :
5903 : match
5904 18 : gfc_match_omp_declare_mapper (void)
5905 : {
5906 18 : match m;
5907 18 : gfc_typespec ts;
5908 18 : char mapper_id[GFC_MAX_SYMBOL_LEN + 1];
5909 18 : char var[GFC_MAX_SYMBOL_LEN + 1];
5910 18 : gfc_namespace *mapper_ns = NULL;
5911 18 : gfc_symtree *var_st;
5912 18 : gfc_symtree *st;
5913 18 : gfc_omp_udm *omp_udm = NULL, *prev_udm = NULL;
5914 18 : locus where = gfc_current_locus;
5915 :
5916 18 : if (gfc_match_char ('(') != MATCH_YES)
5917 : {
5918 1 : gfc_error ("Expected %<(%> at %C");
5919 1 : return MATCH_ERROR;
5920 : }
5921 :
5922 17 : locus old_locus = gfc_current_locus;
5923 :
5924 17 : m = gfc_match (" %n : ", mapper_id);
5925 :
5926 17 : if (m == MATCH_ERROR)
5927 : return MATCH_ERROR;
5928 :
5929 : /* As a special case, a mapper named "default" and an unnamed mapper are
5930 : both the default mapper for a given type. */
5931 17 : if (strcmp (mapper_id, "default") == 0)
5932 0 : mapper_id[0] = '\0';
5933 :
5934 17 : if (gfc_peek_ascii_char () == ':')
5935 : {
5936 : /* If we see '::', the user did not name the mapper, and instead we just
5937 : saw the type. So backtrack and try parsing as a type instead. */
5938 6 : mapper_id[0] = '\0';
5939 6 : gfc_current_locus = old_locus;
5940 : }
5941 17 : old_locus = gfc_current_locus;
5942 :
5943 17 : m = gfc_match_type_spec (&ts);
5944 17 : if (m != MATCH_YES)
5945 : {
5946 4 : gfc_error ("Expected either a type name at %L or a map-type "
5947 : "identifier, a colon, or a type name", &old_locus);
5948 4 : return MATCH_ERROR;
5949 : }
5950 :
5951 13 : if (ts.type != BT_DERIVED)
5952 : {
5953 1 : gfc_error ("!$OMP DECLARE MAPPER with non-derived type at %L", &old_locus);
5954 1 : return MATCH_ERROR;
5955 : }
5956 :
5957 12 : if (gfc_match (" :: ") != MATCH_YES)
5958 : {
5959 0 : gfc_error ("Expected %<::%> at %C");
5960 0 : return MATCH_ERROR;
5961 : }
5962 :
5963 12 : if (gfc_match_name (var) != MATCH_YES)
5964 : {
5965 1 : gfc_error ("Expected variable name at %C");
5966 1 : return MATCH_ERROR;
5967 : }
5968 :
5969 11 : if (gfc_match_char (')') != MATCH_YES)
5970 : {
5971 2 : gfc_error ("Expected %<)%> at %C");
5972 2 : return MATCH_ERROR;
5973 : }
5974 :
5975 9 : st = gfc_find_symtree (gfc_current_ns->omp_udm_root, mapper_id);
5976 :
5977 : /* Now we need to set up a new namespace, and create a new sym_tree for our
5978 : dummy variable so we can use it in the following list of mapping
5979 : clauses. */
5980 :
5981 9 : gfc_current_ns = mapper_ns = gfc_get_namespace (gfc_current_ns, 1);
5982 9 : mapper_ns->proc_name = mapper_ns->parent->proc_name;
5983 9 : mapper_ns->omp_udm_ns = 1;
5984 :
5985 9 : gfc_get_sym_tree (var, mapper_ns, &var_st, false);
5986 9 : var_st->n.sym->ts = ts;
5987 9 : var_st->n.sym->attr.omp_udm_artificial_var = 1;
5988 9 : var_st->n.sym->attr.flavor = FL_VARIABLE;
5989 9 : gfc_commit_symbols ();
5990 :
5991 9 : gfc_omp_clauses *clauses = NULL;
5992 :
5993 9 : m = gfc_match_omp_clauses (&clauses, omp_mask (OMP_CLAUSE_MAP), true, true,
5994 : false, false, OMP_MAP_UNSET);
5995 9 : if (m != MATCH_YES)
5996 1 : goto failure;
5997 :
5998 8 : omp_udm = gfc_get_omp_udm ();
5999 8 : omp_udm->next = NULL;
6000 8 : omp_udm->where = where;
6001 8 : omp_udm->mapper_id = gfc_get_string ("%s", mapper_id);
6002 8 : omp_udm->ts = ts;
6003 8 : omp_udm->var_sym = var_st->n.sym;
6004 8 : omp_udm->mapper_ns = mapper_ns;
6005 8 : omp_udm->clauses = clauses;
6006 :
6007 8 : gfc_current_ns = mapper_ns->parent;
6008 :
6009 8 : prev_udm = gfc_omp_udm_find (st, &ts);
6010 8 : if (prev_udm)
6011 : {
6012 2 : if (mapper_id[0])
6013 1 : gfc_error ("Redefinition of !$OMP DECLARE MAPPER at %L for type %qs with id %qs",
6014 : &where, gfc_typename (&ts), mapper_id);
6015 : else
6016 1 : gfc_error ("Redefinition of !$OMP DECLARE MAPPER at %L for type %qs",
6017 : &where, gfc_typename (&ts));
6018 2 : inform (gfc_get_location (&prev_udm->where),
6019 : "Previous !$OMP DECLARE MAPPER here");
6020 2 : return MATCH_ERROR;
6021 : }
6022 6 : else if (st)
6023 : {
6024 0 : omp_udm->next = st->n.omp_udm;
6025 0 : st->n.omp_udm = omp_udm;
6026 : }
6027 : else
6028 : {
6029 6 : st = gfc_new_symtree (&gfc_current_ns->omp_udm_root, mapper_id);
6030 6 : st->n.omp_udm = omp_udm;
6031 : }
6032 :
6033 : return MATCH_YES;
6034 :
6035 1 : failure:
6036 1 : if (mapper_ns)
6037 1 : gfc_current_ns = mapper_ns->parent;
6038 1 : gfc_free_omp_udm (omp_udm);
6039 :
6040 1 : return MATCH_ERROR;
6041 : }
6042 :
6043 :
6044 : static bool
6045 877 : match_udr_expr (gfc_symtree *omp_sym1, gfc_symtree *omp_sym2)
6046 : {
6047 877 : match m;
6048 877 : locus old_loc = gfc_current_locus;
6049 877 : char sname[GFC_MAX_SYMBOL_LEN + 1];
6050 877 : gfc_symbol *sym;
6051 877 : gfc_namespace *ns = gfc_current_ns;
6052 877 : gfc_expr *lvalue = NULL, *rvalue = NULL;
6053 877 : gfc_symtree *st;
6054 877 : gfc_actual_arglist *arglist;
6055 :
6056 877 : m = gfc_match (" %v =", &lvalue);
6057 877 : if (m != MATCH_YES)
6058 200 : gfc_current_locus = old_loc;
6059 : else
6060 : {
6061 677 : m = gfc_match (" %e )", &rvalue);
6062 677 : if (m == MATCH_YES)
6063 : {
6064 675 : ns->code = gfc_get_code (EXEC_ASSIGN);
6065 675 : ns->code->expr1 = lvalue;
6066 675 : ns->code->expr2 = rvalue;
6067 675 : ns->code->loc = old_loc;
6068 675 : return true;
6069 : }
6070 :
6071 2 : gfc_current_locus = old_loc;
6072 2 : gfc_free_expr (lvalue);
6073 : }
6074 :
6075 202 : m = gfc_match (" %n", sname);
6076 202 : if (m != MATCH_YES)
6077 : return false;
6078 :
6079 202 : if (strcmp (sname, omp_sym1->name) == 0
6080 200 : || strcmp (sname, omp_sym2->name) == 0)
6081 : return false;
6082 :
6083 200 : gfc_current_ns = ns->parent;
6084 200 : if (gfc_get_ha_sym_tree (sname, &st))
6085 : return false;
6086 :
6087 200 : sym = st->n.sym;
6088 200 : if (sym->attr.flavor != FL_PROCEDURE
6089 72 : && sym->attr.flavor != FL_UNKNOWN)
6090 : return false;
6091 :
6092 199 : if (!sym->attr.generic
6093 189 : && !sym->attr.subroutine
6094 71 : && !sym->attr.function)
6095 : {
6096 71 : if (!(sym->attr.external && !sym->attr.referenced))
6097 : {
6098 : /* ...create a symbol in this scope... */
6099 71 : if (sym->ns != gfc_current_ns
6100 71 : && gfc_get_sym_tree (sname, NULL, &st, false) == 1)
6101 : return false;
6102 :
6103 71 : if (sym != st->n.sym)
6104 71 : sym = st->n.sym;
6105 : }
6106 :
6107 : /* ...and then to try to make the symbol into a subroutine. */
6108 71 : if (!gfc_add_subroutine (&sym->attr, sym->name, NULL))
6109 : return false;
6110 : }
6111 :
6112 199 : gfc_set_sym_referenced (sym);
6113 199 : gfc_gobble_whitespace ();
6114 199 : if (gfc_peek_ascii_char () != '(')
6115 : return false;
6116 :
6117 195 : gfc_current_ns = ns;
6118 195 : m = gfc_match_actual_arglist (1, &arglist);
6119 195 : if (m != MATCH_YES)
6120 : return false;
6121 :
6122 195 : if (gfc_match_char (')') != MATCH_YES)
6123 : return false;
6124 :
6125 195 : ns->code = gfc_get_code (EXEC_CALL);
6126 195 : ns->code->symtree = st;
6127 195 : ns->code->ext.actual = arglist;
6128 195 : ns->code->loc = old_loc;
6129 195 : return true;
6130 : }
6131 :
6132 : static bool
6133 1156 : gfc_omp_udr_predef (gfc_omp_reduction_op rop, const char *name,
6134 : gfc_typespec *ts, const char **n)
6135 : {
6136 1156 : if (!gfc_numeric_ts (ts) && ts->type != BT_LOGICAL)
6137 : return false;
6138 :
6139 648 : switch (rop)
6140 : {
6141 21 : case OMP_REDUCTION_PLUS:
6142 21 : case OMP_REDUCTION_MINUS:
6143 21 : case OMP_REDUCTION_TIMES:
6144 21 : return ts->type != BT_LOGICAL;
6145 8 : case OMP_REDUCTION_AND:
6146 8 : case OMP_REDUCTION_OR:
6147 8 : case OMP_REDUCTION_EQV:
6148 8 : case OMP_REDUCTION_NEQV:
6149 8 : return ts->type == BT_LOGICAL;
6150 618 : case OMP_REDUCTION_USER:
6151 618 : if (name[0] != '.' && (ts->type == BT_INTEGER || ts->type == BT_REAL))
6152 : {
6153 546 : gfc_symbol *sym;
6154 :
6155 546 : gfc_find_symbol (name, NULL, 1, &sym);
6156 546 : if (sym != NULL)
6157 : {
6158 93 : if (sym->attr.intrinsic)
6159 0 : *n = sym->name;
6160 93 : else if ((sym->attr.flavor != FL_UNKNOWN
6161 81 : && sym->attr.flavor != FL_PROCEDURE)
6162 69 : || sym->attr.external
6163 54 : || sym->attr.generic
6164 54 : || sym->attr.entry
6165 54 : || sym->attr.result
6166 54 : || sym->attr.dummy
6167 54 : || sym->attr.subroutine
6168 50 : || sym->attr.pointer
6169 50 : || sym->attr.target
6170 50 : || sym->attr.cray_pointer
6171 50 : || sym->attr.cray_pointee
6172 50 : || (sym->attr.proc != PROC_UNKNOWN
6173 0 : && sym->attr.proc != PROC_INTRINSIC)
6174 50 : || sym->attr.if_source != IFSRC_UNKNOWN
6175 50 : || sym == sym->ns->proc_name)
6176 43 : *n = NULL;
6177 : else
6178 50 : *n = sym->name;
6179 : }
6180 : else
6181 453 : *n = name;
6182 546 : if (*n
6183 503 : && (strcmp (*n, "max") == 0 || strcmp (*n, "min") == 0))
6184 54 : return true;
6185 510 : else if (*n
6186 467 : && ts->type == BT_INTEGER
6187 383 : && (strcmp (*n, "iand") == 0
6188 377 : || strcmp (*n, "ior") == 0
6189 371 : || strcmp (*n, "ieor") == 0))
6190 : return true;
6191 : }
6192 : break;
6193 : default:
6194 : break;
6195 : }
6196 : return false;
6197 : }
6198 :
6199 : gfc_omp_udr *
6200 639 : gfc_omp_udr_find (gfc_symtree *st, gfc_typespec *ts)
6201 : {
6202 639 : gfc_omp_udr *omp_udr;
6203 :
6204 639 : if (st == NULL)
6205 : return NULL;
6206 :
6207 250 : for (omp_udr = st->n.omp_udr; omp_udr; omp_udr = omp_udr->next)
6208 154 : if (omp_udr->ts.type == ts->type
6209 89 : || ((omp_udr->ts.type == BT_DERIVED || omp_udr->ts.type == BT_CLASS)
6210 0 : && (ts->type == BT_DERIVED || ts->type == BT_CLASS)))
6211 : {
6212 65 : if (omp_udr->ts.type == BT_DERIVED || omp_udr->ts.type == BT_CLASS)
6213 : {
6214 12 : if (strcmp (omp_udr->ts.u.derived->name, ts->u.derived->name) == 0)
6215 : return omp_udr;
6216 : }
6217 53 : else if (omp_udr->ts.kind == ts->kind)
6218 : {
6219 19 : if (omp_udr->ts.type == BT_CHARACTER)
6220 : {
6221 17 : if (omp_udr->ts.u.cl->length == NULL
6222 15 : || ts->u.cl->length == NULL)
6223 : return omp_udr;
6224 15 : if (omp_udr->ts.u.cl->length->expr_type != EXPR_CONSTANT)
6225 : return omp_udr;
6226 15 : if (ts->u.cl->length->expr_type != EXPR_CONSTANT)
6227 : return omp_udr;
6228 15 : if (omp_udr->ts.u.cl->length->ts.type != BT_INTEGER)
6229 : return omp_udr;
6230 15 : if (ts->u.cl->length->ts.type != BT_INTEGER)
6231 : return omp_udr;
6232 15 : if (gfc_compare_expr (omp_udr->ts.u.cl->length,
6233 : ts->u.cl->length, INTRINSIC_EQ) != 0)
6234 15 : continue;
6235 : }
6236 2 : return omp_udr;
6237 : }
6238 : }
6239 : return NULL;
6240 : }
6241 :
6242 : match
6243 532 : gfc_match_omp_declare_reduction (void)
6244 : {
6245 532 : match m;
6246 532 : gfc_intrinsic_op op;
6247 532 : char name[GFC_MAX_SYMBOL_LEN + 3];
6248 532 : auto_vec<gfc_typespec, 5> tss;
6249 532 : gfc_typespec ts;
6250 532 : unsigned int i;
6251 532 : gfc_symtree *st;
6252 532 : locus where = gfc_current_locus;
6253 532 : locus end_loc = gfc_current_locus;
6254 532 : bool end_loc_set = false;
6255 532 : gfc_omp_reduction_op rop = OMP_REDUCTION_NONE;
6256 :
6257 532 : if (gfc_match_char ('(') != MATCH_YES)
6258 : return MATCH_ERROR;
6259 :
6260 530 : m = gfc_match (" %o : ", &op);
6261 530 : if (m == MATCH_ERROR)
6262 : return MATCH_ERROR;
6263 530 : if (m == MATCH_YES)
6264 : {
6265 117 : snprintf (name, sizeof name, "operator %s", gfc_op2string (op));
6266 117 : rop = (gfc_omp_reduction_op) op;
6267 : }
6268 : else
6269 : {
6270 413 : m = gfc_match_defined_op_name (name + 1, 1);
6271 413 : if (m == MATCH_ERROR)
6272 : return MATCH_ERROR;
6273 413 : if (m == MATCH_YES)
6274 : {
6275 41 : name[0] = '.';
6276 41 : strcat (name, ".");
6277 41 : if (gfc_match (" : ") != MATCH_YES)
6278 : return MATCH_ERROR;
6279 : }
6280 : else
6281 : {
6282 372 : if (gfc_match (" %n : ", name) != MATCH_YES)
6283 : return MATCH_ERROR;
6284 : }
6285 : rop = OMP_REDUCTION_USER;
6286 : }
6287 :
6288 529 : m = gfc_match_type_spec (&ts);
6289 529 : if (m != MATCH_YES)
6290 : return MATCH_ERROR;
6291 : /* Treat len=: the same as len=*. */
6292 528 : if (ts.type == BT_CHARACTER)
6293 61 : ts.deferred = false;
6294 528 : tss.safe_push (ts);
6295 :
6296 1093 : while (gfc_match_char (',') == MATCH_YES)
6297 : {
6298 37 : m = gfc_match_type_spec (&ts);
6299 37 : if (m != MATCH_YES)
6300 : return MATCH_ERROR;
6301 37 : tss.safe_push (ts);
6302 : }
6303 528 : if (gfc_match_char (':') != MATCH_YES)
6304 : return MATCH_ERROR;
6305 :
6306 527 : st = gfc_find_symtree (gfc_current_ns->omp_udr_root, name);
6307 1084 : for (i = 0; i < tss.length (); i++)
6308 : {
6309 564 : gfc_symtree *omp_out, *omp_in;
6310 564 : gfc_symtree *omp_priv = NULL, *omp_orig = NULL;
6311 564 : gfc_namespace *combiner_ns, *initializer_ns = NULL;
6312 564 : gfc_omp_udr *prev_udr, *omp_udr;
6313 564 : const char *predef_name = NULL;
6314 :
6315 564 : omp_udr = gfc_get_omp_udr ();
6316 564 : omp_udr->name = gfc_get_string ("%s", name);
6317 564 : omp_udr->rop = rop;
6318 564 : omp_udr->ts = tss[i];
6319 564 : omp_udr->where = where;
6320 :
6321 564 : gfc_current_ns = combiner_ns = gfc_get_namespace (gfc_current_ns, 1);
6322 564 : combiner_ns->proc_name = combiner_ns->parent->proc_name;
6323 :
6324 564 : gfc_get_sym_tree ("omp_out", combiner_ns, &omp_out, false);
6325 564 : gfc_get_sym_tree ("omp_in", combiner_ns, &omp_in, false);
6326 564 : combiner_ns->omp_udr_ns = 1;
6327 564 : omp_out->n.sym->ts = tss[i];
6328 564 : omp_in->n.sym->ts = tss[i];
6329 564 : omp_out->n.sym->attr.omp_udr_artificial_var = 1;
6330 564 : omp_in->n.sym->attr.omp_udr_artificial_var = 1;
6331 564 : omp_out->n.sym->attr.flavor = FL_VARIABLE;
6332 564 : omp_in->n.sym->attr.flavor = FL_VARIABLE;
6333 564 : gfc_commit_symbols ();
6334 564 : omp_udr->combiner_ns = combiner_ns;
6335 564 : omp_udr->omp_out = omp_out->n.sym;
6336 564 : omp_udr->omp_in = omp_in->n.sym;
6337 :
6338 564 : locus old_loc = gfc_current_locus;
6339 :
6340 564 : if (!match_udr_expr (omp_out, omp_in))
6341 : {
6342 4 : syntax:
6343 7 : gfc_current_locus = old_loc;
6344 7 : gfc_current_ns = combiner_ns->parent;
6345 7 : gfc_undo_symbols ();
6346 7 : gfc_free_omp_udr (omp_udr);
6347 7 : return MATCH_ERROR;
6348 : }
6349 :
6350 560 : if (gfc_match (" initializer ( ") == MATCH_YES)
6351 : {
6352 313 : gfc_current_ns = combiner_ns->parent;
6353 313 : initializer_ns = gfc_get_namespace (gfc_current_ns, 1);
6354 313 : gfc_current_ns = initializer_ns;
6355 313 : initializer_ns->proc_name = initializer_ns->parent->proc_name;
6356 :
6357 313 : gfc_get_sym_tree ("omp_priv", initializer_ns, &omp_priv, false);
6358 313 : gfc_get_sym_tree ("omp_orig", initializer_ns, &omp_orig, false);
6359 313 : initializer_ns->omp_udr_ns = 1;
6360 313 : omp_priv->n.sym->ts = tss[i];
6361 313 : omp_orig->n.sym->ts = tss[i];
6362 313 : omp_priv->n.sym->attr.omp_udr_artificial_var = 1;
6363 313 : omp_orig->n.sym->attr.omp_udr_artificial_var = 1;
6364 313 : omp_priv->n.sym->attr.flavor = FL_VARIABLE;
6365 313 : omp_orig->n.sym->attr.flavor = FL_VARIABLE;
6366 313 : gfc_commit_symbols ();
6367 313 : omp_udr->initializer_ns = initializer_ns;
6368 313 : omp_udr->omp_priv = omp_priv->n.sym;
6369 313 : omp_udr->omp_orig = omp_orig->n.sym;
6370 :
6371 313 : if (!match_udr_expr (omp_priv, omp_orig))
6372 3 : goto syntax;
6373 : }
6374 :
6375 557 : gfc_current_ns = combiner_ns->parent;
6376 557 : if (!end_loc_set)
6377 : {
6378 520 : end_loc_set = true;
6379 520 : end_loc = gfc_current_locus;
6380 : }
6381 557 : gfc_current_locus = old_loc;
6382 :
6383 557 : prev_udr = gfc_omp_udr_find (st, &tss[i]);
6384 557 : if (gfc_omp_udr_predef (rop, name, &tss[i], &predef_name)
6385 : /* Don't error on !$omp declare reduction (min : integer : ...)
6386 : just yet, there could be integer :: min afterwards,
6387 : making it valid. When the UDR is resolved, we'll get
6388 : to it again. */
6389 557 : && (rop != OMP_REDUCTION_USER || name[0] == '.'))
6390 : {
6391 29 : if (predef_name)
6392 0 : gfc_error_now ("Redefinition of predefined %s "
6393 : "!$OMP DECLARE REDUCTION at %L",
6394 : predef_name, &where);
6395 : else
6396 29 : gfc_error_now ("Redefinition of predefined "
6397 : "!$OMP DECLARE REDUCTION at %L", &where);
6398 : }
6399 528 : else if (prev_udr)
6400 : {
6401 6 : gfc_error_now ("Redefinition of !$OMP DECLARE REDUCTION at %L",
6402 : &where);
6403 6 : gfc_error_now ("Previous !$OMP DECLARE REDUCTION at %L",
6404 : &prev_udr->where);
6405 : }
6406 522 : else if (st)
6407 : {
6408 96 : omp_udr->next = st->n.omp_udr;
6409 96 : st->n.omp_udr = omp_udr;
6410 : }
6411 : else
6412 : {
6413 426 : st = gfc_new_symtree (&gfc_current_ns->omp_udr_root, name);
6414 426 : st->n.omp_udr = omp_udr;
6415 : }
6416 : }
6417 :
6418 520 : if (end_loc_set)
6419 : {
6420 520 : gfc_current_locus = end_loc;
6421 520 : if (gfc_match_omp_eos () != MATCH_YES)
6422 : {
6423 1 : gfc_error ("Unexpected junk after !$OMP DECLARE REDUCTION at %C");
6424 1 : gfc_current_locus = where;
6425 1 : return MATCH_ERROR;
6426 : }
6427 :
6428 : return MATCH_YES;
6429 : }
6430 0 : gfc_clear_error ();
6431 0 : return MATCH_ERROR;
6432 532 : }
6433 :
6434 :
6435 : match
6436 471 : gfc_match_omp_declare_target (void)
6437 : {
6438 471 : locus old_loc;
6439 471 : match m;
6440 471 : gfc_omp_clauses *c = NULL;
6441 471 : enum gfc_omp_list_type list;
6442 471 : gfc_omp_namelist *n;
6443 471 : gfc_symbol *s;
6444 :
6445 471 : old_loc = gfc_current_locus;
6446 :
6447 471 : if (gfc_current_ns->proc_name
6448 471 : && gfc_match_omp_eos () == MATCH_YES)
6449 : {
6450 138 : if (!gfc_add_omp_declare_target (&gfc_current_ns->proc_name->attr,
6451 138 : gfc_current_ns->proc_name->name,
6452 : &old_loc))
6453 0 : goto cleanup;
6454 : return MATCH_YES;
6455 : }
6456 :
6457 333 : if (gfc_current_ns->proc_name
6458 333 : && gfc_current_ns->proc_name->attr.if_source == IFSRC_IFBODY)
6459 : {
6460 2 : gfc_error ("Only the !$OMP DECLARE TARGET form without "
6461 : "clauses is allowed in interface block at %C");
6462 2 : goto cleanup;
6463 : }
6464 :
6465 331 : m = gfc_match (" (");
6466 331 : if (m == MATCH_YES)
6467 : {
6468 85 : c = gfc_get_omp_clauses ();
6469 85 : gfc_current_locus = old_loc;
6470 85 : m = gfc_match_omp_to_link (" (", &c->lists[OMP_LIST_ENTER]);
6471 85 : if (m != MATCH_YES)
6472 0 : goto syntax;
6473 85 : if (gfc_match_omp_eos () != MATCH_YES)
6474 : {
6475 0 : gfc_error ("Unexpected junk after !$OMP DECLARE TARGET at %C");
6476 0 : goto cleanup;
6477 : }
6478 : }
6479 246 : else if (gfc_match_omp_clauses (&c, OMP_DECLARE_TARGET_CLAUSES) != MATCH_YES)
6480 : return MATCH_ERROR;
6481 :
6482 325 : gfc_buffer_error (false);
6483 :
6484 325 : static const enum gfc_omp_list_type to_enter_link_lists[]
6485 : = { OMP_LIST_TO, OMP_LIST_ENTER, OMP_LIST_LINK, OMP_LIST_LOCAL };
6486 1625 : for (size_t listn = 0; listn < ARRAY_SIZE (to_enter_link_lists)
6487 1625 : && (list = to_enter_link_lists[listn], true); ++listn)
6488 1844 : for (n = c->lists[list]; n; n = n->next)
6489 544 : if (n->sym)
6490 503 : n->sym->mark = 0;
6491 41 : else if (n->u.common->head)
6492 41 : n->u.common->head->mark = 0;
6493 :
6494 325 : if (c->device_type == OMP_DEVICE_TYPE_UNSET)
6495 257 : c->device_type = OMP_DEVICE_TYPE_ANY;
6496 1300 : for (size_t listn = 0; listn < ARRAY_SIZE (to_enter_link_lists)
6497 1625 : && (list = to_enter_link_lists[listn], true); ++listn)
6498 1844 : for (n = c->lists[list]; n; n = n->next)
6499 544 : if (n->sym)
6500 : {
6501 503 : if (n->sym->attr.in_common)
6502 1 : gfc_error_now ("OMP DECLARE TARGET variable at %L is an "
6503 : "element of a COMMON block", &n->where);
6504 502 : else if (n->sym->attr.omp_groupprivate && list != OMP_LIST_LOCAL)
6505 12 : gfc_error_now ("List item %qs at %L not appear in the %qs clause "
6506 : "as it was previously specified in a GROUPPRIVATE "
6507 : "directive", n->sym->name, &n->where,
6508 : list == OMP_LIST_LINK
6509 5 : ? "link" : list == OMP_LIST_TO ? "to" : "enter");
6510 495 : else if (n->sym->mark)
6511 9 : gfc_error_now ("Variable at %L mentioned multiple times in "
6512 : "clauses of the same OMP DECLARE TARGET directive",
6513 : &n->where);
6514 486 : else if ((n->sym->attr.omp_declare_target_link
6515 481 : || n->sym->attr.omp_declare_target_local)
6516 : && list != OMP_LIST_LINK
6517 7 : && list != OMP_LIST_LOCAL)
6518 1 : gfc_error_now ("OMP DECLARE TARGET variable at %L previously "
6519 : "mentioned in %s clause and later in %s clause",
6520 : &n->where,
6521 : n->sym->attr.omp_declare_target_link ? "LINK"
6522 : : "LOCAL",
6523 : list == OMP_LIST_TO ? "TO" : "ENTER");
6524 485 : else if (n->sym->attr.omp_declare_target
6525 14 : && (list == OMP_LIST_LINK || list == OMP_LIST_LOCAL))
6526 1 : gfc_error_now ("OMP DECLARE TARGET variable at %L previously "
6527 : "mentioned in TO or ENTER clause and later in "
6528 : "%s clause", &n->where,
6529 : list == OMP_LIST_LINK ? "LINK" : "LOCAL");
6530 : else
6531 : {
6532 484 : if (list == OMP_LIST_TO || list == OMP_LIST_ENTER)
6533 445 : gfc_add_omp_declare_target (&n->sym->attr, n->sym->name,
6534 : &n->sym->declared_at);
6535 484 : if (list == OMP_LIST_LINK)
6536 30 : gfc_add_omp_declare_target_link (&n->sym->attr, n->sym->name,
6537 30 : &n->sym->declared_at);
6538 484 : if (list == OMP_LIST_LOCAL)
6539 9 : gfc_add_omp_declare_target_local (&n->sym->attr, n->sym->name,
6540 9 : &n->sym->declared_at);
6541 : }
6542 503 : if (n->sym->attr.omp_device_type != OMP_DEVICE_TYPE_UNSET
6543 36 : && n->sym->attr.omp_device_type != c->device_type)
6544 : {
6545 12 : const char *dt = "any";
6546 12 : if (n->sym->attr.omp_device_type == OMP_DEVICE_TYPE_NOHOST)
6547 : dt = "nohost";
6548 8 : else if (n->sym->attr.omp_device_type == OMP_DEVICE_TYPE_HOST)
6549 4 : dt = "host";
6550 12 : if (n->sym->attr.omp_groupprivate)
6551 1 : gfc_error_now ("List item %qs at %L set in previous OMP "
6552 : "GROUPPRIVATE directive to the different "
6553 : "DEVICE_TYPE %qs", n->sym->name, &n->where, dt);
6554 : else
6555 11 : gfc_error_now ("List item %qs at %L set in previous OMP "
6556 : "DECLARE TARGET directive to the different "
6557 : "DEVICE_TYPE %qs", n->sym->name, &n->where, dt);
6558 : }
6559 503 : n->sym->attr.omp_device_type = c->device_type;
6560 503 : if (c->indirect && c->device_type != OMP_DEVICE_TYPE_ANY)
6561 : {
6562 1 : gfc_error_now ("DEVICE_TYPE must be ANY when used with INDIRECT "
6563 : "at %L", &n->where);
6564 1 : c->indirect = 0;
6565 : }
6566 503 : n->sym->attr.omp_declare_target_indirect = c->indirect;
6567 503 : if (list == OMP_LIST_LINK && c->device_type == OMP_DEVICE_TYPE_NOHOST)
6568 3 : gfc_error_now ("List item %qs at %L set with NOHOST specified may "
6569 : "not appear in a LINK clause", n->sym->name,
6570 : &n->where);
6571 503 : n->sym->mark = 1;
6572 : }
6573 : else /* common block */
6574 : {
6575 41 : if (n->u.common->omp_groupprivate && list != OMP_LIST_LOCAL)
6576 7 : gfc_error_now ("Common block %</%s/%> at %L not appear in the %qs "
6577 : "clause as it was previously specified in a "
6578 : "GROUPPRIVATE directive",
6579 7 : n->u.common->name, &n->where,
6580 : list == OMP_LIST_LINK
6581 5 : ? "link" : list == OMP_LIST_TO ? "to" : "enter");
6582 34 : else if (n->u.common->head && n->u.common->head->mark)
6583 4 : gfc_error_now ("Common block %</%s/%> at %L mentioned multiple "
6584 : "times in clauses of the same OMP DECLARE TARGET "
6585 4 : "directive", n->u.common->name, &n->where);
6586 30 : else if ((n->u.common->omp_declare_target_link
6587 26 : || n->u.common->omp_declare_target_local)
6588 : && list != OMP_LIST_LINK
6589 6 : && list != OMP_LIST_LOCAL)
6590 2 : gfc_error_now ("Common block %</%s/%> at %L previously mentioned "
6591 : "in %s clause and later in %s clause",
6592 1 : n->u.common->name, &n->where,
6593 : n->u.common->omp_declare_target_link ? "LINK"
6594 : : "LOCAL",
6595 : list == OMP_LIST_TO ? "TO" : "ENTER");
6596 29 : else if (n->u.common->omp_declare_target
6597 4 : && (list == OMP_LIST_LINK || list == OMP_LIST_LOCAL))
6598 1 : gfc_error_now ("Common block %</%s/%> at %L previously mentioned "
6599 : "in TO or ENTER clause and later in %s clause",
6600 1 : n->u.common->name, &n->where,
6601 : list == OMP_LIST_LINK ? "LINK" : "LOCAL");
6602 41 : if (n->u.common->omp_device_type != OMP_DEVICE_TYPE_UNSET
6603 21 : && n->u.common->omp_device_type != c->device_type)
6604 : {
6605 1 : const char *dt = "any";
6606 1 : if (n->u.common->omp_device_type == OMP_DEVICE_TYPE_NOHOST)
6607 : dt = "nohost";
6608 0 : else if (n->u.common->omp_device_type == OMP_DEVICE_TYPE_HOST)
6609 0 : dt = "host";
6610 1 : if (n->u.common->omp_groupprivate)
6611 1 : gfc_error_now ("Common block %</%s/%> at %L set in previous OMP "
6612 : "GROUPPRIVATE directive to the different "
6613 1 : "DEVICE_TYPE %qs", n->u.common->name, &n->where,
6614 : dt);
6615 : else
6616 0 : gfc_error_now ("Common block %</%s/%> at %L set in previous OMP "
6617 : "DECLARE TARGET directive to the different "
6618 0 : "DEVICE_TYPE %qs", n->u.common->name, &n->where,
6619 : dt);
6620 : }
6621 41 : n->u.common->omp_device_type = c->device_type;
6622 :
6623 41 : if (c->indirect && c->device_type != OMP_DEVICE_TYPE_ANY)
6624 : {
6625 0 : gfc_error_now ("DEVICE_TYPE must be ANY when used with INDIRECT "
6626 : "at %L", &n->where);
6627 0 : c->indirect = 0;
6628 : }
6629 41 : if (list == OMP_LIST_LINK && c->device_type == OMP_DEVICE_TYPE_NOHOST)
6630 1 : gfc_error_now ("Common block %</%s/%> at %L set with NOHOST "
6631 : "specified may not appear in a LINK clause",
6632 1 : n->u.common->name, &n->where);
6633 :
6634 41 : if (list == OMP_LIST_TO || list == OMP_LIST_ENTER)
6635 21 : n->u.common->omp_declare_target = 1;
6636 41 : if (list == OMP_LIST_LINK)
6637 15 : n->u.common->omp_declare_target_link = 1;
6638 41 : if (list == OMP_LIST_LOCAL)
6639 5 : n->u.common->omp_declare_target_local = 1;
6640 :
6641 110 : for (s = n->u.common->head; s; s = s->common_next)
6642 : {
6643 69 : s->mark = 1;
6644 69 : if (list == OMP_LIST_TO || list == OMP_LIST_ENTER)
6645 33 : gfc_add_omp_declare_target (&s->attr, s->name, &n->where);
6646 69 : if (list == OMP_LIST_LINK)
6647 31 : gfc_add_omp_declare_target_link (&s->attr, s->name, &n->where);
6648 69 : if (list == OMP_LIST_LOCAL)
6649 5 : gfc_add_omp_declare_target_local (&s->attr, s->name, &n->where);
6650 69 : s->attr.omp_device_type = c->device_type;
6651 69 : s->attr.omp_declare_target_indirect = c->indirect;
6652 : }
6653 : }
6654 325 : if ((c->device_type || c->indirect)
6655 325 : && !c->lists[OMP_LIST_ENTER]
6656 151 : && !c->lists[OMP_LIST_TO]
6657 47 : && !c->lists[OMP_LIST_LINK]
6658 10 : && !c->lists[OMP_LIST_LOCAL])
6659 2 : gfc_warning_now (OPT_Wopenmp,
6660 : "OMP DECLARE TARGET directive at %L with only "
6661 : "DEVICE_TYPE or INDIRECT clauses is ignored",
6662 : &old_loc);
6663 :
6664 325 : gfc_buffer_error (true);
6665 :
6666 325 : if (c)
6667 325 : gfc_free_omp_clauses (c);
6668 325 : return MATCH_YES;
6669 :
6670 0 : syntax:
6671 0 : gfc_error ("Syntax error in !$OMP DECLARE TARGET list at %C");
6672 :
6673 2 : cleanup:
6674 2 : gfc_current_locus = old_loc;
6675 2 : if (c)
6676 0 : gfc_free_omp_clauses (c);
6677 : return MATCH_ERROR;
6678 : }
6679 :
6680 : /* Skip over and ignore trait-property-extensions.
6681 :
6682 : trait-property-extension :
6683 : trait-property-name
6684 : identifier (trait-property-extension[, trait-property-extension[, ...]])
6685 : constant integer expression
6686 : */
6687 :
6688 : static match gfc_ignore_trait_property_extension_list (void);
6689 :
6690 : static match
6691 7 : gfc_ignore_trait_property_extension (void)
6692 : {
6693 7 : char buf[GFC_MAX_SYMBOL_LEN + 1];
6694 7 : gfc_expr *expr;
6695 :
6696 : /* Identifier form of trait-property name, possibly followed by
6697 : a list of (recursive) trait-property-extensions. */
6698 7 : if (gfc_match_name (buf) == MATCH_YES)
6699 : {
6700 0 : if (gfc_match (" (") == MATCH_YES)
6701 0 : return gfc_ignore_trait_property_extension_list ();
6702 : return MATCH_YES;
6703 : }
6704 :
6705 : /* Literal constant. */
6706 7 : if (gfc_match_literal_constant (&expr, 0) == MATCH_YES)
6707 : return MATCH_YES;
6708 :
6709 : /* FIXME: constant integer expressions. */
6710 0 : gfc_error ("Expected trait-property-extension at %C");
6711 0 : return MATCH_ERROR;
6712 : }
6713 :
6714 : static match
6715 5 : gfc_ignore_trait_property_extension_list (void)
6716 : {
6717 9 : while (1)
6718 : {
6719 7 : if (gfc_ignore_trait_property_extension () != MATCH_YES)
6720 : return MATCH_ERROR;
6721 7 : if (gfc_match (" ,") == MATCH_YES)
6722 2 : continue;
6723 5 : if (gfc_match (" )") == MATCH_YES)
6724 : return MATCH_YES;
6725 0 : gfc_error ("expected %<)%> at %C");
6726 0 : return MATCH_ERROR;
6727 : }
6728 : }
6729 :
6730 :
6731 : match
6732 110 : gfc_match_omp_interop (void)
6733 : {
6734 110 : return match_omp (EXEC_OMP_INTEROP, OMP_INTEROP_CLAUSES);
6735 : }
6736 :
6737 :
6738 : /* OpenMP 5.0:
6739 :
6740 : trait-selector:
6741 : trait-selector-name[([trait-score:]trait-property[,trait-property[,...]])]
6742 :
6743 : trait-score:
6744 : score(score-expression) */
6745 :
6746 : static match
6747 637 : gfc_match_omp_context_selector (gfc_omp_set_selector *oss)
6748 : {
6749 775 : do
6750 : {
6751 775 : char selector[GFC_MAX_SYMBOL_LEN + 1];
6752 :
6753 775 : if (gfc_match_name (selector) != MATCH_YES)
6754 : {
6755 2 : gfc_error ("expected trait selector name at %C");
6756 39 : return MATCH_ERROR;
6757 : }
6758 :
6759 773 : gfc_omp_selector *os = gfc_get_omp_selector ();
6760 773 : if (oss->code == OMP_TRAIT_SET_CONSTRUCT
6761 335 : && !strcmp (selector, "do"))
6762 48 : os->code = OMP_TRAIT_CONSTRUCT_FOR;
6763 725 : else if (oss->code == OMP_TRAIT_SET_CONSTRUCT
6764 287 : && !strcmp (selector, "for"))
6765 1 : os->code = OMP_TRAIT_INVALID;
6766 : else
6767 724 : os->code = omp_lookup_ts_code (oss->code, selector);
6768 773 : os->next = oss->trait_selectors;
6769 773 : oss->trait_selectors = os;
6770 :
6771 773 : if (os->code == OMP_TRAIT_INVALID)
6772 : {
6773 18 : gfc_warning (OPT_Wopenmp,
6774 : "unknown selector %qs for context selector set %qs "
6775 : "at %C",
6776 18 : selector, omp_tss_map[oss->code]);
6777 18 : if (gfc_match (" (") == MATCH_YES
6778 18 : && gfc_ignore_trait_property_extension_list () != MATCH_YES)
6779 : return MATCH_ERROR;
6780 18 : if (gfc_match (" ,") == MATCH_YES)
6781 1 : continue;
6782 598 : break;
6783 : }
6784 :
6785 755 : enum omp_tp_type property_kind = omp_ts_map[os->code].tp_type;
6786 755 : bool allow_score = omp_ts_map[os->code].allow_score;
6787 :
6788 755 : if (gfc_match (" (") == MATCH_YES)
6789 : {
6790 431 : if (property_kind == OMP_TRAIT_PROPERTY_NONE)
6791 : {
6792 6 : gfc_error ("selector %qs does not accept any properties at %C",
6793 : selector);
6794 6 : return MATCH_ERROR;
6795 : }
6796 :
6797 425 : if (gfc_match (" score") == MATCH_YES)
6798 : {
6799 63 : if (!allow_score)
6800 : {
6801 10 : gfc_error ("%<score%> cannot be specified in traits "
6802 : "in the %qs trait-selector-set at %C",
6803 10 : omp_tss_map[oss->code]);
6804 10 : return MATCH_ERROR;
6805 : }
6806 53 : if (gfc_match (" (") != MATCH_YES)
6807 : {
6808 0 : gfc_error ("expected %<(%> at %C");
6809 0 : return MATCH_ERROR;
6810 : }
6811 53 : if (gfc_match_expr (&os->score) != MATCH_YES)
6812 : return MATCH_ERROR;
6813 :
6814 52 : if (gfc_match (" )") != MATCH_YES)
6815 : {
6816 0 : gfc_error ("expected %<)%> at %C");
6817 0 : return MATCH_ERROR;
6818 : }
6819 :
6820 52 : if (gfc_match (" :") != MATCH_YES)
6821 : {
6822 0 : gfc_error ("expected : at %C");
6823 0 : return MATCH_ERROR;
6824 : }
6825 : }
6826 :
6827 414 : gfc_omp_trait_property *otp = gfc_get_omp_trait_property ();
6828 414 : otp->property_kind = property_kind;
6829 414 : otp->next = os->properties;
6830 414 : os->properties = otp;
6831 :
6832 414 : switch (property_kind)
6833 : {
6834 25 : case OMP_TRAIT_PROPERTY_ID:
6835 25 : {
6836 25 : char buf[GFC_MAX_SYMBOL_LEN + 1];
6837 25 : if (gfc_match_name (buf) == MATCH_YES)
6838 : {
6839 24 : otp->name = XNEWVEC (char, strlen (buf) + 1);
6840 24 : strcpy (otp->name, buf);
6841 : }
6842 : else
6843 : {
6844 1 : gfc_error ("expected identifier at %C");
6845 1 : free (otp);
6846 1 : os->properties = nullptr;
6847 1 : return MATCH_ERROR;
6848 : }
6849 : }
6850 24 : break;
6851 290 : case OMP_TRAIT_PROPERTY_NAME_LIST:
6852 343 : do
6853 : {
6854 290 : char buf[GFC_MAX_SYMBOL_LEN + 1];
6855 290 : if (gfc_match_name (buf) == MATCH_YES)
6856 : {
6857 170 : otp->name = XNEWVEC (char, strlen (buf) + 1);
6858 170 : strcpy (otp->name, buf);
6859 170 : otp->is_name = true;
6860 : }
6861 120 : else if (gfc_match_literal_constant (&otp->expr, 0)
6862 : != MATCH_YES
6863 120 : || otp->expr->ts.type != BT_CHARACTER)
6864 : {
6865 5 : gfc_error ("expected identifier or string literal "
6866 : "at %C");
6867 5 : free (otp);
6868 5 : os->properties = nullptr;
6869 5 : return MATCH_ERROR;
6870 : }
6871 :
6872 285 : if (gfc_match (" ,") == MATCH_YES)
6873 : {
6874 53 : otp = gfc_get_omp_trait_property ();
6875 53 : otp->property_kind = property_kind;
6876 53 : otp->next = os->properties;
6877 53 : os->properties = otp;
6878 : }
6879 : else
6880 : break;
6881 53 : }
6882 : while (1);
6883 232 : break;
6884 137 : case OMP_TRAIT_PROPERTY_DEV_NUM_EXPR:
6885 137 : case OMP_TRAIT_PROPERTY_BOOL_EXPR:
6886 137 : if (gfc_match_expr (&otp->expr) != MATCH_YES)
6887 : {
6888 3 : gfc_error ("expected expression at %C");
6889 3 : free (otp);
6890 3 : os->properties = nullptr;
6891 3 : return MATCH_ERROR;
6892 : }
6893 : break;
6894 15 : case OMP_TRAIT_PROPERTY_CLAUSE_LIST:
6895 15 : {
6896 15 : if (os->code == OMP_TRAIT_CONSTRUCT_SIMD)
6897 : {
6898 15 : gfc_matching_omp_context_selector = true;
6899 15 : if (gfc_match_omp_clauses (&otp->clauses,
6900 15 : OMP_DECLARE_SIMD_CLAUSES,
6901 : true, false, false)
6902 : != MATCH_YES)
6903 : {
6904 1 : gfc_matching_omp_context_selector = false;
6905 1 : gfc_error ("expected simd clause at %C");
6906 1 : return MATCH_ERROR;
6907 : }
6908 14 : gfc_matching_omp_context_selector = false;
6909 : }
6910 0 : else if (os->code == OMP_TRAIT_IMPLEMENTATION_REQUIRES)
6911 : {
6912 : /* FIXME: The "requires" selector was added in OpenMP 5.1.
6913 : Currently only the now-deprecated syntax
6914 : from OpenMP 5.0 is supported.
6915 : TODO: When implementing, update modules.cc as well. */
6916 0 : sorry_at (gfc_get_location (&gfc_current_locus),
6917 : "%<requires%> selector is not supported yet");
6918 0 : return MATCH_ERROR;
6919 : }
6920 : else
6921 0 : gcc_unreachable ();
6922 14 : break;
6923 : }
6924 0 : default:
6925 0 : gcc_unreachable ();
6926 : }
6927 :
6928 404 : if (gfc_match (" )") != MATCH_YES)
6929 : {
6930 2 : gfc_error ("expected %<)%> at %C");
6931 2 : return MATCH_ERROR;
6932 : }
6933 : }
6934 324 : else if (property_kind != OMP_TRAIT_PROPERTY_NONE
6935 324 : && property_kind != OMP_TRAIT_PROPERTY_CLAUSE_LIST
6936 8 : && property_kind != OMP_TRAIT_PROPERTY_EXTENSION)
6937 : {
6938 8 : if (gfc_match (" (") != MATCH_YES)
6939 : {
6940 8 : gfc_error ("expected %<(%> at %C");
6941 8 : return MATCH_ERROR;
6942 : }
6943 : }
6944 :
6945 718 : if (gfc_match (" ,") != MATCH_YES)
6946 : break;
6947 : }
6948 : while (1);
6949 :
6950 598 : return MATCH_YES;
6951 : }
6952 :
6953 : /* OpenMP 5.0:
6954 :
6955 : trait-set-selector[,trait-set-selector[,...]]
6956 :
6957 : trait-set-selector:
6958 : trait-set-selector-name = { trait-selector[, trait-selector[, ...]] }
6959 :
6960 : trait-set-selector-name:
6961 : constructor
6962 : device
6963 : implementation
6964 : user */
6965 :
6966 : static match
6967 577 : gfc_match_omp_context_selector_specification (gfc_omp_set_selector **oss_head)
6968 : {
6969 713 : do
6970 : {
6971 645 : match m;
6972 645 : char buf[GFC_MAX_SYMBOL_LEN + 1];
6973 645 : enum omp_tss_code set = OMP_TRAIT_SET_INVALID;
6974 :
6975 645 : m = gfc_match_name (buf);
6976 645 : if (m == MATCH_YES)
6977 643 : set = omp_lookup_tss_code (buf);
6978 :
6979 643 : if (set == OMP_TRAIT_SET_INVALID)
6980 : {
6981 5 : gfc_error ("expected context selector set name at %C");
6982 47 : return MATCH_ERROR;
6983 : }
6984 :
6985 640 : m = gfc_match (" =");
6986 640 : if (m != MATCH_YES)
6987 : {
6988 1 : gfc_error ("expected %<=%> at %C");
6989 1 : return MATCH_ERROR;
6990 : }
6991 :
6992 639 : m = gfc_match (" {");
6993 639 : if (m != MATCH_YES)
6994 : {
6995 2 : gfc_error ("expected %<{%> at %C");
6996 2 : return MATCH_ERROR;
6997 : }
6998 :
6999 637 : gfc_omp_set_selector *oss = gfc_get_omp_set_selector ();
7000 637 : oss->next = *oss_head;
7001 637 : oss->code = set;
7002 637 : *oss_head = oss;
7003 :
7004 637 : if (gfc_match_omp_context_selector (oss) != MATCH_YES)
7005 : return MATCH_ERROR;
7006 :
7007 598 : m = gfc_match (" }");
7008 598 : if (m != MATCH_YES)
7009 : {
7010 0 : gfc_error ("expected %<}%> at %C");
7011 0 : return MATCH_ERROR;
7012 : }
7013 :
7014 598 : m = gfc_match (" ,");
7015 598 : if (m != MATCH_YES)
7016 : break;
7017 68 : }
7018 : while (1);
7019 :
7020 530 : return MATCH_YES;
7021 : }
7022 :
7023 :
7024 : match
7025 419 : gfc_match_omp_declare_variant (void)
7026 : {
7027 419 : char buf[GFC_MAX_SYMBOL_LEN + 1];
7028 :
7029 419 : if (gfc_match (" (") != MATCH_YES)
7030 : {
7031 2 : gfc_error ("expected %<(%> at %C");
7032 2 : return MATCH_ERROR;
7033 : }
7034 :
7035 417 : gfc_symtree *base_proc_st, *variant_proc_st;
7036 417 : if (gfc_match_name (buf) != MATCH_YES)
7037 : {
7038 2 : gfc_error ("expected name at %C");
7039 2 : return MATCH_ERROR;
7040 : }
7041 :
7042 415 : if (gfc_get_ha_sym_tree (buf, &base_proc_st))
7043 : return MATCH_ERROR;
7044 :
7045 415 : if (gfc_match (" :") == MATCH_YES)
7046 : {
7047 16 : if (gfc_match_name (buf) != MATCH_YES)
7048 : {
7049 0 : gfc_error ("expected variant name at %C");
7050 0 : return MATCH_ERROR;
7051 : }
7052 :
7053 16 : if (gfc_get_ha_sym_tree (buf, &variant_proc_st))
7054 : return MATCH_ERROR;
7055 : }
7056 : else
7057 : {
7058 : /* Base procedure not specified. */
7059 399 : variant_proc_st = base_proc_st;
7060 399 : base_proc_st = NULL;
7061 : }
7062 :
7063 415 : gfc_omp_declare_variant *odv;
7064 415 : odv = gfc_get_omp_declare_variant ();
7065 415 : odv->where = gfc_current_locus;
7066 415 : odv->variant_proc_symtree = variant_proc_st;
7067 415 : odv->adjust_args_list = NULL;
7068 415 : odv->base_proc_symtree = base_proc_st;
7069 415 : odv->next = NULL;
7070 415 : odv->error_p = false;
7071 :
7072 : /* Add the new declare variant to the end of the list. */
7073 415 : gfc_omp_declare_variant **prev_next = &gfc_current_ns->omp_declare_variant;
7074 555 : while (*prev_next)
7075 140 : prev_next = &((*prev_next)->next);
7076 415 : *prev_next = odv;
7077 :
7078 415 : if (gfc_match (" )") != MATCH_YES)
7079 : {
7080 1 : gfc_error ("expected %<)%> at %C");
7081 1 : return MATCH_ERROR;
7082 : }
7083 :
7084 414 : bool has_match = false, has_adjust_args = false, has_append_args = false;
7085 414 : bool error_p = false;
7086 414 : locus adjust_args_loc;
7087 414 : locus append_args_loc;
7088 :
7089 414 : gfc_gobble_whitespace ();
7090 414 : gfc_match_char (',');
7091 632 : for (;;)
7092 : {
7093 523 : gfc_gobble_whitespace ();
7094 :
7095 523 : enum clause
7096 : {
7097 : clause_match,
7098 : clause_adjust_args,
7099 : clause_append_args
7100 : } ccode;
7101 :
7102 523 : if (gfc_match ("match") == MATCH_YES)
7103 : ccode = clause_match;
7104 119 : else if (gfc_match ("adjust_args") == MATCH_YES)
7105 : {
7106 517 : ccode = clause_adjust_args;
7107 : adjust_args_loc = gfc_current_locus;
7108 : }
7109 38 : else if (gfc_match ("append_args") == MATCH_YES)
7110 : {
7111 517 : ccode = clause_append_args;
7112 : append_args_loc = gfc_current_locus;
7113 : }
7114 : else
7115 : {
7116 : error_p = true;
7117 : break;
7118 : }
7119 :
7120 517 : if (gfc_match (" ( ") != MATCH_YES)
7121 : {
7122 1 : gfc_error ("expected %<(%> at %C");
7123 1 : return MATCH_ERROR;
7124 : }
7125 :
7126 516 : if (ccode == clause_match)
7127 : {
7128 403 : if (has_match)
7129 : {
7130 1 : gfc_error ("%qs clause at %L specified more than once",
7131 : "match", &gfc_current_locus);
7132 1 : return MATCH_ERROR;
7133 : }
7134 402 : has_match = true;
7135 402 : if (gfc_match_omp_context_selector_specification (&odv->set_selectors)
7136 : != MATCH_YES)
7137 : return MATCH_ERROR;
7138 362 : if (gfc_match (" )") != MATCH_YES)
7139 : {
7140 0 : gfc_error ("expected %<)%> at %C");
7141 0 : return MATCH_ERROR;
7142 : }
7143 : }
7144 113 : else if (ccode == clause_adjust_args)
7145 : {
7146 81 : has_adjust_args = true;
7147 81 : bool need_device_ptr_p = false;
7148 81 : bool need_device_addr_p = false;
7149 81 : if (gfc_match ("nothing ") == MATCH_YES)
7150 : ;
7151 58 : else if (gfc_match ("need_device_ptr ") == MATCH_YES)
7152 : need_device_ptr_p = true;
7153 9 : else if (gfc_match ("need_device_addr ") == MATCH_YES)
7154 : need_device_addr_p = true;
7155 : else
7156 : {
7157 2 : gfc_error ("expected %<nothing%>, %<need_device_ptr%> or "
7158 : "%<need_device_addr%> at %C");
7159 2 : return MATCH_ERROR;
7160 : }
7161 79 : if (gfc_match (": ") != MATCH_YES)
7162 : {
7163 1 : gfc_error ("expected %<:%> at %C");
7164 1 : return MATCH_ERROR;
7165 : }
7166 : gfc_omp_namelist *tail = NULL;
7167 : bool need_range = false, have_range = false;
7168 125 : while (true)
7169 : {
7170 125 : gfc_omp_namelist *p = gfc_get_omp_namelist ();
7171 125 : p->where = gfc_current_locus;
7172 125 : p->u.adj_args.need_ptr = need_device_ptr_p;
7173 125 : p->u.adj_args.need_addr = need_device_addr_p;
7174 125 : if (tail)
7175 : {
7176 47 : tail->next = p;
7177 47 : tail = tail->next;
7178 : }
7179 : else
7180 : {
7181 78 : gfc_omp_namelist **q = &odv->adjust_args_list;
7182 78 : if (*q)
7183 : {
7184 50 : for (; (*q)->next; q = &(*q)->next)
7185 : ;
7186 28 : (*q)->next = p;
7187 : }
7188 : else
7189 50 : *q = p;
7190 : tail = p;
7191 : }
7192 125 : if (gfc_match (": ") == MATCH_YES)
7193 : {
7194 2 : if (have_range)
7195 : {
7196 0 : gfc_error ("unexpected %<:%> at %C");
7197 2 : return MATCH_ERROR;
7198 : }
7199 2 : p->u.adj_args.range_start = have_range = true;
7200 2 : need_range = false;
7201 49 : continue;
7202 : }
7203 123 : if (have_range && gfc_match (", ") == MATCH_YES)
7204 : {
7205 1 : have_range = false;
7206 1 : continue;
7207 : }
7208 122 : if (have_range && gfc_match (") ") == MATCH_YES)
7209 : break;
7210 121 : locus saved_loc = gfc_current_locus;
7211 :
7212 : /* Without ranges, only arg names or integer literals permitted;
7213 : handle literals here as gfc_match_expr simplifies the expr. */
7214 121 : if (gfc_match_literal_constant (&p->expr, true) == MATCH_YES)
7215 : {
7216 17 : gfc_gobble_whitespace ();
7217 17 : char c = gfc_peek_ascii_char ();
7218 17 : if (c != ')' && c != ',' && c != ':')
7219 : {
7220 1 : gfc_free_expr (p->expr);
7221 1 : p->expr = NULL;
7222 1 : gfc_current_locus = saved_loc;
7223 : }
7224 : }
7225 121 : if (!p->expr && gfc_match ("omp_num_args") == MATCH_YES)
7226 : {
7227 6 : if (!have_range)
7228 3 : p->u.adj_args.range_start = need_range = true;
7229 : else
7230 : need_range = false;
7231 :
7232 6 : locus saved_loc2 = gfc_current_locus;
7233 6 : gfc_gobble_whitespace ();
7234 6 : char c = gfc_peek_ascii_char ();
7235 6 : if (c == '+' || c == '-')
7236 : {
7237 5 : if (gfc_match ("+ %e", &p->expr) == MATCH_YES)
7238 1 : p->u.adj_args.omp_num_args_plus = true;
7239 4 : else if (gfc_match ("- %e", &p->expr) == MATCH_YES)
7240 4 : p->u.adj_args.omp_num_args_minus = true;
7241 0 : else if (!gfc_error_check ())
7242 : {
7243 0 : gfc_error ("expected constant integer expression "
7244 : "at %C");
7245 0 : p->u.adj_args.error_p = true;
7246 0 : return MATCH_ERROR;
7247 : }
7248 5 : p->where = gfc_get_location_range (&saved_loc, 1,
7249 : &saved_loc, 1,
7250 : &gfc_current_locus);
7251 : }
7252 : else
7253 : {
7254 1 : p->where = gfc_get_location_range (&saved_loc, 1,
7255 : &saved_loc, 1,
7256 : &saved_loc2);
7257 1 : p->u.adj_args.omp_num_args_plus = true;
7258 : }
7259 : }
7260 115 : else if (!p->expr)
7261 : {
7262 99 : match m = gfc_match_expr (&p->expr);
7263 99 : if (m != MATCH_YES)
7264 : {
7265 1 : gfc_error ("expected dummy parameter name, "
7266 : "%<omp_num_args%> or constant positive integer"
7267 : " at %C");
7268 1 : p->u.adj_args.error_p = true;
7269 1 : return MATCH_ERROR;
7270 : }
7271 98 : if (p->expr->expr_type == EXPR_CONSTANT && !have_range)
7272 98 : need_range = true; /* Constant expr but not literal. */
7273 98 : p->where = p->expr->where;
7274 : }
7275 : else
7276 16 : p->where = p->expr->where;
7277 120 : gfc_gobble_whitespace ();
7278 120 : match m = gfc_match (": ");
7279 120 : if (need_range && m != MATCH_YES)
7280 : {
7281 1 : gfc_error ("expected %<:%> at %C");
7282 1 : return MATCH_ERROR;
7283 : }
7284 119 : if (m == MATCH_YES)
7285 : {
7286 6 : p->u.adj_args.range_start = have_range = true;
7287 6 : need_range = false;
7288 6 : continue;
7289 : }
7290 113 : need_range = have_range = false;
7291 113 : if (gfc_match (", ") == MATCH_YES)
7292 38 : continue;
7293 75 : if (gfc_match (") ") == MATCH_YES)
7294 : break;
7295 : }
7296 : }
7297 32 : else if (ccode == clause_append_args)
7298 : {
7299 32 : if (has_append_args)
7300 : {
7301 1 : gfc_error ("%qs clause at %L specified more than once",
7302 : "append_args", &gfc_current_locus);
7303 1 : return MATCH_ERROR;
7304 : }
7305 56 : has_append_args = true;
7306 : gfc_omp_namelist *append_args_last = NULL;
7307 81 : do
7308 : {
7309 56 : gfc_gobble_whitespace ();
7310 56 : if (gfc_match ("interop ") != MATCH_YES)
7311 : {
7312 0 : gfc_error ("expected %<interop%> at %C");
7313 3 : return MATCH_ERROR;
7314 : }
7315 56 : if (gfc_match ("( ") != MATCH_YES)
7316 : {
7317 0 : gfc_error ("expected %<(%> at %C");
7318 0 : return MATCH_ERROR;
7319 : }
7320 :
7321 56 : bool target, targetsync;
7322 56 : char *type_str = NULL;
7323 56 : int type_str_len;
7324 56 : locus loc = gfc_current_locus;
7325 56 : if (gfc_parser_omp_clause_init_modifiers (target, targetsync,
7326 : &type_str, type_str_len,
7327 : false) == MATCH_ERROR)
7328 : return MATCH_ERROR;
7329 :
7330 54 : gfc_omp_namelist *n = gfc_get_omp_namelist();
7331 54 : n->where = loc;
7332 54 : n->u.init.target = target;
7333 54 : n->u.init.targetsync = targetsync;
7334 54 : n->u.init.len = type_str_len;
7335 54 : n->u2.init_interop = type_str;
7336 54 : if (odv->append_args_list)
7337 : {
7338 25 : append_args_last->next = n;
7339 25 : append_args_last = n;
7340 : }
7341 : else
7342 29 : append_args_last = odv->append_args_list = n;
7343 :
7344 54 : gfc_gobble_whitespace ();
7345 54 : if (gfc_match_char (',') == MATCH_YES)
7346 25 : continue;
7347 29 : if (gfc_match_char (')') == MATCH_YES)
7348 : break;
7349 1 : gfc_error ("Expected %<,%> or %<)%> at %C");
7350 1 : return MATCH_ERROR;
7351 : }
7352 : while (true);
7353 : }
7354 466 : gfc_gobble_whitespace ();
7355 466 : if (gfc_match_omp_eos () == MATCH_YES)
7356 : break;
7357 109 : gfc_match_char (',');
7358 109 : }
7359 :
7360 363 : if (error_p || (!has_match && !has_adjust_args && !has_append_args))
7361 : {
7362 6 : gfc_error ("expected %<match%>, %<adjust_args%> or %<append_args%> at %C");
7363 6 : return MATCH_ERROR;
7364 : }
7365 :
7366 357 : if (!has_match)
7367 : {
7368 3 : gfc_error ("expected %<match%> clause at %C");
7369 3 : return MATCH_ERROR;
7370 : }
7371 :
7372 : return MATCH_YES;
7373 : }
7374 :
7375 :
7376 : static match
7377 160 : match_omp_metadirective (bool begin_p)
7378 : {
7379 160 : locus old_loc = gfc_current_locus;
7380 160 : gfc_omp_variant *variants_head;
7381 160 : gfc_omp_variant **next_variant = &variants_head;
7382 160 : bool default_seen = false;
7383 :
7384 : /* Parse the context selectors. */
7385 656 : for (;;)
7386 : {
7387 408 : bool default_p = false;
7388 408 : gfc_omp_set_selector *selectors = NULL;
7389 :
7390 408 : gfc_gobble_whitespace ();
7391 408 : if (gfc_match_eos () == MATCH_YES)
7392 : break;
7393 266 : gfc_match_char (',');
7394 266 : gfc_gobble_whitespace ();
7395 :
7396 266 : locus variant_locus = gfc_current_locus;
7397 :
7398 266 : if (gfc_match ("default ( ") == MATCH_YES)
7399 : {
7400 82 : default_p = true;
7401 82 : gfc_warning (OPT_Wdeprecated_openmp,
7402 : "%<default%> clause with metadirective at %L "
7403 : "deprecated since OpenMP 5.2", &variant_locus);
7404 : }
7405 184 : else if (gfc_match ("otherwise ( ") == MATCH_YES)
7406 : default_p = true;
7407 177 : else if (gfc_match ("when ( ") != MATCH_YES)
7408 : {
7409 1 : gfc_error ("expected %<when%>, %<otherwise%>, or %<default%> at %C");
7410 1 : gfc_current_locus = old_loc;
7411 18 : return MATCH_ERROR;
7412 : }
7413 89 : if (default_p && default_seen)
7414 : {
7415 3 : gfc_error ("too many %<otherwise%> or %<default%> clauses "
7416 : "in %<metadirective%> at %C");
7417 3 : gfc_current_locus = old_loc;
7418 3 : return MATCH_ERROR;
7419 : }
7420 262 : else if (default_seen)
7421 : {
7422 1 : gfc_error ("%<otherwise%> or %<default%> clause "
7423 : "must appear last in %<metadirective%> at %C");
7424 1 : gfc_current_locus = old_loc;
7425 1 : return MATCH_ERROR;
7426 : }
7427 :
7428 261 : if (!default_p)
7429 : {
7430 175 : if (gfc_match_omp_context_selector_specification (&selectors)
7431 : != MATCH_YES)
7432 : return MATCH_ERROR;
7433 :
7434 168 : if (gfc_match (" : ") != MATCH_YES)
7435 : {
7436 1 : gfc_error ("expected %<:%> at %C");
7437 1 : gfc_current_locus = old_loc;
7438 1 : return MATCH_ERROR;
7439 : }
7440 :
7441 167 : gfc_commit_symbols ();
7442 : }
7443 :
7444 253 : gfc_matching_omp_context_selector = true;
7445 253 : gfc_statement directive = match_omp_directive ();
7446 253 : gfc_matching_omp_context_selector = false;
7447 :
7448 253 : if (is_omp_declarative_stmt (directive))
7449 0 : sorry_at (gfc_get_location (&gfc_current_locus),
7450 : "declarative directive variants are not supported");
7451 :
7452 253 : if (gfc_error_flag_test ())
7453 : {
7454 2 : gfc_current_locus = old_loc;
7455 2 : return MATCH_ERROR;
7456 : }
7457 :
7458 251 : if (gfc_match (" )") != MATCH_YES)
7459 : {
7460 0 : gfc_error ("Expected %<)%> at %C");
7461 0 : gfc_current_locus = old_loc;
7462 0 : return MATCH_ERROR;
7463 : }
7464 :
7465 251 : gfc_commit_symbols ();
7466 :
7467 251 : if (begin_p
7468 251 : && directive != ST_NONE
7469 251 : && gfc_omp_end_stmt (directive) == ST_NONE)
7470 : {
7471 3 : gfc_error ("variant directive used in OMP BEGIN METADIRECTIVE "
7472 : "at %C must have a corresponding end directive");
7473 3 : gfc_current_locus = old_loc;
7474 3 : return MATCH_ERROR;
7475 : }
7476 :
7477 248 : if (default_p)
7478 : default_seen = true;
7479 :
7480 248 : gfc_omp_variant *omv = gfc_get_omp_variant ();
7481 248 : omv->selectors = selectors;
7482 248 : omv->stmt = directive;
7483 248 : omv->where = variant_locus;
7484 :
7485 248 : if (directive == ST_NONE)
7486 : {
7487 : /* The directive was a 'nothing' directive. */
7488 15 : omv->code = gfc_get_code (EXEC_CONTINUE);
7489 15 : omv->code->ext.omp_clauses = NULL;
7490 : }
7491 : else
7492 : {
7493 233 : omv->code = gfc_get_code (new_st.op);
7494 233 : omv->code->ext.omp_clauses = new_st.ext.omp_clauses;
7495 : /* Prevent the OpenMP clauses from being freed via NEW_ST. */
7496 233 : new_st.ext.omp_clauses = NULL;
7497 : }
7498 :
7499 248 : *next_variant = omv;
7500 248 : next_variant = &omv->next;
7501 248 : }
7502 :
7503 142 : if (gfc_match_omp_eos () != MATCH_YES)
7504 : {
7505 0 : gfc_error ("Unexpected junk after OMP METADIRECTIVE at %C");
7506 0 : gfc_current_locus = old_loc;
7507 0 : return MATCH_ERROR;
7508 : }
7509 :
7510 : /* Add a 'default (nothing)' clause if no default is explicitly given. */
7511 142 : if (!default_seen)
7512 : {
7513 65 : gfc_omp_variant *omv = gfc_get_omp_variant ();
7514 65 : omv->stmt = ST_NONE;
7515 65 : omv->code = gfc_get_code (EXEC_CONTINUE);
7516 65 : omv->code->ext.omp_clauses = NULL;
7517 65 : omv->where = old_loc;
7518 65 : omv->selectors = NULL;
7519 :
7520 65 : *next_variant = omv;
7521 65 : next_variant = &omv->next;
7522 : }
7523 :
7524 142 : new_st.op = EXEC_OMP_METADIRECTIVE;
7525 142 : new_st.ext.omp_variants = variants_head;
7526 :
7527 142 : return MATCH_YES;
7528 : }
7529 :
7530 : match
7531 43 : gfc_match_omp_begin_metadirective (void)
7532 : {
7533 43 : return match_omp_metadirective (true);
7534 : }
7535 :
7536 : match
7537 117 : gfc_match_omp_metadirective (void)
7538 : {
7539 117 : return match_omp_metadirective (false);
7540 : }
7541 :
7542 : /* Match 'omp threadprivate' or 'omp groupprivate'. */
7543 : static match
7544 259 : gfc_match_omp_thread_group_private (bool is_groupprivate)
7545 : {
7546 259 : locus old_loc;
7547 259 : char n[GFC_MAX_SYMBOL_LEN+1];
7548 259 : gfc_symbol *sym;
7549 259 : match m;
7550 259 : gfc_symtree *st;
7551 259 : struct sym_loc_t { gfc_symbol *sym; gfc_common_head *com; locus loc; };
7552 259 : auto_vec<sym_loc_t> syms;
7553 :
7554 259 : old_loc = gfc_current_locus;
7555 :
7556 259 : m = gfc_match (" ( ");
7557 259 : if (m != MATCH_YES)
7558 : return m;
7559 :
7560 369 : for (;;)
7561 : {
7562 314 : locus sym_loc = gfc_current_locus;
7563 314 : m = gfc_match_symbol (&sym, 0);
7564 314 : switch (m)
7565 : {
7566 209 : case MATCH_YES:
7567 209 : if (sym->attr.in_common)
7568 0 : gfc_error_now ("%qs variable at %L is an element of a COMMON block",
7569 : is_groupprivate ? "groupprivate" : "threadprivate",
7570 : &sym_loc);
7571 209 : else if (!is_groupprivate
7572 209 : && !gfc_add_threadprivate (&sym->attr, sym->name, &sym_loc))
7573 16 : goto cleanup;
7574 207 : else if (is_groupprivate)
7575 : {
7576 30 : if (!gfc_add_omp_groupprivate (&sym->attr, sym->name, &sym_loc))
7577 4 : goto cleanup;
7578 26 : syms.safe_push ({sym, nullptr, sym_loc});
7579 : }
7580 203 : goto next_item;
7581 : case MATCH_NO:
7582 : break;
7583 0 : case MATCH_ERROR:
7584 0 : goto cleanup;
7585 : }
7586 :
7587 105 : m = gfc_match (" / %n /", n);
7588 105 : if (m == MATCH_ERROR)
7589 0 : goto cleanup;
7590 105 : if (m == MATCH_NO || n[0] == '\0')
7591 0 : goto syntax;
7592 :
7593 105 : st = gfc_find_symtree (gfc_current_ns->common_root, n);
7594 105 : if (st == NULL)
7595 : {
7596 2 : gfc_error ("COMMON block /%s/ not found at %L", n, &sym_loc);
7597 2 : goto cleanup;
7598 : }
7599 103 : syms.safe_push ({nullptr, st->n.common, sym_loc});
7600 103 : if (is_groupprivate)
7601 30 : st->n.common->omp_groupprivate = 1;
7602 : else
7603 73 : st->n.common->threadprivate = 1;
7604 236 : for (sym = st->n.common->head; sym; sym = sym->common_next)
7605 141 : if (!is_groupprivate
7606 141 : && !gfc_add_threadprivate (&sym->attr, sym->name, &sym_loc))
7607 3 : goto cleanup;
7608 138 : else if (is_groupprivate
7609 138 : && !gfc_add_omp_groupprivate (&sym->attr, sym->name, &sym_loc))
7610 5 : goto cleanup;
7611 :
7612 95 : next_item:
7613 298 : if (gfc_match_char (')') == MATCH_YES)
7614 : break;
7615 55 : if (gfc_match_char (',') != MATCH_YES)
7616 0 : goto syntax;
7617 55 : }
7618 :
7619 243 : if (is_groupprivate)
7620 : {
7621 39 : gfc_omp_clauses *c;
7622 39 : m = gfc_match_omp_clauses (&c, omp_mask (OMP_CLAUSE_DEVICE_TYPE));
7623 39 : if (m == MATCH_ERROR)
7624 0 : return MATCH_ERROR;
7625 :
7626 39 : if (c->device_type == OMP_DEVICE_TYPE_UNSET)
7627 19 : c->device_type = OMP_DEVICE_TYPE_ANY;
7628 :
7629 86 : for (size_t i = 0; i < syms.length (); i++)
7630 47 : if (syms[i].sym)
7631 : {
7632 24 : sym_loc_t &n = syms[i];
7633 24 : if (n.sym->attr.in_common)
7634 0 : gfc_error_now ("Variable %qs at %L is an element of a COMMON "
7635 : "block", n.sym->name, &n.loc);
7636 24 : else if (n.sym->attr.omp_declare_target
7637 23 : || n.sym->attr.omp_declare_target_link)
7638 2 : gfc_error_now ("List item %qs at %L implies OMP DECLARE TARGET "
7639 : "with the LOCAL clause, but it has been specified"
7640 : " with a different clause before",
7641 : n.sym->name, &n.loc);
7642 24 : if (n.sym->attr.omp_device_type != OMP_DEVICE_TYPE_UNSET
7643 5 : && n.sym->attr.omp_device_type != c->device_type)
7644 : {
7645 2 : const char *dt = "any";
7646 2 : if (n.sym->attr.omp_device_type == OMP_DEVICE_TYPE_HOST)
7647 : dt = "host";
7648 0 : else if (n.sym->attr.omp_device_type == OMP_DEVICE_TYPE_NOHOST)
7649 0 : dt = "nohost";
7650 2 : gfc_error_now ("List item %qs at %L set in previous OMP DECLARE "
7651 : "TARGET directive to the different DEVICE_TYPE %qs",
7652 : n.sym->name, &n.loc, dt);
7653 : }
7654 24 : gfc_add_omp_declare_target_local (&n.sym->attr, n.sym->name,
7655 : &n.loc);
7656 24 : n.sym->attr.omp_device_type = c->device_type;
7657 : }
7658 : else /* Common block. */
7659 : {
7660 23 : sym_loc_t &n = syms[i];
7661 23 : if (n.com->omp_declare_target
7662 22 : || n.com->omp_declare_target_link)
7663 2 : gfc_error_now ("List item %</%s/%> at %L implies OMP DECLARE "
7664 : "TARGET with the LOCAL clause, but it has been "
7665 : "specified with a different clause before",
7666 2 : n.com->name, &n.loc);
7667 23 : if (n.com->omp_device_type != OMP_DEVICE_TYPE_UNSET
7668 5 : && n.com->omp_device_type != c->device_type)
7669 : {
7670 2 : const char *dt = "any";
7671 2 : if (n.com->omp_device_type == OMP_DEVICE_TYPE_HOST)
7672 : dt = "host";
7673 0 : else if (n.com->omp_device_type == OMP_DEVICE_TYPE_NOHOST)
7674 0 : dt = "nohost";
7675 2 : gfc_error_now ("List item %qs at %L set in previous OMP DECLARE"
7676 : " TARGET directive to the different DEVICE_TYPE "
7677 2 : "%qs", n.com->name, &n.loc, dt);
7678 : }
7679 23 : n.com->omp_declare_target_local = 1;
7680 23 : n.com->omp_device_type = c->device_type;
7681 46 : for (gfc_symbol *s = n.com->head; s; s = s->common_next)
7682 : {
7683 23 : gfc_add_omp_declare_target_local (&s->attr, s->name, &n.loc);
7684 23 : s->attr.omp_device_type = c->device_type;
7685 : }
7686 : }
7687 39 : free (c);
7688 : }
7689 :
7690 243 : if (gfc_match_omp_eos () != MATCH_YES)
7691 : {
7692 0 : gfc_error ("Unexpected junk after OMP %s at %C",
7693 : is_groupprivate ? "GROUPPRIVATE" : "THREADPRIVATE");
7694 0 : goto cleanup;
7695 : }
7696 :
7697 : return MATCH_YES;
7698 :
7699 0 : syntax:
7700 0 : gfc_error ("Syntax error in !$OMP %s list at %C",
7701 : is_groupprivate ? "GROUPPRIVATE" : "THREADPRIVATE");
7702 :
7703 16 : cleanup:
7704 16 : gfc_current_locus = old_loc;
7705 16 : return MATCH_ERROR;
7706 259 : }
7707 :
7708 :
7709 : match
7710 48 : gfc_match_omp_groupprivate (void)
7711 : {
7712 48 : return gfc_match_omp_thread_group_private (true);
7713 : }
7714 :
7715 :
7716 : match
7717 211 : gfc_match_omp_threadprivate (void)
7718 : {
7719 211 : return gfc_match_omp_thread_group_private (false);
7720 : }
7721 :
7722 :
7723 : match
7724 2145 : gfc_match_omp_parallel (void)
7725 : {
7726 2145 : return match_omp (EXEC_OMP_PARALLEL, OMP_PARALLEL_CLAUSES);
7727 : }
7728 :
7729 :
7730 : match
7731 1199 : gfc_match_omp_parallel_do (void)
7732 : {
7733 1199 : return match_omp (EXEC_OMP_PARALLEL_DO,
7734 1199 : (OMP_PARALLEL_CLAUSES | OMP_DO_CLAUSES)
7735 1199 : & ~(omp_mask (OMP_CLAUSE_NOWAIT)));
7736 : }
7737 :
7738 :
7739 : match
7740 298 : gfc_match_omp_parallel_do_simd (void)
7741 : {
7742 298 : return match_omp (EXEC_OMP_PARALLEL_DO_SIMD,
7743 298 : (OMP_PARALLEL_CLAUSES | OMP_DO_CLAUSES | OMP_SIMD_CLAUSES)
7744 298 : & ~(omp_mask (OMP_CLAUSE_NOWAIT)));
7745 : }
7746 :
7747 :
7748 : match
7749 14 : gfc_match_omp_parallel_masked (void)
7750 : {
7751 14 : return match_omp (EXEC_OMP_PARALLEL_MASKED,
7752 14 : OMP_PARALLEL_CLAUSES | OMP_MASKED_CLAUSES);
7753 : }
7754 :
7755 : match
7756 10 : gfc_match_omp_parallel_masked_taskloop (void)
7757 : {
7758 10 : return match_omp (EXEC_OMP_PARALLEL_MASKED_TASKLOOP,
7759 10 : (OMP_PARALLEL_CLAUSES | OMP_MASKED_CLAUSES
7760 10 : | OMP_TASKLOOP_CLAUSES)
7761 10 : & ~(omp_mask (OMP_CLAUSE_IN_REDUCTION)));
7762 : }
7763 :
7764 : match
7765 13 : gfc_match_omp_parallel_masked_taskloop_simd (void)
7766 : {
7767 13 : return match_omp (EXEC_OMP_PARALLEL_MASKED_TASKLOOP_SIMD,
7768 13 : (OMP_PARALLEL_CLAUSES | OMP_MASKED_CLAUSES
7769 13 : | OMP_TASKLOOP_CLAUSES | OMP_SIMD_CLAUSES)
7770 13 : & ~(omp_mask (OMP_CLAUSE_IN_REDUCTION)));
7771 : }
7772 :
7773 : match
7774 14 : gfc_match_omp_parallel_master (void)
7775 : {
7776 14 : gfc_warning (OPT_Wdeprecated_openmp,
7777 : "%<master%> construct at %C deprecated since OpenMP 5.1, use "
7778 : "%<masked%>");
7779 14 : return match_omp (EXEC_OMP_PARALLEL_MASTER, OMP_PARALLEL_CLAUSES);
7780 : }
7781 :
7782 : match
7783 15 : gfc_match_omp_parallel_master_taskloop (void)
7784 : {
7785 15 : gfc_warning (OPT_Wdeprecated_openmp,
7786 : "%<master%> construct at %C deprecated since OpenMP 5.1, "
7787 : "use %<masked%>");
7788 15 : return match_omp (EXEC_OMP_PARALLEL_MASTER_TASKLOOP,
7789 15 : (OMP_PARALLEL_CLAUSES | OMP_TASKLOOP_CLAUSES)
7790 15 : & ~(omp_mask (OMP_CLAUSE_IN_REDUCTION)));
7791 : }
7792 :
7793 : match
7794 21 : gfc_match_omp_parallel_master_taskloop_simd (void)
7795 : {
7796 21 : gfc_warning (OPT_Wdeprecated_openmp,
7797 : "%<master%> construct at %C deprecated since OpenMP 5.1, "
7798 : "use %<masked%>");
7799 21 : return match_omp (EXEC_OMP_PARALLEL_MASTER_TASKLOOP_SIMD,
7800 21 : (OMP_PARALLEL_CLAUSES | OMP_TASKLOOP_CLAUSES
7801 21 : | OMP_SIMD_CLAUSES)
7802 21 : & ~(omp_mask (OMP_CLAUSE_IN_REDUCTION)));
7803 : }
7804 :
7805 : match
7806 59 : gfc_match_omp_parallel_sections (void)
7807 : {
7808 59 : return match_omp (EXEC_OMP_PARALLEL_SECTIONS,
7809 59 : (OMP_PARALLEL_CLAUSES | OMP_SECTIONS_CLAUSES)
7810 59 : & ~(omp_mask (OMP_CLAUSE_NOWAIT)));
7811 : }
7812 :
7813 :
7814 : match
7815 56 : gfc_match_omp_parallel_workshare (void)
7816 : {
7817 56 : return match_omp (EXEC_OMP_PARALLEL_WORKSHARE, OMP_PARALLEL_CLAUSES);
7818 : }
7819 :
7820 : void
7821 49121 : gfc_check_omp_requires (gfc_namespace *ns, int ref_omp_requires)
7822 : {
7823 49121 : const char *msg = G_("Program unit at %L has OpenMP device "
7824 : "constructs/routines but does not set !$OMP REQUIRES %s "
7825 : "but other program units do");
7826 49121 : if (ns->omp_target_seen
7827 1240 : && (ns->omp_requires & OMP_REQ_TARGET_MASK)
7828 1240 : != (ref_omp_requires & OMP_REQ_TARGET_MASK))
7829 : {
7830 6 : gcc_assert (ns->proc_name);
7831 6 : if ((ref_omp_requires & OMP_REQ_REVERSE_OFFLOAD)
7832 5 : && !(ns->omp_requires & OMP_REQ_REVERSE_OFFLOAD))
7833 4 : gfc_error (msg, &ns->proc_name->declared_at, "REVERSE_OFFLOAD");
7834 6 : if ((ref_omp_requires & OMP_REQ_UNIFIED_ADDRESS)
7835 1 : && !(ns->omp_requires & OMP_REQ_UNIFIED_ADDRESS))
7836 1 : gfc_error (msg, &ns->proc_name->declared_at, "UNIFIED_ADDRESS");
7837 6 : if ((ref_omp_requires & OMP_REQ_UNIFIED_SHARED_MEMORY)
7838 4 : && !(ns->omp_requires & OMP_REQ_UNIFIED_SHARED_MEMORY))
7839 2 : gfc_error (msg, &ns->proc_name->declared_at, "UNIFIED_SHARED_MEMORY");
7840 6 : if ((ref_omp_requires & OMP_REQ_SELF_MAPS)
7841 1 : && !(ns->omp_requires & OMP_REQ_UNIFIED_SHARED_MEMORY))
7842 1 : gfc_error (msg, &ns->proc_name->declared_at, "SELF_MAPS");
7843 : }
7844 49121 : }
7845 :
7846 : bool
7847 120 : gfc_omp_requires_add_clause (gfc_omp_requires_kind clause,
7848 : const char *clause_name, locus *loc,
7849 : const char *module_name)
7850 : {
7851 120 : gfc_namespace *prog_unit = gfc_current_ns;
7852 144 : while (prog_unit->parent)
7853 : {
7854 25 : if (gfc_state_stack->previous
7855 25 : && gfc_state_stack->previous->state == COMP_INTERFACE)
7856 : break;
7857 : prog_unit = prog_unit->parent;
7858 : }
7859 :
7860 : /* Requires added after use. */
7861 120 : if (prog_unit->omp_target_seen
7862 24 : && (clause & OMP_REQ_TARGET_MASK)
7863 24 : && !(prog_unit->omp_requires & clause))
7864 : {
7865 0 : if (module_name)
7866 0 : gfc_error ("!$OMP REQUIRES clause %qs specified via module %qs use "
7867 : "at %L comes after using a device construct/routine",
7868 : clause_name, module_name, loc);
7869 : else
7870 0 : gfc_error ("!$OMP REQUIRES clause %qs specified at %L comes after "
7871 : "using a device construct/routine", clause_name, loc);
7872 0 : return false;
7873 : }
7874 :
7875 : /* Overriding atomic_default_mem_order clause value. */
7876 120 : if ((clause & OMP_REQ_ATOMIC_MEM_ORDER_MASK)
7877 34 : && (prog_unit->omp_requires & OMP_REQ_ATOMIC_MEM_ORDER_MASK)
7878 6 : && (prog_unit->omp_requires & OMP_REQ_ATOMIC_MEM_ORDER_MASK)
7879 6 : != (int) clause)
7880 : {
7881 3 : const char *other;
7882 3 : switch (prog_unit->omp_requires & OMP_REQ_ATOMIC_MEM_ORDER_MASK)
7883 : {
7884 : case OMP_REQ_ATOMIC_MEM_ORDER_SEQ_CST: other = "seq_cst"; break;
7885 0 : case OMP_REQ_ATOMIC_MEM_ORDER_ACQ_REL: other = "acq_rel"; break;
7886 1 : case OMP_REQ_ATOMIC_MEM_ORDER_ACQUIRE: other = "acquire"; break;
7887 1 : case OMP_REQ_ATOMIC_MEM_ORDER_RELAXED: other = "relaxed"; break;
7888 0 : case OMP_REQ_ATOMIC_MEM_ORDER_RELEASE: other = "release"; break;
7889 0 : default: gcc_unreachable ();
7890 : }
7891 :
7892 3 : if (module_name)
7893 0 : gfc_error ("!$OMP REQUIRES clause %<atomic_default_mem_order(%s)%> "
7894 : "specified via module %qs use at %L overrides a previous "
7895 : "%<atomic_default_mem_order(%s)%> (which might be through "
7896 : "using a module)", clause_name, module_name, loc, other);
7897 : else
7898 3 : gfc_error ("!$OMP REQUIRES clause %<atomic_default_mem_order(%s)%> "
7899 : "specified at %L overrides a previous "
7900 : "%<atomic_default_mem_order(%s)%> (which might be through "
7901 : "using a module)", clause_name, loc, other);
7902 3 : return false;
7903 : }
7904 :
7905 : /* Requires via module not at program-unit level and not repeating clause. */
7906 117 : if (prog_unit != gfc_current_ns && !(prog_unit->omp_requires & clause))
7907 : {
7908 0 : if (clause & OMP_REQ_ATOMIC_MEM_ORDER_MASK)
7909 0 : gfc_error ("!$OMP REQUIRES clause %<atomic_default_mem_order(%s)%> "
7910 : "specified via module %qs use at %L but same clause is "
7911 : "not specified for the program unit", clause_name,
7912 : module_name, loc);
7913 : else
7914 0 : gfc_error ("!$OMP REQUIRES clause %qs specified via module %qs use at "
7915 : "%L but same clause is not specified for the program unit",
7916 : clause_name, module_name, loc);
7917 0 : return false;
7918 : }
7919 :
7920 117 : if (!gfc_state_stack->previous
7921 109 : || gfc_state_stack->previous->state != COMP_INTERFACE)
7922 116 : prog_unit->omp_requires |= clause;
7923 : return true;
7924 : }
7925 :
7926 : match
7927 92 : gfc_match_omp_requires (void)
7928 : {
7929 92 : static const char *clauses[] = {"reverse_offload",
7930 : "unified_address",
7931 : "unified_shared_memory",
7932 : "self_maps",
7933 : "dynamic_allocators",
7934 : "atomic_default"};
7935 92 : const char *clause = NULL;
7936 92 : int requires_clauses = 0;
7937 92 : bool first = true;
7938 92 : locus old_loc;
7939 :
7940 92 : if (gfc_current_ns->parent
7941 7 : && (!gfc_state_stack->previous
7942 7 : || gfc_state_stack->previous->state != COMP_INTERFACE))
7943 : {
7944 6 : gfc_error ("!$OMP REQUIRES at %C must appear in the specification part "
7945 : "of a program unit");
7946 6 : return MATCH_ERROR;
7947 : }
7948 :
7949 258 : while (true)
7950 : {
7951 172 : old_loc = gfc_current_locus;
7952 172 : gfc_omp_requires_kind requires_clause;
7953 86 : if ((first || gfc_match_char (',') != MATCH_YES)
7954 172 : && (first && gfc_match_space () != MATCH_YES))
7955 0 : goto error;
7956 172 : first = false;
7957 172 : gfc_gobble_whitespace ();
7958 172 : old_loc = gfc_current_locus;
7959 :
7960 172 : if (gfc_match_omp_eos () != MATCH_NO)
7961 : break;
7962 97 : if (gfc_match (clauses[0]) == MATCH_YES)
7963 : {
7964 34 : clause = clauses[0];
7965 34 : requires_clause = OMP_REQ_REVERSE_OFFLOAD;
7966 34 : if (requires_clauses & OMP_REQ_REVERSE_OFFLOAD)
7967 1 : goto duplicate_clause;
7968 : }
7969 63 : else if (gfc_match (clauses[1]) == MATCH_YES)
7970 : {
7971 9 : clause = clauses[1];
7972 9 : requires_clause = OMP_REQ_UNIFIED_ADDRESS;
7973 9 : if (requires_clauses & OMP_REQ_UNIFIED_ADDRESS)
7974 1 : goto duplicate_clause;
7975 : }
7976 54 : else if (gfc_match (clauses[2]) == MATCH_YES)
7977 : {
7978 14 : clause = clauses[2];
7979 14 : requires_clause = OMP_REQ_UNIFIED_SHARED_MEMORY;
7980 14 : if (requires_clauses & OMP_REQ_UNIFIED_SHARED_MEMORY)
7981 1 : goto duplicate_clause;
7982 : }
7983 40 : else if (gfc_match (clauses[3]) == MATCH_YES)
7984 : {
7985 1 : clause = clauses[3];
7986 1 : requires_clause = OMP_REQ_SELF_MAPS;
7987 1 : if (requires_clauses & OMP_REQ_SELF_MAPS)
7988 0 : goto duplicate_clause;
7989 : }
7990 39 : else if (gfc_match (clauses[4]) == MATCH_YES)
7991 : {
7992 7 : clause = clauses[4];
7993 7 : requires_clause = OMP_REQ_DYNAMIC_ALLOCATORS;
7994 7 : if (requires_clauses & OMP_REQ_DYNAMIC_ALLOCATORS)
7995 1 : goto duplicate_clause;
7996 : }
7997 32 : else if (gfc_match ("atomic_default_mem_order (") == MATCH_YES)
7998 : {
7999 31 : clause = clauses[5];
8000 31 : if (requires_clauses & OMP_REQ_ATOMIC_MEM_ORDER_MASK)
8001 1 : goto duplicate_clause;
8002 30 : if (gfc_match (" seq_cst )") == MATCH_YES)
8003 : {
8004 : clause = "seq_cst";
8005 : requires_clause = OMP_REQ_ATOMIC_MEM_ORDER_SEQ_CST;
8006 : }
8007 18 : else if (gfc_match (" acq_rel )") == MATCH_YES)
8008 : {
8009 : clause = "acq_rel";
8010 : requires_clause = OMP_REQ_ATOMIC_MEM_ORDER_ACQ_REL;
8011 : }
8012 12 : else if (gfc_match (" acquire )") == MATCH_YES)
8013 : {
8014 : clause = "acquire";
8015 : requires_clause = OMP_REQ_ATOMIC_MEM_ORDER_ACQUIRE;
8016 : }
8017 9 : else if (gfc_match (" relaxed )") == MATCH_YES)
8018 : {
8019 : clause = "relaxed";
8020 : requires_clause = OMP_REQ_ATOMIC_MEM_ORDER_RELAXED;
8021 : }
8022 5 : else if (gfc_match (" release )") == MATCH_YES)
8023 : {
8024 : clause = "release";
8025 : requires_clause = OMP_REQ_ATOMIC_MEM_ORDER_RELEASE;
8026 : }
8027 : else
8028 : {
8029 2 : gfc_error ("Expected ACQ_REL, ACQUIRE, RELAXED, RELEASE or "
8030 : "SEQ_CST for ATOMIC_DEFAULT_MEM_ORDER clause at %C");
8031 2 : goto error;
8032 : }
8033 : }
8034 : else
8035 1 : goto error;
8036 :
8037 89 : if (!gfc_omp_requires_add_clause (requires_clause, clause, &old_loc, NULL))
8038 3 : goto error;
8039 86 : requires_clauses |= requires_clause;
8040 86 : }
8041 :
8042 75 : if (requires_clauses == 0)
8043 : {
8044 1 : if (!gfc_error_flag_test ())
8045 1 : gfc_error ("Clause expected at %C");
8046 1 : goto error;
8047 : }
8048 : return MATCH_YES;
8049 :
8050 5 : duplicate_clause:
8051 5 : gfc_error ("%qs clause at %L specified more than once", clause, &old_loc);
8052 12 : error:
8053 12 : if (!gfc_error_flag_test ())
8054 1 : gfc_error ("Expected UNIFIED_ADDRESS, UNIFIED_SHARED_MEMORY, SELF_MAPS, "
8055 : "DYNAMIC_ALLOCATORS, REVERSE_OFFLOAD, or "
8056 : "ATOMIC_DEFAULT_MEM_ORDER clause at %L", &old_loc);
8057 : return MATCH_ERROR;
8058 : }
8059 :
8060 :
8061 : match
8062 51 : gfc_match_omp_scan (void)
8063 : {
8064 51 : bool incl;
8065 51 : gfc_omp_clauses *c = gfc_get_omp_clauses ();
8066 51 : gfc_gobble_whitespace ();
8067 51 : if ((incl = (gfc_match ("inclusive") == MATCH_YES))
8068 51 : || gfc_match ("exclusive") == MATCH_YES)
8069 : {
8070 70 : if (gfc_match_omp_variable_list (" (", &c->lists[incl ? OMP_LIST_SCAN_IN
8071 : : OMP_LIST_SCAN_EX],
8072 : false) != MATCH_YES)
8073 : {
8074 0 : gfc_free_omp_clauses (c);
8075 0 : return MATCH_ERROR;
8076 : }
8077 : }
8078 : else
8079 : {
8080 1 : gfc_error ("Expected INCLUSIVE or EXCLUSIVE clause at %C");
8081 1 : gfc_free_omp_clauses (c);
8082 1 : return MATCH_ERROR;
8083 : }
8084 50 : if (gfc_match_omp_eos () != MATCH_YES)
8085 : {
8086 1 : gfc_error ("Unexpected junk after !$OMP SCAN at %C");
8087 1 : gfc_free_omp_clauses (c);
8088 1 : return MATCH_ERROR;
8089 : }
8090 :
8091 49 : new_st.op = EXEC_OMP_SCAN;
8092 49 : new_st.ext.omp_clauses = c;
8093 49 : return MATCH_YES;
8094 : }
8095 :
8096 :
8097 : match
8098 58 : gfc_match_omp_scope (void)
8099 : {
8100 58 : return match_omp (EXEC_OMP_SCOPE, OMP_SCOPE_CLAUSES);
8101 : }
8102 :
8103 :
8104 : match
8105 82 : gfc_match_omp_sections (void)
8106 : {
8107 82 : return match_omp (EXEC_OMP_SECTIONS, OMP_SECTIONS_CLAUSES);
8108 : }
8109 :
8110 :
8111 : match
8112 782 : gfc_match_omp_simd (void)
8113 : {
8114 782 : return match_omp (EXEC_OMP_SIMD, OMP_SIMD_CLAUSES);
8115 : }
8116 :
8117 :
8118 : match
8119 570 : gfc_match_omp_single (void)
8120 : {
8121 570 : return match_omp (EXEC_OMP_SINGLE, OMP_SINGLE_CLAUSES);
8122 : }
8123 :
8124 :
8125 : match
8126 2166 : gfc_match_omp_target (void)
8127 : {
8128 2166 : return match_omp (EXEC_OMP_TARGET, OMP_TARGET_CLAUSES);
8129 : }
8130 :
8131 :
8132 : match
8133 1398 : gfc_match_omp_target_data (void)
8134 : {
8135 1398 : return match_omp (EXEC_OMP_TARGET_DATA, OMP_TARGET_DATA_CLAUSES);
8136 : }
8137 :
8138 :
8139 : match
8140 452 : gfc_match_omp_target_enter_data (void)
8141 : {
8142 452 : return match_omp (EXEC_OMP_TARGET_ENTER_DATA, OMP_TARGET_ENTER_DATA_CLAUSES);
8143 : }
8144 :
8145 :
8146 : match
8147 364 : gfc_match_omp_target_exit_data (void)
8148 : {
8149 364 : return match_omp (EXEC_OMP_TARGET_EXIT_DATA, OMP_TARGET_EXIT_DATA_CLAUSES);
8150 : }
8151 :
8152 :
8153 : match
8154 25 : gfc_match_omp_target_parallel (void)
8155 : {
8156 25 : return match_omp (EXEC_OMP_TARGET_PARALLEL,
8157 25 : (OMP_TARGET_CLAUSES | OMP_PARALLEL_CLAUSES)
8158 25 : & ~(omp_mask (OMP_CLAUSE_COPYIN)));
8159 : }
8160 :
8161 :
8162 : match
8163 81 : gfc_match_omp_target_parallel_do (void)
8164 : {
8165 81 : return match_omp (EXEC_OMP_TARGET_PARALLEL_DO,
8166 81 : (OMP_TARGET_CLAUSES | OMP_PARALLEL_CLAUSES
8167 81 : | OMP_DO_CLAUSES) & ~(omp_mask (OMP_CLAUSE_COPYIN)));
8168 : }
8169 :
8170 :
8171 : match
8172 19 : gfc_match_omp_target_parallel_do_simd (void)
8173 : {
8174 19 : return match_omp (EXEC_OMP_TARGET_PARALLEL_DO_SIMD,
8175 19 : (OMP_TARGET_CLAUSES | OMP_PARALLEL_CLAUSES | OMP_DO_CLAUSES
8176 19 : | OMP_SIMD_CLAUSES) & ~(omp_mask (OMP_CLAUSE_COPYIN)));
8177 : }
8178 :
8179 :
8180 : match
8181 34 : gfc_match_omp_target_simd (void)
8182 : {
8183 34 : return match_omp (EXEC_OMP_TARGET_SIMD,
8184 34 : OMP_TARGET_CLAUSES | OMP_SIMD_CLAUSES);
8185 : }
8186 :
8187 :
8188 : match
8189 72 : gfc_match_omp_target_teams (void)
8190 : {
8191 72 : return match_omp (EXEC_OMP_TARGET_TEAMS,
8192 72 : OMP_TARGET_CLAUSES | OMP_TEAMS_CLAUSES);
8193 : }
8194 :
8195 :
8196 : match
8197 19 : gfc_match_omp_target_teams_distribute (void)
8198 : {
8199 19 : return match_omp (EXEC_OMP_TARGET_TEAMS_DISTRIBUTE,
8200 19 : OMP_TARGET_CLAUSES | OMP_TEAMS_CLAUSES
8201 19 : | OMP_DISTRIBUTE_CLAUSES);
8202 : }
8203 :
8204 :
8205 : match
8206 64 : gfc_match_omp_target_teams_distribute_parallel_do (void)
8207 : {
8208 64 : return match_omp (EXEC_OMP_TARGET_TEAMS_DISTRIBUTE_PARALLEL_DO,
8209 64 : (OMP_TARGET_CLAUSES | OMP_TEAMS_CLAUSES
8210 64 : | OMP_DISTRIBUTE_CLAUSES | OMP_PARALLEL_CLAUSES
8211 64 : | OMP_DO_CLAUSES)
8212 64 : & ~(omp_mask (OMP_CLAUSE_ORDERED))
8213 64 : & ~(omp_mask (OMP_CLAUSE_LINEAR)));
8214 : }
8215 :
8216 :
8217 : match
8218 35 : gfc_match_omp_target_teams_distribute_parallel_do_simd (void)
8219 : {
8220 35 : return match_omp (EXEC_OMP_TARGET_TEAMS_DISTRIBUTE_PARALLEL_DO_SIMD,
8221 35 : (OMP_TARGET_CLAUSES | OMP_TEAMS_CLAUSES
8222 35 : | OMP_DISTRIBUTE_CLAUSES | OMP_PARALLEL_CLAUSES
8223 35 : | OMP_DO_CLAUSES | OMP_SIMD_CLAUSES)
8224 35 : & ~(omp_mask (OMP_CLAUSE_ORDERED)));
8225 : }
8226 :
8227 :
8228 : match
8229 21 : gfc_match_omp_target_teams_distribute_simd (void)
8230 : {
8231 21 : return match_omp (EXEC_OMP_TARGET_TEAMS_DISTRIBUTE_SIMD,
8232 21 : OMP_TARGET_CLAUSES | OMP_TEAMS_CLAUSES
8233 21 : | OMP_DISTRIBUTE_CLAUSES | OMP_SIMD_CLAUSES);
8234 : }
8235 :
8236 :
8237 : match
8238 1704 : gfc_match_omp_target_update (void)
8239 : {
8240 1704 : return match_omp (EXEC_OMP_TARGET_UPDATE, OMP_TARGET_UPDATE_CLAUSES);
8241 : }
8242 :
8243 :
8244 : match
8245 1182 : gfc_match_omp_task (void)
8246 : {
8247 1182 : return match_omp (EXEC_OMP_TASK, OMP_TASK_CLAUSES);
8248 : }
8249 :
8250 :
8251 : match
8252 72 : gfc_match_omp_taskloop (void)
8253 : {
8254 72 : return match_omp (EXEC_OMP_TASKLOOP, OMP_TASKLOOP_CLAUSES);
8255 : }
8256 :
8257 :
8258 : match
8259 40 : gfc_match_omp_taskloop_simd (void)
8260 : {
8261 40 : return match_omp (EXEC_OMP_TASKLOOP_SIMD,
8262 40 : OMP_TASKLOOP_CLAUSES | OMP_SIMD_CLAUSES);
8263 : }
8264 :
8265 :
8266 : match
8267 147 : gfc_match_omp_taskwait (void)
8268 : {
8269 147 : if (gfc_match_omp_eos () == MATCH_YES)
8270 : {
8271 133 : new_st.op = EXEC_OMP_TASKWAIT;
8272 133 : new_st.ext.omp_clauses = NULL;
8273 133 : return MATCH_YES;
8274 : }
8275 14 : return match_omp (EXEC_OMP_TASKWAIT,
8276 14 : omp_mask (OMP_CLAUSE_DEPEND) | OMP_CLAUSE_NOWAIT);
8277 : }
8278 :
8279 :
8280 : match
8281 10 : gfc_match_omp_taskyield (void)
8282 : {
8283 10 : if (gfc_match_omp_eos () != MATCH_YES)
8284 : {
8285 0 : gfc_error ("Unexpected junk after TASKYIELD clause at %C");
8286 0 : return MATCH_ERROR;
8287 : }
8288 10 : new_st.op = EXEC_OMP_TASKYIELD;
8289 10 : new_st.ext.omp_clauses = NULL;
8290 10 : return MATCH_YES;
8291 : }
8292 :
8293 :
8294 : match
8295 150 : gfc_match_omp_teams (void)
8296 : {
8297 150 : return match_omp (EXEC_OMP_TEAMS, OMP_TEAMS_CLAUSES);
8298 : }
8299 :
8300 :
8301 : match
8302 22 : gfc_match_omp_teams_distribute (void)
8303 : {
8304 22 : return match_omp (EXEC_OMP_TEAMS_DISTRIBUTE,
8305 22 : OMP_TEAMS_CLAUSES | OMP_DISTRIBUTE_CLAUSES);
8306 : }
8307 :
8308 :
8309 : match
8310 39 : gfc_match_omp_teams_distribute_parallel_do (void)
8311 : {
8312 39 : return match_omp (EXEC_OMP_TEAMS_DISTRIBUTE_PARALLEL_DO,
8313 39 : (OMP_TEAMS_CLAUSES | OMP_DISTRIBUTE_CLAUSES
8314 39 : | OMP_PARALLEL_CLAUSES | OMP_DO_CLAUSES)
8315 39 : & ~(omp_mask (OMP_CLAUSE_ORDERED)
8316 39 : | OMP_CLAUSE_LINEAR | OMP_CLAUSE_NOWAIT));
8317 : }
8318 :
8319 :
8320 : match
8321 62 : gfc_match_omp_teams_distribute_parallel_do_simd (void)
8322 : {
8323 62 : return match_omp (EXEC_OMP_TEAMS_DISTRIBUTE_PARALLEL_DO_SIMD,
8324 62 : (OMP_TEAMS_CLAUSES | OMP_DISTRIBUTE_CLAUSES
8325 62 : | OMP_PARALLEL_CLAUSES | OMP_DO_CLAUSES
8326 62 : | OMP_SIMD_CLAUSES)
8327 62 : & ~(omp_mask (OMP_CLAUSE_ORDERED) | OMP_CLAUSE_NOWAIT));
8328 : }
8329 :
8330 :
8331 : match
8332 44 : gfc_match_omp_teams_distribute_simd (void)
8333 : {
8334 44 : return match_omp (EXEC_OMP_TEAMS_DISTRIBUTE_SIMD,
8335 44 : OMP_TEAMS_CLAUSES | OMP_DISTRIBUTE_CLAUSES
8336 44 : | OMP_SIMD_CLAUSES);
8337 : }
8338 :
8339 : match
8340 203 : gfc_match_omp_tile (void)
8341 : {
8342 203 : return match_omp (EXEC_OMP_TILE, OMP_TILE_CLAUSES);
8343 : }
8344 :
8345 : match
8346 415 : gfc_match_omp_unroll (void)
8347 : {
8348 415 : return match_omp (EXEC_OMP_UNROLL, OMP_UNROLL_CLAUSES);
8349 : }
8350 :
8351 : match
8352 39 : gfc_match_omp_workshare (void)
8353 : {
8354 39 : return match_omp (EXEC_OMP_WORKSHARE, OMP_WORKSHARE_CLAUSES);
8355 : }
8356 :
8357 :
8358 : match
8359 49 : gfc_match_omp_masked (void)
8360 : {
8361 49 : return match_omp (EXEC_OMP_MASKED, OMP_MASKED_CLAUSES);
8362 : }
8363 :
8364 : match
8365 10 : gfc_match_omp_masked_taskloop (void)
8366 : {
8367 10 : return match_omp (EXEC_OMP_MASKED_TASKLOOP,
8368 10 : OMP_MASKED_CLAUSES | OMP_TASKLOOP_CLAUSES);
8369 : }
8370 :
8371 : match
8372 16 : gfc_match_omp_masked_taskloop_simd (void)
8373 : {
8374 16 : return match_omp (EXEC_OMP_MASKED_TASKLOOP_SIMD,
8375 16 : (OMP_MASKED_CLAUSES | OMP_TASKLOOP_CLAUSES
8376 16 : | OMP_SIMD_CLAUSES));
8377 : }
8378 :
8379 : match
8380 111 : gfc_match_omp_master (void)
8381 : {
8382 111 : gfc_warning (OPT_Wdeprecated_openmp,
8383 : "%<master%> construct at %C deprecated since OpenMP 5.1, "
8384 : "use %<masked%>");
8385 111 : if (gfc_match_omp_eos () != MATCH_YES)
8386 : {
8387 1 : gfc_error ("Unexpected junk after $OMP MASTER statement at %C");
8388 1 : return MATCH_ERROR;
8389 : }
8390 110 : new_st.op = EXEC_OMP_MASTER;
8391 110 : new_st.ext.omp_clauses = NULL;
8392 110 : return MATCH_YES;
8393 : }
8394 :
8395 : match
8396 16 : gfc_match_omp_master_taskloop (void)
8397 : {
8398 16 : gfc_warning (OPT_Wdeprecated_openmp,
8399 : "%<master%> construct at %C deprecated since OpenMP 5.1, "
8400 : "use %<masked%>");
8401 16 : return match_omp (EXEC_OMP_MASTER_TASKLOOP, OMP_TASKLOOP_CLAUSES);
8402 : }
8403 :
8404 : match
8405 21 : gfc_match_omp_master_taskloop_simd (void)
8406 : {
8407 21 : gfc_warning (OPT_Wdeprecated_openmp,
8408 : "%<master%> construct at %C deprecated since OpenMP 5.1, use "
8409 : "%<masked%>");
8410 21 : return match_omp (EXEC_OMP_MASTER_TASKLOOP_SIMD,
8411 21 : OMP_TASKLOOP_CLAUSES | OMP_SIMD_CLAUSES);
8412 : }
8413 :
8414 : match
8415 235 : gfc_match_omp_ordered (void)
8416 : {
8417 235 : return match_omp (EXEC_OMP_ORDERED, OMP_ORDERED_CLAUSES);
8418 : }
8419 :
8420 : match
8421 24 : gfc_match_omp_nothing (void)
8422 : {
8423 24 : if (gfc_match_omp_eos () != MATCH_YES)
8424 : {
8425 1 : gfc_error ("Unexpected junk after $OMP NOTHING statement at %C");
8426 1 : return MATCH_ERROR;
8427 : }
8428 : /* Will use ST_NONE; therefore, no EXEC_OMP_ is needed. */
8429 : return MATCH_YES;
8430 : }
8431 :
8432 : match
8433 317 : gfc_match_omp_ordered_depend (void)
8434 : {
8435 317 : return match_omp (EXEC_OMP_ORDERED, omp_mask (OMP_CLAUSE_DOACROSS));
8436 : }
8437 :
8438 :
8439 : /* omp atomic [clause-list]
8440 : - atomic-clause: read | write | update
8441 : - capture
8442 : - memory-order-clause: seq_cst | acq_rel | release | acquire | relaxed
8443 : - hint(hint-expr)
8444 : - OpenMP 5.1: compare | fail (seq_cst | acquire | relaxed ) | weak
8445 : */
8446 :
8447 : match
8448 2171 : gfc_match_omp_atomic (void)
8449 : {
8450 2171 : gfc_omp_clauses *c;
8451 2171 : locus loc = gfc_current_locus;
8452 :
8453 2171 : if (gfc_match_omp_clauses (&c, OMP_ATOMIC_CLAUSES, true, true) != MATCH_YES)
8454 : return MATCH_ERROR;
8455 :
8456 2153 : if (c->atomic_op == GFC_OMP_ATOMIC_UNSET)
8457 1011 : c->atomic_op = GFC_OMP_ATOMIC_UPDATE;
8458 :
8459 2153 : if (c->capture && c->atomic_op != GFC_OMP_ATOMIC_UPDATE)
8460 3 : gfc_error ("!$OMP ATOMIC at %L with %s clause is incompatible with "
8461 : "READ or WRITE", &loc, "CAPTURE");
8462 2153 : if (c->compare && c->atomic_op != GFC_OMP_ATOMIC_UPDATE)
8463 3 : gfc_error ("!$OMP ATOMIC at %L with %s clause is incompatible with "
8464 : "READ or WRITE", &loc, "COMPARE");
8465 2153 : if (c->fail != OMP_MEMORDER_UNSET && c->atomic_op != GFC_OMP_ATOMIC_UPDATE)
8466 2 : gfc_error ("!$OMP ATOMIC at %L with %s clause is incompatible with "
8467 : "READ or WRITE", &loc, "FAIL");
8468 2153 : if (c->weak && !c->compare)
8469 : {
8470 5 : gfc_error ("!$OMP ATOMIC at %L with %s clause requires %s clause", &loc,
8471 : "WEAK", "COMPARE");
8472 5 : c->weak = false;
8473 : }
8474 :
8475 2153 : if (c->memorder == OMP_MEMORDER_UNSET)
8476 : {
8477 1969 : gfc_namespace *prog_unit = gfc_current_ns;
8478 2525 : while (prog_unit->parent)
8479 : prog_unit = prog_unit->parent;
8480 1969 : switch (prog_unit->omp_requires & OMP_REQ_ATOMIC_MEM_ORDER_MASK)
8481 : {
8482 1936 : case 0:
8483 1936 : case OMP_REQ_ATOMIC_MEM_ORDER_RELAXED:
8484 1936 : c->memorder = OMP_MEMORDER_RELAXED;
8485 1936 : break;
8486 7 : case OMP_REQ_ATOMIC_MEM_ORDER_SEQ_CST:
8487 7 : c->memorder = OMP_MEMORDER_SEQ_CST;
8488 7 : break;
8489 16 : case OMP_REQ_ATOMIC_MEM_ORDER_ACQ_REL:
8490 16 : if (c->capture)
8491 5 : c->memorder = OMP_MEMORDER_ACQ_REL;
8492 11 : else if (c->atomic_op == GFC_OMP_ATOMIC_READ)
8493 3 : c->memorder = OMP_MEMORDER_ACQUIRE;
8494 : else
8495 8 : c->memorder = OMP_MEMORDER_RELEASE;
8496 : break;
8497 5 : case OMP_REQ_ATOMIC_MEM_ORDER_ACQUIRE:
8498 5 : if (c->atomic_op == GFC_OMP_ATOMIC_WRITE)
8499 : {
8500 1 : gfc_error ("!$OMP ATOMIC WRITE at %L incompatible with "
8501 : "ACQUIRES clause implicitly provided by a "
8502 : "REQUIRES directive", &loc);
8503 1 : c->memorder = OMP_MEMORDER_SEQ_CST;
8504 : }
8505 : else
8506 4 : c->memorder = OMP_MEMORDER_ACQUIRE;
8507 : break;
8508 5 : case OMP_REQ_ATOMIC_MEM_ORDER_RELEASE:
8509 5 : if (c->atomic_op == GFC_OMP_ATOMIC_READ)
8510 : {
8511 1 : gfc_error ("!$OMP ATOMIC READ at %L incompatible with "
8512 : "RELEASE clause implicitly provided by a "
8513 : "REQUIRES directive", &loc);
8514 1 : c->memorder = OMP_MEMORDER_SEQ_CST;
8515 : }
8516 : else
8517 4 : c->memorder = OMP_MEMORDER_RELEASE;
8518 : break;
8519 0 : default:
8520 0 : gcc_unreachable ();
8521 : }
8522 : }
8523 : else
8524 184 : switch (c->atomic_op)
8525 : {
8526 29 : case GFC_OMP_ATOMIC_READ:
8527 29 : if (c->memorder == OMP_MEMORDER_RELEASE)
8528 : {
8529 1 : gfc_error ("!$OMP ATOMIC READ at %L incompatible with "
8530 : "RELEASE clause", &loc);
8531 1 : c->memorder = OMP_MEMORDER_SEQ_CST;
8532 : }
8533 28 : else if (c->memorder == OMP_MEMORDER_ACQ_REL)
8534 1 : c->memorder = OMP_MEMORDER_ACQUIRE;
8535 : break;
8536 35 : case GFC_OMP_ATOMIC_WRITE:
8537 35 : if (c->memorder == OMP_MEMORDER_ACQUIRE)
8538 : {
8539 1 : gfc_error ("!$OMP ATOMIC WRITE at %L incompatible with "
8540 : "ACQUIRE clause", &loc);
8541 1 : c->memorder = OMP_MEMORDER_SEQ_CST;
8542 : }
8543 34 : else if (c->memorder == OMP_MEMORDER_ACQ_REL)
8544 1 : c->memorder = OMP_MEMORDER_RELEASE;
8545 : break;
8546 : default:
8547 : break;
8548 : }
8549 2153 : gfc_error_check ();
8550 2153 : new_st.ext.omp_clauses = c;
8551 2153 : new_st.op = EXEC_OMP_ATOMIC;
8552 2153 : return MATCH_YES;
8553 : }
8554 :
8555 :
8556 : /* acc atomic [ read | write | update | capture] */
8557 :
8558 : match
8559 552 : gfc_match_oacc_atomic (void)
8560 : {
8561 552 : gfc_omp_clauses *c = gfc_get_omp_clauses ();
8562 552 : c->atomic_op = GFC_OMP_ATOMIC_UPDATE;
8563 552 : c->memorder = OMP_MEMORDER_RELAXED;
8564 552 : gfc_gobble_whitespace ();
8565 552 : if (gfc_match ("update") == MATCH_YES)
8566 : ;
8567 373 : else if (gfc_match ("read") == MATCH_YES)
8568 17 : c->atomic_op = GFC_OMP_ATOMIC_READ;
8569 356 : else if (gfc_match ("write") == MATCH_YES)
8570 13 : c->atomic_op = GFC_OMP_ATOMIC_WRITE;
8571 343 : else if (gfc_match ("capture") == MATCH_YES)
8572 319 : c->capture = true;
8573 552 : gfc_gobble_whitespace ();
8574 552 : if (gfc_match_omp_eos () != MATCH_YES)
8575 : {
8576 9 : gfc_error ("Unexpected junk after !$ACC ATOMIC statement at %C");
8577 9 : gfc_free_omp_clauses (c);
8578 9 : return MATCH_ERROR;
8579 : }
8580 543 : new_st.ext.omp_clauses = c;
8581 543 : new_st.op = EXEC_OACC_ATOMIC;
8582 543 : return MATCH_YES;
8583 : }
8584 :
8585 :
8586 : match
8587 614 : gfc_match_omp_barrier (void)
8588 : {
8589 614 : if (gfc_match_omp_eos () != MATCH_YES)
8590 : {
8591 0 : gfc_error ("Unexpected junk after $OMP BARRIER statement at %C");
8592 0 : return MATCH_ERROR;
8593 : }
8594 614 : new_st.op = EXEC_OMP_BARRIER;
8595 614 : new_st.ext.omp_clauses = NULL;
8596 614 : return MATCH_YES;
8597 : }
8598 :
8599 :
8600 : match
8601 188 : gfc_match_omp_taskgroup (void)
8602 : {
8603 188 : return match_omp (EXEC_OMP_TASKGROUP, OMP_TASKGROUP_CLAUSES);
8604 : }
8605 :
8606 :
8607 : static enum gfc_omp_cancel_kind
8608 494 : gfc_match_omp_cancel_kind (void)
8609 : {
8610 494 : if (gfc_match_space () != MATCH_YES)
8611 : return OMP_CANCEL_UNKNOWN;
8612 492 : if (gfc_match ("parallel") == MATCH_YES)
8613 : return OMP_CANCEL_PARALLEL;
8614 352 : if (gfc_match ("sections") == MATCH_YES)
8615 : return OMP_CANCEL_SECTIONS;
8616 253 : if (gfc_match ("do") == MATCH_YES)
8617 : return OMP_CANCEL_DO;
8618 123 : if (gfc_match ("taskgroup") == MATCH_YES)
8619 : return OMP_CANCEL_TASKGROUP;
8620 : return OMP_CANCEL_UNKNOWN;
8621 : }
8622 :
8623 :
8624 : match
8625 321 : gfc_match_omp_cancel (void)
8626 : {
8627 321 : gfc_omp_clauses *c;
8628 321 : enum gfc_omp_cancel_kind kind = gfc_match_omp_cancel_kind ();
8629 321 : if (kind == OMP_CANCEL_UNKNOWN)
8630 : return MATCH_ERROR;
8631 319 : if (gfc_match_omp_clauses (&c, omp_mask (OMP_CLAUSE_IF), false) != MATCH_YES)
8632 : return MATCH_ERROR;
8633 316 : c->cancel = kind;
8634 316 : new_st.op = EXEC_OMP_CANCEL;
8635 316 : new_st.ext.omp_clauses = c;
8636 316 : return MATCH_YES;
8637 : }
8638 :
8639 :
8640 : match
8641 173 : gfc_match_omp_cancellation_point (void)
8642 : {
8643 173 : gfc_omp_clauses *c;
8644 173 : enum gfc_omp_cancel_kind kind = gfc_match_omp_cancel_kind ();
8645 173 : if (kind == OMP_CANCEL_UNKNOWN)
8646 : {
8647 2 : gfc_error ("Expected construct-type PARALLEL, SECTIONS, DO or TASKGROUP "
8648 : "in $OMP CANCELLATION POINT statement at %C");
8649 2 : return MATCH_ERROR;
8650 : }
8651 171 : if (gfc_match_omp_eos () != MATCH_YES)
8652 : {
8653 0 : gfc_error ("Unexpected junk after $OMP CANCELLATION POINT statement "
8654 : "at %C");
8655 0 : return MATCH_ERROR;
8656 : }
8657 171 : c = gfc_get_omp_clauses ();
8658 171 : c->cancel = kind;
8659 171 : new_st.op = EXEC_OMP_CANCELLATION_POINT;
8660 171 : new_st.ext.omp_clauses = c;
8661 171 : return MATCH_YES;
8662 : }
8663 :
8664 :
8665 : match
8666 2676 : gfc_match_omp_end_nowait (void)
8667 : {
8668 2676 : bool nowait = false;
8669 2676 : if (gfc_match ("% nowait") == MATCH_YES)
8670 258 : nowait = true;
8671 2676 : if (gfc_match_omp_eos () != MATCH_YES)
8672 : {
8673 4 : if (nowait)
8674 3 : gfc_error ("Unexpected junk after NOWAIT clause at %C");
8675 : else
8676 1 : gfc_error ("Unexpected junk at %C");
8677 4 : return MATCH_ERROR;
8678 : }
8679 2672 : new_st.op = EXEC_OMP_END_NOWAIT;
8680 2672 : new_st.ext.omp_bool = nowait;
8681 2672 : return MATCH_YES;
8682 : }
8683 :
8684 :
8685 : match
8686 566 : gfc_match_omp_end_single (void)
8687 : {
8688 566 : gfc_omp_clauses *c;
8689 566 : if (gfc_match_omp_clauses (&c, omp_mask (OMP_CLAUSE_COPYPRIVATE)
8690 : | OMP_CLAUSE_NOWAIT) != MATCH_YES)
8691 : return MATCH_ERROR;
8692 566 : new_st.op = EXEC_OMP_END_SINGLE;
8693 566 : new_st.ext.omp_clauses = c;
8694 566 : return MATCH_YES;
8695 : }
8696 :
8697 :
8698 : static bool
8699 37071 : oacc_is_loop (gfc_code *code)
8700 : {
8701 37071 : return code->op == EXEC_OACC_PARALLEL_LOOP
8702 : || code->op == EXEC_OACC_KERNELS_LOOP
8703 20016 : || code->op == EXEC_OACC_SERIAL_LOOP
8704 13457 : || code->op == EXEC_OACC_LOOP;
8705 : }
8706 :
8707 : static void
8708 5725 : resolve_scalar_int_expr (gfc_expr *expr, const char *clause)
8709 : {
8710 5725 : if (!gfc_resolve_expr (expr)
8711 5725 : || expr->ts.type != BT_INTEGER
8712 11379 : || expr->rank != 0)
8713 89 : gfc_error ("%s clause at %L requires a scalar INTEGER expression",
8714 : clause, &expr->where);
8715 5725 : }
8716 :
8717 : static void
8718 3940 : resolve_positive_int_expr (gfc_expr *expr, const char *clause)
8719 : {
8720 3940 : resolve_scalar_int_expr (expr, clause);
8721 3940 : if (expr->expr_type == EXPR_CONSTANT
8722 3519 : && expr->ts.type == BT_INTEGER
8723 3486 : && mpz_sgn (expr->value.integer) <= 0)
8724 54 : gfc_warning ((flag_openmp || flag_openmp_simd) ? OPT_Wopenmp : 0,
8725 : "INTEGER expression of %s clause at %L must be positive",
8726 : clause, &expr->where);
8727 3940 : }
8728 :
8729 : static void
8730 86 : resolve_nonnegative_int_expr (gfc_expr *expr, const char *clause)
8731 : {
8732 86 : resolve_scalar_int_expr (expr, clause);
8733 86 : if (expr->expr_type == EXPR_CONSTANT
8734 13 : && expr->ts.type == BT_INTEGER
8735 11 : && mpz_sgn (expr->value.integer) < 0)
8736 6 : gfc_warning ((flag_openmp || flag_openmp_simd) ? OPT_Wopenmp : 0,
8737 : "INTEGER expression of %s clause at %L must be non-negative",
8738 : clause, &expr->where);
8739 86 : }
8740 :
8741 : /* Emits error when symbol is pointer, cray pointer or cray pointee
8742 : of derived of polymorphic type. */
8743 :
8744 : static void
8745 98 : check_symbol_not_pointer (gfc_symbol *sym, locus loc, const char *name)
8746 : {
8747 98 : if (sym->ts.type == BT_DERIVED && sym->attr.cray_pointer)
8748 0 : gfc_error ("Cray pointer object %qs of derived type in %s clause at %L",
8749 : sym->name, name, &loc);
8750 98 : if (sym->ts.type == BT_DERIVED && sym->attr.cray_pointee)
8751 0 : gfc_error ("Cray pointee object %qs of derived type in %s clause at %L",
8752 : sym->name, name, &loc);
8753 :
8754 98 : if ((sym->ts.type == BT_ASSUMED && sym->attr.pointer)
8755 98 : || (sym->ts.type == BT_CLASS && CLASS_DATA (sym)
8756 0 : && CLASS_DATA (sym)->attr.pointer))
8757 0 : gfc_error ("POINTER object %qs of polymorphic type in %s clause at %L",
8758 : sym->name, name, &loc);
8759 98 : if ((sym->ts.type == BT_ASSUMED && sym->attr.cray_pointer)
8760 98 : || (sym->ts.type == BT_CLASS && CLASS_DATA (sym)
8761 0 : && CLASS_DATA (sym)->attr.cray_pointer))
8762 0 : gfc_error ("Cray pointer object %qs of polymorphic type in %s clause at %L",
8763 : sym->name, name, &loc);
8764 98 : if ((sym->ts.type == BT_ASSUMED && sym->attr.cray_pointee)
8765 98 : || (sym->ts.type == BT_CLASS && CLASS_DATA (sym)
8766 0 : && CLASS_DATA (sym)->attr.cray_pointee))
8767 0 : gfc_error ("Cray pointee object %qs of polymorphic type in %s clause at %L",
8768 : sym->name, name, &loc);
8769 98 : }
8770 :
8771 : /* Emits error when symbol represents assumed size/rank array. */
8772 :
8773 : static void
8774 14844 : check_array_not_assumed (gfc_symbol *sym, locus loc, const char *name)
8775 : {
8776 14844 : if (sym->as && sym->as->type == AS_ASSUMED_SIZE)
8777 13 : gfc_error ("Assumed size array %qs in %s clause at %L",
8778 : sym->name, name, &loc);
8779 14844 : if (sym->as && sym->as->type == AS_ASSUMED_RANK)
8780 11 : gfc_error ("Assumed rank array %qs in %s clause at %L",
8781 : sym->name, name, &loc);
8782 14844 : }
8783 :
8784 : static void
8785 5850 : resolve_oacc_data_clauses (gfc_symbol *sym, locus loc, const char *name)
8786 : {
8787 0 : check_array_not_assumed (sym, loc, name);
8788 0 : }
8789 :
8790 : static void
8791 65 : resolve_oacc_deviceptr_clause (gfc_symbol *sym, locus loc, const char *name)
8792 : {
8793 65 : if (sym->attr.pointer
8794 64 : || (sym->ts.type == BT_CLASS && CLASS_DATA (sym)
8795 0 : && CLASS_DATA (sym)->attr.class_pointer))
8796 1 : gfc_error ("POINTER object %qs in %s clause at %L",
8797 : sym->name, name, &loc);
8798 65 : if (sym->attr.cray_pointer
8799 63 : || (sym->ts.type == BT_CLASS && CLASS_DATA (sym)
8800 0 : && CLASS_DATA (sym)->attr.cray_pointer))
8801 2 : gfc_error ("Cray pointer object %qs in %s clause at %L",
8802 : sym->name, name, &loc);
8803 65 : if (sym->attr.cray_pointee
8804 63 : || (sym->ts.type == BT_CLASS && CLASS_DATA (sym)
8805 0 : && CLASS_DATA (sym)->attr.cray_pointee))
8806 2 : gfc_error ("Cray pointee object %qs in %s clause at %L",
8807 : sym->name, name, &loc);
8808 65 : if (sym->attr.allocatable
8809 64 : || (sym->ts.type == BT_CLASS && CLASS_DATA (sym)
8810 0 : && CLASS_DATA (sym)->attr.allocatable))
8811 1 : gfc_error ("ALLOCATABLE object %qs in %s clause at %L",
8812 : sym->name, name, &loc);
8813 65 : if (sym->attr.value)
8814 1 : gfc_error ("VALUE object %qs in %s clause at %L",
8815 : sym->name, name, &loc);
8816 65 : check_array_not_assumed (sym, loc, name);
8817 65 : }
8818 :
8819 :
8820 : struct resolve_omp_udr_callback_data
8821 : {
8822 : gfc_symbol *sym1, *sym2;
8823 : };
8824 :
8825 :
8826 : static int
8827 1413 : resolve_omp_udr_callback (gfc_expr **e, int *, void *data)
8828 : {
8829 1413 : struct resolve_omp_udr_callback_data *rcd
8830 : = (struct resolve_omp_udr_callback_data *) data;
8831 1413 : if ((*e)->expr_type == EXPR_VARIABLE
8832 801 : && ((*e)->symtree->n.sym == rcd->sym1
8833 255 : || (*e)->symtree->n.sym == rcd->sym2))
8834 : {
8835 801 : gfc_ref *ref = gfc_get_ref ();
8836 801 : ref->type = REF_ARRAY;
8837 801 : ref->u.ar.where = (*e)->where;
8838 801 : ref->u.ar.as = (*e)->symtree->n.sym->as;
8839 801 : ref->u.ar.type = AR_FULL;
8840 801 : ref->u.ar.dimen = 0;
8841 801 : ref->next = (*e)->ref;
8842 801 : (*e)->ref = ref;
8843 : }
8844 1413 : return 0;
8845 : }
8846 :
8847 :
8848 : static int
8849 2990 : resolve_omp_udr_callback2 (gfc_expr **e, int *, void *)
8850 : {
8851 2990 : if ((*e)->expr_type == EXPR_FUNCTION
8852 360 : && (*e)->value.function.isym == NULL)
8853 : {
8854 174 : gfc_symbol *sym = (*e)->symtree->n.sym;
8855 174 : if (!sym->attr.intrinsic
8856 174 : && sym->attr.if_source == IFSRC_UNKNOWN)
8857 4 : gfc_error ("Implicitly declared function %s used in "
8858 : "!$OMP DECLARE REDUCTION at %L", sym->name, &(*e)->where);
8859 : }
8860 2990 : return 0;
8861 : }
8862 :
8863 :
8864 : static gfc_code *
8865 797 : resolve_omp_udr_clause (gfc_omp_namelist *n, gfc_namespace *ns,
8866 : gfc_symbol *sym1, gfc_symbol *sym2)
8867 : {
8868 797 : gfc_code *copy;
8869 797 : gfc_symbol sym1_copy, sym2_copy;
8870 :
8871 797 : if (ns->code->op == EXEC_ASSIGN)
8872 : {
8873 625 : copy = gfc_get_code (EXEC_ASSIGN);
8874 625 : copy->expr1 = gfc_copy_expr (ns->code->expr1);
8875 625 : copy->expr2 = gfc_copy_expr (ns->code->expr2);
8876 : }
8877 : else
8878 : {
8879 172 : copy = gfc_get_code (EXEC_CALL);
8880 172 : copy->symtree = ns->code->symtree;
8881 172 : copy->ext.actual = gfc_copy_actual_arglist (ns->code->ext.actual);
8882 : }
8883 797 : copy->loc = ns->code->loc;
8884 797 : sym1_copy = *sym1;
8885 797 : sym2_copy = *sym2;
8886 797 : *sym1 = *n->sym;
8887 797 : *sym2 = *n->sym;
8888 797 : sym1->name = sym1_copy.name;
8889 797 : sym2->name = sym2_copy.name;
8890 797 : ns->proc_name = ns->parent->proc_name;
8891 797 : if (n->sym->attr.dimension)
8892 : {
8893 348 : struct resolve_omp_udr_callback_data rcd;
8894 348 : rcd.sym1 = sym1;
8895 348 : rcd.sym2 = sym2;
8896 348 : gfc_code_walker (©, gfc_dummy_code_callback,
8897 : resolve_omp_udr_callback, &rcd);
8898 : }
8899 797 : gfc_resolve_code (copy, gfc_current_ns);
8900 797 : if (copy->op == EXEC_CALL && copy->resolved_isym == NULL)
8901 : {
8902 172 : gfc_symbol *sym = copy->resolved_sym;
8903 172 : if (sym
8904 170 : && !sym->attr.intrinsic
8905 170 : && sym->attr.if_source == IFSRC_UNKNOWN)
8906 4 : gfc_error ("Implicitly declared subroutine %s used in "
8907 : "!$OMP DECLARE REDUCTION at %L", sym->name,
8908 : ©->loc);
8909 : }
8910 797 : gfc_code_walker (©, gfc_dummy_code_callback,
8911 : resolve_omp_udr_callback2, NULL);
8912 797 : *sym1 = sym1_copy;
8913 797 : *sym2 = sym2_copy;
8914 797 : return copy;
8915 : }
8916 :
8917 : /* Assume that a constant expression in the range 1 (omp_default_mem_alloc)
8918 : to GOMP_OMP_PREDEF_ALLOC_MAX, or GOMP_OMPX_PREDEF_ALLOC_MIN to
8919 : GOMP_OMPX_PREDEF_ALLOC_MAX is fine. The original symbol name is already
8920 : lost during matching via gfc_match_expr. */
8921 : static bool
8922 130 : is_predefined_allocator (gfc_expr *expr)
8923 : {
8924 130 : return (gfc_resolve_expr (expr)
8925 129 : && expr->rank == 0
8926 124 : && expr->ts.type == BT_INTEGER
8927 119 : && expr->ts.kind == gfc_c_intptr_kind
8928 114 : && expr->expr_type == EXPR_CONSTANT
8929 239 : && ((mpz_sgn (expr->value.integer) > 0
8930 107 : && mpz_cmp_si (expr->value.integer,
8931 : GOMP_OMP_PREDEF_ALLOC_MAX) <= 0)
8932 4 : || (mpz_cmp_si (expr->value.integer,
8933 : GOMP_OMPX_PREDEF_ALLOC_MIN) >= 0
8934 1 : && mpz_cmp_si (expr->value.integer,
8935 130 : GOMP_OMPX_PREDEF_ALLOC_MAX) <= 0)));
8936 : }
8937 :
8938 : /* Resolve declarative ALLOCATE statement. Note: Common block vars only appear
8939 : as /block/ not individual, which is ensured during parsing. */
8940 :
8941 : void
8942 62 : gfc_resolve_omp_allocate (gfc_namespace *ns, gfc_omp_namelist *list)
8943 : {
8944 278 : for (gfc_omp_namelist *n = list; n; n = n->next)
8945 : {
8946 216 : if (n->sym->attr.result || n->sym->result == n->sym)
8947 : {
8948 1 : gfc_error ("Unexpected function-result variable %qs at %L in "
8949 : "declarative !$OMP ALLOCATE", n->sym->name, &n->where);
8950 31 : continue;
8951 : }
8952 215 : if (ns->omp_allocate->sym->attr.proc_pointer)
8953 : {
8954 0 : gfc_error ("Procedure pointer %qs not supported with !$OMP "
8955 : "ALLOCATE at %L", n->sym->name, &n->where);
8956 0 : continue;
8957 : }
8958 215 : if (n->sym->attr.flavor != FL_VARIABLE)
8959 : {
8960 3 : gfc_error ("Argument %qs at %L to declarative !$OMP ALLOCATE "
8961 : "directive must be a variable", n->sym->name,
8962 : &n->where);
8963 3 : continue;
8964 : }
8965 212 : if (ns != n->sym->ns || n->sym->attr.use_assoc || n->sym->attr.imported)
8966 : {
8967 8 : gfc_error ("Argument %qs at %L to declarative !$OMP ALLOCATE shall be"
8968 : " in the same scope as the variable declaration",
8969 : n->sym->name, &n->where);
8970 8 : continue;
8971 : }
8972 204 : if (n->sym->attr.dummy)
8973 : {
8974 3 : gfc_error ("Unexpected dummy argument %qs as argument at %L to "
8975 : "declarative !$OMP ALLOCATE", n->sym->name, &n->where);
8976 3 : continue;
8977 : }
8978 201 : if (n->sym->attr.codimension)
8979 : {
8980 0 : gfc_error ("Unexpected coarray argument %qs as argument at %L to "
8981 : "declarative !$OMP ALLOCATE", n->sym->name, &n->where);
8982 0 : continue;
8983 : }
8984 201 : if (n->sym->attr.omp_allocate)
8985 : {
8986 5 : if (n->sym->attr.in_common)
8987 : {
8988 1 : gfc_error ("Duplicated common block %</%s/%> in !$OMP ALLOCATE "
8989 1 : "at %L", n->sym->common_head->name, &n->where);
8990 3 : while (n->next && n->next->sym
8991 3 : && n->sym->common_head == n->next->sym->common_head)
8992 : n = n->next;
8993 : }
8994 : else
8995 4 : gfc_error ("Duplicated variable %qs in !$OMP ALLOCATE at %L",
8996 : n->sym->name, &n->where);
8997 5 : continue;
8998 : }
8999 : /* For 'equivalence(a,b)', a 'union_type {<type> a,b} equiv.0' is created
9000 : with a value expression for 'a' as 'equiv.0.a' (likewise for b); while
9001 : this can be handled, EQUIVALENCE is marked as obsolescent since Fortran
9002 : 2018 and also not widely used. However, it could be supported,
9003 : if needed. */
9004 196 : if (n->sym->attr.in_equivalence)
9005 : {
9006 2 : gfc_error ("Sorry, EQUIVALENCE object %qs not supported with !$OMP "
9007 : "ALLOCATE at %L", n->sym->name, &n->where);
9008 2 : continue;
9009 : }
9010 : /* Similar for Cray pointer/pointee - they could be implemented but as
9011 : common vendor extension but nowadays rarely used and requiring
9012 : -fcray-pointer, there is no need to support them. */
9013 194 : if (n->sym->attr.cray_pointer || n->sym->attr.cray_pointee)
9014 : {
9015 2 : gfc_error ("Sorry, Cray pointers and pointees such as %qs are not "
9016 : "supported with !$OMP ALLOCATE at %L",
9017 : n->sym->name, &n->where);
9018 2 : continue;
9019 : }
9020 192 : n->sym->attr.omp_allocate = 1;
9021 192 : if ((n->sym->ts.type == BT_CLASS && n->sym->attr.class_ok
9022 0 : && CLASS_DATA (n->sym)->attr.allocatable)
9023 192 : || (n->sym->ts.type != BT_CLASS && n->sym->attr.allocatable))
9024 1 : gfc_error ("Unexpected allocatable variable %qs at %L in declarative "
9025 : "!$OMP ALLOCATE directive", n->sym->name, &n->where);
9026 191 : else if ((n->sym->ts.type == BT_CLASS && n->sym->attr.class_ok
9027 0 : && CLASS_DATA (n->sym)->attr.class_pointer)
9028 191 : || (n->sym->ts.type != BT_CLASS && n->sym->attr.pointer))
9029 1 : gfc_error ("Unexpected pointer variable %qs at %L in declarative "
9030 : "!$OMP ALLOCATE directive", n->sym->name, &n->where);
9031 192 : HOST_WIDE_INT alignment = 0;
9032 198 : if (n->u.align
9033 192 : && (!gfc_resolve_expr (n->u.align)
9034 27 : || n->u.align->ts.type != BT_INTEGER
9035 26 : || n->u.align->rank != 0
9036 24 : || n->u.align->expr_type != EXPR_CONSTANT
9037 23 : || gfc_extract_hwi (n->u.align, &alignment)
9038 23 : || !pow2p_hwi (alignment)))
9039 : {
9040 6 : gfc_error ("ALIGN requires a scalar positive constant integer "
9041 : "alignment expression at %L that is a power of two",
9042 6 : &n->u.align->where);
9043 6 : while (n->sym->attr.in_common && n->next && n->next->sym
9044 6 : && n->sym->common_head == n->next->sym->common_head)
9045 : n = n->next;
9046 6 : continue;
9047 : }
9048 186 : if (n->sym->attr.in_common || n->sym->attr.save || n->sym->ns->save_all
9049 63 : || (n->sym->ns->proc_name
9050 63 : && (n->sym->ns->proc_name->attr.flavor == FL_PROGRAM
9051 : || n->sym->ns->proc_name->attr.flavor == FL_MODULE
9052 : || n->sym->ns->proc_name->attr.flavor == FL_BLOCK_DATA)))
9053 : {
9054 131 : bool com = n->sym->attr.in_common;
9055 131 : if (!n->u2.allocator)
9056 1 : gfc_error ("An ALLOCATOR clause is required as the list item "
9057 : "%<%s%s%s%> at %L has the SAVE attribute", com ? "/" : "",
9058 0 : com ? n->sym->common_head->name : n->sym->name,
9059 : com ? "/" : "", &n->where);
9060 130 : else if (!is_predefined_allocator (n->u2.allocator))
9061 24 : gfc_error ("Predefined allocator required in ALLOCATOR clause at %L"
9062 : " as the list item %<%s%s%s%> at %L has the SAVE attribute",
9063 24 : &n->u2.allocator->where, com ? "/" : "",
9064 24 : com ? n->sym->common_head->name : n->sym->name,
9065 : com ? "/" : "", &n->where);
9066 : /* Static variables may not use omp_cgroup_mem_alloc (6),
9067 : omp_pteam_mem_alloc (7), or omp_thread_mem_alloc (8). */
9068 106 : else if (mpz_cmp_si (n->u2.allocator->value.integer,
9069 : 6 /* cgroup */) >= 0
9070 34 : && mpz_cmp_si (n->u2.allocator->value.integer,
9071 : 8 /* thread */) <= 0)
9072 : {
9073 33 : STATIC_ASSERT (GOMP_OMP_PREDEF_ALLOC_CGROUP == 6);
9074 33 : STATIC_ASSERT (GOMP_OMP_PREDEF_ALLOC_PTEAM == 7);
9075 33 : STATIC_ASSERT (GOMP_OMP_PREDEF_ALLOC_THREAD == 8);
9076 33 : const char *alloc_name[] = {"omp_cgroup_mem_alloc",
9077 : "omp_pteam_mem_alloc",
9078 : "omp_thread_mem_alloc" };
9079 33 : gfc_error ("Predefined allocator %qs in ALLOCATOR clause at %L, "
9080 : "used for list item %<%s%s%s%> at %L, may not be used"
9081 : " for static variables",
9082 33 : alloc_name[mpz_get_ui (n->u2.allocator->value.integer)
9083 33 : - 6 /* cgroup */], &n->u2.allocator->where,
9084 : com ? "/" : "",
9085 33 : com ? n->sym->common_head->name : n->sym->name,
9086 : com ? "/" : "", &n->where);
9087 : }
9088 67 : while (n->sym->attr.in_common && n->next && n->next->sym
9089 186 : && n->sym->common_head == n->next->sym->common_head)
9090 : n = n->next;
9091 : }
9092 55 : else if (n->u2.allocator
9093 55 : && (!gfc_resolve_expr (n->u2.allocator)
9094 20 : || n->u2.allocator->ts.type != BT_INTEGER
9095 19 : || n->u2.allocator->rank != 0
9096 18 : || n->u2.allocator->ts.kind != gfc_c_intptr_kind))
9097 3 : gfc_error ("Expected integer expression of the "
9098 : "%<omp_allocator_handle_kind%> kind at %L",
9099 3 : &n->u2.allocator->where);
9100 : }
9101 62 : }
9102 :
9103 : /* Resolve ASSUME's and ASSUMES' assumption clauses. Note that absent/contains
9104 : is handled during parse time in omp_verify_merge_absent_contains. */
9105 :
9106 : void
9107 29 : gfc_resolve_omp_assumptions (gfc_omp_assumptions *assume)
9108 : {
9109 46 : for (gfc_expr_list *el = assume->holds; el; el = el->next)
9110 17 : if (!gfc_resolve_expr (el->expr)
9111 17 : || el->expr->ts.type != BT_LOGICAL
9112 32 : || el->expr->rank != 0)
9113 4 : gfc_error ("HOLDS expression at %L must be a scalar logical expression",
9114 4 : &el->expr->where);
9115 29 : }
9116 :
9117 :
9118 : /* OpenMP directive resolving routines. */
9119 :
9120 : static void
9121 32471 : resolve_omp_clauses (gfc_code *code, gfc_omp_clauses *omp_clauses,
9122 : gfc_namespace *ns, bool openacc = false)
9123 : {
9124 32471 : gfc_omp_namelist *n, *last;
9125 32471 : gfc_expr_list *el;
9126 32471 : enum gfc_omp_list_type list;
9127 32471 : int ifc;
9128 32471 : bool if_without_mod = false;
9129 32471 : gfc_omp_linear_op linear_op = OMP_LINEAR_DEFAULT;
9130 32471 : static const char *clause_names[]
9131 : = { "PRIVATE", "FIRSTPRIVATE", "LASTPRIVATE", "COPYPRIVATE", "SHARED",
9132 : "COPYIN", "UNIFORM", "AFFINITY", "ALIGNED", "LINEAR", "DEPEND", "MAP",
9133 : "TO", "FROM", "INCLUSIVE", "EXCLUSIVE",
9134 : "REDUCTION", "REDUCTION" /*inscan*/, "REDUCTION" /*task*/,
9135 : "IN_REDUCTION", "TASK_REDUCTION",
9136 : "DEVICE_RESIDENT", "LINK", "LOCAL", "USE_DEVICE",
9137 : "CACHE", "IS_DEVICE_PTR", "USE_DEVICE_PTR", "USE_DEVICE_ADDR",
9138 : "NONTEMPORAL", "ALLOCATE", "HAS_DEVICE_ADDR", "ENTER",
9139 : "USES_ALLOCATORS", "INIT", "USE", "DESTROY", "INTEROP", "ADJUST_ARGS" };
9140 32471 : STATIC_ASSERT (ARRAY_SIZE (clause_names) == OMP_LIST_NUM);
9141 :
9142 32471 : if (omp_clauses == NULL)
9143 : return;
9144 :
9145 32471 : if (ns == NULL)
9146 32044 : ns = gfc_current_ns;
9147 :
9148 32471 : if (omp_clauses->orderedc && omp_clauses->orderedc < omp_clauses->collapse)
9149 0 : gfc_error ("ORDERED clause parameter is less than COLLAPSE at %L",
9150 : &code->loc);
9151 32471 : if (omp_clauses->order_concurrent && omp_clauses->ordered)
9152 4 : gfc_error ("ORDER clause must not be used together with ORDERED at %L",
9153 : &code->loc);
9154 32471 : if (omp_clauses->if_expr)
9155 : {
9156 1184 : gfc_expr *expr = omp_clauses->if_expr;
9157 1184 : if (!gfc_resolve_expr (expr)
9158 1184 : || expr->ts.type != BT_LOGICAL || expr->rank != 0)
9159 16 : gfc_error ("IF clause at %L requires a scalar LOGICAL expression",
9160 : &expr->where);
9161 : if_without_mod = true;
9162 : }
9163 357181 : for (ifc = 0; ifc < OMP_IF_LAST; ifc++)
9164 324710 : if (omp_clauses->if_exprs[ifc])
9165 : {
9166 137 : gfc_expr *expr = omp_clauses->if_exprs[ifc];
9167 137 : bool ok = true;
9168 137 : if (!gfc_resolve_expr (expr)
9169 137 : || expr->ts.type != BT_LOGICAL || expr->rank != 0)
9170 0 : gfc_error ("IF clause at %L requires a scalar LOGICAL expression",
9171 : &expr->where);
9172 137 : else if (if_without_mod)
9173 : {
9174 1 : gfc_error ("IF clause without modifier at %L used together with "
9175 : "IF clauses with modifiers",
9176 1 : &omp_clauses->if_expr->where);
9177 1 : if_without_mod = false;
9178 : }
9179 : else
9180 136 : switch (code->op)
9181 : {
9182 13 : case EXEC_OMP_CANCEL:
9183 13 : ok = ifc == OMP_IF_CANCEL;
9184 13 : break;
9185 :
9186 16 : case EXEC_OMP_PARALLEL:
9187 16 : case EXEC_OMP_PARALLEL_DO:
9188 16 : case EXEC_OMP_PARALLEL_LOOP:
9189 16 : case EXEC_OMP_PARALLEL_MASKED:
9190 16 : case EXEC_OMP_PARALLEL_MASTER:
9191 16 : case EXEC_OMP_PARALLEL_SECTIONS:
9192 16 : case EXEC_OMP_PARALLEL_WORKSHARE:
9193 16 : case EXEC_OMP_DISTRIBUTE_PARALLEL_DO:
9194 16 : case EXEC_OMP_TEAMS_DISTRIBUTE_PARALLEL_DO:
9195 16 : ok = ifc == OMP_IF_PARALLEL;
9196 16 : break;
9197 :
9198 28 : case EXEC_OMP_PARALLEL_DO_SIMD:
9199 28 : case EXEC_OMP_DISTRIBUTE_PARALLEL_DO_SIMD:
9200 28 : case EXEC_OMP_TEAMS_DISTRIBUTE_PARALLEL_DO_SIMD:
9201 28 : ok = ifc == OMP_IF_PARALLEL || ifc == OMP_IF_SIMD;
9202 28 : break;
9203 :
9204 8 : case EXEC_OMP_PARALLEL_MASKED_TASKLOOP:
9205 8 : case EXEC_OMP_PARALLEL_MASTER_TASKLOOP:
9206 8 : ok = ifc == OMP_IF_PARALLEL || ifc == OMP_IF_TASKLOOP;
9207 8 : break;
9208 :
9209 12 : case EXEC_OMP_PARALLEL_MASKED_TASKLOOP_SIMD:
9210 12 : case EXEC_OMP_PARALLEL_MASTER_TASKLOOP_SIMD:
9211 12 : ok = (ifc == OMP_IF_PARALLEL
9212 12 : || ifc == OMP_IF_TASKLOOP
9213 : || ifc == OMP_IF_SIMD);
9214 : break;
9215 :
9216 0 : case EXEC_OMP_SIMD:
9217 0 : case EXEC_OMP_DO_SIMD:
9218 0 : case EXEC_OMP_DISTRIBUTE_SIMD:
9219 0 : case EXEC_OMP_TEAMS_DISTRIBUTE_SIMD:
9220 0 : ok = ifc == OMP_IF_SIMD;
9221 0 : break;
9222 :
9223 1 : case EXEC_OMP_TASK:
9224 1 : ok = ifc == OMP_IF_TASK;
9225 1 : break;
9226 :
9227 5 : case EXEC_OMP_TASKLOOP:
9228 5 : case EXEC_OMP_MASKED_TASKLOOP:
9229 5 : case EXEC_OMP_MASTER_TASKLOOP:
9230 5 : ok = ifc == OMP_IF_TASKLOOP;
9231 5 : break;
9232 :
9233 20 : case EXEC_OMP_TASKLOOP_SIMD:
9234 20 : case EXEC_OMP_MASKED_TASKLOOP_SIMD:
9235 20 : case EXEC_OMP_MASTER_TASKLOOP_SIMD:
9236 20 : ok = ifc == OMP_IF_TASKLOOP || ifc == OMP_IF_SIMD;
9237 20 : break;
9238 :
9239 5 : case EXEC_OMP_TARGET:
9240 5 : case EXEC_OMP_TARGET_TEAMS:
9241 5 : case EXEC_OMP_TARGET_TEAMS_DISTRIBUTE:
9242 5 : case EXEC_OMP_TARGET_TEAMS_LOOP:
9243 5 : ok = ifc == OMP_IF_TARGET;
9244 5 : break;
9245 :
9246 4 : case EXEC_OMP_TARGET_TEAMS_DISTRIBUTE_SIMD:
9247 4 : case EXEC_OMP_TARGET_SIMD:
9248 4 : ok = ifc == OMP_IF_TARGET || ifc == OMP_IF_SIMD;
9249 4 : break;
9250 :
9251 1 : case EXEC_OMP_TARGET_DATA:
9252 1 : ok = ifc == OMP_IF_TARGET_DATA;
9253 1 : break;
9254 :
9255 1 : case EXEC_OMP_TARGET_UPDATE:
9256 1 : ok = ifc == OMP_IF_TARGET_UPDATE;
9257 1 : break;
9258 :
9259 1 : case EXEC_OMP_TARGET_ENTER_DATA:
9260 1 : ok = ifc == OMP_IF_TARGET_ENTER_DATA;
9261 1 : break;
9262 :
9263 1 : case EXEC_OMP_TARGET_EXIT_DATA:
9264 1 : ok = ifc == OMP_IF_TARGET_EXIT_DATA;
9265 1 : break;
9266 :
9267 10 : case EXEC_OMP_TARGET_TEAMS_DISTRIBUTE_PARALLEL_DO:
9268 10 : case EXEC_OMP_TARGET_PARALLEL:
9269 10 : case EXEC_OMP_TARGET_PARALLEL_DO:
9270 10 : case EXEC_OMP_TARGET_PARALLEL_LOOP:
9271 10 : ok = ifc == OMP_IF_TARGET || ifc == OMP_IF_PARALLEL;
9272 10 : break;
9273 :
9274 10 : case EXEC_OMP_TARGET_PARALLEL_DO_SIMD:
9275 10 : case EXEC_OMP_TARGET_TEAMS_DISTRIBUTE_PARALLEL_DO_SIMD:
9276 10 : ok = (ifc == OMP_IF_TARGET
9277 10 : || ifc == OMP_IF_PARALLEL
9278 : || ifc == OMP_IF_SIMD);
9279 : break;
9280 :
9281 : default:
9282 : ok = false;
9283 : break;
9284 : }
9285 115 : if (!ok)
9286 : {
9287 2 : static const char *ifs[] = {
9288 : "CANCEL",
9289 : "PARALLEL",
9290 : "SIMD",
9291 : "TASK",
9292 : "TASKLOOP",
9293 : "TARGET",
9294 : "TARGET DATA",
9295 : "TARGET UPDATE",
9296 : "TARGET ENTER DATA",
9297 : "TARGET EXIT DATA"
9298 : };
9299 2 : gfc_error ("IF clause modifier %s at %L not appropriate for "
9300 : "the current OpenMP construct", ifs[ifc], &expr->where);
9301 : }
9302 : }
9303 :
9304 32471 : if (omp_clauses->self_expr)
9305 : {
9306 177 : gfc_expr *expr = omp_clauses->self_expr;
9307 177 : if (!gfc_resolve_expr (expr)
9308 177 : || expr->ts.type != BT_LOGICAL || expr->rank != 0)
9309 6 : gfc_error ("SELF clause at %L requires a scalar LOGICAL expression",
9310 : &expr->where);
9311 : }
9312 :
9313 32471 : if (omp_clauses->final_expr)
9314 : {
9315 64 : gfc_expr *expr = omp_clauses->final_expr;
9316 64 : if (!gfc_resolve_expr (expr)
9317 64 : || expr->ts.type != BT_LOGICAL || expr->rank != 0)
9318 0 : gfc_error ("FINAL clause at %L requires a scalar LOGICAL expression",
9319 : &expr->where);
9320 : }
9321 32471 : if (omp_clauses->novariants)
9322 : {
9323 9 : gfc_expr *expr = omp_clauses->novariants;
9324 18 : if (!gfc_resolve_expr (expr) || expr->ts.type != BT_LOGICAL
9325 17 : || expr->rank != 0)
9326 1 : gfc_error (
9327 : "NOVARIANTS clause at %L requires a scalar LOGICAL expression",
9328 : &expr->where);
9329 32471 : if_without_mod = true;
9330 : }
9331 32471 : if (omp_clauses->nocontext)
9332 : {
9333 12 : gfc_expr *expr = omp_clauses->nocontext;
9334 24 : if (!gfc_resolve_expr (expr) || expr->ts.type != BT_LOGICAL
9335 23 : || expr->rank != 0)
9336 1 : gfc_error (
9337 : "NOCONTEXT clause at %L requires a scalar LOGICAL expression",
9338 : &expr->where);
9339 32471 : if_without_mod = true;
9340 : }
9341 32471 : if (omp_clauses->num_threads)
9342 962 : resolve_positive_int_expr (omp_clauses->num_threads, "NUM_THREADS");
9343 32471 : if (omp_clauses->dyn_groupprivate)
9344 10 : resolve_nonnegative_int_expr (omp_clauses->dyn_groupprivate,
9345 : "DYN_GROUPPRIVATE");
9346 32471 : if (omp_clauses->chunk_size)
9347 : {
9348 510 : gfc_expr *expr = omp_clauses->chunk_size;
9349 510 : if (!gfc_resolve_expr (expr)
9350 510 : || expr->ts.type != BT_INTEGER || expr->rank != 0)
9351 0 : gfc_error ("SCHEDULE clause's chunk_size at %L requires "
9352 : "a scalar INTEGER expression", &expr->where);
9353 510 : else if (expr->expr_type == EXPR_CONSTANT
9354 : && expr->ts.type == BT_INTEGER
9355 485 : && mpz_sgn (expr->value.integer) <= 0)
9356 2 : gfc_warning (OPT_Wopenmp, "INTEGER expression of SCHEDULE clause's "
9357 : "chunk_size at %L must be positive", &expr->where);
9358 : }
9359 32471 : if (omp_clauses->sched_kind != OMP_SCHED_NONE
9360 891 : && omp_clauses->sched_nonmonotonic)
9361 : {
9362 34 : if (omp_clauses->sched_monotonic)
9363 2 : gfc_error ("Both MONOTONIC and NONMONOTONIC schedule modifiers "
9364 : "specified at %L", &code->loc);
9365 32 : else if (omp_clauses->ordered)
9366 4 : gfc_error ("NONMONOTONIC schedule modifier specified with ORDERED "
9367 : "clause at %L", &code->loc);
9368 : }
9369 :
9370 32471 : if (omp_clauses->depobj
9371 32471 : && (!gfc_resolve_expr (omp_clauses->depobj)
9372 115 : || omp_clauses->depobj->ts.type != BT_INTEGER
9373 114 : || omp_clauses->depobj->ts.kind != 2 * gfc_index_integer_kind
9374 113 : || omp_clauses->depobj->rank != 0))
9375 4 : gfc_error ("DEPOBJ in DEPOBJ construct at %L shall be a scalar integer "
9376 4 : "of OMP_DEPEND_KIND kind", &omp_clauses->depobj->where);
9377 :
9378 : /* Check that no symbol appears on multiple clauses, except that
9379 : a symbol can appear on both firstprivate and lastprivate. */
9380 1298840 : for (list = OMP_LIST_FIRST; list < OMP_LIST_NUM;
9381 1266369 : list = gfc_omp_list_type (list + 1))
9382 1311975 : for (n = omp_clauses->lists[list]; n; n = n->next)
9383 : {
9384 45606 : if (!n->sym) /* omp_all_memory. */
9385 47 : continue;
9386 45559 : n->sym->mark = 0;
9387 45559 : n->sym->comp_mark = 0;
9388 45559 : n->sym->data_mark = 0;
9389 45559 : n->sym->dev_mark = 0;
9390 45559 : n->sym->gen_mark = 0;
9391 45559 : n->sym->reduc_mark = 0;
9392 45559 : if (n->sym->attr.flavor == FL_VARIABLE
9393 274 : || n->sym->attr.proc_pointer
9394 233 : || (!code
9395 0 : && !ns->omp_udm_ns
9396 0 : && (!n->sym->attr.dummy || n->sym->ns != ns)))
9397 : {
9398 45326 : if (!code
9399 271 : && !ns->omp_udm_ns
9400 264 : && (!n->sym->attr.dummy || n->sym->ns != ns))
9401 0 : gfc_error ("Variable %qs is not a dummy argument at %L",
9402 : n->sym->name, &n->where);
9403 45326 : continue;
9404 : }
9405 233 : if (n->sym->attr.flavor == FL_PROCEDURE
9406 153 : && n->sym->result == n->sym
9407 138 : && n->sym->attr.function)
9408 : {
9409 138 : if (ns->proc_name == n->sym
9410 44 : || (ns->parent && ns->parent->proc_name == n->sym))
9411 101 : continue;
9412 37 : if (ns->proc_name->attr.entry_master)
9413 : {
9414 32 : gfc_entry_list *el = ns->entries;
9415 51 : for (; el; el = el->next)
9416 51 : if (el->sym == n->sym)
9417 : break;
9418 32 : if (el)
9419 32 : continue;
9420 : }
9421 5 : if (ns->parent
9422 3 : && ns->parent->proc_name->attr.entry_master)
9423 : {
9424 2 : gfc_entry_list *el = ns->parent->entries;
9425 3 : for (; el; el = el->next)
9426 3 : if (el->sym == n->sym)
9427 : break;
9428 2 : if (el)
9429 2 : continue;
9430 : }
9431 : }
9432 98 : if (list == OMP_LIST_MAP
9433 18 : && n->sym->attr.flavor == FL_PARAMETER)
9434 : {
9435 : /* OpenACC since 3.4 permits for Fortran named constants, but
9436 : permits removing then as optimization is not needed and such
9437 : ignore them. Likewise below for FIRSTPRIVATE. */
9438 12 : if (openacc)
9439 10 : gfc_warning (OPT_Wsurprising, "Clause for object %qs at %L is "
9440 : "ignored as parameters need not be copied",
9441 : n->sym->name, &n->where);
9442 : else
9443 2 : gfc_error ("Object %qs is not a variable at %L; parameters"
9444 : " cannot be and need not be mapped", n->sym->name,
9445 : &n->where);
9446 : }
9447 86 : else if (openacc && n->sym->attr.flavor == FL_PARAMETER)
9448 9 : gfc_warning (OPT_Wsurprising, "Clause for object %qs at %L is ignored"
9449 : " as it is a parameter", n->sym->name, &n->where);
9450 77 : else if (list != OMP_LIST_USES_ALLOCATORS)
9451 30 : gfc_error ("Object %qs is not a variable at %L", n->sym->name,
9452 : &n->where);
9453 : }
9454 32471 : if (omp_clauses->lists[OMP_LIST_REDUCTION_INSCAN])
9455 : {
9456 69 : locus *loc = &omp_clauses->lists[OMP_LIST_REDUCTION_INSCAN]->where;
9457 69 : if (code->op != EXEC_OMP_DO
9458 : && code->op != EXEC_OMP_SIMD
9459 : && code->op != EXEC_OMP_DO_SIMD
9460 : && code->op != EXEC_OMP_PARALLEL_DO
9461 : && code->op != EXEC_OMP_PARALLEL_DO_SIMD)
9462 23 : gfc_error ("%<inscan%> REDUCTION clause on construct other than DO, "
9463 : "SIMD, DO SIMD, PARALLEL DO, PARALLEL DO SIMD at %L",
9464 : loc);
9465 69 : if (omp_clauses->ordered)
9466 2 : gfc_error ("ORDERED clause specified together with %<inscan%> "
9467 : "REDUCTION clause at %L", loc);
9468 69 : if (omp_clauses->sched_kind != OMP_SCHED_NONE)
9469 3 : gfc_error ("SCHEDULE clause specified together with %<inscan%> "
9470 : "REDUCTION clause at %L", loc);
9471 : }
9472 :
9473 1298840 : for (list = OMP_LIST_FIRST; list < OMP_LIST_NUM;
9474 1266369 : list = gfc_omp_list_type (list + 1))
9475 1266369 : if (list != OMP_LIST_FIRSTPRIVATE
9476 1266369 : && list != OMP_LIST_LASTPRIVATE
9477 1266369 : && list != OMP_LIST_ALIGNED
9478 1168956 : && list != OMP_LIST_DEPEND
9479 1168956 : && list != OMP_LIST_FROM
9480 1104014 : && list != OMP_LIST_TO
9481 1104014 : && list != OMP_LIST_INTEROP
9482 1039072 : && (list != OMP_LIST_REDUCTION || !openacc)
9483 1026447 : && list != OMP_LIST_ALLOCATE)
9484 1028756 : for (n = omp_clauses->lists[list]; n; n = n->next)
9485 : {
9486 34780 : bool component_ref_p = false;
9487 :
9488 : /* Allow multiple components of the same (e.g. derived-type)
9489 : variable here. Duplicate components are detected elsewhere. */
9490 34780 : if (n->expr && n->expr->expr_type == EXPR_VARIABLE)
9491 15801 : for (gfc_ref *ref = n->expr->ref; ref; ref = ref->next)
9492 9591 : if (ref->type == REF_COMPONENT)
9493 3135 : component_ref_p = true;
9494 34780 : if ((list == OMP_LIST_IS_DEVICE_PTR
9495 34780 : || list == OMP_LIST_HAS_DEVICE_ADDR)
9496 313 : && !component_ref_p)
9497 : {
9498 313 : if (n->sym->gen_mark
9499 311 : || n->sym->dev_mark
9500 310 : || n->sym->reduc_mark
9501 310 : || n->sym->mark)
9502 5 : gfc_error ("Symbol %qs present on multiple clauses at %L",
9503 : n->sym->name, &n->where);
9504 : else
9505 308 : n->sym->dev_mark = 1;
9506 : }
9507 34467 : else if ((list == OMP_LIST_USE_DEVICE_PTR
9508 34467 : || list == OMP_LIST_USE_DEVICE_ADDR
9509 34467 : || list == OMP_LIST_PRIVATE
9510 : || list == OMP_LIST_SHARED)
9511 12851 : && !component_ref_p)
9512 : {
9513 12851 : if (n->sym->gen_mark || n->sym->dev_mark || n->sym->reduc_mark)
9514 13 : gfc_error ("Symbol %qs present on multiple clauses at %L",
9515 : n->sym->name, &n->where);
9516 : else
9517 : {
9518 12838 : n->sym->gen_mark = 1;
9519 : /* Set both generic and device bits if we have
9520 : use_device_*(x) or shared(x). This allows us to diagnose
9521 : "map(x) private(x)" below. */
9522 12838 : if (list != OMP_LIST_PRIVATE)
9523 3456 : n->sym->dev_mark = 1;
9524 : }
9525 : }
9526 21616 : else if ((list == OMP_LIST_REDUCTION
9527 21616 : || list == OMP_LIST_REDUCTION_TASK
9528 19159 : || list == OMP_LIST_REDUCTION_INSCAN
9529 19159 : || list == OMP_LIST_IN_REDUCTION
9530 18946 : || list == OMP_LIST_TASK_REDUCTION)
9531 2670 : && !component_ref_p)
9532 : {
9533 : /* Attempts to mix reduction types are diagnosed below. */
9534 2670 : if (n->sym->gen_mark || n->sym->dev_mark)
9535 2 : gfc_error ("Symbol %qs present on multiple clauses at %L",
9536 : n->sym->name, &n->where);
9537 2670 : n->sym->reduc_mark = 1;
9538 : }
9539 18946 : else if ((!component_ref_p && n->sym->comp_mark)
9540 2452 : || (component_ref_p && n->sym->mark))
9541 : {
9542 28 : if (openacc)
9543 3 : gfc_error ("Symbol %qs has mixed component and non-component "
9544 3 : "accesses at %L", n->sym->name, &n->where);
9545 : }
9546 18918 : else if ((openacc || list != OMP_LIST_MAP) && n->sym->mark)
9547 88 : gfc_error ("Symbol %qs present on multiple clauses at %L",
9548 : n->sym->name, &n->where);
9549 : else
9550 : {
9551 18830 : if (component_ref_p)
9552 2425 : n->sym->comp_mark = 1;
9553 : else
9554 16405 : n->sym->mark = 1;
9555 : }
9556 : }
9557 :
9558 32471 : if (code
9559 32247 : && code->op == EXEC_OMP_INTEROP
9560 63 : && omp_clauses->lists[OMP_LIST_DEPEND])
9561 : {
9562 12 : if (!omp_clauses->lists[OMP_LIST_INIT]
9563 5 : && !omp_clauses->lists[OMP_LIST_USE]
9564 1 : && !omp_clauses->lists[OMP_LIST_DESTROY])
9565 : {
9566 1 : gfc_error ("DEPEND clause at %L requires action clause with "
9567 : "%<targetsync%> interop-type",
9568 : &omp_clauses->lists[OMP_LIST_DEPEND]->where);
9569 : }
9570 22 : for (n = omp_clauses->lists[OMP_LIST_INIT]; n; n = n->next)
9571 12 : if (!n->u.init.targetsync)
9572 : {
9573 2 : gfc_error ("DEPEND clause at %L requires %<targetsync%> "
9574 : "interop-type, lacking it for %qs at %L",
9575 2 : &omp_clauses->lists[OMP_LIST_DEPEND]->where,
9576 2 : n->sym->name, &n->where);
9577 2 : break;
9578 : }
9579 : }
9580 32247 : if (code && (code->op == EXEC_OMP_INTEROP || code->op == EXEC_OMP_DISPATCH))
9581 1085 : for (list = OMP_LIST_INIT; list <= OMP_LIST_INTEROP;
9582 868 : list = gfc_omp_list_type (list + 1))
9583 1123 : for (n = omp_clauses->lists[list]; n; n = n->next)
9584 : {
9585 255 : if (n->sym->ts.type != BT_INTEGER
9586 252 : || n->sym->ts.kind != gfc_index_integer_kind
9587 248 : || n->sym->attr.dimension
9588 243 : || n->sym->attr.flavor != FL_VARIABLE)
9589 16 : gfc_error ("%qs at %L in %qs clause must be a scalar integer "
9590 : "variable of %<omp_interop_kind%> kind", n->sym->name,
9591 : &n->where, clause_names[list]);
9592 255 : if (list != OMP_LIST_USE && list != OMP_LIST_INTEROP
9593 109 : && n->sym->attr.intent == INTENT_IN)
9594 2 : gfc_error ("%qs at %L in %qs clause must be definable",
9595 : n->sym->name, &n->where, clause_names[list]);
9596 : }
9597 :
9598 : /* Detect specifically the case where we have "map(x) private(x)" and raise
9599 : an error. If we have "...simd" combined directives though, the "private"
9600 : applies to the simd part, so this is permitted though. */
9601 41861 : for (n = omp_clauses->lists[OMP_LIST_PRIVATE]; n; n = n->next)
9602 9390 : if (n->sym->mark
9603 6 : && n->sym->gen_mark
9604 6 : && !n->sym->dev_mark
9605 6 : && !n->sym->reduc_mark
9606 5 : && code->op != EXEC_OMP_TARGET_SIMD
9607 : && code->op != EXEC_OMP_TARGET_PARALLEL_DO_SIMD
9608 : && code->op != EXEC_OMP_TARGET_TEAMS_DISTRIBUTE_SIMD
9609 : && code->op != EXEC_OMP_TARGET_TEAMS_DISTRIBUTE_PARALLEL_DO_SIMD)
9610 1 : gfc_error ("Symbol %qs present on multiple clauses at %L",
9611 : n->sym->name, &n->where);
9612 :
9613 : gcc_assert (OMP_LIST_LASTPRIVATE == OMP_LIST_FIRSTPRIVATE + 1);
9614 97413 : for (list = OMP_LIST_FIRSTPRIVATE; list <= OMP_LIST_LASTPRIVATE;
9615 64942 : list = gfc_omp_list_type (list + 1))
9616 69103 : for (n = omp_clauses->lists[list]; n; n = n->next)
9617 4161 : if (n->sym->data_mark || n->sym->gen_mark || n->sym->dev_mark)
9618 : {
9619 9 : gfc_error ("Symbol %qs present on multiple clauses at %L",
9620 : n->sym->name, &n->where);
9621 9 : n->sym->data_mark = n->sym->gen_mark = n->sym->dev_mark = 0;
9622 : }
9623 4152 : else if (n->sym->mark
9624 18 : && code->op != EXEC_OMP_TARGET_TEAMS
9625 : && code->op != EXEC_OMP_TARGET_TEAMS_DISTRIBUTE
9626 : && code->op != EXEC_OMP_TARGET_TEAMS_LOOP
9627 : && code->op != EXEC_OMP_TARGET_TEAMS_DISTRIBUTE_SIMD
9628 : && code->op != EXEC_OMP_TARGET_TEAMS_DISTRIBUTE_PARALLEL_DO
9629 : && code->op != EXEC_OMP_TARGET_PARALLEL
9630 : && code->op != EXEC_OMP_TARGET_PARALLEL_DO
9631 : && code->op != EXEC_OMP_TARGET_PARALLEL_LOOP
9632 : && code->op != EXEC_OMP_TARGET_PARALLEL_DO_SIMD
9633 : && code->op != EXEC_OMP_TARGET_TEAMS_DISTRIBUTE_PARALLEL_DO_SIMD)
9634 7 : gfc_error ("Symbol %qs present on both data and map clauses "
9635 : "at %L", n->sym->name, &n->where);
9636 :
9637 34326 : for (n = omp_clauses->lists[OMP_LIST_FIRSTPRIVATE]; n; n = n->next)
9638 : {
9639 1855 : if (n->sym->data_mark || n->sym->gen_mark || n->sym->dev_mark)
9640 7 : gfc_error ("Symbol %qs present on multiple clauses at %L",
9641 : n->sym->name, &n->where);
9642 : else
9643 1848 : n->sym->data_mark = 1;
9644 : }
9645 34777 : for (n = omp_clauses->lists[OMP_LIST_LASTPRIVATE]; n; n = n->next)
9646 2306 : n->sym->data_mark = 0;
9647 :
9648 34777 : for (n = omp_clauses->lists[OMP_LIST_LASTPRIVATE]; n; n = n->next)
9649 : {
9650 2306 : if (n->sym->data_mark || n->sym->gen_mark || n->sym->dev_mark)
9651 0 : gfc_error ("Symbol %qs present on multiple clauses at %L",
9652 : n->sym->name, &n->where);
9653 : else
9654 2306 : n->sym->data_mark = 1;
9655 : }
9656 :
9657 32621 : for (n = omp_clauses->lists[OMP_LIST_ALIGNED]; n; n = n->next)
9658 150 : n->sym->mark = 0;
9659 :
9660 32621 : for (n = omp_clauses->lists[OMP_LIST_ALIGNED]; n; n = n->next)
9661 : {
9662 150 : if (n->sym->mark)
9663 0 : gfc_error ("Symbol %qs present on multiple clauses at %L",
9664 : n->sym->name, &n->where);
9665 : else
9666 150 : n->sym->mark = 1;
9667 : }
9668 :
9669 32471 : if (omp_clauses->lists[OMP_LIST_ALLOCATE])
9670 : {
9671 791 : for (n = omp_clauses->lists[OMP_LIST_ALLOCATE]; n; n = n->next)
9672 : {
9673 513 : if (n->u2.allocator
9674 513 : && (!gfc_resolve_expr (n->u2.allocator)
9675 288 : || n->u2.allocator->ts.type != BT_INTEGER
9676 286 : || n->u2.allocator->rank != 0
9677 285 : || n->u2.allocator->ts.kind != gfc_c_intptr_kind))
9678 : {
9679 8 : gfc_error ("Expected integer expression of the "
9680 : "%<omp_allocator_handle_kind%> kind at %L",
9681 8 : &n->u2.allocator->where);
9682 28 : break;
9683 : }
9684 505 : if (!n->u.align)
9685 397 : continue;
9686 108 : HOST_WIDE_INT alignment = 0;
9687 108 : if (!gfc_resolve_expr (n->u.align)
9688 108 : || n->u.align->ts.type != BT_INTEGER
9689 105 : || n->u.align->rank != 0
9690 102 : || n->u.align->expr_type != EXPR_CONSTANT
9691 99 : || gfc_extract_hwi (n->u.align, &alignment)
9692 99 : || alignment <= 0
9693 207 : || !pow2p_hwi (alignment))
9694 : {
9695 12 : gfc_error ("ALIGN requires a scalar positive constant integer "
9696 : "alignment expression at %L that is a power of two",
9697 12 : &n->u.align->where);
9698 12 : break;
9699 : }
9700 : }
9701 :
9702 : /* Check for 2 things here.
9703 : 1. There is no duplication of variable in allocate clause.
9704 : 2. Variable in allocate clause are also present in some
9705 : privatization clase (non-composite case). */
9706 811 : for (n = omp_clauses->lists[OMP_LIST_ALLOCATE]; n; n = n->next)
9707 513 : if (n->sym)
9708 487 : n->sym->mark = 0;
9709 :
9710 : gfc_omp_namelist *prev = NULL;
9711 811 : for (n = omp_clauses->lists[OMP_LIST_ALLOCATE]; n; )
9712 : {
9713 513 : if (n->sym == NULL)
9714 : {
9715 26 : n = n->next;
9716 26 : continue;
9717 : }
9718 487 : if (n->sym->mark == 1)
9719 : {
9720 3 : gfc_warning (OPT_Wopenmp, "%qs appears more than once in "
9721 : "%<allocate%> at %L" , n->sym->name, &n->where);
9722 : /* We have already seen this variable so it is a duplicate.
9723 : Remove it. */
9724 3 : if (prev != NULL && prev->next == n)
9725 : {
9726 3 : prev->next = n->next;
9727 3 : n->next = NULL;
9728 3 : gfc_free_omp_namelist (n, OMP_LIST_ALLOCATE);
9729 3 : n = prev->next;
9730 : }
9731 3 : continue;
9732 : }
9733 484 : n->sym->mark = 1;
9734 484 : prev = n;
9735 484 : n = n->next;
9736 : }
9737 :
9738 : /* Non-composite constructs. */
9739 298 : if (code && code->op < EXEC_OMP_DO_SIMD)
9740 : {
9741 4760 : for (list = OMP_LIST_FIRST; list < OMP_LIST_NUM;
9742 4641 : list = gfc_omp_list_type (list + 1))
9743 4641 : switch (list)
9744 : {
9745 1071 : case OMP_LIST_PRIVATE:
9746 1071 : case OMP_LIST_FIRSTPRIVATE:
9747 1071 : case OMP_LIST_LASTPRIVATE:
9748 1071 : case OMP_LIST_REDUCTION:
9749 1071 : case OMP_LIST_REDUCTION_INSCAN:
9750 1071 : case OMP_LIST_REDUCTION_TASK:
9751 1071 : case OMP_LIST_IN_REDUCTION:
9752 1071 : case OMP_LIST_TASK_REDUCTION:
9753 1071 : case OMP_LIST_LINEAR:
9754 1370 : for (n = omp_clauses->lists[list]; n; n = n->next)
9755 299 : n->sym->mark = 0;
9756 : break;
9757 : default:
9758 : break;
9759 : }
9760 :
9761 410 : for (n = omp_clauses->lists[OMP_LIST_ALLOCATE]; n; n = n->next)
9762 291 : if (n->sym->mark == 1)
9763 4 : gfc_error ("%qs specified in %<allocate%> clause at %L but not "
9764 : "in an explicit privatization clause",
9765 : n->sym->name, &n->where);
9766 : }
9767 : if (code
9768 298 : && (code->op == EXEC_OMP_ALLOCATORS || code->op == EXEC_OMP_ALLOCATE)
9769 73 : && code->block
9770 72 : && code->block->next
9771 71 : && code->block->next->op == EXEC_ALLOCATE)
9772 : {
9773 68 : if (code->op == EXEC_OMP_ALLOCATE)
9774 49 : gfc_warning (OPT_Wdeprecated_openmp,
9775 : "The use of one or more %<allocate%> directives with "
9776 : "an associated %<allocate%> statement at %L is "
9777 : "deprecated since OpenMP 5.2, use an %<allocators%> "
9778 : "directive", &code->loc);
9779 68 : gfc_alloc *a;
9780 68 : gfc_omp_namelist *n_null = NULL;
9781 68 : bool missing_allocator = false;
9782 68 : gfc_symbol *missing_allocator_sym = NULL;
9783 161 : for (n = omp_clauses->lists[OMP_LIST_ALLOCATE]; n; n = n->next)
9784 : {
9785 93 : if (n->u2.allocator == NULL)
9786 : {
9787 77 : if (!missing_allocator_sym)
9788 59 : missing_allocator_sym = n->sym;
9789 : missing_allocator = true;
9790 : }
9791 93 : if (n->sym == NULL)
9792 : {
9793 26 : n_null = n;
9794 26 : continue;
9795 : }
9796 67 : if (n->sym->attr.codimension)
9797 2 : gfc_error ("Unexpected coarray %qs in %<allocate%> at %L",
9798 : n->sym->name, &n->where);
9799 103 : for (a = code->block->next->ext.alloc.list; a; a = a->next)
9800 101 : if (a->expr->expr_type == EXPR_VARIABLE
9801 101 : && a->expr->symtree->n.sym == n->sym)
9802 : {
9803 65 : gfc_ref *ref;
9804 82 : for (ref = a->expr->ref; ref; ref = ref->next)
9805 17 : if (ref->type == REF_COMPONENT)
9806 : break;
9807 : if (ref == NULL)
9808 : break;
9809 : }
9810 67 : if (a == NULL)
9811 2 : gfc_error ("%qs specified in %<allocate%> at %L but not "
9812 : "in the associated ALLOCATE statement",
9813 2 : n->sym->name, &n->where);
9814 : }
9815 : /* If there is an ALLOCATE directive without list argument, a
9816 : namelist with its allocator/align clauses and n->sym = NULL is
9817 : created during parsing; here, we add all not otherwise specified
9818 : items from the Fortran allocate to that list.
9819 : For an ALLOCATORS directive, not listed items use the normal
9820 : Fortran way.
9821 : The behavior of an ALLOCATE directive that does not list all
9822 : arguments but there is no directive without list argument is not
9823 : well specified. Thus, we reject such code below. In OpenMP 5.2
9824 : the executable ALLOCATE directive is deprecated and in 6.0
9825 : deleted such that no spec clarification is to be expected. */
9826 125 : for (a = code->block->next->ext.alloc.list; a; a = a->next)
9827 89 : if (a->expr->expr_type == EXPR_VARIABLE)
9828 : {
9829 154 : for (n = omp_clauses->lists[OMP_LIST_ALLOCATE]; n; n = n->next)
9830 122 : if (a->expr->symtree->n.sym == n->sym)
9831 : {
9832 57 : gfc_ref *ref;
9833 72 : for (ref = a->expr->ref; ref; ref = ref->next)
9834 15 : if (ref->type == REF_COMPONENT)
9835 : break;
9836 : if (ref == NULL)
9837 : break;
9838 : }
9839 89 : if (n == NULL && n_null == NULL)
9840 : {
9841 : /* OK for ALLOCATORS but for ALLOCATE: Unspecified whether
9842 : that should use the default allocator of OpenMP or the
9843 : Fortran allocator. Thus, just reject it. */
9844 7 : if (code->op == EXEC_OMP_ALLOCATE)
9845 1 : gfc_error ("%qs listed in %<allocate%> statement at %L "
9846 : "but it is neither explicitly in listed in "
9847 : "the %<!$OMP ALLOCATE%> directive nor exists"
9848 : " a directive without argument list",
9849 1 : a->expr->symtree->n.sym->name,
9850 : &a->expr->where);
9851 : break;
9852 : }
9853 82 : if (n == NULL)
9854 : {
9855 25 : if (a->expr->symtree->n.sym->attr.codimension)
9856 1 : gfc_error ("Unexpected coarray %qs in %<allocate%> at "
9857 : "%L, implicitly listed in %<!$OMP ALLOCATE%>"
9858 : " at %L", a->expr->symtree->n.sym->name,
9859 : &a->expr->where, &n_null->where);
9860 : break;
9861 : }
9862 : }
9863 68 : gfc_namespace *prog_unit = ns;
9864 87 : while (prog_unit->parent)
9865 : prog_unit = prog_unit->parent;
9866 : gfc_namespace *fn_ns = ns;
9867 72 : while (fn_ns)
9868 : {
9869 70 : if (ns->proc_name
9870 70 : && (ns->proc_name->attr.subroutine
9871 6 : || ns->proc_name->attr.function))
9872 : break;
9873 4 : fn_ns = fn_ns->parent;
9874 : }
9875 68 : if (missing_allocator
9876 58 : && !(prog_unit->omp_requires & OMP_REQ_DYNAMIC_ALLOCATORS)
9877 58 : && ((fn_ns && fn_ns->proc_name->attr.omp_declare_target)
9878 55 : || omp_clauses->contained_in_target_construct))
9879 : {
9880 6 : if (code->op == EXEC_OMP_ALLOCATORS)
9881 2 : gfc_error ("ALLOCATORS directive at %L inside a target region "
9882 : "must specify an ALLOCATOR modifier for %qs",
9883 : &code->loc, missing_allocator_sym->name);
9884 4 : else if (missing_allocator_sym)
9885 2 : gfc_error ("ALLOCATE directive at %L inside a target region "
9886 : "must specify an ALLOCATOR clause for %qs",
9887 : &code->loc, missing_allocator_sym->name);
9888 : else
9889 2 : gfc_error ("ALLOCATE directive at %L inside a target region "
9890 : "must specify an ALLOCATOR clause", &code->loc);
9891 : }
9892 :
9893 : }
9894 : }
9895 :
9896 : /* OpenACC reductions. */
9897 32471 : if (openacc)
9898 : {
9899 14761 : for (n = omp_clauses->lists[OMP_LIST_REDUCTION]; n; n = n->next)
9900 2136 : n->sym->mark = 0;
9901 :
9902 14761 : for (n = omp_clauses->lists[OMP_LIST_REDUCTION]; n; n = n->next)
9903 : {
9904 2136 : if (n->sym->mark)
9905 0 : gfc_error ("Symbol %qs present on multiple clauses at %L",
9906 : n->sym->name, &n->where);
9907 : else
9908 2136 : n->sym->mark = 1;
9909 :
9910 : /* OpenACC does not support reductions on arrays. */
9911 2136 : if (n->sym->as)
9912 71 : gfc_error ("Array %qs is not permitted in reduction at %L",
9913 : n->sym->name, &n->where);
9914 : }
9915 : }
9916 :
9917 33225 : for (n = omp_clauses->lists[OMP_LIST_TO]; n; n = n->next)
9918 754 : n->sym->mark = 0;
9919 33502 : for (n = omp_clauses->lists[OMP_LIST_FROM]; n; n = n->next)
9920 1031 : if (n->expr == NULL)
9921 1015 : n->sym->mark = 1;
9922 33225 : for (n = omp_clauses->lists[OMP_LIST_TO]; n; n = n->next)
9923 : {
9924 754 : if (n->expr == NULL && n->sym->mark)
9925 0 : gfc_error ("Symbol %qs present on both FROM and TO clauses at %L",
9926 : n->sym->name, &n->where);
9927 : else
9928 754 : n->sym->mark = 1;
9929 : }
9930 :
9931 : bool has_inscan = false, has_notinscan = false;
9932 1298840 : for (enum gfc_omp_list_type list = OMP_LIST_FIRST; list < OMP_LIST_NUM;
9933 1266369 : list = gfc_omp_list_type (list + 1))
9934 1266369 : if ((n = omp_clauses->lists[list]) != NULL)
9935 : {
9936 29155 : const char *name = clause_names[list];
9937 :
9938 29155 : switch (list)
9939 : {
9940 : case OMP_LIST_COPYIN:
9941 267 : for (; n != NULL; n = n->next)
9942 : {
9943 170 : if (!n->sym->attr.threadprivate)
9944 0 : gfc_error ("Non-THREADPRIVATE object %qs in COPYIN clause"
9945 : " at %L", n->sym->name, &n->where);
9946 : }
9947 : break;
9948 83 : case OMP_LIST_COPYPRIVATE:
9949 83 : if (omp_clauses->nowait)
9950 6 : gfc_error ("NOWAIT clause must not be used with COPYPRIVATE "
9951 : "clause at %L", &n->where);
9952 376 : for (; n != NULL; n = n->next)
9953 : {
9954 293 : if (n->sym->as && n->sym->as->type == AS_ASSUMED_SIZE)
9955 0 : gfc_error ("Assumed size array %qs in COPYPRIVATE clause "
9956 : "at %L", n->sym->name, &n->where);
9957 293 : if (n->sym->attr.pointer && n->sym->attr.intent == INTENT_IN)
9958 1 : gfc_error ("INTENT(IN) POINTER %qs in COPYPRIVATE clause "
9959 : "at %L", n->sym->name, &n->where);
9960 : }
9961 : break;
9962 : case OMP_LIST_SHARED:
9963 2604 : for (; n != NULL; n = n->next)
9964 : {
9965 1642 : if (n->sym->attr.threadprivate)
9966 0 : gfc_error ("THREADPRIVATE object %qs in SHARED clause at "
9967 : "%L", n->sym->name, &n->where);
9968 1642 : if (n->sym->attr.cray_pointee)
9969 1 : gfc_error ("Cray pointee %qs in SHARED clause at %L",
9970 : n->sym->name, &n->where);
9971 1642 : if (n->sym->attr.associate_var)
9972 8 : gfc_error ("Associate name %qs in SHARED clause at %L",
9973 8 : n->sym->attr.select_type_temporary
9974 4 : ? n->sym->assoc->target->symtree->n.sym->name
9975 : : n->sym->name, &n->where);
9976 1642 : if (omp_clauses->detach
9977 1 : && n->sym == omp_clauses->detach->symtree->n.sym)
9978 1 : gfc_error ("DETACH event handle %qs in SHARED clause at %L",
9979 : n->sym->name, &n->where);
9980 : }
9981 : break;
9982 : case OMP_LIST_ALIGNED:
9983 256 : for (; n != NULL; n = n->next)
9984 : {
9985 150 : if (!n->sym->attr.pointer
9986 45 : && !n->sym->attr.allocatable
9987 30 : && !n->sym->attr.cray_pointer
9988 18 : && (n->sym->ts.type != BT_DERIVED
9989 18 : || (n->sym->ts.u.derived->from_intmod
9990 : != INTMOD_ISO_C_BINDING)
9991 18 : || (n->sym->ts.u.derived->intmod_sym_id
9992 : != ISOCBINDING_PTR)))
9993 0 : gfc_error ("%qs in ALIGNED clause must be POINTER, "
9994 : "ALLOCATABLE, Cray pointer or C_PTR at %L",
9995 : n->sym->name, &n->where);
9996 150 : else if (n->expr)
9997 : {
9998 147 : if (!gfc_resolve_expr (n->expr)
9999 147 : || n->expr->ts.type != BT_INTEGER
10000 146 : || n->expr->rank != 0
10001 146 : || n->expr->expr_type != EXPR_CONSTANT
10002 292 : || mpz_sgn (n->expr->value.integer) <= 0)
10003 4 : gfc_error ("%qs in ALIGNED clause at %L requires a scalar"
10004 : " positive constant integer alignment "
10005 4 : "expression", n->sym->name, &n->where);
10006 : }
10007 : }
10008 : break;
10009 : case OMP_LIST_AFFINITY:
10010 : case OMP_LIST_DEPEND:
10011 : case OMP_LIST_MAP:
10012 : case OMP_LIST_TO:
10013 : case OMP_LIST_FROM:
10014 : case OMP_LIST_CACHE:
10015 32966 : for (; n != NULL; n = n->next)
10016 : {
10017 20805 : if ((list == OMP_LIST_DEPEND || list == OMP_LIST_AFFINITY)
10018 1998 : && n->u2.ns && !n->u2.ns->resolved)
10019 : {
10020 56 : n->u2.ns->resolved = 1;
10021 56 : for (gfc_symbol *sym = n->u2.ns->omp_affinity_iterators;
10022 116 : sym; sym = sym->tlink)
10023 : {
10024 60 : gfc_constructor *c;
10025 60 : c = gfc_constructor_first (sym->value->value.constructor);
10026 60 : if (!gfc_resolve_expr (c->expr)
10027 60 : || c->expr->ts.type != BT_INTEGER
10028 118 : || c->expr->rank != 0)
10029 2 : gfc_error ("Scalar integer expression for range begin"
10030 2 : " expected at %L", &c->expr->where);
10031 60 : c = gfc_constructor_next (c);
10032 60 : if (!gfc_resolve_expr (c->expr)
10033 60 : || c->expr->ts.type != BT_INTEGER
10034 118 : || c->expr->rank != 0)
10035 2 : gfc_error ("Scalar integer expression for range end "
10036 2 : "expected at %L", &c->expr->where);
10037 60 : c = gfc_constructor_next (c);
10038 60 : if (c && (!gfc_resolve_expr (c->expr)
10039 16 : || c->expr->ts.type != BT_INTEGER
10040 14 : || c->expr->rank != 0))
10041 2 : gfc_error ("Scalar integer expression for range step "
10042 2 : "expected at %L", &c->expr->where);
10043 58 : else if (c
10044 14 : && c->expr->expr_type == EXPR_CONSTANT
10045 12 : && mpz_cmp_si (c->expr->value.integer, 0) == 0)
10046 2 : gfc_error ("Nonzero range step expected at %L",
10047 : &c->expr->where);
10048 : }
10049 : }
10050 :
10051 1998 : if (list == OMP_LIST_DEPEND)
10052 : {
10053 3196 : if (n->u.depend_doacross_op == OMP_DEPEND_SINK_FIRST
10054 : || n->u.depend_doacross_op == OMP_DOACROSS_SINK_FIRST
10055 1963 : || n->u.depend_doacross_op == OMP_DOACROSS_SINK)
10056 : {
10057 1233 : if (omp_clauses->doacross_source)
10058 : {
10059 0 : gfc_error ("Dependence-type SINK used together with"
10060 : " SOURCE on the same construct at %L",
10061 : &n->where);
10062 0 : omp_clauses->doacross_source = false;
10063 : }
10064 1233 : else if (n->expr)
10065 : {
10066 571 : if (!gfc_resolve_expr (n->expr)
10067 571 : || n->expr->ts.type != BT_INTEGER
10068 1142 : || n->expr->rank != 0)
10069 0 : gfc_error ("SINK addend not a constant integer "
10070 : "at %L", &n->where);
10071 : }
10072 1233 : if (n->sym == NULL
10073 4 : && (n->expr == NULL
10074 3 : || mpz_cmp_si (n->expr->value.integer, -1) != 0))
10075 2 : gfc_error ("omp_cur_iteration at %L requires %<-1%> "
10076 : "as logical offset", &n->where);
10077 1233 : continue;
10078 : }
10079 730 : else if (n->u.depend_doacross_op == OMP_DEPEND_DEPOBJ
10080 38 : && !n->expr
10081 22 : && (n->sym->ts.type != BT_INTEGER
10082 22 : || n->sym->ts.kind
10083 22 : != 2 * gfc_index_integer_kind
10084 22 : || n->sym->attr.dimension))
10085 0 : gfc_error ("Locator %qs at %L in DEPEND clause of depobj "
10086 : "type shall be a scalar integer of "
10087 : "OMP_DEPEND_KIND kind", n->sym->name,
10088 : &n->where);
10089 730 : else if (n->u.depend_doacross_op == OMP_DEPEND_DEPOBJ
10090 38 : && n->expr
10091 746 : && (!gfc_resolve_expr (n->expr)
10092 16 : || n->expr->ts.type != BT_INTEGER
10093 16 : || n->expr->ts.kind
10094 16 : != 2 * gfc_index_integer_kind
10095 16 : || n->expr->rank != 0))
10096 0 : gfc_error ("Locator at %L in DEPEND clause of depobj "
10097 : "type shall be a scalar integer of "
10098 0 : "OMP_DEPEND_KIND kind", &n->expr->where);
10099 : }
10100 19572 : gfc_ref *lastref = NULL, *lastslice = NULL;
10101 19572 : bool resolved = false;
10102 19572 : if (n->expr)
10103 : {
10104 6462 : lastref = n->expr->ref;
10105 6462 : resolved = gfc_resolve_expr (n->expr);
10106 :
10107 : /* Look through component refs to find last array
10108 : reference. */
10109 6462 : if (resolved)
10110 : {
10111 16305 : for (gfc_ref *ref = n->expr->ref; ref; ref = ref->next)
10112 9861 : if (ref->type == REF_COMPONENT
10113 : || ref->type == REF_SUBSTRING
10114 9861 : || ref->type == REF_INQUIRY)
10115 : lastref = ref;
10116 6678 : else if (ref->type == REF_ARRAY)
10117 : {
10118 14046 : for (int i = 0; i < ref->u.ar.dimen; i++)
10119 7368 : if (ref->u.ar.dimen_type[i] == DIMEN_RANGE)
10120 6214 : lastslice = ref;
10121 :
10122 : lastref = ref;
10123 : }
10124 :
10125 : /* The "!$acc cache" directive allows rectangular
10126 : subarrays to be specified, with some restrictions
10127 : on the form of bounds (not implemented).
10128 : Only raise an error here if we're really sure the
10129 : array isn't contiguous. An expression such as
10130 : arr(-n:n,-n:n) could be contiguous even if it looks
10131 : like it may not be. */
10132 6444 : if (code
10133 6443 : && code->op != EXEC_OACC_UPDATE
10134 5661 : && list != OMP_LIST_CACHE
10135 5661 : && list != OMP_LIST_DEPEND
10136 5339 : && !gfc_is_simply_contiguous (n->expr, false, true)
10137 1467 : && gfc_is_not_contiguous (n->expr)
10138 6457 : && !(lastslice
10139 13 : && (lastslice->next
10140 3 : || lastslice->type != REF_ARRAY)))
10141 3 : gfc_error ("Array is not contiguous at %L",
10142 : &n->where);
10143 : }
10144 : }
10145 19572 : if (list == OMP_LIST_MAP
10146 16921 : && (n->sym->attr.omp_groupprivate
10147 16920 : || n->sym->attr.omp_declare_target_local))
10148 2 : gfc_error ("%qs argument to MAP clause at %L must not be a "
10149 : "device-local variable, including GROUPPRIVATE",
10150 : n->sym->name, &n->where);
10151 19572 : if (openacc
10152 19572 : && list == OMP_LIST_MAP
10153 9571 : && (n->u.map.op == OMP_MAP_ATTACH
10154 9501 : || n->u.map.op == OMP_MAP_DETACH))
10155 : {
10156 117 : symbol_attribute attr;
10157 117 : if (n->expr)
10158 99 : attr = gfc_expr_attr (n->expr);
10159 : else
10160 18 : attr = n->sym->attr;
10161 117 : if (!attr.pointer && !attr.allocatable)
10162 7 : gfc_error ("%qs clause argument must be ALLOCATABLE or "
10163 : "a POINTER at %L",
10164 7 : (n->u.map.op == OMP_MAP_ATTACH) ? "attach"
10165 : : "detach", &n->where);
10166 : }
10167 19572 : if (lastref
10168 13122 : || (n->expr
10169 12 : && (!resolved || n->expr->expr_type != EXPR_VARIABLE)))
10170 : {
10171 6462 : if (!lastslice
10172 6462 : && lastref
10173 898 : && lastref->type == REF_SUBSTRING)
10174 11 : gfc_error ("Unexpected substring reference in %s clause "
10175 : "at %L", name, &n->where);
10176 6451 : else if (!lastslice
10177 : && lastref
10178 887 : && lastref->type == REF_INQUIRY)
10179 : {
10180 12 : gcc_assert (lastref->u.i == INQUIRY_RE
10181 : || lastref->u.i == INQUIRY_IM);
10182 12 : gfc_error ("Unexpected complex-parts designator "
10183 : "reference in %s clause at %L",
10184 : name, &n->where);
10185 : }
10186 6439 : else if (!resolved
10187 6421 : || n->expr->expr_type != EXPR_VARIABLE
10188 6409 : || (lastslice
10189 5552 : && (lastslice->next
10190 5536 : || lastslice->type != REF_ARRAY)))
10191 46 : gfc_error ("%qs in %s clause at %L is not a proper "
10192 46 : "array section", n->sym->name, name,
10193 : &n->where);
10194 : else if (lastslice)
10195 : {
10196 : int i;
10197 : gfc_array_ref *ar = &lastslice->u.ar;
10198 11747 : for (i = 0; i < ar->dimen; i++)
10199 6212 : if (ar->stride[i] && code->op != EXEC_OACC_UPDATE)
10200 : {
10201 1 : gfc_error ("Stride should not be specified for "
10202 : "array section in %s clause at %L",
10203 : name, &n->where);
10204 1 : break;
10205 : }
10206 6211 : else if (ar->dimen_type[i] != DIMEN_ELEMENT
10207 6211 : && ar->dimen_type[i] != DIMEN_RANGE)
10208 : {
10209 0 : gfc_error ("%qs in %s clause at %L is not a "
10210 : "proper array section",
10211 0 : n->sym->name, name, &n->where);
10212 0 : break;
10213 : }
10214 6211 : else if ((list == OMP_LIST_DEPEND
10215 : || list == OMP_LIST_AFFINITY)
10216 161 : && ar->start[i]
10217 133 : && ar->start[i]->expr_type == EXPR_CONSTANT
10218 97 : && ar->end[i]
10219 72 : && ar->end[i]->expr_type == EXPR_CONSTANT
10220 72 : && mpz_cmp (ar->start[i]->value.integer,
10221 72 : ar->end[i]->value.integer) > 0)
10222 : {
10223 0 : gfc_error ("%qs in %s clause at %L is a "
10224 : "zero size array section",
10225 0 : n->sym->name,
10226 : list == OMP_LIST_DEPEND
10227 : ? "DEPEND" : "AFFINITY", &n->where);
10228 0 : break;
10229 : }
10230 : }
10231 : }
10232 13110 : else if (openacc)
10233 : {
10234 5915 : if (list == OMP_LIST_MAP
10235 5900 : && n->u.map.op == OMP_MAP_FORCE_DEVICEPTR)
10236 65 : resolve_oacc_deviceptr_clause (n->sym, n->where, name);
10237 : else
10238 5850 : resolve_oacc_data_clauses (n->sym, n->where, name);
10239 : }
10240 7195 : else if (list != OMP_LIST_DEPEND
10241 6702 : && n->sym->as
10242 3331 : && n->sym->as->type == AS_ASSUMED_SIZE)
10243 5 : gfc_error ("Assumed size array %qs in %s clause at %L",
10244 : n->sym->name, name, &n->where);
10245 19572 : if (code && list == OMP_LIST_MAP && !openacc)
10246 7343 : switch (code->op)
10247 : {
10248 6085 : case EXEC_OMP_TARGET:
10249 6085 : case EXEC_OMP_TARGET_PARALLEL:
10250 6085 : case EXEC_OMP_TARGET_PARALLEL_DO:
10251 6085 : case EXEC_OMP_TARGET_PARALLEL_DO_SIMD:
10252 6085 : case EXEC_OMP_TARGET_PARALLEL_LOOP:
10253 6085 : case EXEC_OMP_TARGET_SIMD:
10254 6085 : case EXEC_OMP_TARGET_TEAMS:
10255 6085 : case EXEC_OMP_TARGET_TEAMS_DISTRIBUTE:
10256 6085 : case EXEC_OMP_TARGET_TEAMS_DISTRIBUTE_PARALLEL_DO:
10257 6085 : case EXEC_OMP_TARGET_TEAMS_DISTRIBUTE_PARALLEL_DO_SIMD:
10258 6085 : case EXEC_OMP_TARGET_TEAMS_DISTRIBUTE_SIMD:
10259 6085 : case EXEC_OMP_TARGET_TEAMS_LOOP:
10260 6085 : case EXEC_OMP_TARGET_DATA:
10261 6085 : switch (n->u.map.op)
10262 : {
10263 : case OMP_MAP_TO:
10264 : case OMP_MAP_ALWAYS_TO:
10265 : case OMP_MAP_PRESENT_TO:
10266 : case OMP_MAP_ALWAYS_PRESENT_TO:
10267 : case OMP_MAP_FROM:
10268 : case OMP_MAP_ALWAYS_FROM:
10269 : case OMP_MAP_PRESENT_FROM:
10270 : case OMP_MAP_ALWAYS_PRESENT_FROM:
10271 : case OMP_MAP_TOFROM:
10272 : case OMP_MAP_ALWAYS_TOFROM:
10273 : case OMP_MAP_PRESENT_TOFROM:
10274 : case OMP_MAP_ALWAYS_PRESENT_TOFROM:
10275 : case OMP_MAP_ALLOC:
10276 : case OMP_MAP_PRESENT_ALLOC:
10277 : break;
10278 2 : default:
10279 2 : gfc_error ("TARGET%s with map-type other than TO, "
10280 : "FROM, TOFROM, or ALLOC on MAP clause "
10281 : "at %L",
10282 : code->op == EXEC_OMP_TARGET_DATA
10283 : ? " DATA" : "", &n->where);
10284 2 : break;
10285 : }
10286 : break;
10287 681 : case EXEC_OMP_TARGET_ENTER_DATA:
10288 681 : switch (n->u.map.op)
10289 : {
10290 : case OMP_MAP_TO:
10291 : case OMP_MAP_ALWAYS_TO:
10292 : case OMP_MAP_PRESENT_TO:
10293 : case OMP_MAP_ALWAYS_PRESENT_TO:
10294 : case OMP_MAP_ALLOC:
10295 : case OMP_MAP_PRESENT_ALLOC:
10296 : break;
10297 177 : case OMP_MAP_TOFROM:
10298 177 : n->u.map.op = OMP_MAP_TO;
10299 177 : break;
10300 3 : case OMP_MAP_ALWAYS_TOFROM:
10301 3 : n->u.map.op = OMP_MAP_ALWAYS_TO;
10302 3 : break;
10303 2 : case OMP_MAP_PRESENT_TOFROM:
10304 2 : n->u.map.op = OMP_MAP_PRESENT_TO;
10305 2 : break;
10306 2 : case OMP_MAP_ALWAYS_PRESENT_TOFROM:
10307 2 : n->u.map.op = OMP_MAP_ALWAYS_PRESENT_TO;
10308 2 : break;
10309 2 : default:
10310 2 : gfc_error ("TARGET ENTER DATA with map-type other "
10311 : "than TO, TOFROM or ALLOC on MAP clause "
10312 : "at %L", &n->where);
10313 2 : break;
10314 : }
10315 : break;
10316 577 : case EXEC_OMP_TARGET_EXIT_DATA:
10317 577 : switch (n->u.map.op)
10318 : {
10319 : case OMP_MAP_FROM:
10320 : case OMP_MAP_ALWAYS_FROM:
10321 : case OMP_MAP_PRESENT_FROM:
10322 : case OMP_MAP_ALWAYS_PRESENT_FROM:
10323 : case OMP_MAP_RELEASE:
10324 : case OMP_MAP_DELETE:
10325 : break;
10326 132 : case OMP_MAP_TOFROM:
10327 132 : n->u.map.op = OMP_MAP_FROM;
10328 132 : break;
10329 1 : case OMP_MAP_ALWAYS_TOFROM:
10330 1 : n->u.map.op = OMP_MAP_ALWAYS_FROM;
10331 1 : break;
10332 0 : case OMP_MAP_PRESENT_TOFROM:
10333 0 : n->u.map.op = OMP_MAP_PRESENT_FROM;
10334 0 : break;
10335 0 : case OMP_MAP_ALWAYS_PRESENT_TOFROM:
10336 0 : n->u.map.op = OMP_MAP_ALWAYS_PRESENT_FROM;
10337 0 : break;
10338 2 : default:
10339 2 : gfc_error ("TARGET EXIT DATA with map-type other "
10340 : "than FROM, TOFROM, RELEASE, or DELETE on "
10341 : "MAP clause at %L", &n->where);
10342 2 : break;
10343 : }
10344 : break;
10345 : default:
10346 : break;
10347 : }
10348 : }
10349 :
10350 12161 : if (list != OMP_LIST_DEPEND)
10351 30156 : for (n = omp_clauses->lists[list]; n != NULL; n = n->next)
10352 : {
10353 18842 : n->sym->attr.referenced = 1;
10354 18842 : if (n->sym->attr.threadprivate)
10355 1 : gfc_error ("THREADPRIVATE object %qs in %s clause at %L",
10356 : n->sym->name, name, &n->where);
10357 18842 : if (n->sym->attr.cray_pointee)
10358 14 : gfc_error ("Cray pointee %qs in %s clause at %L",
10359 : n->sym->name, name, &n->where);
10360 : }
10361 : break;
10362 : case OMP_LIST_IS_DEVICE_PTR:
10363 : last = NULL;
10364 377 : for (n = omp_clauses->lists[list]; n != NULL; )
10365 : {
10366 257 : if ((n->sym->ts.type != BT_DERIVED
10367 71 : || !n->sym->ts.u.derived->ts.is_iso_c
10368 71 : || (n->sym->ts.u.derived->intmod_sym_id
10369 : != ISOCBINDING_PTR))
10370 187 : && code->op == EXEC_OMP_DISPATCH)
10371 : /* Non-TARGET (i.e. DISPATCH) requires a C_PTR. */
10372 3 : gfc_error ("List item %qs in %s clause at %L must be of "
10373 : "TYPE(C_PTR)", n->sym->name, name, &n->where);
10374 254 : else if (n->sym->ts.type != BT_DERIVED
10375 70 : || !n->sym->ts.u.derived->ts.is_iso_c
10376 70 : || (n->sym->ts.u.derived->intmod_sym_id
10377 : != ISOCBINDING_PTR))
10378 : {
10379 : /* For TARGET, non-C_PTR are deprecated and handled as
10380 : has_device_addr. */
10381 184 : gfc_warning (OPT_Wdeprecated_openmp,
10382 : "Non-C_PTR type argument at %L is deprecated, "
10383 : "use HAS_DEVICE_ADDR", &n->where);
10384 184 : gfc_omp_namelist *n2 = n;
10385 184 : n = n->next;
10386 184 : if (last)
10387 0 : last->next = n;
10388 : else
10389 184 : omp_clauses->lists[list] = n;
10390 184 : n2->next = omp_clauses->lists[OMP_LIST_HAS_DEVICE_ADDR];
10391 184 : omp_clauses->lists[OMP_LIST_HAS_DEVICE_ADDR] = n2;
10392 184 : continue;
10393 184 : }
10394 73 : last = n;
10395 73 : n = n->next;
10396 : }
10397 : break;
10398 : case OMP_LIST_HAS_DEVICE_ADDR:
10399 : case OMP_LIST_USE_DEVICE_ADDR:
10400 : break;
10401 : case OMP_LIST_USE_DEVICE_PTR:
10402 : /* Non-C_PTR are deprecated and handled as use_device_ADDR. */
10403 : last = NULL;
10404 475 : for (n = omp_clauses->lists[list]; n != NULL; )
10405 : {
10406 312 : gfc_omp_namelist *n2 = n;
10407 312 : if (n->sym->ts.type != BT_DERIVED
10408 18 : || !n->sym->ts.u.derived->ts.is_iso_c)
10409 : {
10410 294 : gfc_warning (OPT_Wdeprecated_openmp,
10411 : "Non-C_PTR type argument at %L is "
10412 : "deprecated, use USE_DEVICE_ADDR", &n->where);
10413 294 : n = n->next;
10414 294 : if (last)
10415 0 : last->next = n;
10416 : else
10417 294 : omp_clauses->lists[list] = n;
10418 294 : n2->next = omp_clauses->lists[OMP_LIST_USE_DEVICE_ADDR];
10419 294 : omp_clauses->lists[OMP_LIST_USE_DEVICE_ADDR] = n2;
10420 294 : continue;
10421 : }
10422 18 : last = n;
10423 18 : n = n->next;
10424 : }
10425 : break;
10426 48 : case OMP_LIST_USES_ALLOCATORS:
10427 48 : {
10428 48 : if (n != NULL
10429 48 : && n->u.memspace_sym
10430 14 : && (n->u.memspace_sym->attr.flavor != FL_PARAMETER
10431 13 : || n->u.memspace_sym->ts.type != BT_INTEGER
10432 13 : || n->u.memspace_sym->ts.kind != gfc_c_intptr_kind
10433 13 : || n->u.memspace_sym->attr.dimension
10434 13 : || (!startswith (n->u.memspace_sym->name, "omp_")
10435 0 : && !startswith (n->u.memspace_sym->name, "ompx_"))
10436 13 : || !endswith (n->u.memspace_sym->name, "_mem_space")))
10437 2 : gfc_error ("Memspace %qs at %L in USES_ALLOCATORS must be "
10438 : "a predefined memory space",
10439 : n->u.memspace_sym->name, &n->where);
10440 144 : for (; n != NULL; n = n->next)
10441 : {
10442 102 : if (n->sym->ts.type != BT_INTEGER
10443 102 : || n->sym->ts.kind != gfc_c_intptr_kind
10444 101 : || n->sym->attr.dimension)
10445 2 : gfc_error ("Allocator %qs at %L in USES_ALLOCATORS must "
10446 : "be a scalar integer of kind "
10447 : "%<omp_allocator_handle_kind%>", n->sym->name,
10448 : &n->where);
10449 100 : else if (n->sym->attr.flavor != FL_VARIABLE
10450 47 : && strcmp (n->sym->name, "omp_null_allocator") != 0
10451 144 : && ((!startswith (n->sym->name, "omp_")
10452 1 : && !startswith (n->sym->name, "ompx_"))
10453 43 : || !endswith (n->sym->name, "_mem_alloc")))
10454 2 : gfc_error ("Allocator %qs at %L in USES_ALLOCATORS must "
10455 : "either a variable or a predefined allocator",
10456 : n->sym->name, &n->where);
10457 98 : else if ((n->u.memspace_sym || n->u2.traits_sym)
10458 47 : && n->sym->attr.flavor != FL_VARIABLE)
10459 3 : gfc_error ("A memory space or traits array may not be "
10460 : "specified for predefined allocator %qs at %L",
10461 : n->sym->name, &n->where);
10462 102 : if (n->u2.traits_sym
10463 41 : && (n->u2.traits_sym->attr.flavor != FL_PARAMETER
10464 39 : || !n->u2.traits_sym->attr.dimension
10465 37 : || n->u2.traits_sym->as->rank != 1
10466 37 : || n->u2.traits_sym->ts.type != BT_DERIVED
10467 35 : || strcmp (n->u2.traits_sym->ts.u.derived->name,
10468 : "omp_alloctrait") != 0))
10469 : {
10470 6 : gfc_error ("Traits array %qs in USES_ALLOCATORS %L must "
10471 : "be a one-dimensional named constant array of "
10472 : "type %<omp_alloctrait%>",
10473 : n->u2.traits_sym->name, &n->where);
10474 6 : break;
10475 : }
10476 : }
10477 : break;
10478 : }
10479 : default:
10480 34670 : for (; n != NULL; n = n->next)
10481 : {
10482 20309 : if (n->sym == NULL)
10483 : {
10484 26 : gcc_assert (code->op == EXEC_OMP_ALLOCATORS
10485 : || code->op == EXEC_OMP_ALLOCATE);
10486 26 : continue;
10487 : }
10488 20283 : bool bad = false;
10489 20283 : bool is_reduction = (list == OMP_LIST_REDUCTION
10490 : || list == OMP_LIST_REDUCTION_INSCAN
10491 : || list == OMP_LIST_REDUCTION_TASK
10492 : || list == OMP_LIST_IN_REDUCTION
10493 20283 : || list == OMP_LIST_TASK_REDUCTION);
10494 20283 : if (list == OMP_LIST_REDUCTION_INSCAN)
10495 : has_inscan = true;
10496 20211 : else if (is_reduction)
10497 4734 : has_notinscan = true;
10498 20283 : if (has_inscan && has_notinscan && is_reduction)
10499 : {
10500 3 : gfc_error ("%<inscan%> and non-%<inscan%> %<reduction%> "
10501 : "clauses on the same construct at %L",
10502 : &n->where);
10503 3 : break;
10504 : }
10505 20280 : if (n->sym->attr.threadprivate)
10506 1 : gfc_error ("THREADPRIVATE object %qs in %s clause at %L",
10507 : n->sym->name, name, &n->where);
10508 20280 : if (n->sym->attr.cray_pointee)
10509 14 : gfc_error ("Cray pointee %qs in %s clause at %L",
10510 : n->sym->name, name, &n->where);
10511 20280 : if (n->sym->attr.associate_var)
10512 22 : gfc_error ("Associate name %qs in %s clause at %L",
10513 22 : n->sym->attr.select_type_temporary
10514 4 : ? n->sym->assoc->target->symtree->n.sym->name
10515 : : n->sym->name, name, &n->where);
10516 20280 : if (list != OMP_LIST_PRIVATE && is_reduction)
10517 : {
10518 4803 : if (n->sym->attr.proc_pointer)
10519 1 : gfc_error ("Procedure pointer %qs in %s clause at %L",
10520 : n->sym->name, name, &n->where);
10521 4803 : if (n->sym->attr.pointer)
10522 3 : gfc_error ("POINTER object %qs in %s clause at %L",
10523 : n->sym->name, name, &n->where);
10524 4803 : if (n->sym->attr.cray_pointer)
10525 5 : gfc_error ("Cray pointer %qs in %s clause at %L",
10526 : n->sym->name, name, &n->where);
10527 : }
10528 20280 : if (code
10529 20280 : && (oacc_is_loop (code)
10530 : || code->op == EXEC_OACC_PARALLEL
10531 : || code->op == EXEC_OACC_SERIAL))
10532 8741 : check_array_not_assumed (n->sym, n->where, name);
10533 11539 : else if (list != OMP_LIST_UNIFORM
10534 11422 : && n->sym->as && n->sym->as->type == AS_ASSUMED_SIZE)
10535 2 : gfc_error ("Assumed size array %qs in %s clause at %L",
10536 : n->sym->name, name, &n->where);
10537 20280 : if (n->sym->attr.in_namelist && !is_reduction)
10538 0 : gfc_error ("Variable %qs in %s clause is used in "
10539 : "NAMELIST statement at %L",
10540 : n->sym->name, name, &n->where);
10541 20280 : if (n->sym->attr.pointer && n->sym->attr.intent == INTENT_IN)
10542 3 : switch (list)
10543 : {
10544 3 : case OMP_LIST_PRIVATE:
10545 3 : case OMP_LIST_LASTPRIVATE:
10546 3 : case OMP_LIST_LINEAR:
10547 : /* case OMP_LIST_REDUCTION: */
10548 3 : gfc_error ("INTENT(IN) POINTER %qs in %s clause at %L",
10549 : n->sym->name, name, &n->where);
10550 3 : break;
10551 : default:
10552 : break;
10553 : }
10554 20280 : if (omp_clauses->detach
10555 3 : && (list == OMP_LIST_PRIVATE
10556 : || list == OMP_LIST_FIRSTPRIVATE
10557 : || list == OMP_LIST_LASTPRIVATE)
10558 3 : && n->sym == omp_clauses->detach->symtree->n.sym)
10559 1 : gfc_error ("DETACH event handle %qs in %s clause at %L",
10560 : n->sym->name, name, &n->where);
10561 :
10562 20280 : if (!openacc
10563 20280 : && (list == OMP_LIST_PRIVATE
10564 20280 : || list == OMP_LIST_FIRSTPRIVATE)
10565 4640 : && ((n->sym->ts.type == BT_DERIVED
10566 158 : && n->sym->ts.u.derived->attr.alloc_comp)
10567 4530 : || n->sym->ts.type == BT_CLASS))
10568 170 : switch (code->op)
10569 : {
10570 8 : case EXEC_OMP_TARGET:
10571 8 : case EXEC_OMP_TARGET_PARALLEL:
10572 8 : case EXEC_OMP_TARGET_PARALLEL_DO:
10573 8 : case EXEC_OMP_TARGET_PARALLEL_DO_SIMD:
10574 8 : case EXEC_OMP_TARGET_PARALLEL_LOOP:
10575 8 : case EXEC_OMP_TARGET_SIMD:
10576 8 : case EXEC_OMP_TARGET_TEAMS:
10577 8 : case EXEC_OMP_TARGET_TEAMS_DISTRIBUTE:
10578 8 : case EXEC_OMP_TARGET_TEAMS_DISTRIBUTE_PARALLEL_DO:
10579 8 : case EXEC_OMP_TARGET_TEAMS_DISTRIBUTE_PARALLEL_DO_SIMD:
10580 8 : case EXEC_OMP_TARGET_TEAMS_DISTRIBUTE_SIMD:
10581 8 : case EXEC_OMP_TARGET_TEAMS_LOOP:
10582 8 : if (n->sym->ts.type == BT_DERIVED
10583 2 : && n->sym->ts.u.derived->attr.alloc_comp)
10584 3 : gfc_error ("Sorry, list item %qs at %L with allocatable"
10585 : " components is not yet supported in %s "
10586 : "clause", n->sym->name, &n->where,
10587 : list == OMP_LIST_PRIVATE ? "PRIVATE"
10588 : : "FIRSTPRIVATE");
10589 : else
10590 9 : gfc_error ("Polymorphic list item %qs at %L in %s "
10591 : "clause has unspecified behavior and "
10592 : "unsupported", n->sym->name, &n->where,
10593 : list == OMP_LIST_PRIVATE ? "PRIVATE"
10594 : : "FIRSTPRIVATE");
10595 : break;
10596 : default:
10597 : break;
10598 : }
10599 :
10600 20280 : switch (list)
10601 : {
10602 104 : case OMP_LIST_REDUCTION_TASK:
10603 104 : if (code
10604 104 : && (code->op == EXEC_OMP_LOOP
10605 : || code->op == EXEC_OMP_TASKLOOP
10606 : || code->op == EXEC_OMP_TASKLOOP_SIMD
10607 : || code->op == EXEC_OMP_MASKED_TASKLOOP
10608 : || code->op == EXEC_OMP_MASKED_TASKLOOP_SIMD
10609 : || code->op == EXEC_OMP_MASTER_TASKLOOP
10610 : || code->op == EXEC_OMP_MASTER_TASKLOOP_SIMD
10611 : || code->op == EXEC_OMP_PARALLEL_LOOP
10612 : || code->op == EXEC_OMP_PARALLEL_MASKED_TASKLOOP
10613 : || code->op == EXEC_OMP_PARALLEL_MASKED_TASKLOOP_SIMD
10614 : || code->op == EXEC_OMP_PARALLEL_MASTER_TASKLOOP
10615 : || code->op == EXEC_OMP_PARALLEL_MASTER_TASKLOOP_SIMD
10616 : || code->op == EXEC_OMP_TARGET_PARALLEL_LOOP
10617 : || code->op == EXEC_OMP_TARGET_TEAMS_LOOP
10618 : || code->op == EXEC_OMP_TEAMS
10619 : || code->op == EXEC_OMP_TEAMS_DISTRIBUTE
10620 : || code->op == EXEC_OMP_TEAMS_LOOP))
10621 : {
10622 17 : gfc_error ("Only DEFAULT permitted as reduction-"
10623 : "modifier in REDUCTION clause at %L",
10624 : &n->where);
10625 17 : break;
10626 : }
10627 4786 : gcc_fallthrough ();
10628 4786 : case OMP_LIST_REDUCTION:
10629 4786 : case OMP_LIST_IN_REDUCTION:
10630 4786 : case OMP_LIST_TASK_REDUCTION:
10631 4786 : case OMP_LIST_REDUCTION_INSCAN:
10632 4786 : switch (n->u.reduction_op)
10633 : {
10634 2652 : case OMP_REDUCTION_PLUS:
10635 2652 : case OMP_REDUCTION_TIMES:
10636 2652 : case OMP_REDUCTION_MINUS:
10637 2652 : if (!gfc_numeric_ts (&n->sym->ts))
10638 : bad = true;
10639 : break;
10640 1112 : case OMP_REDUCTION_AND:
10641 1112 : case OMP_REDUCTION_OR:
10642 1112 : case OMP_REDUCTION_EQV:
10643 1112 : case OMP_REDUCTION_NEQV:
10644 1112 : if (n->sym->ts.type != BT_LOGICAL)
10645 : bad = true;
10646 : break;
10647 480 : case OMP_REDUCTION_MAX:
10648 480 : case OMP_REDUCTION_MIN:
10649 480 : if (n->sym->ts.type != BT_INTEGER
10650 212 : && n->sym->ts.type != BT_REAL)
10651 : bad = true;
10652 : break;
10653 192 : case OMP_REDUCTION_IAND:
10654 192 : case OMP_REDUCTION_IOR:
10655 192 : case OMP_REDUCTION_IEOR:
10656 192 : if (n->sym->ts.type != BT_INTEGER)
10657 : bad = true;
10658 : break;
10659 : case OMP_REDUCTION_USER:
10660 : bad = true;
10661 : break;
10662 : default:
10663 : break;
10664 : }
10665 : if (!bad)
10666 4215 : n->u2.udr = NULL;
10667 : else
10668 : {
10669 571 : const char *udr_name = NULL;
10670 571 : if (n->u2.udr)
10671 : {
10672 467 : udr_name = n->u2.udr->udr->name;
10673 467 : n->u2.udr->udr
10674 934 : = gfc_find_omp_udr (NULL, udr_name,
10675 467 : &n->sym->ts);
10676 467 : if (n->u2.udr->udr == NULL)
10677 : {
10678 0 : free (n->u2.udr);
10679 0 : n->u2.udr = NULL;
10680 : }
10681 : }
10682 571 : if (n->u2.udr == NULL)
10683 : {
10684 104 : if (udr_name == NULL)
10685 104 : switch (n->u.reduction_op)
10686 : {
10687 50 : case OMP_REDUCTION_PLUS:
10688 50 : case OMP_REDUCTION_TIMES:
10689 50 : case OMP_REDUCTION_MINUS:
10690 50 : case OMP_REDUCTION_AND:
10691 50 : case OMP_REDUCTION_OR:
10692 50 : case OMP_REDUCTION_EQV:
10693 50 : case OMP_REDUCTION_NEQV:
10694 50 : udr_name = gfc_op2string ((gfc_intrinsic_op)
10695 : n->u.reduction_op);
10696 50 : break;
10697 : case OMP_REDUCTION_MAX:
10698 : udr_name = "max";
10699 : break;
10700 9 : case OMP_REDUCTION_MIN:
10701 9 : udr_name = "min";
10702 9 : break;
10703 12 : case OMP_REDUCTION_IAND:
10704 12 : udr_name = "iand";
10705 12 : break;
10706 12 : case OMP_REDUCTION_IOR:
10707 12 : udr_name = "ior";
10708 12 : break;
10709 9 : case OMP_REDUCTION_IEOR:
10710 9 : udr_name = "ieor";
10711 9 : break;
10712 0 : default:
10713 0 : gcc_unreachable ();
10714 : }
10715 104 : gfc_error ("!$OMP DECLARE REDUCTION %s not found "
10716 : "for type %s at %L", udr_name,
10717 104 : gfc_typename (&n->sym->ts), &n->where);
10718 : }
10719 : else
10720 : {
10721 467 : gfc_omp_udr *udr = n->u2.udr->udr;
10722 467 : n->u.reduction_op = OMP_REDUCTION_USER;
10723 467 : n->u2.udr->combiner
10724 934 : = resolve_omp_udr_clause (n, udr->combiner_ns,
10725 467 : udr->omp_out,
10726 467 : udr->omp_in);
10727 467 : if (udr->initializer_ns)
10728 330 : n->u2.udr->initializer
10729 330 : = resolve_omp_udr_clause (n,
10730 : udr->initializer_ns,
10731 330 : udr->omp_priv,
10732 330 : udr->omp_orig);
10733 : }
10734 : }
10735 : break;
10736 874 : case OMP_LIST_LINEAR:
10737 874 : if (code)
10738 : {
10739 727 : bool is_worksharing_for = false;
10740 727 : switch (code->op)
10741 : {
10742 54 : case EXEC_OMP_DO:
10743 54 : case EXEC_OMP_PARALLEL_DO:
10744 54 : case EXEC_OMP_DISTRIBUTE_PARALLEL_DO:
10745 54 : case EXEC_OMP_TARGET_PARALLEL_DO:
10746 54 : case EXEC_OMP_TEAMS_DISTRIBUTE_PARALLEL_DO:
10747 54 : case EXEC_OMP_TARGET_TEAMS_DISTRIBUTE_PARALLEL_DO:
10748 54 : is_worksharing_for = true;
10749 54 : break;
10750 : default:
10751 : break;
10752 : }
10753 :
10754 54 : if (is_worksharing_for
10755 54 : && (n->sym->attr.dimension
10756 53 : || n->sym->attr.allocatable))
10757 : {
10758 1 : if (n->sym->attr.allocatable)
10759 0 : gfc_error ("Sorry, ALLOCATABLE object %qs in "
10760 : "LINEAR clause on worksharing-loop "
10761 : "construct at %L is not yet supported",
10762 : n->sym->name, &n->where);
10763 : else
10764 1 : gfc_error ("Sorry, array %qs in LINEAR clause "
10765 : "on worksharing-loop construct at %L "
10766 : "is not yet supported",
10767 : n->sym->name, &n->where);
10768 : break;
10769 : }
10770 : }
10771 :
10772 726 : if (code
10773 726 : && n->u.linear.op != OMP_LINEAR_DEFAULT
10774 23 : && n->u.linear.op != linear_op)
10775 : {
10776 23 : if (n->u.linear.old_modifier)
10777 : {
10778 9 : gfc_error ("LINEAR clause modifier used on DO or "
10779 : "SIMD construct at %L", &n->where);
10780 9 : linear_op = n->u.linear.op;
10781 : }
10782 14 : else if (n->u.linear.op != OMP_LINEAR_VAL)
10783 : {
10784 6 : gfc_error ("LINEAR clause modifier other than VAL "
10785 : "used on DO or SIMD construct at %L",
10786 : &n->where);
10787 6 : linear_op = n->u.linear.op;
10788 : }
10789 : }
10790 850 : else if (n->u.linear.op != OMP_LINEAR_REF
10791 800 : && n->sym->ts.type != BT_INTEGER)
10792 1 : gfc_error ("LINEAR variable %qs must be INTEGER "
10793 : "at %L", n->sym->name, &n->where);
10794 849 : else if ((n->u.linear.op == OMP_LINEAR_REF
10795 799 : || n->u.linear.op == OMP_LINEAR_UVAL)
10796 61 : && n->sym->attr.value)
10797 0 : gfc_error ("LINEAR dummy argument %qs with VALUE "
10798 : "attribute with %s modifier at %L",
10799 : n->sym->name,
10800 : n->u.linear.op == OMP_LINEAR_REF
10801 : ? "REF" : "UVAL", &n->where);
10802 849 : else if (n->expr)
10803 : {
10804 830 : gfc_expr *expr = n->expr;
10805 830 : if (!gfc_resolve_expr (expr)
10806 830 : || expr->ts.type != BT_INTEGER
10807 1660 : || expr->rank != 0)
10808 0 : gfc_error ("%qs in LINEAR clause at %L requires "
10809 : "a scalar integer linear-step expression",
10810 0 : n->sym->name, &n->where);
10811 830 : else if (!code && expr->expr_type != EXPR_CONSTANT)
10812 : {
10813 11 : if (expr->expr_type == EXPR_VARIABLE
10814 7 : && expr->symtree->n.sym->attr.dummy
10815 6 : && expr->symtree->n.sym->ns == ns)
10816 : {
10817 6 : gfc_omp_namelist *n2;
10818 6 : for (n2 = omp_clauses->lists[OMP_LIST_UNIFORM];
10819 6 : n2; n2 = n2->next)
10820 6 : if (n2->sym == expr->symtree->n.sym)
10821 : break;
10822 6 : if (n2)
10823 : break;
10824 : }
10825 5 : gfc_error ("%qs in LINEAR clause at %L requires "
10826 : "a constant integer linear-step "
10827 : "expression or dummy argument "
10828 : "specified in UNIFORM clause",
10829 5 : n->sym->name, &n->where);
10830 : }
10831 : }
10832 : break;
10833 : /* Workaround for PR middle-end/26316, nothing really needs
10834 : to be done here for OMP_LIST_PRIVATE. */
10835 9390 : case OMP_LIST_PRIVATE:
10836 9390 : gcc_assert (code && code->op != EXEC_NOP);
10837 : break;
10838 98 : case OMP_LIST_USE_DEVICE:
10839 98 : if (n->sym->attr.allocatable
10840 98 : || (n->sym->ts.type == BT_CLASS && CLASS_DATA (n->sym)
10841 0 : && CLASS_DATA (n->sym)->attr.allocatable))
10842 0 : gfc_error ("ALLOCATABLE object %qs in %s clause at %L",
10843 : n->sym->name, name, &n->where);
10844 98 : if (n->sym->ts.type == BT_CLASS
10845 0 : && CLASS_DATA (n->sym)
10846 0 : && CLASS_DATA (n->sym)->attr.class_pointer)
10847 0 : gfc_error ("POINTER object %qs of polymorphic type in "
10848 : "%s clause at %L", n->sym->name, name,
10849 : &n->where);
10850 98 : if (n->sym->attr.cray_pointer)
10851 2 : gfc_error ("Cray pointer object %qs in %s clause at %L",
10852 : n->sym->name, name, &n->where);
10853 96 : else if (n->sym->attr.cray_pointee)
10854 2 : gfc_error ("Cray pointee object %qs in %s clause at %L",
10855 : n->sym->name, name, &n->where);
10856 94 : else if (n->sym->attr.flavor == FL_VARIABLE
10857 93 : && !n->sym->as
10858 54 : && !n->sym->attr.pointer)
10859 13 : gfc_error ("%s clause variable %qs at %L is neither "
10860 : "a POINTER nor an array", name,
10861 : n->sym->name, &n->where);
10862 : /* FALLTHRU */
10863 98 : case OMP_LIST_DEVICE_RESIDENT:
10864 98 : check_symbol_not_pointer (n->sym, n->where, name);
10865 98 : check_array_not_assumed (n->sym, n->where, name);
10866 98 : break;
10867 : default:
10868 : break;
10869 : }
10870 : }
10871 : break;
10872 : }
10873 : }
10874 : /* OpenMP 5.1: use_device_ptr acts like use_device_addr, except for
10875 : type(c_ptr). */
10876 32471 : if (omp_clauses->lists[OMP_LIST_USE_DEVICE_PTR])
10877 : {
10878 9 : gfc_omp_namelist *n_prev, *n_next, *n_addr;
10879 9 : n_addr = omp_clauses->lists[OMP_LIST_USE_DEVICE_ADDR];
10880 28 : for (; n_addr && n_addr->next; n_addr = n_addr->next)
10881 : ;
10882 : n_prev = NULL;
10883 : n = omp_clauses->lists[OMP_LIST_USE_DEVICE_PTR];
10884 27 : while (n)
10885 : {
10886 18 : n_next = n->next;
10887 18 : if (n->sym->ts.type != BT_DERIVED
10888 18 : || n->sym->ts.u.derived->ts.f90_type != BT_VOID)
10889 : {
10890 0 : n->next = NULL;
10891 0 : if (n_addr)
10892 0 : n_addr->next = n;
10893 : else
10894 0 : omp_clauses->lists[OMP_LIST_USE_DEVICE_ADDR] = n;
10895 0 : n_addr = n;
10896 0 : if (n_prev)
10897 0 : n_prev->next = n_next;
10898 : else
10899 0 : omp_clauses->lists[OMP_LIST_USE_DEVICE_PTR] = n_next;
10900 : }
10901 : else
10902 : n_prev = n;
10903 : n = n_next;
10904 : }
10905 : }
10906 32471 : if (omp_clauses->safelen_expr)
10907 93 : resolve_positive_int_expr (omp_clauses->safelen_expr, "SAFELEN");
10908 32471 : if (omp_clauses->simdlen_expr)
10909 123 : resolve_positive_int_expr (omp_clauses->simdlen_expr, "SIMDLEN");
10910 32471 : if (omp_clauses->num_teams_lower)
10911 21 : resolve_positive_int_expr (omp_clauses->num_teams_lower, "NUM_TEAMS");
10912 32471 : if (omp_clauses->num_teams_upper)
10913 127 : resolve_positive_int_expr (omp_clauses->num_teams_upper, "NUM_TEAMS");
10914 32471 : if (omp_clauses->num_teams_lower
10915 21 : && omp_clauses->num_teams_lower->expr_type == EXPR_CONSTANT
10916 7 : && omp_clauses->num_teams_upper->expr_type == EXPR_CONSTANT
10917 7 : && mpz_cmp (omp_clauses->num_teams_lower->value.integer,
10918 7 : omp_clauses->num_teams_upper->value.integer) > 0)
10919 2 : gfc_warning (OPT_Wopenmp, "NUM_TEAMS lower bound at %L larger than upper "
10920 : "bound at %L", &omp_clauses->num_teams_lower->where,
10921 : &omp_clauses->num_teams_upper->where);
10922 32471 : if (omp_clauses->device)
10923 331 : resolve_scalar_int_expr (omp_clauses->device, "DEVICE");
10924 32471 : if (omp_clauses->filter)
10925 42 : resolve_nonnegative_int_expr (omp_clauses->filter, "FILTER");
10926 32471 : if (omp_clauses->hint)
10927 : {
10928 42 : resolve_scalar_int_expr (omp_clauses->hint, "HINT");
10929 42 : if (omp_clauses->hint->ts.type != BT_INTEGER
10930 40 : || omp_clauses->hint->expr_type != EXPR_CONSTANT
10931 38 : || mpz_sgn (omp_clauses->hint->value.integer) < 0)
10932 5 : gfc_error ("Value of HINT clause at %L shall be a valid "
10933 : "constant hint expression", &omp_clauses->hint->where);
10934 : }
10935 32471 : if (omp_clauses->priority)
10936 34 : resolve_nonnegative_int_expr (omp_clauses->priority, "PRIORITY");
10937 32471 : if (omp_clauses->dist_chunk_size)
10938 : {
10939 83 : gfc_expr *expr = omp_clauses->dist_chunk_size;
10940 83 : if (!gfc_resolve_expr (expr)
10941 83 : || expr->ts.type != BT_INTEGER || expr->rank != 0)
10942 0 : gfc_error ("DIST_SCHEDULE clause's chunk_size at %L requires "
10943 : "a scalar INTEGER expression", &expr->where);
10944 : }
10945 32471 : if (omp_clauses->thread_limit)
10946 72 : resolve_positive_int_expr (omp_clauses->thread_limit, "THREAD_LIMIT");
10947 32471 : if (omp_clauses->grainsize)
10948 34 : resolve_positive_int_expr (omp_clauses->grainsize, "GRAINSIZE");
10949 32471 : if (omp_clauses->num_tasks)
10950 26 : resolve_positive_int_expr (omp_clauses->num_tasks, "NUM_TASKS");
10951 32471 : if (omp_clauses->grainsize && omp_clauses->num_tasks)
10952 1 : gfc_error ("%<GRAINSIZE%> clause at %L must not be used together with "
10953 : "%<NUM_TASKS%> clause", &omp_clauses->grainsize->where);
10954 32471 : if (omp_clauses->lists[OMP_LIST_REDUCTION] && omp_clauses->nogroup)
10955 1 : gfc_error ("%<REDUCTION%> clause at %L must not be used together with "
10956 : "%<NOGROUP%> clause",
10957 : &omp_clauses->lists[OMP_LIST_REDUCTION]->where);
10958 32471 : if (omp_clauses->full && omp_clauses->partial)
10959 0 : gfc_error ("%<FULL%> clause at %C must not be used together with "
10960 : "%<PARTIAL%> clause");
10961 32471 : if (omp_clauses->async)
10962 610 : if (omp_clauses->async_expr)
10963 610 : resolve_scalar_int_expr (omp_clauses->async_expr, "ASYNC");
10964 32471 : if (omp_clauses->num_gangs_expr)
10965 682 : resolve_positive_int_expr (omp_clauses->num_gangs_expr, "NUM_GANGS");
10966 32471 : if (omp_clauses->num_workers_expr)
10967 599 : resolve_positive_int_expr (omp_clauses->num_workers_expr, "NUM_WORKERS");
10968 32471 : if (omp_clauses->vector_length_expr)
10969 569 : resolve_positive_int_expr (omp_clauses->vector_length_expr,
10970 : "VECTOR_LENGTH");
10971 32471 : if (omp_clauses->gang_num_expr)
10972 114 : resolve_positive_int_expr (omp_clauses->gang_num_expr, "GANG");
10973 32471 : if (omp_clauses->gang_static_expr)
10974 94 : resolve_positive_int_expr (omp_clauses->gang_static_expr, "GANG");
10975 32471 : if (omp_clauses->worker_expr)
10976 101 : resolve_positive_int_expr (omp_clauses->worker_expr, "WORKER");
10977 32471 : if (omp_clauses->vector_expr)
10978 132 : resolve_positive_int_expr (omp_clauses->vector_expr, "VECTOR");
10979 32810 : for (el = omp_clauses->wait_list; el; el = el->next)
10980 339 : resolve_scalar_int_expr (el->expr, "WAIT");
10981 32471 : if (omp_clauses->collapse && omp_clauses->tile_list)
10982 4 : gfc_error ("Incompatible use of TILE and COLLAPSE at %L", &code->loc);
10983 32471 : if (omp_clauses->message)
10984 : {
10985 45 : gfc_expr *expr = omp_clauses->message;
10986 45 : if (!gfc_resolve_expr (expr)
10987 45 : || expr->ts.kind != gfc_default_character_kind
10988 87 : || expr->ts.type != BT_CHARACTER || expr->rank != 0)
10989 4 : gfc_error ("MESSAGE clause at %L requires a scalar default-kind "
10990 : "CHARACTER expression", &expr->where);
10991 : }
10992 32471 : if (!openacc
10993 32471 : && code
10994 19622 : && omp_clauses->lists[OMP_LIST_MAP] == NULL
10995 15896 : && omp_clauses->lists[OMP_LIST_USE_DEVICE_PTR] == NULL
10996 15893 : && omp_clauses->lists[OMP_LIST_USE_DEVICE_ADDR] == NULL)
10997 : {
10998 15870 : const char *p = NULL;
10999 15870 : switch (code->op)
11000 : {
11001 1 : case EXEC_OMP_TARGET_ENTER_DATA: p = "TARGET ENTER DATA"; break;
11002 1 : case EXEC_OMP_TARGET_EXIT_DATA: p = "TARGET EXIT DATA"; break;
11003 : default: break;
11004 : }
11005 15870 : if (code->op == EXEC_OMP_TARGET_DATA)
11006 1 : gfc_error ("TARGET DATA must contain at least one MAP, USE_DEVICE_PTR, "
11007 : "or USE_DEVICE_ADDR clause at %L", &code->loc);
11008 15869 : else if (p)
11009 2 : gfc_error ("%s must contain at least one MAP clause at %L",
11010 : p, &code->loc);
11011 : }
11012 32471 : if (omp_clauses->sizes_list)
11013 : {
11014 : gfc_expr_list *el;
11015 572 : for (el = omp_clauses->sizes_list; el; el = el->next)
11016 : {
11017 377 : resolve_scalar_int_expr (el->expr, "SIZES");
11018 377 : if (el->expr->expr_type != EXPR_CONSTANT)
11019 1 : gfc_error ("SIZES requires constant expression at %L",
11020 : &el->expr->where);
11021 376 : else if (el->expr->expr_type == EXPR_CONSTANT
11022 376 : && el->expr->ts.type == BT_INTEGER
11023 376 : && mpz_sgn (el->expr->value.integer) <= 0)
11024 2 : gfc_error ("INTEGER expression of %s clause at %L must be "
11025 : "positive", "SIZES", &el->expr->where);
11026 : }
11027 : }
11028 :
11029 32471 : if (!openacc && omp_clauses->detach)
11030 : {
11031 125 : if (!gfc_resolve_expr (omp_clauses->detach)
11032 125 : || omp_clauses->detach->ts.type != BT_INTEGER
11033 124 : || omp_clauses->detach->ts.kind != gfc_c_intptr_kind
11034 248 : || omp_clauses->detach->rank != 0)
11035 3 : gfc_error ("%qs at %L should be a scalar of type "
11036 : "integer(kind=omp_event_handle_kind)",
11037 3 : omp_clauses->detach->symtree->n.sym->name,
11038 3 : &omp_clauses->detach->where);
11039 122 : else if (omp_clauses->detach->symtree->n.sym->attr.dimension > 0)
11040 1 : gfc_error ("The event handle at %L must not be an array element",
11041 : &omp_clauses->detach->where);
11042 121 : else if (omp_clauses->detach->symtree->n.sym->ts.type == BT_DERIVED
11043 120 : || omp_clauses->detach->symtree->n.sym->ts.type == BT_CLASS)
11044 1 : gfc_error ("The event handle at %L must not be part of "
11045 : "a derived type or class", &omp_clauses->detach->where);
11046 :
11047 125 : if (omp_clauses->mergeable)
11048 2 : gfc_error ("%<DETACH%> clause at %L must not be used together with "
11049 2 : "%<MERGEABLE%> clause", &omp_clauses->detach->where);
11050 : }
11051 :
11052 12625 : if (openacc
11053 12625 : && code->op == EXEC_OACC_HOST_DATA
11054 60 : && omp_clauses->lists[OMP_LIST_USE_DEVICE] == NULL)
11055 1 : gfc_error ("%<host_data%> construct at %L requires %<use_device%> clause",
11056 : &code->loc);
11057 :
11058 32471 : if (omp_clauses->assume)
11059 16 : gfc_resolve_omp_assumptions (omp_clauses->assume);
11060 : }
11061 :
11062 :
11063 : /* Return true if SYM is ever referenced in EXPR except in the SE node. */
11064 :
11065 : static bool
11066 4991 : expr_references_sym (gfc_expr *e, gfc_symbol *s, gfc_expr *se)
11067 : {
11068 6617 : gfc_actual_arglist *arg;
11069 6617 : if (e == NULL || e == se)
11070 : return false;
11071 5366 : switch (e->expr_type)
11072 : {
11073 3120 : case EXPR_CONSTANT:
11074 3120 : case EXPR_NULL:
11075 3120 : case EXPR_VARIABLE:
11076 3120 : case EXPR_STRUCTURE:
11077 3120 : case EXPR_ARRAY:
11078 3120 : if (e->symtree != NULL
11079 1152 : && e->symtree->n.sym == s)
11080 : return true;
11081 : return false;
11082 0 : case EXPR_SUBSTRING:
11083 0 : if (e->ref != NULL
11084 0 : && (expr_references_sym (e->ref->u.ss.start, s, se)
11085 0 : || expr_references_sym (e->ref->u.ss.end, s, se)))
11086 0 : return true;
11087 : return false;
11088 1735 : case EXPR_OP:
11089 1735 : if (expr_references_sym (e->value.op.op2, s, se))
11090 : return true;
11091 1626 : return expr_references_sym (e->value.op.op1, s, se);
11092 511 : case EXPR_FUNCTION:
11093 896 : for (arg = e->value.function.actual; arg; arg = arg->next)
11094 586 : if (expr_references_sym (arg->expr, s, se))
11095 : return true;
11096 : return false;
11097 0 : default:
11098 0 : gcc_unreachable ();
11099 : }
11100 : }
11101 :
11102 :
11103 : /* If EXPR is a conversion function that widens the type
11104 : if WIDENING is true or narrows the type if NARROW is true,
11105 : return the inner expression, otherwise return NULL. */
11106 :
11107 : static gfc_expr *
11108 5911 : is_conversion (gfc_expr *expr, bool narrowing, bool widening)
11109 : {
11110 5911 : gfc_typespec *ts1, *ts2;
11111 :
11112 5911 : if (expr->expr_type != EXPR_FUNCTION
11113 917 : || expr->value.function.isym == NULL
11114 894 : || expr->value.function.esym != NULL
11115 894 : || expr->value.function.isym->id != GFC_ISYM_CONVERSION
11116 388 : || (!narrowing && !widening))
11117 : return NULL;
11118 :
11119 388 : if (narrowing && widening)
11120 267 : return expr->value.function.actual->expr;
11121 :
11122 121 : if (widening)
11123 : {
11124 121 : ts1 = &expr->ts;
11125 121 : ts2 = &expr->value.function.actual->expr->ts;
11126 : }
11127 : else
11128 : {
11129 0 : ts1 = &expr->value.function.actual->expr->ts;
11130 0 : ts2 = &expr->ts;
11131 : }
11132 :
11133 121 : if (ts1->type > ts2->type
11134 49 : || (ts1->type == ts2->type && ts1->kind > ts2->kind))
11135 121 : return expr->value.function.actual->expr;
11136 :
11137 : return NULL;
11138 : }
11139 :
11140 : static bool
11141 6855 : is_scalar_intrinsic_expr (gfc_expr *expr, bool must_be_var, bool conv_ok)
11142 : {
11143 6855 : if (must_be_var
11144 4020 : && (expr->expr_type != EXPR_VARIABLE || !expr->symtree))
11145 : {
11146 37 : if (!conv_ok)
11147 : return false;
11148 37 : gfc_expr *conv = is_conversion (expr, true, true);
11149 37 : if (!conv)
11150 : return false;
11151 36 : if (conv->expr_type != EXPR_VARIABLE || !conv->symtree)
11152 : return false;
11153 : }
11154 6852 : return (expr->rank == 0
11155 6848 : && !gfc_is_coindexed (expr)
11156 13700 : && (expr->ts.type == BT_INTEGER
11157 : || expr->ts.type == BT_REAL
11158 : || expr->ts.type == BT_COMPLEX
11159 : || expr->ts.type == BT_LOGICAL));
11160 : }
11161 :
11162 : static void
11163 2697 : resolve_omp_atomic (gfc_code *code)
11164 : {
11165 2697 : gfc_code *atomic_code = code->block;
11166 2697 : gfc_symbol *var;
11167 2697 : gfc_expr *stmt_expr2, *capt_expr2;
11168 2697 : gfc_omp_atomic_op aop
11169 2697 : = (gfc_omp_atomic_op) (atomic_code->ext.omp_clauses->atomic_op
11170 : & GFC_OMP_ATOMIC_MASK);
11171 2697 : gfc_code *stmt = NULL, *capture_stmt = NULL, *tailing_stmt = NULL;
11172 2697 : gfc_expr *comp_cond = NULL;
11173 2697 : locus *loc = NULL;
11174 :
11175 2697 : code = code->block->next;
11176 : /* resolve_blocks asserts this is initially EXEC_ASSIGN or EXEC_IF
11177 : If it changed to EXEC_NOP, assume an error has been emitted already. */
11178 2697 : if (code->op == EXEC_NOP)
11179 : return;
11180 :
11181 2696 : if (atomic_code->ext.omp_clauses->compare
11182 156 : && atomic_code->ext.omp_clauses->capture)
11183 : {
11184 : /* Must be either "if (x == e) then; x = d; else; v = x; end if"
11185 : or "v = expr" followed/preceded by
11186 : "if (x == e) then; x = d; end if" or "if (x == e) x = d". */
11187 103 : gfc_code *next = code;
11188 103 : if (code->op == EXEC_ASSIGN)
11189 : {
11190 19 : capture_stmt = code;
11191 19 : next = code->next;
11192 : }
11193 103 : if (next->op == EXEC_IF
11194 103 : && next->block
11195 103 : && next->block->op == EXEC_IF
11196 103 : && next->block->next
11197 102 : && next->block->next->op == EXEC_ASSIGN)
11198 : {
11199 102 : comp_cond = next->block->expr1;
11200 102 : stmt = next->block->next;
11201 102 : if (stmt->next)
11202 : {
11203 0 : loc = &stmt->loc;
11204 0 : goto unexpected;
11205 : }
11206 : }
11207 1 : else if (capture_stmt)
11208 : {
11209 0 : gfc_error ("Expected IF at %L in atomic compare capture",
11210 : &next->loc);
11211 0 : return;
11212 : }
11213 103 : if (stmt && !capture_stmt && next->block->block)
11214 : {
11215 64 : if (next->block->block->expr1)
11216 : {
11217 0 : gfc_error ("Expected ELSE at %L in atomic compare capture",
11218 : &next->block->block->expr1->where);
11219 0 : return;
11220 : }
11221 64 : if (!code->block->block->next
11222 64 : || code->block->block->next->op != EXEC_ASSIGN)
11223 : {
11224 0 : loc = (code->block->block->next ? &code->block->block->next->loc
11225 : : &code->block->block->loc);
11226 0 : goto unexpected;
11227 : }
11228 64 : capture_stmt = code->block->block->next;
11229 64 : if (capture_stmt->next)
11230 : {
11231 0 : loc = &capture_stmt->next->loc;
11232 0 : goto unexpected;
11233 : }
11234 : }
11235 103 : if (stmt && !capture_stmt && next->next->op == EXEC_ASSIGN)
11236 : capture_stmt = next->next;
11237 84 : else if (!capture_stmt)
11238 : {
11239 1 : loc = &code->loc;
11240 1 : goto unexpected;
11241 : }
11242 : }
11243 2593 : else if (atomic_code->ext.omp_clauses->compare)
11244 : {
11245 : /* Must be: "if (x == e) then; x = d; end if" or "if (x == e) x = d". */
11246 53 : if (code->op == EXEC_IF
11247 53 : && code->block
11248 53 : && code->block->op == EXEC_IF
11249 53 : && code->block->next
11250 51 : && code->block->next->op == EXEC_ASSIGN)
11251 : {
11252 51 : comp_cond = code->block->expr1;
11253 51 : stmt = code->block->next;
11254 51 : if (stmt->next || code->block->block)
11255 : {
11256 0 : loc = stmt->next ? &stmt->next->loc : &code->block->block->loc;
11257 0 : goto unexpected;
11258 : }
11259 : }
11260 : else
11261 : {
11262 2 : loc = &code->loc;
11263 2 : goto unexpected;
11264 : }
11265 : }
11266 2540 : else if (atomic_code->ext.omp_clauses->capture)
11267 : {
11268 : /* Must be: "v = x" followed/preceded by "x = ...". */
11269 489 : if (code->op != EXEC_ASSIGN)
11270 0 : goto unexpected;
11271 489 : if (code->next->op != EXEC_ASSIGN)
11272 : {
11273 0 : loc = &code->next->loc;
11274 0 : goto unexpected;
11275 : }
11276 489 : gfc_expr *expr2, *expr2_next;
11277 489 : expr2 = is_conversion (code->expr2, true, true);
11278 489 : if (expr2 == NULL)
11279 447 : expr2 = code->expr2;
11280 489 : expr2_next = is_conversion (code->next->expr2, true, true);
11281 489 : if (expr2_next == NULL)
11282 478 : expr2_next = code->next->expr2;
11283 489 : if (code->expr1->expr_type == EXPR_VARIABLE
11284 489 : && code->next->expr1->expr_type == EXPR_VARIABLE
11285 489 : && expr2->expr_type == EXPR_VARIABLE
11286 243 : && expr2_next->expr_type == EXPR_VARIABLE)
11287 : {
11288 1 : if (code->expr1->symtree->n.sym == expr2_next->symtree->n.sym)
11289 : {
11290 : stmt = code;
11291 : capture_stmt = code->next;
11292 : }
11293 : else
11294 : {
11295 489 : capture_stmt = code;
11296 489 : stmt = code->next;
11297 : }
11298 : }
11299 488 : else if (expr2->expr_type == EXPR_VARIABLE)
11300 : {
11301 : capture_stmt = code;
11302 : stmt = code->next;
11303 : }
11304 : else
11305 : {
11306 247 : stmt = code;
11307 247 : capture_stmt = code->next;
11308 : }
11309 : /* Shall be NULL but can happen for invalid code. */
11310 489 : tailing_stmt = code->next->next;
11311 : }
11312 : else
11313 : {
11314 : /* x = ... */
11315 2051 : stmt = code;
11316 2051 : if (!atomic_code->ext.omp_clauses->compare && stmt->op != EXEC_ASSIGN)
11317 1 : goto unexpected;
11318 : /* Shall be NULL but can happen for invalid code. */
11319 2050 : tailing_stmt = code->next;
11320 : }
11321 :
11322 2692 : if (comp_cond)
11323 : {
11324 153 : if (comp_cond->expr_type != EXPR_OP
11325 153 : || (comp_cond->value.op.op != INTRINSIC_EQ
11326 : && comp_cond->value.op.op != INTRINSIC_EQ_OS
11327 : && comp_cond->value.op.op != INTRINSIC_EQV))
11328 : {
11329 0 : gfc_error ("Expected %<==%>, %<.EQ.%> or %<.EQV.%> atomic comparison "
11330 : "expression at %L", &comp_cond->where);
11331 0 : return;
11332 : }
11333 153 : if (!is_scalar_intrinsic_expr (comp_cond->value.op.op1, true, true))
11334 : {
11335 1 : gfc_error ("Expected scalar intrinsic variable at %L in atomic "
11336 1 : "comparison", &comp_cond->value.op.op1->where);
11337 1 : return;
11338 : }
11339 152 : if (!gfc_resolve_expr (comp_cond->value.op.op2))
11340 : return;
11341 152 : if (!is_scalar_intrinsic_expr (comp_cond->value.op.op2, false, false))
11342 : {
11343 0 : gfc_error ("Expected scalar intrinsic expression at %L in atomic "
11344 0 : "comparison", &comp_cond->value.op.op1->where);
11345 0 : return;
11346 : }
11347 : }
11348 :
11349 2691 : if (!is_scalar_intrinsic_expr (stmt->expr1, true, false))
11350 : {
11351 4 : gfc_error ("!$OMP ATOMIC statement must set a scalar variable of "
11352 4 : "intrinsic type at %L", &stmt->expr1->where);
11353 4 : return;
11354 : }
11355 :
11356 2687 : if (!gfc_resolve_expr (stmt->expr2))
11357 : return;
11358 2683 : if (!is_scalar_intrinsic_expr (stmt->expr2, false, false))
11359 : {
11360 0 : gfc_error ("!$OMP ATOMIC statement must assign an expression of "
11361 0 : "intrinsic type at %L", &stmt->expr2->where);
11362 0 : return;
11363 : }
11364 :
11365 2683 : if (gfc_expr_attr (stmt->expr1).allocatable)
11366 : {
11367 0 : gfc_error ("!$OMP ATOMIC with ALLOCATABLE variable at %L",
11368 0 : &stmt->expr1->where);
11369 0 : return;
11370 : }
11371 :
11372 : /* Should be diagnosed above already. */
11373 2683 : gcc_assert (tailing_stmt == NULL);
11374 :
11375 2683 : var = stmt->expr1->symtree->n.sym;
11376 2683 : stmt_expr2 = is_conversion (stmt->expr2, true, true);
11377 2683 : if (stmt_expr2 == NULL)
11378 2527 : stmt_expr2 = stmt->expr2;
11379 :
11380 2683 : switch (aop)
11381 : {
11382 503 : case GFC_OMP_ATOMIC_READ:
11383 503 : if (stmt_expr2->expr_type != EXPR_VARIABLE)
11384 0 : gfc_error ("!$OMP ATOMIC READ statement must read from a scalar "
11385 : "variable of intrinsic type at %L", &stmt_expr2->where);
11386 : return;
11387 421 : case GFC_OMP_ATOMIC_WRITE:
11388 421 : if (expr_references_sym (stmt_expr2, var, NULL))
11389 0 : gfc_error ("expr in !$OMP ATOMIC WRITE assignment var = expr "
11390 : "must be scalar and cannot reference var at %L",
11391 : &stmt_expr2->where);
11392 : return;
11393 1759 : default:
11394 1759 : break;
11395 : }
11396 :
11397 1759 : if (atomic_code->ext.omp_clauses->capture)
11398 : {
11399 588 : if (!is_scalar_intrinsic_expr (capture_stmt->expr1, true, false))
11400 : {
11401 0 : gfc_error ("!$OMP ATOMIC capture-statement must set a scalar "
11402 : "variable of intrinsic type at %L",
11403 0 : &capture_stmt->expr1->where);
11404 0 : return;
11405 : }
11406 :
11407 588 : if (!is_scalar_intrinsic_expr (capture_stmt->expr2, true, true))
11408 : {
11409 2 : gfc_error ("!$OMP ATOMIC capture-statement requires a scalar variable"
11410 2 : " of intrinsic type at %L", &capture_stmt->expr2->where);
11411 2 : return;
11412 : }
11413 586 : capt_expr2 = is_conversion (capture_stmt->expr2, true, true);
11414 586 : if (capt_expr2 == NULL)
11415 564 : capt_expr2 = capture_stmt->expr2;
11416 :
11417 586 : if (capt_expr2->symtree->n.sym != var)
11418 : {
11419 1 : gfc_error ("!$OMP ATOMIC CAPTURE capture statement reads from "
11420 : "different variable than update statement writes "
11421 : "into at %L", &capture_stmt->expr2->where);
11422 1 : return;
11423 : }
11424 : }
11425 :
11426 1756 : if (atomic_code->ext.omp_clauses->compare)
11427 : {
11428 149 : gfc_expr *var_expr;
11429 149 : if (comp_cond->value.op.op1->expr_type == EXPR_VARIABLE)
11430 : var_expr = comp_cond->value.op.op1;
11431 : else
11432 12 : var_expr = comp_cond->value.op.op1->value.function.actual->expr;
11433 149 : if (var_expr->symtree->n.sym != var)
11434 : {
11435 2 : gfc_error ("For !$OMP ATOMIC COMPARE, the first operand in comparison"
11436 : " at %L must be the variable %qs that the update statement"
11437 : " writes into at %L", &var_expr->where, var->name,
11438 2 : &stmt->expr1->where);
11439 2 : return;
11440 : }
11441 147 : if (stmt_expr2->rank != 0 || expr_references_sym (stmt_expr2, var, NULL))
11442 : {
11443 1 : gfc_error ("expr in !$OMP ATOMIC COMPARE assignment var = expr "
11444 : "must be scalar and cannot reference var at %L",
11445 : &stmt_expr2->where);
11446 1 : return;
11447 : }
11448 : }
11449 1607 : else if (atomic_code->ext.omp_clauses->capture
11450 1607 : && !expr_references_sym (stmt_expr2, var, NULL))
11451 22 : atomic_code->ext.omp_clauses->atomic_op
11452 22 : = (gfc_omp_atomic_op) (atomic_code->ext.omp_clauses->atomic_op
11453 : | GFC_OMP_ATOMIC_SWAP);
11454 1585 : else if (stmt_expr2->expr_type == EXPR_OP)
11455 : {
11456 1229 : gfc_expr *v = NULL, *e, *c;
11457 1229 : gfc_intrinsic_op op = stmt_expr2->value.op.op;
11458 1229 : gfc_intrinsic_op alt_op = INTRINSIC_NONE;
11459 :
11460 1229 : if (atomic_code->ext.omp_clauses->fail != OMP_MEMORDER_UNSET)
11461 3 : gfc_error ("!$OMP ATOMIC UPDATE at %L with FAIL clause requires either"
11462 : " the COMPARE clause or using the intrinsic MIN/MAX "
11463 : "procedure", &atomic_code->loc);
11464 1229 : switch (op)
11465 : {
11466 742 : case INTRINSIC_PLUS:
11467 742 : alt_op = INTRINSIC_MINUS;
11468 742 : break;
11469 94 : case INTRINSIC_TIMES:
11470 94 : alt_op = INTRINSIC_DIVIDE;
11471 94 : break;
11472 120 : case INTRINSIC_MINUS:
11473 120 : alt_op = INTRINSIC_PLUS;
11474 120 : break;
11475 94 : case INTRINSIC_DIVIDE:
11476 94 : alt_op = INTRINSIC_TIMES;
11477 94 : break;
11478 : case INTRINSIC_AND:
11479 : case INTRINSIC_OR:
11480 : break;
11481 43 : case INTRINSIC_EQV:
11482 43 : alt_op = INTRINSIC_NEQV;
11483 43 : break;
11484 43 : case INTRINSIC_NEQV:
11485 43 : alt_op = INTRINSIC_EQV;
11486 43 : break;
11487 1 : default:
11488 1 : gfc_error ("!$OMP ATOMIC assignment operator must be binary "
11489 : "+, *, -, /, .AND., .OR., .EQV. or .NEQV. at %L",
11490 : &stmt_expr2->where);
11491 1 : return;
11492 : }
11493 :
11494 : /* Check for var = var op expr resp. var = expr op var where
11495 : expr doesn't reference var and var op expr is mathematically
11496 : equivalent to var op (expr) resp. expr op var equivalent to
11497 : (expr) op var. We rely here on the fact that the matcher
11498 : for x op1 y op2 z where op1 and op2 have equal precedence
11499 : returns (x op1 y) op2 z. */
11500 1228 : e = stmt_expr2->value.op.op2;
11501 1228 : if (e->expr_type == EXPR_VARIABLE
11502 288 : && e->symtree != NULL
11503 288 : && e->symtree->n.sym == var)
11504 : v = e;
11505 999 : else if ((c = is_conversion (e, false, true)) != NULL
11506 48 : && c->expr_type == EXPR_VARIABLE
11507 48 : && c->symtree != NULL
11508 1047 : && c->symtree->n.sym == var)
11509 : v = c;
11510 : else
11511 : {
11512 951 : gfc_expr **p = NULL, **q;
11513 1049 : for (q = &stmt_expr2->value.op.op1; (e = *q) != NULL; )
11514 1049 : if (e->expr_type == EXPR_VARIABLE
11515 948 : && e->symtree != NULL
11516 948 : && e->symtree->n.sym == var)
11517 : {
11518 : v = e;
11519 : break;
11520 : }
11521 101 : else if ((c = is_conversion (e, false, true)) != NULL)
11522 60 : q = &e->value.function.actual->expr;
11523 41 : else if (e->expr_type != EXPR_OP
11524 41 : || (e->value.op.op != op
11525 15 : && e->value.op.op != alt_op)
11526 38 : || e->rank != 0)
11527 : break;
11528 : else
11529 : {
11530 38 : p = q;
11531 38 : q = &e->value.op.op1;
11532 : }
11533 :
11534 951 : if (v == NULL)
11535 : {
11536 3 : gfc_error ("!$OMP ATOMIC assignment must be var = var op expr "
11537 : "or var = expr op var at %L", &stmt_expr2->where);
11538 3 : return;
11539 : }
11540 :
11541 948 : if (p != NULL)
11542 : {
11543 38 : e = *p;
11544 38 : switch (e->value.op.op)
11545 : {
11546 8 : case INTRINSIC_MINUS:
11547 8 : case INTRINSIC_DIVIDE:
11548 8 : case INTRINSIC_EQV:
11549 8 : case INTRINSIC_NEQV:
11550 8 : gfc_error ("!$OMP ATOMIC var = var op expr not "
11551 : "mathematically equivalent to var = var op "
11552 : "(expr) at %L", &stmt_expr2->where);
11553 8 : break;
11554 : default:
11555 : break;
11556 : }
11557 :
11558 : /* Canonicalize into var = var op (expr). */
11559 38 : *p = e->value.op.op2;
11560 38 : e->value.op.op2 = stmt_expr2;
11561 38 : e->ts = stmt_expr2->ts;
11562 38 : if (stmt->expr2 == stmt_expr2)
11563 26 : stmt->expr2 = stmt_expr2 = e;
11564 : else
11565 12 : stmt->expr2->value.function.actual->expr = stmt_expr2 = e;
11566 :
11567 38 : if (!gfc_compare_types (&stmt_expr2->value.op.op1->ts,
11568 : &stmt_expr2->ts))
11569 : {
11570 24 : for (p = &stmt_expr2->value.op.op1; *p != v;
11571 12 : p = &(*p)->value.function.actual->expr)
11572 : ;
11573 12 : *p = NULL;
11574 12 : gfc_free_expr (stmt_expr2->value.op.op1);
11575 12 : stmt_expr2->value.op.op1 = v;
11576 12 : gfc_convert_type (v, &stmt_expr2->ts, 2);
11577 : }
11578 : }
11579 : }
11580 :
11581 1225 : if (e->rank != 0 || expr_references_sym (stmt->expr2, var, v))
11582 : {
11583 1 : gfc_error ("expr in !$OMP ATOMIC assignment var = var op expr "
11584 : "must be scalar and cannot reference var at %L",
11585 : &stmt_expr2->where);
11586 1 : return;
11587 : }
11588 : }
11589 356 : else if (stmt_expr2->expr_type == EXPR_FUNCTION
11590 355 : && stmt_expr2->value.function.isym != NULL
11591 355 : && stmt_expr2->value.function.esym == NULL
11592 355 : && stmt_expr2->value.function.actual != NULL
11593 355 : && stmt_expr2->value.function.actual->next != NULL)
11594 : {
11595 355 : gfc_actual_arglist *arg, *var_arg;
11596 :
11597 355 : switch (stmt_expr2->value.function.isym->id)
11598 : {
11599 : case GFC_ISYM_MIN:
11600 : case GFC_ISYM_MAX:
11601 : break;
11602 147 : case GFC_ISYM_IAND:
11603 147 : case GFC_ISYM_IOR:
11604 147 : case GFC_ISYM_IEOR:
11605 147 : if (stmt_expr2->value.function.actual->next->next != NULL)
11606 : {
11607 0 : gfc_error ("!$OMP ATOMIC assignment intrinsic IAND, IOR "
11608 : "or IEOR must have two arguments at %L",
11609 : &stmt_expr2->where);
11610 0 : return;
11611 : }
11612 : break;
11613 1 : default:
11614 1 : gfc_error ("!$OMP ATOMIC assignment intrinsic must be "
11615 : "MIN, MAX, IAND, IOR or IEOR at %L",
11616 : &stmt_expr2->where);
11617 1 : return;
11618 : }
11619 :
11620 : var_arg = NULL;
11621 1088 : for (arg = stmt_expr2->value.function.actual; arg; arg = arg->next)
11622 : {
11623 741 : gfc_expr *e = NULL;
11624 741 : if (arg == stmt_expr2->value.function.actual
11625 387 : || (var_arg == NULL && arg->next == NULL))
11626 : {
11627 527 : e = is_conversion (arg->expr, false, true);
11628 527 : if (!e)
11629 514 : e = arg->expr;
11630 527 : if (e->expr_type == EXPR_VARIABLE
11631 453 : && e->symtree != NULL
11632 453 : && e->symtree->n.sym == var)
11633 741 : var_arg = arg;
11634 : }
11635 741 : if ((!var_arg || !e) && expr_references_sym (arg->expr, var, NULL))
11636 : {
11637 7 : gfc_error ("!$OMP ATOMIC intrinsic arguments except one must "
11638 : "not reference %qs at %L",
11639 : var->name, &arg->expr->where);
11640 7 : return;
11641 : }
11642 734 : if (arg->expr->rank != 0)
11643 : {
11644 0 : gfc_error ("!$OMP ATOMIC intrinsic arguments must be scalar "
11645 : "at %L", &arg->expr->where);
11646 0 : return;
11647 : }
11648 : }
11649 :
11650 347 : if (var_arg == NULL)
11651 : {
11652 1 : gfc_error ("First or last !$OMP ATOMIC intrinsic argument must "
11653 : "be %qs at %L", var->name, &stmt_expr2->where);
11654 1 : return;
11655 : }
11656 :
11657 346 : if (var_arg != stmt_expr2->value.function.actual)
11658 : {
11659 : /* Canonicalize, so that var comes first. */
11660 172 : gcc_assert (var_arg->next == NULL);
11661 : for (arg = stmt_expr2->value.function.actual;
11662 185 : arg->next != var_arg; arg = arg->next)
11663 : ;
11664 172 : var_arg->next = stmt_expr2->value.function.actual;
11665 172 : stmt_expr2->value.function.actual = var_arg;
11666 172 : arg->next = NULL;
11667 : }
11668 : }
11669 : else
11670 1 : gfc_error ("!$OMP ATOMIC assignment must have an operator or "
11671 : "intrinsic on right hand side at %L", &stmt_expr2->where);
11672 : return;
11673 :
11674 4 : unexpected:
11675 4 : gfc_error ("unexpected !$OMP ATOMIC expression at %L",
11676 : loc ? loc : &code->loc);
11677 4 : return;
11678 : }
11679 :
11680 :
11681 : static struct fortran_omp_context
11682 : {
11683 : gfc_code *code;
11684 : hash_set<gfc_symbol *> *sharing_clauses;
11685 : hash_set<gfc_symbol *> *private_iterators;
11686 : struct fortran_omp_context *previous;
11687 : bool is_openmp;
11688 : } *omp_current_ctx;
11689 : static gfc_code *omp_current_do_code;
11690 : static int omp_current_do_collapse;
11691 :
11692 : /* Forward declaration for mutually recursive functions. */
11693 : static gfc_code *
11694 : find_nested_loop_in_block (gfc_code *block);
11695 :
11696 : /* Return the first nested DO loop in CHAIN, or NULL if there
11697 : isn't one. Does no error checking on intervening code. */
11698 :
11699 : static gfc_code *
11700 27482 : find_nested_loop_in_chain (gfc_code *chain)
11701 : {
11702 27482 : gfc_code *code;
11703 :
11704 27482 : if (!chain)
11705 : return NULL;
11706 :
11707 31643 : for (code = chain; code; code = code->next)
11708 31222 : switch (code->op)
11709 : {
11710 : case EXEC_DO:
11711 : case EXEC_OMP_TILE:
11712 : case EXEC_OMP_UNROLL:
11713 : return code;
11714 621 : case EXEC_BLOCK:
11715 621 : if (gfc_code *c = find_nested_loop_in_block (code))
11716 : return c;
11717 : break;
11718 : default:
11719 : break;
11720 : }
11721 : return NULL;
11722 : }
11723 :
11724 : /* Return the first nested DO loop in BLOCK, or NULL if there
11725 : isn't one. Does no error checking on intervening code. */
11726 : static gfc_code *
11727 939 : find_nested_loop_in_block (gfc_code *block)
11728 : {
11729 939 : gfc_namespace *ns;
11730 939 : gcc_assert (block->op == EXEC_BLOCK);
11731 939 : ns = block->ext.block.ns;
11732 939 : gcc_assert (ns);
11733 939 : return find_nested_loop_in_chain (ns->code);
11734 : }
11735 :
11736 : void
11737 5420 : gfc_resolve_omp_do_blocks (gfc_code *code, gfc_namespace *ns)
11738 : {
11739 5420 : if (code->block->next && code->block->next->op == EXEC_DO)
11740 : {
11741 5067 : int i;
11742 :
11743 5067 : omp_current_do_code = code->block->next;
11744 5067 : if (code->ext.omp_clauses->orderedc)
11745 142 : omp_current_do_collapse = code->ext.omp_clauses->orderedc;
11746 4925 : else if (code->ext.omp_clauses->collapse)
11747 1121 : omp_current_do_collapse = code->ext.omp_clauses->collapse;
11748 3804 : else if (code->ext.omp_clauses->sizes_list)
11749 175 : omp_current_do_collapse
11750 175 : = gfc_expr_list_len (code->ext.omp_clauses->sizes_list);
11751 : else
11752 3629 : omp_current_do_collapse = 1;
11753 5067 : if (code->ext.omp_clauses->lists[OMP_LIST_REDUCTION_INSCAN])
11754 : {
11755 : /* Checking that there is a matching EXEC_OMP_SCAN in the
11756 : innermost body cannot be deferred to resolve_omp_do because
11757 : we process directives nested in the loop before we get
11758 : there. */
11759 60 : locus *loc
11760 : = &code->ext.omp_clauses->lists[OMP_LIST_REDUCTION_INSCAN]->where;
11761 60 : gfc_code *c;
11762 :
11763 80 : for (i = 1, c = omp_current_do_code;
11764 80 : i < omp_current_do_collapse; i++)
11765 : {
11766 22 : c = find_nested_loop_in_chain (c->block->next);
11767 22 : if (!c || c->op != EXEC_DO || c->block == NULL)
11768 : break;
11769 : }
11770 :
11771 : /* Skip this if we don't have enough nested loops. That
11772 : problem will be diagnosed elsewhere. */
11773 60 : if (c && c->op == EXEC_DO)
11774 : {
11775 58 : gfc_code *block = c->block ? c->block->next : NULL;
11776 58 : if (block && block->op != EXEC_OMP_SCAN)
11777 54 : while (block && block->next
11778 54 : && block->next->op != EXEC_OMP_SCAN)
11779 : block = block->next;
11780 43 : if (!block
11781 46 : || (block->op != EXEC_OMP_SCAN
11782 43 : && (!block->next || block->next->op != EXEC_OMP_SCAN)))
11783 19 : gfc_error ("With INSCAN at %L, expected loop body with "
11784 : "!$OMP SCAN between two "
11785 : "structured block sequences", loc);
11786 : else
11787 : {
11788 39 : if (block->op == EXEC_OMP_SCAN)
11789 3 : gfc_warning (OPT_Wopenmp,
11790 : "!$OMP SCAN at %L with zero executable "
11791 : "statements in preceding structured block "
11792 : "sequence", &block->loc);
11793 39 : if ((block->op == EXEC_OMP_SCAN && !block->next)
11794 38 : || (block->next && block->next->op == EXEC_OMP_SCAN
11795 36 : && !block->next->next))
11796 3 : gfc_warning (OPT_Wopenmp,
11797 : "!$OMP SCAN at %L with zero executable "
11798 : "statements in succeeding structured block "
11799 : "sequence", block->op == EXEC_OMP_SCAN
11800 1 : ? &block->loc : &block->next->loc);
11801 : }
11802 58 : if (block && block->op != EXEC_OMP_SCAN)
11803 43 : block = block->next;
11804 46 : if (block && block->op == EXEC_OMP_SCAN)
11805 : /* Mark 'omp scan' as checked; flag will be unset later. */
11806 39 : block->ext.omp_clauses->if_present = true;
11807 : }
11808 : }
11809 : }
11810 5420 : gfc_resolve_blocks (code->block, ns);
11811 5420 : omp_current_do_collapse = 0;
11812 5420 : omp_current_do_code = NULL;
11813 5420 : }
11814 :
11815 :
11816 : void
11817 6031 : gfc_resolve_omp_parallel_blocks (gfc_code *code, gfc_namespace *ns)
11818 : {
11819 6031 : struct fortran_omp_context ctx;
11820 6031 : gfc_omp_clauses *omp_clauses = code->ext.omp_clauses;
11821 6031 : gfc_omp_namelist *n;
11822 :
11823 6031 : ctx.code = code;
11824 6031 : ctx.sharing_clauses = new hash_set<gfc_symbol *>;
11825 6031 : ctx.private_iterators = new hash_set<gfc_symbol *>;
11826 6031 : ctx.previous = omp_current_ctx;
11827 6031 : ctx.is_openmp = true;
11828 6031 : omp_current_ctx = &ctx;
11829 :
11830 241240 : for (enum gfc_omp_list_type list = OMP_LIST_FIRST; list < OMP_LIST_NUM;
11831 235209 : list = gfc_omp_list_type (list + 1))
11832 235209 : switch (list)
11833 : {
11834 60310 : case OMP_LIST_SHARED:
11835 60310 : case OMP_LIST_PRIVATE:
11836 60310 : case OMP_LIST_FIRSTPRIVATE:
11837 60310 : case OMP_LIST_LASTPRIVATE:
11838 60310 : case OMP_LIST_REDUCTION:
11839 60310 : case OMP_LIST_REDUCTION_INSCAN:
11840 60310 : case OMP_LIST_REDUCTION_TASK:
11841 60310 : case OMP_LIST_IN_REDUCTION:
11842 60310 : case OMP_LIST_TASK_REDUCTION:
11843 60310 : case OMP_LIST_LINEAR:
11844 69267 : for (n = omp_clauses->lists[list]; n; n = n->next)
11845 8957 : ctx.sharing_clauses->add (n->sym);
11846 : break;
11847 : default:
11848 : break;
11849 : }
11850 :
11851 6031 : switch (code->op)
11852 : {
11853 2357 : case EXEC_OMP_DISTRIBUTE_PARALLEL_DO:
11854 2357 : case EXEC_OMP_DISTRIBUTE_PARALLEL_DO_SIMD:
11855 2357 : case EXEC_OMP_MASKED_TASKLOOP:
11856 2357 : case EXEC_OMP_MASKED_TASKLOOP_SIMD:
11857 2357 : case EXEC_OMP_MASTER_TASKLOOP:
11858 2357 : case EXEC_OMP_MASTER_TASKLOOP_SIMD:
11859 2357 : case EXEC_OMP_PARALLEL_DO:
11860 2357 : case EXEC_OMP_PARALLEL_DO_SIMD:
11861 2357 : case EXEC_OMP_PARALLEL_LOOP:
11862 2357 : case EXEC_OMP_PARALLEL_MASKED_TASKLOOP:
11863 2357 : case EXEC_OMP_PARALLEL_MASKED_TASKLOOP_SIMD:
11864 2357 : case EXEC_OMP_PARALLEL_MASTER_TASKLOOP:
11865 2357 : case EXEC_OMP_PARALLEL_MASTER_TASKLOOP_SIMD:
11866 2357 : case EXEC_OMP_TARGET_PARALLEL_DO:
11867 2357 : case EXEC_OMP_TARGET_PARALLEL_DO_SIMD:
11868 2357 : case EXEC_OMP_TARGET_PARALLEL_LOOP:
11869 2357 : case EXEC_OMP_TARGET_TEAMS_DISTRIBUTE:
11870 2357 : case EXEC_OMP_TARGET_TEAMS_DISTRIBUTE_PARALLEL_DO:
11871 2357 : case EXEC_OMP_TARGET_TEAMS_DISTRIBUTE_PARALLEL_DO_SIMD:
11872 2357 : case EXEC_OMP_TARGET_TEAMS_DISTRIBUTE_SIMD:
11873 2357 : case EXEC_OMP_TARGET_TEAMS_LOOP:
11874 2357 : case EXEC_OMP_TASKLOOP:
11875 2357 : case EXEC_OMP_TASKLOOP_SIMD:
11876 2357 : case EXEC_OMP_TEAMS_DISTRIBUTE:
11877 2357 : case EXEC_OMP_TEAMS_DISTRIBUTE_PARALLEL_DO:
11878 2357 : case EXEC_OMP_TEAMS_DISTRIBUTE_PARALLEL_DO_SIMD:
11879 2357 : case EXEC_OMP_TEAMS_DISTRIBUTE_SIMD:
11880 2357 : case EXEC_OMP_TEAMS_LOOP:
11881 2357 : gfc_resolve_omp_do_blocks (code, ns);
11882 2357 : break;
11883 3674 : default:
11884 3674 : gfc_resolve_blocks (code->block, ns);
11885 : }
11886 :
11887 6031 : omp_current_ctx = ctx.previous;
11888 12062 : delete ctx.sharing_clauses;
11889 12062 : delete ctx.private_iterators;
11890 6031 : }
11891 :
11892 :
11893 : /* Save and clear openmp.cc private state. */
11894 :
11895 : void
11896 288079 : gfc_omp_save_and_clear_state (struct gfc_omp_saved_state *state)
11897 : {
11898 288079 : state->ptrs[0] = omp_current_ctx;
11899 288079 : state->ptrs[1] = omp_current_do_code;
11900 288079 : state->ints[0] = omp_current_do_collapse;
11901 288079 : omp_current_ctx = NULL;
11902 288079 : omp_current_do_code = NULL;
11903 288079 : omp_current_do_collapse = 0;
11904 288079 : }
11905 :
11906 :
11907 : /* Restore openmp.cc private state from the saved state. */
11908 :
11909 : void
11910 288078 : gfc_omp_restore_state (struct gfc_omp_saved_state *state)
11911 : {
11912 288078 : omp_current_ctx = (struct fortran_omp_context *) state->ptrs[0];
11913 288078 : omp_current_do_code = (gfc_code *) state->ptrs[1];
11914 288078 : omp_current_do_collapse = state->ints[0];
11915 288078 : }
11916 :
11917 :
11918 : /* Note a DO iterator variable. This is special in !$omp parallel
11919 : construct, where they are predetermined private. */
11920 :
11921 : void
11922 32897 : gfc_resolve_do_iterator (gfc_code *code, gfc_symbol *sym, bool add_clause)
11923 : {
11924 32897 : if (omp_current_ctx == NULL)
11925 : return;
11926 :
11927 13094 : int i = omp_current_do_collapse;
11928 13094 : gfc_code *c = omp_current_do_code;
11929 :
11930 13094 : if (sym->attr.threadprivate)
11931 : return;
11932 :
11933 : /* !$omp do and !$omp parallel do iteration variable is predetermined
11934 : private just in the !$omp do resp. !$omp parallel do construct,
11935 : with no implications for the outer parallel constructs. */
11936 :
11937 17929 : while (i-- >= 1 && c)
11938 : {
11939 9490 : if (code == c)
11940 : return;
11941 4835 : c = find_nested_loop_in_chain (c->block->next);
11942 4835 : if (c && (c->op == EXEC_OMP_TILE || c->op == EXEC_OMP_UNROLL))
11943 : return;
11944 : }
11945 :
11946 : /* An openacc context may represent a data clause. Abort if so. */
11947 8439 : if (!omp_current_ctx->is_openmp && !oacc_is_loop (omp_current_ctx->code))
11948 : return;
11949 :
11950 7461 : if (omp_current_ctx->sharing_clauses->contains (sym))
11951 : return;
11952 :
11953 6459 : if (! omp_current_ctx->private_iterators->add (sym) && add_clause)
11954 : {
11955 6272 : gfc_omp_clauses *omp_clauses = omp_current_ctx->code->ext.omp_clauses;
11956 6272 : gfc_omp_namelist *p;
11957 :
11958 6272 : p = gfc_get_omp_namelist ();
11959 6272 : p->sym = sym;
11960 6272 : p->where = omp_current_ctx->code->loc;
11961 6272 : p->next = omp_clauses->lists[OMP_LIST_PRIVATE];
11962 6272 : omp_clauses->lists[OMP_LIST_PRIVATE] = p;
11963 : }
11964 : }
11965 :
11966 : static void
11967 698 : handle_local_var (gfc_symbol *sym)
11968 : {
11969 698 : if (sym->attr.flavor != FL_VARIABLE
11970 178 : || sym->as != NULL
11971 137 : || (sym->ts.type != BT_INTEGER && sym->ts.type != BT_REAL))
11972 : return;
11973 71 : gfc_resolve_do_iterator (sym->ns->code, sym, false);
11974 : }
11975 :
11976 : void
11977 334285 : gfc_resolve_omp_local_vars (gfc_namespace *ns)
11978 : {
11979 334285 : if (omp_current_ctx)
11980 452 : gfc_traverse_ns (ns, handle_local_var);
11981 334285 : }
11982 :
11983 :
11984 : /* Error checking on intervening code uses a code walker. */
11985 :
11986 : struct icode_error_state
11987 : {
11988 : const char *name;
11989 : bool errorp;
11990 : gfc_code *nested;
11991 : gfc_code *next;
11992 : };
11993 :
11994 : static int
11995 944 : icode_code_error_callback (gfc_code **codep,
11996 : int *walk_subtrees ATTRIBUTE_UNUSED, void *opaque)
11997 : {
11998 944 : gfc_code *code = *codep;
11999 944 : icode_error_state *state = (icode_error_state *)opaque;
12000 :
12001 : /* gfc_code_walker walks down CODE's next chain as well as
12002 : walking things that are actually nested in CODE. We need to
12003 : special-case traversal of outer blocks, so stop immediately if we
12004 : are heading down such a next chain. */
12005 944 : if (code == state->next)
12006 : return 1;
12007 :
12008 647 : switch (code->op)
12009 : {
12010 1 : case EXEC_DO:
12011 1 : case EXEC_DO_WHILE:
12012 1 : case EXEC_DO_CONCURRENT:
12013 1 : gfc_error ("%s cannot contain loop in intervening code at %L",
12014 : state->name, &code->loc);
12015 1 : state->errorp = true;
12016 1 : break;
12017 0 : case EXEC_CYCLE:
12018 0 : case EXEC_EXIT:
12019 : /* Errors have already been diagnosed in match_exit_cycle. */
12020 0 : state->errorp = true;
12021 0 : break;
12022 : case EXEC_OMP_ASSUME:
12023 : case EXEC_OMP_METADIRECTIVE:
12024 : /* Per OpenMP 6.0, some non-executable directives are allowed in
12025 : intervening code. */
12026 : break;
12027 477 : case EXEC_CALL:
12028 : /* Per OpenMP 5.2, the "omp_" prefix is reserved, so we don't have to
12029 : consider the possibility that some locally-bound definition
12030 : overrides the runtime routine. */
12031 477 : if (code->resolved_sym
12032 477 : && omp_runtime_api_procname (code->resolved_sym->name))
12033 : {
12034 1 : gfc_error ("%s cannot contain OpenMP API call in intervening code "
12035 : "at %L",
12036 : state->name, &code->loc);
12037 1 : state->errorp = true;
12038 : }
12039 : break;
12040 168 : default:
12041 168 : if (code->op >= EXEC_OMP_FIRST_OPENMP_EXEC
12042 168 : && code->op <= EXEC_OMP_LAST_OPENMP_EXEC)
12043 : {
12044 2 : gfc_error ("%s cannot contain OpenMP directive in intervening code "
12045 : "at %L",
12046 : state->name, &code->loc);
12047 2 : state->errorp = true;
12048 : }
12049 : }
12050 : return 0;
12051 : }
12052 :
12053 : static int
12054 1081 : icode_expr_error_callback (gfc_expr **expr,
12055 : int *walk_subtrees ATTRIBUTE_UNUSED, void *opaque)
12056 : {
12057 1081 : icode_error_state *state = (icode_error_state *)opaque;
12058 :
12059 1081 : switch ((*expr)->expr_type)
12060 : {
12061 : /* As for EXPR_CALL with "omp_"-prefixed symbols. */
12062 2 : case EXPR_FUNCTION:
12063 2 : {
12064 2 : gfc_symbol *sym = (*expr)->value.function.esym;
12065 2 : if (sym && omp_runtime_api_procname (sym->name))
12066 : {
12067 1 : gfc_error ("%s cannot contain OpenMP API call in intervening code "
12068 : "at %L",
12069 1 : state->name, &((*expr)->where));
12070 1 : state->errorp = true;
12071 : }
12072 : }
12073 :
12074 : break;
12075 : default:
12076 : break;
12077 : }
12078 :
12079 : /* FIXME: The description of canonical loop form in the OpenMP standard
12080 : also says "array expressions" are not permitted in intervening code.
12081 : That term is not defined in either the OpenMP spec or the Fortran
12082 : standard, although the latter uses it informally to refer to any
12083 : expression that is not scalar-valued. It is also apparently not the
12084 : thing GCC internally calls EXPR_ARRAY. It seems the intent of the
12085 : OpenMP restriction is to disallow elemental operations/intrinsics
12086 : (including things that are not expressions, like assignment
12087 : statements) that generate implicit loops over array operands
12088 : (even if the result is a scalar), but even if the spec said
12089 : that there is no list of all the cases that would be forbidden.
12090 : This is OpenMP issue 3326. */
12091 :
12092 1081 : return 0;
12093 : }
12094 :
12095 : static void
12096 267 : diagnose_intervening_code_errors_1 (gfc_code *chain,
12097 : struct icode_error_state *state)
12098 : {
12099 267 : gfc_code *code;
12100 1080 : for (code = chain; code; code = code->next)
12101 : {
12102 813 : if (code == state->nested)
12103 : /* Do not walk the nested loop or its body, we are only
12104 : interested in intervening code. */
12105 : ;
12106 636 : else if (code->op == EXEC_BLOCK
12107 636 : && find_nested_loop_in_block (code) == state->nested)
12108 : /* This block contains the nested loop, recurse on its
12109 : statements. */
12110 : {
12111 90 : gfc_namespace* ns = code->ext.block.ns;
12112 90 : diagnose_intervening_code_errors_1 (ns->code, state);
12113 : }
12114 : else
12115 : /* Treat the whole statement as a unit. */
12116 : {
12117 546 : gfc_code *temp = state->next;
12118 546 : state->next = code->next;
12119 546 : gfc_code_walker (&code, icode_code_error_callback,
12120 : icode_expr_error_callback, state);
12121 546 : state->next = temp;
12122 : }
12123 : }
12124 267 : }
12125 :
12126 : /* Diagnose intervening code errors in BLOCK with nested loop NESTED.
12127 : NAME is the user-friendly name of the OMP directive, used for error
12128 : messages. Returns true if any error was found. */
12129 : static bool
12130 177 : diagnose_intervening_code_errors (gfc_code *chain, const char *name,
12131 : gfc_code *nested)
12132 : {
12133 177 : struct icode_error_state state;
12134 177 : state.name = name;
12135 177 : state.errorp = false;
12136 177 : state.nested = nested;
12137 177 : state.next = NULL;
12138 0 : diagnose_intervening_code_errors_1 (chain, &state);
12139 177 : return state.errorp;
12140 : }
12141 :
12142 : /* Helper function for restructure_intervening_code: wrap CHAIN in
12143 : a marker to indicate that it is a structured block sequence. That
12144 : information will be used later on (in omp-low.cc) for error checking. */
12145 : static gfc_code *
12146 461 : make_structured_block (gfc_code *chain)
12147 : {
12148 461 : gcc_assert (chain);
12149 461 : gfc_namespace *ns = gfc_build_block_ns (gfc_current_ns);
12150 461 : gfc_code *result = gfc_get_code (EXEC_BLOCK);
12151 461 : result->op = EXEC_BLOCK;
12152 461 : result->ext.block.ns = ns;
12153 461 : result->ext.block.assoc = NULL;
12154 461 : result->loc = chain->loc;
12155 461 : ns->omp_structured_block = 1;
12156 461 : ns->code = chain;
12157 461 : return result;
12158 : }
12159 :
12160 : /* Push intervening code surrounding a loop, including nested scopes,
12161 : into the body of the loop. CHAINP is the pointer to the head of
12162 : the next-chain to scan, OUTER_LOOP is the EXEC_DO for the next outer
12163 : loop level, and COLLAPSE is the number of nested loops we need to
12164 : process.
12165 : Note that CHAINP may point at outer_loop->block->next when we
12166 : are scanning the body of a loop, but if there is an intervening block
12167 : CHAINP points into the block's chain rather than its enclosing outer
12168 : loop. This is why OUTER_LOOP is passed separately. */
12169 : static gfc_code *
12170 7170 : restructure_intervening_code (gfc_code **chainp, gfc_code *outer_loop,
12171 : int count)
12172 : {
12173 7170 : gfc_code *code;
12174 7170 : gfc_code *head = *chainp;
12175 7170 : gfc_code *tail = NULL;
12176 7170 : gfc_code *innermost_loop = NULL;
12177 :
12178 7434 : for (code = *chainp; code; code = code->next, chainp = &(*chainp)->next)
12179 : {
12180 7434 : if (code->op == EXEC_DO)
12181 : {
12182 : /* Cut CODE free from its chain, leaving the ends dangling. */
12183 7086 : *chainp = NULL;
12184 7086 : tail = code->next;
12185 7086 : code->next = NULL;
12186 :
12187 7086 : if (count == 1)
12188 : innermost_loop = code;
12189 : else
12190 2090 : innermost_loop
12191 2090 : = restructure_intervening_code (&code->block->next,
12192 : code, count - 1);
12193 : break;
12194 : }
12195 348 : else if (code->op == EXEC_BLOCK
12196 348 : && find_nested_loop_in_block (code))
12197 : {
12198 84 : gfc_namespace *ns = code->ext.block.ns;
12199 :
12200 : /* Cut CODE free from its chain, leaving the ends dangling. */
12201 84 : *chainp = NULL;
12202 84 : tail = code->next;
12203 84 : code->next = NULL;
12204 :
12205 84 : innermost_loop
12206 84 : = restructure_intervening_code (&ns->code, outer_loop,
12207 : count);
12208 :
12209 : /* At this point we have already pulled out the nested loop and
12210 : pointed outer_loop at it, and moved the intervening code that
12211 : was previously in the block into the body of innermost_loop.
12212 : Now we want to move the BLOCK itself so it wraps the entire
12213 : current body of innermost_loop. */
12214 84 : ns->code = innermost_loop->block->next;
12215 84 : innermost_loop->block->next = code;
12216 84 : break;
12217 : }
12218 : }
12219 :
12220 2174 : gcc_assert (innermost_loop);
12221 :
12222 : /* Now we have split the intervening code into two parts:
12223 : head is the start of the part before the loop/block, terminating
12224 : at *chainp, and tail is the part after it. Mark each part as
12225 : a structured block sequence, and splice the two parts around the
12226 : existing body of the innermost loop. */
12227 7170 : if (head != code)
12228 : {
12229 222 : gfc_code *block = make_structured_block (head);
12230 222 : if (innermost_loop->block->next)
12231 221 : gfc_append_code (block, innermost_loop->block->next);
12232 222 : innermost_loop->block->next = block;
12233 : }
12234 7170 : if (tail)
12235 : {
12236 239 : gfc_code *block = make_structured_block (tail);
12237 239 : if (innermost_loop->block->next)
12238 237 : gfc_append_code (innermost_loop->block->next, block);
12239 : else
12240 2 : innermost_loop->block->next = block;
12241 : }
12242 :
12243 : /* For loops, finally splice CODE into OUTER_LOOP. We already handled
12244 : relinking EXEC_BLOCK above. */
12245 7170 : if (code->op == EXEC_DO && outer_loop)
12246 7086 : outer_loop->block->next = code;
12247 :
12248 7170 : return innermost_loop;
12249 : }
12250 :
12251 : /* CODE is an OMP loop construct. Return true if VAR matches an iteration
12252 : variable outer to level DEPTH. */
12253 : static bool
12254 8083 : is_outer_iteration_variable (gfc_code *code, int depth, gfc_symbol *var)
12255 : {
12256 8083 : int i;
12257 8083 : gfc_code *do_code = code;
12258 :
12259 12610 : for (i = 1; i < depth; i++)
12260 : {
12261 5028 : do_code = find_nested_loop_in_chain (do_code->block->next);
12262 5028 : gcc_assert (do_code);
12263 5028 : if (do_code->op == EXEC_OMP_TILE || do_code->op == EXEC_OMP_UNROLL)
12264 : {
12265 51 : --i;
12266 51 : continue;
12267 : }
12268 4977 : gfc_symbol *ivar = do_code->ext.iterator->var->symtree->n.sym;
12269 4977 : if (var == ivar)
12270 : return true;
12271 : }
12272 : return false;
12273 : }
12274 :
12275 : /* Forward declaration for recursive functions. */
12276 : static gfc_code *
12277 : check_nested_loop_in_block (gfc_code *block, gfc_expr *expr, gfc_symbol *sym,
12278 : bool *bad);
12279 :
12280 : /* Like find_nested_loop_in_chain, but additionally check that EXPR
12281 : does not reference any variables bound in intervening EXEC_BLOCKs
12282 : and that SYM is not bound in such intervening blocks. Either EXPR or SYM
12283 : may be null. Sets *BAD to true if either test fails. */
12284 : static gfc_code *
12285 48165 : check_nested_loop_in_chain (gfc_code *chain, gfc_expr *expr, gfc_symbol *sym,
12286 : bool *bad)
12287 : {
12288 51769 : for (gfc_code *code = chain; code; code = code->next)
12289 : {
12290 51481 : if (code->op == EXEC_DO)
12291 : return code;
12292 4123 : else if (code->op == EXEC_OMP_TILE || code->op == EXEC_OMP_UNROLL)
12293 1682 : return check_nested_loop_in_chain (code->block->next, expr, sym, bad);
12294 2441 : else if (code->op == EXEC_BLOCK)
12295 : {
12296 807 : gfc_code *c = check_nested_loop_in_block (code, expr, sym, bad);
12297 807 : if (c)
12298 : return c;
12299 : }
12300 : }
12301 : return NULL;
12302 : }
12303 :
12304 : /* Code walker for block symtrees. It doesn't take any kind of state
12305 : argument, so use a static variable. */
12306 : static struct check_nested_loop_in_block_state_t {
12307 : gfc_expr *expr;
12308 : gfc_symbol *sym;
12309 : bool *bad;
12310 : } check_nested_loop_in_block_state;
12311 :
12312 : static void
12313 766 : check_nested_loop_in_block_symbol (gfc_symbol *sym)
12314 : {
12315 766 : if (sym == check_nested_loop_in_block_state.sym
12316 766 : || (check_nested_loop_in_block_state.expr
12317 567 : && gfc_find_sym_in_expr (sym,
12318 : check_nested_loop_in_block_state.expr)))
12319 5 : *check_nested_loop_in_block_state.bad = true;
12320 766 : }
12321 :
12322 : /* Return the first nested DO loop in BLOCK, or NULL if there
12323 : isn't one. Set *BAD to true if EXPR references any variables in BLOCK, or
12324 : SYM is bound in BLOCK. Either EXPR or SYM may be null. */
12325 : static gfc_code *
12326 807 : check_nested_loop_in_block (gfc_code *block, gfc_expr *expr,
12327 : gfc_symbol *sym, bool *bad)
12328 : {
12329 807 : gfc_namespace *ns;
12330 807 : gcc_assert (block->op == EXEC_BLOCK);
12331 807 : ns = block->ext.block.ns;
12332 807 : gcc_assert (ns);
12333 :
12334 : /* Skip the check if this block doesn't contain the nested loop, or
12335 : if we already know it's bad. */
12336 807 : gfc_code *result = check_nested_loop_in_chain (ns->code, expr, sym, bad);
12337 807 : if (result && !*bad)
12338 : {
12339 519 : check_nested_loop_in_block_state.expr = expr;
12340 519 : check_nested_loop_in_block_state.sym = sym;
12341 519 : check_nested_loop_in_block_state.bad = bad;
12342 519 : gfc_traverse_ns (ns, check_nested_loop_in_block_symbol);
12343 519 : check_nested_loop_in_block_state.expr = NULL;
12344 519 : check_nested_loop_in_block_state.sym = NULL;
12345 519 : check_nested_loop_in_block_state.bad = NULL;
12346 : }
12347 807 : return result;
12348 : }
12349 :
12350 : /* CODE is an OMP loop construct. Return true if EXPR references
12351 : any variables bound in intervening code, to level DEPTH. */
12352 : static bool
12353 22717 : expr_uses_intervening_var (gfc_code *code, int depth, gfc_expr *expr)
12354 : {
12355 22717 : int i;
12356 22717 : gfc_code *do_code = code;
12357 :
12358 58213 : for (i = 0; i < depth; i++)
12359 : {
12360 35499 : bool bad = false;
12361 35499 : do_code = check_nested_loop_in_chain (do_code->block->next,
12362 : expr, NULL, &bad);
12363 35499 : if (bad)
12364 3 : return true;
12365 : }
12366 : return false;
12367 : }
12368 :
12369 : /* CODE is an OMP loop construct. Return true if SYM is bound in
12370 : intervening code, to level DEPTH. */
12371 : static bool
12372 7582 : is_intervening_var (gfc_code *code, int depth, gfc_symbol *sym)
12373 : {
12374 7582 : int i;
12375 7582 : gfc_code *do_code = code;
12376 :
12377 19439 : for (i = 0; i < depth; i++)
12378 : {
12379 11859 : bool bad = false;
12380 11859 : do_code = check_nested_loop_in_chain (do_code->block->next,
12381 : NULL, sym, &bad);
12382 11859 : if (bad)
12383 2 : return true;
12384 : }
12385 : return false;
12386 : }
12387 :
12388 : /* CODE is an OMP loop construct. Return true if EXPR does not reference
12389 : any iteration variables outer to level DEPTH. */
12390 : static bool
12391 23796 : expr_is_invariant (gfc_code *code, int depth, gfc_expr *expr)
12392 : {
12393 23796 : int i;
12394 23796 : gfc_code *do_code = code;
12395 :
12396 37118 : for (i = 1; i < depth; i++)
12397 : {
12398 14388 : do_code = find_nested_loop_in_chain (do_code->block->next);
12399 14388 : gcc_assert (do_code);
12400 14388 : if (do_code->op == EXEC_OMP_TILE || do_code->op == EXEC_OMP_UNROLL)
12401 : {
12402 136 : --i;
12403 136 : continue;
12404 : }
12405 14252 : gfc_symbol *ivar = do_code->ext.iterator->var->symtree->n.sym;
12406 14252 : if (gfc_find_sym_in_expr (ivar, expr))
12407 : return false;
12408 : }
12409 : return true;
12410 : }
12411 :
12412 : /* CODE is an OMP loop construct. Return true if EXPR matches one of the
12413 : canonical forms for a bound expression. It may include references to
12414 : an iteration variable outer to level DEPTH; set OUTER_VARP if so. */
12415 : static bool
12416 15155 : bound_expr_is_canonical (gfc_code *code, int depth, gfc_expr *expr,
12417 : gfc_symbol **outer_varp)
12418 : {
12419 15155 : gfc_expr *expr2 = NULL;
12420 :
12421 : /* Rectangular case. */
12422 15155 : if (depth == 0 || expr_is_invariant (code, depth, expr))
12423 14587 : return true;
12424 :
12425 : /* Any simple variable that didn't pass expr_is_invariant must be
12426 : an outer_var. */
12427 568 : if (expr->expr_type == EXPR_VARIABLE && expr->rank == 0)
12428 : {
12429 63 : *outer_varp = expr->symtree->n.sym;
12430 63 : return true;
12431 : }
12432 :
12433 : /* All other permitted forms are binary operators. */
12434 505 : if (expr->expr_type != EXPR_OP)
12435 : return false;
12436 :
12437 : /* Check for plus/minus a loop invariant expr. */
12438 503 : if (expr->value.op.op == INTRINSIC_PLUS
12439 503 : || expr->value.op.op == INTRINSIC_MINUS)
12440 : {
12441 483 : if (expr_is_invariant (code, depth, expr->value.op.op1))
12442 48 : expr2 = expr->value.op.op2;
12443 435 : else if (expr_is_invariant (code, depth, expr->value.op.op2))
12444 434 : expr2 = expr->value.op.op1;
12445 : else
12446 : return false;
12447 : }
12448 : else
12449 : expr2 = expr;
12450 :
12451 : /* Check for a product with a loop-invariant expr. */
12452 502 : if (expr2->expr_type == EXPR_OP
12453 96 : && expr2->value.op.op == INTRINSIC_TIMES)
12454 : {
12455 96 : if (expr_is_invariant (code, depth, expr2->value.op.op1))
12456 40 : expr2 = expr2->value.op.op2;
12457 56 : else if (expr_is_invariant (code, depth, expr2->value.op.op2))
12458 53 : expr2 = expr2->value.op.op1;
12459 : else
12460 : return false;
12461 : }
12462 :
12463 : /* What's left must be a reference to an outer loop variable. */
12464 499 : if (expr2->expr_type == EXPR_VARIABLE
12465 499 : && expr2->rank == 0
12466 998 : && is_outer_iteration_variable (code, depth, expr2->symtree->n.sym))
12467 : {
12468 499 : *outer_varp = expr2->symtree->n.sym;
12469 499 : return true;
12470 : }
12471 :
12472 : return false;
12473 : }
12474 :
12475 : static void
12476 5420 : resolve_omp_do (gfc_code *code)
12477 : {
12478 5420 : gfc_code *do_code, *next;
12479 5420 : int i, count, non_generated_count;
12480 5420 : gfc_omp_namelist *n;
12481 5420 : gfc_symbol *dovar;
12482 5420 : const char *name;
12483 5420 : bool is_simd = false;
12484 5420 : bool errorp = false;
12485 5420 : bool perfect_nesting_errorp = false;
12486 5420 : bool imperfect = false;
12487 :
12488 5420 : switch (code->op)
12489 : {
12490 : case EXEC_OMP_DISTRIBUTE: name = "!$OMP DISTRIBUTE"; break;
12491 49 : case EXEC_OMP_DISTRIBUTE_PARALLEL_DO:
12492 49 : name = "!$OMP DISTRIBUTE PARALLEL DO";
12493 49 : break;
12494 32 : case EXEC_OMP_DISTRIBUTE_PARALLEL_DO_SIMD:
12495 32 : name = "!$OMP DISTRIBUTE PARALLEL DO SIMD";
12496 32 : is_simd = true;
12497 32 : break;
12498 50 : case EXEC_OMP_DISTRIBUTE_SIMD:
12499 50 : name = "!$OMP DISTRIBUTE SIMD";
12500 50 : is_simd = true;
12501 50 : break;
12502 1335 : case EXEC_OMP_DO: name = "!$OMP DO"; break;
12503 134 : case EXEC_OMP_DO_SIMD: name = "!$OMP DO SIMD"; is_simd = true; break;
12504 64 : case EXEC_OMP_LOOP: name = "!$OMP LOOP"; break;
12505 1216 : case EXEC_OMP_PARALLEL_DO: name = "!$OMP PARALLEL DO"; break;
12506 304 : case EXEC_OMP_PARALLEL_DO_SIMD:
12507 304 : name = "!$OMP PARALLEL DO SIMD";
12508 304 : is_simd = true;
12509 304 : break;
12510 46 : case EXEC_OMP_PARALLEL_LOOP: name = "!$OMP PARALLEL LOOP"; break;
12511 7 : case EXEC_OMP_PARALLEL_MASKED_TASKLOOP:
12512 7 : name = "!$OMP PARALLEL MASKED TASKLOOP";
12513 7 : break;
12514 10 : case EXEC_OMP_PARALLEL_MASKED_TASKLOOP_SIMD:
12515 10 : name = "!$OMP PARALLEL MASKED TASKLOOP SIMD";
12516 10 : is_simd = true;
12517 10 : break;
12518 12 : case EXEC_OMP_PARALLEL_MASTER_TASKLOOP:
12519 12 : name = "!$OMP PARALLEL MASTER TASKLOOP";
12520 12 : break;
12521 18 : case EXEC_OMP_PARALLEL_MASTER_TASKLOOP_SIMD:
12522 18 : name = "!$OMP PARALLEL MASTER TASKLOOP SIMD";
12523 18 : is_simd = true;
12524 18 : break;
12525 8 : case EXEC_OMP_MASKED_TASKLOOP: name = "!$OMP MASKED TASKLOOP"; break;
12526 14 : case EXEC_OMP_MASKED_TASKLOOP_SIMD:
12527 14 : name = "!$OMP MASKED TASKLOOP SIMD";
12528 14 : is_simd = true;
12529 14 : break;
12530 14 : case EXEC_OMP_MASTER_TASKLOOP: name = "!$OMP MASTER TASKLOOP"; break;
12531 19 : case EXEC_OMP_MASTER_TASKLOOP_SIMD:
12532 19 : name = "!$OMP MASTER TASKLOOP SIMD";
12533 19 : is_simd = true;
12534 19 : break;
12535 783 : case EXEC_OMP_SIMD: name = "!$OMP SIMD"; is_simd = true; break;
12536 88 : case EXEC_OMP_TARGET_PARALLEL_DO: name = "!$OMP TARGET PARALLEL DO"; break;
12537 19 : case EXEC_OMP_TARGET_PARALLEL_DO_SIMD:
12538 19 : name = "!$OMP TARGET PARALLEL DO SIMD";
12539 19 : is_simd = true;
12540 19 : break;
12541 16 : case EXEC_OMP_TARGET_PARALLEL_LOOP:
12542 16 : name = "!$OMP TARGET PARALLEL LOOP";
12543 16 : break;
12544 33 : case EXEC_OMP_TARGET_SIMD:
12545 33 : name = "!$OMP TARGET SIMD";
12546 33 : is_simd = true;
12547 33 : break;
12548 20 : case EXEC_OMP_TARGET_TEAMS_DISTRIBUTE:
12549 20 : name = "!$OMP TARGET TEAMS DISTRIBUTE";
12550 20 : break;
12551 75 : case EXEC_OMP_TARGET_TEAMS_DISTRIBUTE_PARALLEL_DO:
12552 75 : name = "!$OMP TARGET TEAMS DISTRIBUTE PARALLEL DO";
12553 75 : break;
12554 37 : case EXEC_OMP_TARGET_TEAMS_DISTRIBUTE_PARALLEL_DO_SIMD:
12555 37 : name = "!$OMP TARGET TEAMS DISTRIBUTE PARALLEL DO SIMD";
12556 37 : is_simd = true;
12557 37 : break;
12558 20 : case EXEC_OMP_TARGET_TEAMS_DISTRIBUTE_SIMD:
12559 20 : name = "!$OMP TARGET TEAMS DISTRIBUTE SIMD";
12560 20 : is_simd = true;
12561 20 : break;
12562 19 : case EXEC_OMP_TARGET_TEAMS_LOOP: name = "!$OMP TARGET TEAMS LOOP"; break;
12563 69 : case EXEC_OMP_TASKLOOP: name = "!$OMP TASKLOOP"; break;
12564 38 : case EXEC_OMP_TASKLOOP_SIMD:
12565 38 : name = "!$OMP TASKLOOP SIMD";
12566 38 : is_simd = true;
12567 38 : break;
12568 20 : case EXEC_OMP_TEAMS_DISTRIBUTE: name = "!$OMP TEAMS DISTRIBUTE"; break;
12569 37 : case EXEC_OMP_TEAMS_DISTRIBUTE_PARALLEL_DO:
12570 37 : name = "!$OMP TEAMS DISTRIBUTE PARALLEL DO";
12571 37 : break;
12572 60 : case EXEC_OMP_TEAMS_DISTRIBUTE_PARALLEL_DO_SIMD:
12573 60 : name = "!$OMP TEAMS DISTRIBUTE PARALLEL DO SIMD";
12574 60 : is_simd = true;
12575 60 : break;
12576 42 : case EXEC_OMP_TEAMS_DISTRIBUTE_SIMD:
12577 42 : name = "!$OMP TEAMS DISTRIBUTE SIMD";
12578 42 : is_simd = true;
12579 42 : break;
12580 48 : case EXEC_OMP_TEAMS_LOOP: name = "!$OMP TEAMS LOOP"; break;
12581 195 : case EXEC_OMP_TILE: name = "!$OMP TILE"; break;
12582 415 : case EXEC_OMP_UNROLL: name = "!$OMP UNROLL"; break;
12583 0 : default: gcc_unreachable ();
12584 : }
12585 :
12586 5420 : if (code->ext.omp_clauses)
12587 5420 : resolve_omp_clauses (code, code->ext.omp_clauses, NULL);
12588 :
12589 5420 : if (code->op == EXEC_OMP_TILE && code->ext.omp_clauses->sizes_list == NULL)
12590 0 : gfc_error ("SIZES clause is required on !$OMP TILE construct at %L",
12591 : &code->loc);
12592 :
12593 5420 : do_code = code->block->next;
12594 5420 : if (code->ext.omp_clauses->orderedc)
12595 : count = code->ext.omp_clauses->orderedc;
12596 5276 : else if (code->ext.omp_clauses->sizes_list)
12597 195 : count = gfc_expr_list_len (code->ext.omp_clauses->sizes_list);
12598 : else
12599 : {
12600 5081 : count = code->ext.omp_clauses->collapse;
12601 5081 : if (count <= 0)
12602 : count = 1;
12603 : }
12604 :
12605 5420 : non_generated_count = count;
12606 : /* While the spec defines the loop nest depth independently of the COLLAPSE
12607 : clause, in practice the middle end only pays attention to the COLLAPSE
12608 : depth and treats any further inner loops as the final-loop-body. So
12609 : here we also check canonical loop nest form only for the number of
12610 : outer loops specified by the COLLAPSE clause too. */
12611 8060 : for (i = 1; i <= count; i++)
12612 : {
12613 8060 : gfc_symbol *start_var = NULL, *end_var = NULL;
12614 : /* Parse errors are not recoverable. */
12615 8060 : if (do_code->op == EXEC_DO_WHILE)
12616 : {
12617 6 : gfc_error ("%s cannot be a DO WHILE or DO without loop control "
12618 : "at %L", name, &do_code->loc);
12619 106 : goto fail;
12620 : }
12621 8054 : if (do_code->op == EXEC_DO_CONCURRENT)
12622 : {
12623 4 : gfc_error ("%s cannot be a DO CONCURRENT loop at %L", name,
12624 : &do_code->loc);
12625 4 : goto fail;
12626 : }
12627 8050 : if (do_code->op == EXEC_OMP_TILE || do_code->op == EXEC_OMP_UNROLL)
12628 : {
12629 466 : if (do_code->op == EXEC_OMP_UNROLL)
12630 : {
12631 308 : if (!do_code->ext.omp_clauses->partial)
12632 : {
12633 53 : gfc_error ("Generated loop of UNROLL construct at %L "
12634 : "without PARTIAL clause does not have "
12635 : "canonical form", &do_code->loc);
12636 53 : goto fail;
12637 : }
12638 255 : else if (i != count)
12639 : {
12640 5 : gfc_error ("UNROLL construct at %L with PARTIAL clause "
12641 : "generates just one loop with canonical form "
12642 : "but %d loops are needed",
12643 5 : &do_code->loc, count - i + 1);
12644 5 : goto fail;
12645 : }
12646 : }
12647 158 : else if (do_code->op == EXEC_OMP_TILE)
12648 : {
12649 158 : if (do_code->ext.omp_clauses->sizes_list == NULL)
12650 : /* This should have been diagnosed earlier already. */
12651 0 : return;
12652 158 : int l = gfc_expr_list_len (do_code->ext.omp_clauses->sizes_list);
12653 158 : if (count - i + 1 > l)
12654 : {
12655 14 : gfc_error ("TILE construct at %L generates %d loops "
12656 : "with canonical form but %d loops are needed",
12657 : &do_code->loc, l, count - i + 1);
12658 14 : goto fail;
12659 : }
12660 : }
12661 394 : if (do_code->ext.omp_clauses && do_code->ext.omp_clauses->erroneous)
12662 17 : goto fail;
12663 377 : if (imperfect && !perfect_nesting_errorp)
12664 : {
12665 4 : sorry_at (gfc_get_location (&do_code->loc),
12666 : "Imperfectly nested loop using generated loops");
12667 4 : errorp = true;
12668 : }
12669 377 : if (non_generated_count == count)
12670 329 : non_generated_count = i - 1;
12671 377 : --i;
12672 377 : do_code = do_code->block->next;
12673 377 : continue;
12674 377 : }
12675 7584 : gcc_assert (do_code->op == EXEC_DO);
12676 7584 : if (do_code->ext.iterator->var->ts.type != BT_INTEGER)
12677 : {
12678 3 : gfc_error ("%s iteration variable must be of type integer at %L",
12679 : name, &do_code->loc);
12680 3 : errorp = true;
12681 : }
12682 7584 : dovar = do_code->ext.iterator->var->symtree->n.sym;
12683 7584 : if (dovar->attr.threadprivate)
12684 : {
12685 0 : gfc_error ("%s iteration variable must not be THREADPRIVATE "
12686 : "at %L", name, &do_code->loc);
12687 0 : errorp = true;
12688 : }
12689 7584 : if (code->ext.omp_clauses)
12690 303360 : for (enum gfc_omp_list_type list = OMP_LIST_FIRST; list < OMP_LIST_NUM;
12691 295776 : list = gfc_omp_list_type (list + 1))
12692 97461 : if (!is_simd || code->ext.omp_clauses->collapse > 1
12693 295776 : ? (list != OMP_LIST_PRIVATE && list != OMP_LIST_LASTPRIVATE
12694 254670 : && list != OMP_LIST_ALLOCATE)
12695 41106 : : (list != OMP_LIST_PRIVATE && list != OMP_LIST_LASTPRIVATE
12696 41106 : && list != OMP_LIST_ALLOCATE && list != OMP_LIST_LINEAR))
12697 276351 : for (n = code->ext.omp_clauses->lists[list]; n; n = n->next)
12698 4381 : if (dovar == n->sym)
12699 : {
12700 5 : if (!is_simd || code->ext.omp_clauses->collapse > 1)
12701 4 : gfc_error ("%s iteration variable present on clause "
12702 : "other than PRIVATE, LASTPRIVATE or "
12703 : "ALLOCATE at %L", name, &do_code->loc);
12704 : else
12705 1 : gfc_error ("%s iteration variable present on clause "
12706 : "other than PRIVATE, LASTPRIVATE, ALLOCATE or "
12707 : "LINEAR at %L", name, &do_code->loc);
12708 : errorp = true;
12709 : }
12710 7584 : if (is_outer_iteration_variable (code, i, dovar))
12711 : {
12712 2 : gfc_error ("%s iteration variable used in more than one loop at %L",
12713 : name, &do_code->loc);
12714 2 : errorp = true;
12715 : }
12716 7582 : else if (is_intervening_var (code, i, dovar))
12717 : {
12718 2 : gfc_error ("%s iteration variable at %L is bound in "
12719 : "intervening code",
12720 : name, &do_code->loc);
12721 2 : errorp = true;
12722 : }
12723 7580 : else if (!bound_expr_is_canonical (code, i,
12724 7580 : do_code->ext.iterator->start,
12725 : &start_var))
12726 : {
12727 4 : gfc_error ("%s loop start expression not in canonical form at %L",
12728 : name, &do_code->loc);
12729 4 : errorp = true;
12730 : }
12731 7576 : else if (expr_uses_intervening_var (code, i,
12732 7576 : do_code->ext.iterator->start))
12733 : {
12734 1 : gfc_error ("%s loop start expression at %L uses variable bound in "
12735 : "intervening code",
12736 : name, &do_code->loc);
12737 1 : errorp = true;
12738 : }
12739 7575 : else if (!bound_expr_is_canonical (code, i,
12740 7575 : do_code->ext.iterator->end,
12741 : &end_var))
12742 : {
12743 2 : gfc_error ("%s loop end expression not in canonical form at %L",
12744 : name, &do_code->loc);
12745 2 : errorp = true;
12746 : }
12747 7573 : else if (expr_uses_intervening_var (code, i,
12748 7573 : do_code->ext.iterator->end))
12749 : {
12750 1 : gfc_error ("%s loop end expression at %L uses variable bound in "
12751 : "intervening code",
12752 : name, &do_code->loc);
12753 1 : errorp = true;
12754 : }
12755 7572 : else if (start_var && end_var && start_var != end_var)
12756 : {
12757 1 : gfc_error ("%s loop bounds reference different "
12758 : "iteration variables at %L", name, &do_code->loc);
12759 1 : errorp = true;
12760 : }
12761 7571 : else if (!expr_is_invariant (code, i, do_code->ext.iterator->step))
12762 : {
12763 3 : gfc_error ("%s loop increment not in canonical form at %L",
12764 : name, &do_code->loc);
12765 3 : errorp = true;
12766 : }
12767 7568 : else if (expr_uses_intervening_var (code, i,
12768 7568 : do_code->ext.iterator->step))
12769 : {
12770 1 : gfc_error ("%s loop increment expression at %L uses variable "
12771 : "bound in intervening code",
12772 : name, &do_code->loc);
12773 1 : errorp = true;
12774 : }
12775 7584 : if (start_var || end_var)
12776 : {
12777 528 : code->ext.omp_clauses->non_rectangular = 1;
12778 528 : if (i > non_generated_count)
12779 : {
12780 3 : sorry_at (gfc_get_location (&do_code->loc),
12781 : "Non-rectangular loops from generated loops "
12782 : "unsupported");
12783 3 : errorp = true;
12784 : }
12785 : }
12786 :
12787 : /* Only parse loop body into nested loop and intervening code if
12788 : there are supposed to be more loops in the nest to collapse. */
12789 7584 : if (i == count)
12790 : break;
12791 :
12792 2270 : next = find_nested_loop_in_chain (do_code->block->next);
12793 :
12794 2270 : if (!next)
12795 : {
12796 : /* Parse error, can't recover from this. */
12797 7 : gfc_error ("not enough DO loops for collapsed %s (level %d) at %L",
12798 : name, i, &code->loc);
12799 7 : goto fail;
12800 : }
12801 2263 : else if (next != do_code->block->next
12802 2103 : || (next->next && next->next->op != EXEC_CONTINUE))
12803 : /* Imperfectly nested loop found. */
12804 : {
12805 : /* Only diagnose violation of imperfect nesting constraints once. */
12806 177 : if (!perfect_nesting_errorp)
12807 : {
12808 176 : if (code->ext.omp_clauses->orderedc)
12809 : {
12810 3 : gfc_error ("%s inner loops must be perfectly nested with "
12811 : "ORDERED clause at %L",
12812 : name, &code->loc);
12813 3 : perfect_nesting_errorp = true;
12814 : }
12815 173 : else if (code->ext.omp_clauses->lists[OMP_LIST_REDUCTION_INSCAN])
12816 : {
12817 2 : gfc_error ("%s inner loops must be perfectly nested with "
12818 : "REDUCTION INSCAN clause at %L",
12819 : name, &code->loc);
12820 2 : perfect_nesting_errorp = true;
12821 : }
12822 171 : else if (code->op == EXEC_OMP_TILE)
12823 : {
12824 8 : gfc_error ("%s inner loops must be perfectly nested at %L",
12825 : name, &code->loc);
12826 8 : perfect_nesting_errorp = true;
12827 : }
12828 13 : if (perfect_nesting_errorp)
12829 : errorp = true;
12830 : }
12831 177 : if (diagnose_intervening_code_errors (do_code->block->next,
12832 : name, next))
12833 5 : errorp = true;
12834 : imperfect = true;
12835 : }
12836 2263 : do_code = next;
12837 : }
12838 :
12839 : /* Give up now if we found any constraint violations. */
12840 5314 : if (errorp)
12841 : {
12842 48 : fail:
12843 154 : if (code->ext.omp_clauses)
12844 154 : code->ext.omp_clauses->erroneous = 1;
12845 154 : return;
12846 : }
12847 :
12848 5266 : if (non_generated_count)
12849 4996 : restructure_intervening_code (&code->block->next, code,
12850 : non_generated_count);
12851 : }
12852 :
12853 : /* Resolve the context selector. In particular, SKIP_P is set to true,
12854 : the context can never be matched. */
12855 :
12856 : static void
12857 764 : gfc_resolve_omp_context_selector (gfc_omp_set_selector *oss,
12858 : bool is_metadirective, bool *skip_p)
12859 : {
12860 764 : if (skip_p)
12861 310 : *skip_p = false;
12862 1453 : for (gfc_omp_set_selector *set_selector = oss; set_selector;
12863 689 : set_selector = set_selector->next)
12864 1485 : for (gfc_omp_selector *os = set_selector->trait_selectors; os; os = os->next)
12865 : {
12866 814 : if (os->score)
12867 : {
12868 52 : if (!gfc_resolve_expr (os->score)
12869 52 : || os->score->ts.type != BT_INTEGER
12870 104 : || os->score->rank != 0)
12871 : {
12872 0 : gfc_error ("%<score%> argument must be constant integer "
12873 0 : "expression at %L", &os->score->where);
12874 0 : gfc_free_expr (os->score);
12875 0 : os->score = nullptr;
12876 : }
12877 52 : else if (os->score->expr_type == EXPR_CONSTANT
12878 52 : && mpz_sgn (os->score->value.integer) < 0)
12879 : {
12880 1 : gfc_error ("%<score%> argument must be non-negative at %L",
12881 : &os->score->where);
12882 1 : gfc_free_expr (os->score);
12883 1 : os->score = nullptr;
12884 : }
12885 : }
12886 :
12887 814 : if (os->code == OMP_TRAIT_INVALID)
12888 : break;
12889 796 : enum omp_tp_type property_kind = omp_ts_map[os->code].tp_type;
12890 796 : gfc_omp_trait_property *otp = os->properties;
12891 :
12892 796 : if (!otp)
12893 409 : continue;
12894 387 : switch (property_kind)
12895 : {
12896 139 : case OMP_TRAIT_PROPERTY_DEV_NUM_EXPR:
12897 139 : case OMP_TRAIT_PROPERTY_BOOL_EXPR:
12898 139 : if (!gfc_resolve_expr (otp->expr)
12899 138 : || (property_kind == OMP_TRAIT_PROPERTY_BOOL_EXPR
12900 124 : && otp->expr->ts.type != BT_LOGICAL)
12901 137 : || (property_kind == OMP_TRAIT_PROPERTY_DEV_NUM_EXPR
12902 14 : && otp->expr->ts.type != BT_INTEGER)
12903 137 : || otp->expr->rank != 0
12904 276 : || (!is_metadirective && otp->expr->expr_type != EXPR_CONSTANT))
12905 : {
12906 3 : if (is_metadirective)
12907 : {
12908 0 : if (property_kind == OMP_TRAIT_PROPERTY_BOOL_EXPR)
12909 0 : gfc_error ("property must be a "
12910 : "logical expression at %L",
12911 0 : &otp->expr->where);
12912 : else
12913 0 : gfc_error ("property must be an "
12914 : "integer expression at %L",
12915 0 : &otp->expr->where);
12916 : }
12917 : else
12918 : {
12919 3 : if (property_kind == OMP_TRAIT_PROPERTY_BOOL_EXPR)
12920 2 : gfc_error ("property must be a constant "
12921 : "logical expression at %L",
12922 2 : &otp->expr->where);
12923 : else
12924 1 : gfc_error ("property must be a constant "
12925 : "integer expression at %L",
12926 1 : &otp->expr->where);
12927 : }
12928 : /* Prevent later ICEs. */
12929 3 : gfc_expr *e;
12930 3 : if (property_kind == OMP_TRAIT_PROPERTY_BOOL_EXPR)
12931 2 : e = gfc_get_logical_expr (gfc_default_logical_kind,
12932 2 : &otp->expr->where, true);
12933 : else
12934 1 : e = gfc_get_int_expr (gfc_default_integer_kind,
12935 1 : &otp->expr->where, 0);
12936 3 : gfc_free_expr (otp->expr);
12937 3 : otp->expr = e;
12938 3 : continue;
12939 3 : }
12940 : /* Device number must be conforming, which includes
12941 : omp_initial_device (-1), omp_invalid_device (-4),
12942 : and omp_default_device (-5). */
12943 136 : if (property_kind == OMP_TRAIT_PROPERTY_DEV_NUM_EXPR
12944 14 : && otp->expr->expr_type == EXPR_CONSTANT
12945 5 : && mpz_sgn (otp->expr->value.integer) < 0
12946 3 : && mpz_cmp_si (otp->expr->value.integer, -1) != 0
12947 2 : && mpz_cmp_si (otp->expr->value.integer, -4) != 0
12948 1 : && mpz_cmp_si (otp->expr->value.integer, -5) != 0)
12949 1 : gfc_error ("property must be a conforming device number at %L",
12950 : &otp->expr->where);
12951 : break;
12952 : default:
12953 : break;
12954 : }
12955 : /* This only handles one specific case: User condition.
12956 : FIXME: Handle more cases by calling omp_context_selector_matches;
12957 : unfortunately, we cannot generate the tree here as, e.g., PARM_DECL
12958 : backend decl are not available at this stage - but might be used in,
12959 : e.g. user conditions. See PR122361. */
12960 384 : if (skip_p && otp
12961 138 : && os->code == OMP_TRAIT_USER_CONDITION
12962 81 : && otp->expr->expr_type == EXPR_CONSTANT
12963 14 : && otp->expr->value.logical == false)
12964 12 : *skip_p = true;
12965 : }
12966 764 : }
12967 :
12968 :
12969 : static void
12970 138 : resolve_omp_metadirective (gfc_code *code, gfc_namespace *ns)
12971 : {
12972 138 : gfc_omp_variant *variant = code->ext.omp_variants;
12973 138 : gfc_omp_variant *prev_variant = variant;
12974 :
12975 448 : while (variant)
12976 : {
12977 310 : bool skip;
12978 310 : gfc_resolve_omp_context_selector (variant->selectors, true, &skip);
12979 310 : gfc_code *variant_code = variant->code;
12980 310 : gfc_resolve_code (variant_code, ns);
12981 310 : if (skip)
12982 : {
12983 : /* The following should only be true if an error occurred
12984 : as the 'otherwise' clause should always match. */
12985 12 : if (variant == code->ext.omp_variants && !variant->next)
12986 : break;
12987 12 : gfc_omp_variant *tmp = variant;
12988 12 : if (variant == code->ext.omp_variants)
12989 11 : variant = prev_variant = code->ext.omp_variants = variant->next;
12990 : else
12991 1 : variant = prev_variant->next = variant->next;
12992 12 : gfc_free_omp_set_selector_list (tmp->selectors);
12993 12 : free (tmp);
12994 : }
12995 : else
12996 : {
12997 298 : prev_variant = variant;
12998 298 : variant = variant->next;
12999 : }
13000 : }
13001 : /* Replace metadirective by its body if only 'nothing' remains. */
13002 138 : if (!code->ext.omp_variants->next && code->ext.omp_variants->stmt == ST_NONE)
13003 : {
13004 11 : gfc_code *next = code->next;
13005 11 : gfc_code *inner = code->ext.omp_variants->code;
13006 11 : gfc_free_omp_set_selector_list (code->ext.omp_variants->selectors);
13007 11 : free (code->ext.omp_variants);
13008 11 : *code = *inner;
13009 11 : free (inner);
13010 11 : while (code->next)
13011 : code = code->next;
13012 11 : code->next = next;
13013 : }
13014 138 : }
13015 :
13016 :
13017 : static gfc_statement
13018 63 : omp_code_to_statement (gfc_code *code)
13019 : {
13020 63 : switch (code->op)
13021 : {
13022 : case EXEC_OMP_PARALLEL:
13023 : return ST_OMP_PARALLEL;
13024 0 : case EXEC_OMP_PARALLEL_MASKED:
13025 0 : return ST_OMP_PARALLEL_MASKED;
13026 0 : case EXEC_OMP_PARALLEL_MASKED_TASKLOOP:
13027 0 : return ST_OMP_PARALLEL_MASKED_TASKLOOP;
13028 0 : case EXEC_OMP_PARALLEL_MASKED_TASKLOOP_SIMD:
13029 0 : return ST_OMP_PARALLEL_MASKED_TASKLOOP_SIMD;
13030 0 : case EXEC_OMP_PARALLEL_MASTER:
13031 0 : return ST_OMP_PARALLEL_MASTER;
13032 0 : case EXEC_OMP_PARALLEL_MASTER_TASKLOOP:
13033 0 : return ST_OMP_PARALLEL_MASTER_TASKLOOP;
13034 0 : case EXEC_OMP_PARALLEL_MASTER_TASKLOOP_SIMD:
13035 0 : return ST_OMP_PARALLEL_MASTER_TASKLOOP_SIMD;
13036 1 : case EXEC_OMP_PARALLEL_SECTIONS:
13037 1 : return ST_OMP_PARALLEL_SECTIONS;
13038 1 : case EXEC_OMP_SECTIONS:
13039 1 : return ST_OMP_SECTIONS;
13040 1 : case EXEC_OMP_ORDERED:
13041 1 : return ST_OMP_ORDERED;
13042 1 : case EXEC_OMP_CRITICAL:
13043 1 : return ST_OMP_CRITICAL;
13044 0 : case EXEC_OMP_MASKED:
13045 0 : return ST_OMP_MASKED;
13046 0 : case EXEC_OMP_MASKED_TASKLOOP:
13047 0 : return ST_OMP_MASKED_TASKLOOP;
13048 0 : case EXEC_OMP_MASKED_TASKLOOP_SIMD:
13049 0 : return ST_OMP_MASKED_TASKLOOP_SIMD;
13050 1 : case EXEC_OMP_MASTER:
13051 1 : return ST_OMP_MASTER;
13052 0 : case EXEC_OMP_MASTER_TASKLOOP:
13053 0 : return ST_OMP_MASTER_TASKLOOP;
13054 0 : case EXEC_OMP_MASTER_TASKLOOP_SIMD:
13055 0 : return ST_OMP_MASTER_TASKLOOP_SIMD;
13056 1 : case EXEC_OMP_SINGLE:
13057 1 : return ST_OMP_SINGLE;
13058 1 : case EXEC_OMP_TASK:
13059 1 : return ST_OMP_TASK;
13060 1 : case EXEC_OMP_WORKSHARE:
13061 1 : return ST_OMP_WORKSHARE;
13062 1 : case EXEC_OMP_PARALLEL_WORKSHARE:
13063 1 : return ST_OMP_PARALLEL_WORKSHARE;
13064 3 : case EXEC_OMP_DO:
13065 3 : return ST_OMP_DO;
13066 0 : case EXEC_OMP_LOOP:
13067 0 : return ST_OMP_LOOP;
13068 0 : case EXEC_OMP_ALLOCATE:
13069 0 : return ST_OMP_ALLOCATE_EXEC;
13070 0 : case EXEC_OMP_ALLOCATORS:
13071 0 : return ST_OMP_ALLOCATORS;
13072 0 : case EXEC_OMP_ASSUME:
13073 0 : return ST_OMP_ASSUME;
13074 1 : case EXEC_OMP_ATOMIC:
13075 1 : return ST_OMP_ATOMIC;
13076 1 : case EXEC_OMP_BARRIER:
13077 1 : return ST_OMP_BARRIER;
13078 1 : case EXEC_OMP_CANCEL:
13079 1 : return ST_OMP_CANCEL;
13080 1 : case EXEC_OMP_CANCELLATION_POINT:
13081 1 : return ST_OMP_CANCELLATION_POINT;
13082 0 : case EXEC_OMP_ERROR:
13083 0 : return ST_OMP_ERROR;
13084 1 : case EXEC_OMP_FLUSH:
13085 1 : return ST_OMP_FLUSH;
13086 0 : case EXEC_OMP_INTEROP:
13087 0 : return ST_OMP_INTEROP;
13088 1 : case EXEC_OMP_DISTRIBUTE:
13089 1 : return ST_OMP_DISTRIBUTE;
13090 1 : case EXEC_OMP_DISTRIBUTE_PARALLEL_DO:
13091 1 : return ST_OMP_DISTRIBUTE_PARALLEL_DO;
13092 1 : case EXEC_OMP_DISTRIBUTE_PARALLEL_DO_SIMD:
13093 1 : return ST_OMP_DISTRIBUTE_PARALLEL_DO_SIMD;
13094 1 : case EXEC_OMP_DISTRIBUTE_SIMD:
13095 1 : return ST_OMP_DISTRIBUTE_SIMD;
13096 1 : case EXEC_OMP_DO_SIMD:
13097 1 : return ST_OMP_DO_SIMD;
13098 0 : case EXEC_OMP_SCAN:
13099 0 : return ST_OMP_SCAN;
13100 0 : case EXEC_OMP_SCOPE:
13101 0 : return ST_OMP_SCOPE;
13102 1 : case EXEC_OMP_SIMD:
13103 1 : return ST_OMP_SIMD;
13104 1 : case EXEC_OMP_TARGET:
13105 1 : return ST_OMP_TARGET;
13106 1 : case EXEC_OMP_TARGET_DATA:
13107 1 : return ST_OMP_TARGET_DATA;
13108 1 : case EXEC_OMP_TARGET_ENTER_DATA:
13109 1 : return ST_OMP_TARGET_ENTER_DATA;
13110 1 : case EXEC_OMP_TARGET_EXIT_DATA:
13111 1 : return ST_OMP_TARGET_EXIT_DATA;
13112 1 : case EXEC_OMP_TARGET_PARALLEL:
13113 1 : return ST_OMP_TARGET_PARALLEL;
13114 1 : case EXEC_OMP_TARGET_PARALLEL_DO:
13115 1 : return ST_OMP_TARGET_PARALLEL_DO;
13116 1 : case EXEC_OMP_TARGET_PARALLEL_DO_SIMD:
13117 1 : return ST_OMP_TARGET_PARALLEL_DO_SIMD;
13118 0 : case EXEC_OMP_TARGET_PARALLEL_LOOP:
13119 0 : return ST_OMP_TARGET_PARALLEL_LOOP;
13120 1 : case EXEC_OMP_TARGET_SIMD:
13121 1 : return ST_OMP_TARGET_SIMD;
13122 1 : case EXEC_OMP_TARGET_TEAMS:
13123 1 : return ST_OMP_TARGET_TEAMS;
13124 1 : case EXEC_OMP_TARGET_TEAMS_DISTRIBUTE:
13125 1 : return ST_OMP_TARGET_TEAMS_DISTRIBUTE;
13126 1 : case EXEC_OMP_TARGET_TEAMS_DISTRIBUTE_PARALLEL_DO:
13127 1 : return ST_OMP_TARGET_TEAMS_DISTRIBUTE_PARALLEL_DO;
13128 1 : case EXEC_OMP_TARGET_TEAMS_DISTRIBUTE_PARALLEL_DO_SIMD:
13129 1 : return ST_OMP_TARGET_TEAMS_DISTRIBUTE_PARALLEL_DO_SIMD;
13130 1 : case EXEC_OMP_TARGET_TEAMS_DISTRIBUTE_SIMD:
13131 1 : return ST_OMP_TARGET_TEAMS_DISTRIBUTE_SIMD;
13132 0 : case EXEC_OMP_TARGET_TEAMS_LOOP:
13133 0 : return ST_OMP_TARGET_TEAMS_LOOP;
13134 1 : case EXEC_OMP_TARGET_UPDATE:
13135 1 : return ST_OMP_TARGET_UPDATE;
13136 1 : case EXEC_OMP_TASKGROUP:
13137 1 : return ST_OMP_TASKGROUP;
13138 1 : case EXEC_OMP_TASKLOOP:
13139 1 : return ST_OMP_TASKLOOP;
13140 1 : case EXEC_OMP_TASKLOOP_SIMD:
13141 1 : return ST_OMP_TASKLOOP_SIMD;
13142 1 : case EXEC_OMP_TASKWAIT:
13143 1 : return ST_OMP_TASKWAIT;
13144 1 : case EXEC_OMP_TASKYIELD:
13145 1 : return ST_OMP_TASKYIELD;
13146 1 : case EXEC_OMP_TEAMS:
13147 1 : return ST_OMP_TEAMS;
13148 1 : case EXEC_OMP_TEAMS_DISTRIBUTE:
13149 1 : return ST_OMP_TEAMS_DISTRIBUTE;
13150 1 : case EXEC_OMP_TEAMS_DISTRIBUTE_PARALLEL_DO:
13151 1 : return ST_OMP_TEAMS_DISTRIBUTE_PARALLEL_DO;
13152 1 : case EXEC_OMP_TEAMS_DISTRIBUTE_PARALLEL_DO_SIMD:
13153 1 : return ST_OMP_TEAMS_DISTRIBUTE_PARALLEL_DO_SIMD;
13154 1 : case EXEC_OMP_TEAMS_DISTRIBUTE_SIMD:
13155 1 : return ST_OMP_TEAMS_DISTRIBUTE_SIMD;
13156 0 : case EXEC_OMP_TEAMS_LOOP:
13157 0 : return ST_OMP_TEAMS_LOOP;
13158 6 : case EXEC_OMP_PARALLEL_DO:
13159 6 : return ST_OMP_PARALLEL_DO;
13160 1 : case EXEC_OMP_PARALLEL_DO_SIMD:
13161 1 : return ST_OMP_PARALLEL_DO_SIMD;
13162 0 : case EXEC_OMP_PARALLEL_LOOP:
13163 0 : return ST_OMP_PARALLEL_LOOP;
13164 1 : case EXEC_OMP_DEPOBJ:
13165 1 : return ST_OMP_DEPOBJ;
13166 0 : case EXEC_OMP_TILE:
13167 0 : return ST_OMP_TILE;
13168 0 : case EXEC_OMP_UNROLL:
13169 0 : return ST_OMP_UNROLL;
13170 0 : case EXEC_OMP_DISPATCH:
13171 0 : return ST_OMP_DISPATCH;
13172 0 : default:
13173 0 : gcc_unreachable ();
13174 : }
13175 : }
13176 :
13177 : static gfc_statement
13178 63 : oacc_code_to_statement (gfc_code *code)
13179 : {
13180 63 : switch (code->op)
13181 : {
13182 : case EXEC_OACC_PARALLEL:
13183 : return ST_OACC_PARALLEL;
13184 : case EXEC_OACC_KERNELS:
13185 : return ST_OACC_KERNELS;
13186 : case EXEC_OACC_SERIAL:
13187 : return ST_OACC_SERIAL;
13188 : case EXEC_OACC_DATA:
13189 : return ST_OACC_DATA;
13190 : case EXEC_OACC_HOST_DATA:
13191 : return ST_OACC_HOST_DATA;
13192 : case EXEC_OACC_PARALLEL_LOOP:
13193 : return ST_OACC_PARALLEL_LOOP;
13194 : case EXEC_OACC_KERNELS_LOOP:
13195 : return ST_OACC_KERNELS_LOOP;
13196 : case EXEC_OACC_SERIAL_LOOP:
13197 : return ST_OACC_SERIAL_LOOP;
13198 : case EXEC_OACC_LOOP:
13199 : return ST_OACC_LOOP;
13200 : case EXEC_OACC_ATOMIC:
13201 : return ST_OACC_ATOMIC;
13202 : case EXEC_OACC_ROUTINE:
13203 : return ST_OACC_ROUTINE;
13204 : case EXEC_OACC_UPDATE:
13205 : return ST_OACC_UPDATE;
13206 : case EXEC_OACC_WAIT:
13207 : return ST_OACC_WAIT;
13208 : case EXEC_OACC_CACHE:
13209 : return ST_OACC_CACHE;
13210 : case EXEC_OACC_ENTER_DATA:
13211 : return ST_OACC_ENTER_DATA;
13212 : case EXEC_OACC_EXIT_DATA:
13213 : return ST_OACC_EXIT_DATA;
13214 : case EXEC_OACC_DECLARE:
13215 : return ST_OACC_DECLARE;
13216 0 : default:
13217 0 : gcc_unreachable ();
13218 : }
13219 : }
13220 :
13221 : static void
13222 13168 : resolve_oacc_directive_inside_omp_region (gfc_code *code)
13223 : {
13224 13168 : if (omp_current_ctx != NULL && omp_current_ctx->is_openmp)
13225 : {
13226 11 : gfc_statement st = omp_code_to_statement (omp_current_ctx->code);
13227 11 : gfc_statement oacc_st = oacc_code_to_statement (code);
13228 11 : gfc_error ("The %s directive cannot be specified within "
13229 : "a %s region at %L", gfc_ascii_statement (oacc_st),
13230 : gfc_ascii_statement (st), &code->loc);
13231 : }
13232 13168 : }
13233 :
13234 : static void
13235 21062 : resolve_omp_directive_inside_oacc_region (gfc_code *code)
13236 : {
13237 21062 : if (omp_current_ctx != NULL && !omp_current_ctx->is_openmp)
13238 : {
13239 52 : gfc_statement st = oacc_code_to_statement (omp_current_ctx->code);
13240 52 : gfc_statement omp_st = omp_code_to_statement (code);
13241 52 : gfc_error ("The %s directive cannot be specified within "
13242 : "a %s region at %L", gfc_ascii_statement (omp_st),
13243 : gfc_ascii_statement (st), &code->loc);
13244 : }
13245 21062 : }
13246 :
13247 :
13248 : static void
13249 5272 : resolve_oacc_nested_loops (gfc_code *code, gfc_code* do_code, int collapse,
13250 : const char *clause)
13251 : {
13252 5272 : gfc_symbol *dovar;
13253 5272 : gfc_code *c;
13254 5272 : int i;
13255 :
13256 5792 : for (i = 1; i <= collapse; i++)
13257 : {
13258 5792 : if (do_code->op == EXEC_DO_WHILE)
13259 : {
13260 10 : gfc_error ("!$ACC LOOP cannot be a DO WHILE or DO without loop control "
13261 : "at %L", &do_code->loc);
13262 10 : break;
13263 : }
13264 5782 : if (do_code->op == EXEC_DO_CONCURRENT)
13265 : {
13266 3 : gfc_error ("!$ACC LOOP cannot be a DO CONCURRENT loop at %L",
13267 : &do_code->loc);
13268 3 : break;
13269 : }
13270 5779 : gcc_assert (do_code->op == EXEC_DO);
13271 5779 : if (do_code->ext.iterator->var->ts.type != BT_INTEGER)
13272 6 : gfc_error ("!$ACC LOOP iteration variable must be of type integer at %L",
13273 : &do_code->loc);
13274 5779 : dovar = do_code->ext.iterator->var->symtree->n.sym;
13275 5779 : if (i > 1)
13276 : {
13277 518 : gfc_code *do_code2 = code->block->next;
13278 518 : int j;
13279 :
13280 1218 : for (j = 1; j < i; j++)
13281 : {
13282 710 : gfc_symbol *ivar = do_code2->ext.iterator->var->symtree->n.sym;
13283 710 : if (dovar == ivar
13284 710 : || gfc_find_sym_in_expr (ivar, do_code->ext.iterator->start)
13285 701 : || gfc_find_sym_in_expr (ivar, do_code->ext.iterator->end)
13286 1410 : || gfc_find_sym_in_expr (ivar, do_code->ext.iterator->step))
13287 : {
13288 10 : gfc_error ("!$ACC LOOP %s loops don't form rectangular "
13289 : "iteration space at %L", clause, &do_code->loc);
13290 10 : break;
13291 : }
13292 700 : do_code2 = do_code2->block->next;
13293 : }
13294 : }
13295 5779 : if (i == collapse)
13296 : break;
13297 577 : for (c = do_code->next; c; c = c->next)
13298 48 : if (c->op != EXEC_NOP && c->op != EXEC_CONTINUE)
13299 : {
13300 0 : gfc_error ("%s !$ACC LOOP loops not perfectly nested at %L",
13301 : clause, &c->loc);
13302 0 : break;
13303 : }
13304 529 : if (c)
13305 : break;
13306 529 : do_code = do_code->block;
13307 529 : if (do_code->op != EXEC_DO && do_code->op != EXEC_DO_WHILE
13308 0 : && do_code->op != EXEC_DO_CONCURRENT)
13309 : {
13310 0 : gfc_error ("not enough DO loops for %s !$ACC LOOP at %L",
13311 : clause, &code->loc);
13312 0 : break;
13313 : }
13314 529 : do_code = do_code->next;
13315 529 : if (do_code == NULL
13316 522 : || (do_code->op != EXEC_DO && do_code->op != EXEC_DO_WHILE
13317 2 : && do_code->op != EXEC_DO_CONCURRENT))
13318 : {
13319 9 : gfc_error ("not enough DO loops for %s !$ACC LOOP at %L",
13320 : clause, &code->loc);
13321 9 : break;
13322 : }
13323 : }
13324 5272 : }
13325 :
13326 :
13327 : static void
13328 10119 : resolve_oacc_loop_blocks (gfc_code *code)
13329 : {
13330 10119 : if (!oacc_is_loop (code))
13331 : return;
13332 :
13333 5272 : if (code->ext.omp_clauses->tile_list && code->ext.omp_clauses->gang
13334 24 : && code->ext.omp_clauses->worker && code->ext.omp_clauses->vector)
13335 0 : gfc_error ("Tiled loop cannot be parallelized across gangs, workers and "
13336 : "vectors at the same time at %L", &code->loc);
13337 :
13338 5272 : if (code->ext.omp_clauses->tile_list)
13339 : {
13340 : gfc_expr_list *el;
13341 501 : for (el = code->ext.omp_clauses->tile_list; el; el = el->next)
13342 : {
13343 304 : if (el->expr == NULL)
13344 : {
13345 : /* NULL expressions are used to represent '*' arguments.
13346 : Convert those to a 0 expressions. */
13347 113 : el->expr = gfc_get_constant_expr (BT_INTEGER,
13348 : gfc_default_integer_kind,
13349 : &code->loc);
13350 113 : mpz_set_si (el->expr->value.integer, 0);
13351 : }
13352 : else
13353 : {
13354 191 : resolve_positive_int_expr (el->expr, "TILE");
13355 191 : if (el->expr->expr_type != EXPR_CONSTANT)
13356 14 : gfc_error ("TILE requires constant expression at %L",
13357 : &code->loc);
13358 : }
13359 : }
13360 : }
13361 : }
13362 :
13363 :
13364 : void
13365 10119 : gfc_resolve_oacc_blocks (gfc_code *code, gfc_namespace *ns)
13366 : {
13367 10119 : fortran_omp_context ctx;
13368 10119 : gfc_omp_clauses *omp_clauses = code->ext.omp_clauses;
13369 10119 : gfc_omp_namelist *n;
13370 :
13371 10119 : resolve_oacc_loop_blocks (code);
13372 :
13373 10119 : ctx.code = code;
13374 10119 : ctx.sharing_clauses = new hash_set<gfc_symbol *>;
13375 10119 : ctx.private_iterators = new hash_set<gfc_symbol *>;
13376 10119 : ctx.previous = omp_current_ctx;
13377 10119 : ctx.is_openmp = false;
13378 10119 : omp_current_ctx = &ctx;
13379 :
13380 404760 : for (enum gfc_omp_list_type list = OMP_LIST_FIRST; list < OMP_LIST_NUM;
13381 394641 : list = gfc_omp_list_type (list + 1))
13382 394641 : switch (list)
13383 : {
13384 10119 : case OMP_LIST_PRIVATE:
13385 10710 : for (n = omp_clauses->lists[list]; n; n = n->next)
13386 591 : ctx.sharing_clauses->add (n->sym);
13387 : break;
13388 : default:
13389 : break;
13390 : }
13391 :
13392 10119 : gfc_resolve_blocks (code->block, ns);
13393 :
13394 10119 : omp_current_ctx = ctx.previous;
13395 20238 : delete ctx.sharing_clauses;
13396 20238 : delete ctx.private_iterators;
13397 10119 : }
13398 :
13399 :
13400 : static void
13401 5272 : resolve_oacc_loop (gfc_code *code)
13402 : {
13403 5272 : gfc_code *do_code;
13404 5272 : int collapse;
13405 :
13406 5272 : if (code->ext.omp_clauses)
13407 5272 : resolve_omp_clauses (code, code->ext.omp_clauses, NULL, true);
13408 :
13409 5272 : do_code = code->block->next;
13410 5272 : collapse = code->ext.omp_clauses->collapse;
13411 :
13412 : /* Both collapsed and tiled loops are lowered the same way, but are not
13413 : compatible. In gfc_trans_omp_do, the tile is prioritized. */
13414 5272 : if (code->ext.omp_clauses->tile_list)
13415 : {
13416 : int num = 0;
13417 : gfc_expr_list *el;
13418 501 : for (el = code->ext.omp_clauses->tile_list; el; el = el->next)
13419 304 : ++num;
13420 197 : resolve_oacc_nested_loops (code, code->block->next, num, "tiled");
13421 197 : return;
13422 : }
13423 :
13424 5075 : if (collapse <= 0)
13425 : collapse = 1;
13426 5075 : resolve_oacc_nested_loops (code, do_code, collapse, "collapsed");
13427 : }
13428 :
13429 : void
13430 334285 : gfc_resolve_oacc_declare (gfc_namespace *ns)
13431 : {
13432 334285 : enum gfc_omp_list_type list;
13433 334285 : gfc_omp_namelist *n;
13434 334285 : gfc_oacc_declare *oc;
13435 :
13436 334285 : if (ns->oacc_declare == NULL)
13437 : return;
13438 :
13439 290 : for (oc = ns->oacc_declare; oc; oc = oc->next)
13440 : {
13441 6480 : for (list = OMP_LIST_FIRST; list < OMP_LIST_NUM;
13442 6318 : list = gfc_omp_list_type (list + 1))
13443 6574 : for (n = oc->clauses->lists[list]; n; n = n->next)
13444 : {
13445 256 : n->sym->mark = 0;
13446 256 : if (n->sym->attr.flavor != FL_VARIABLE
13447 16 : && (n->sym->attr.flavor != FL_PROCEDURE
13448 8 : || n->sym->result != n->sym))
13449 : {
13450 14 : if (n->sym->attr.flavor != FL_PARAMETER)
13451 : {
13452 8 : gfc_error ("Object %qs is not a variable at %L",
13453 : n->sym->name, &oc->loc);
13454 8 : continue;
13455 : }
13456 : /* Note that OpenACC 3.4 permits name constants, but the
13457 : implementation is permitted to ignore the clause;
13458 : as semantically, device_resident kind of makes sense
13459 : (and the wording with it is a bit odd), the warning
13460 : is suppressed. */
13461 6 : if (list != OMP_LIST_DEVICE_RESIDENT)
13462 5 : gfc_warning (OPT_Wsurprising, "Object %qs at %L is ignored as"
13463 : " parameters need not be copied", n->sym->name,
13464 : &oc->loc);
13465 : }
13466 :
13467 248 : if (n->expr && n->expr->ref->type == REF_ARRAY)
13468 : {
13469 1 : gfc_error ("Array sections: %qs not allowed in"
13470 1 : " !$ACC DECLARE at %L", n->sym->name, &oc->loc);
13471 1 : continue;
13472 : }
13473 : }
13474 :
13475 252 : for (n = oc->clauses->lists[OMP_LIST_DEVICE_RESIDENT]; n; n = n->next)
13476 90 : check_array_not_assumed (n->sym, oc->loc, "DEVICE_RESIDENT");
13477 : }
13478 :
13479 290 : for (oc = ns->oacc_declare; oc; oc = oc->next)
13480 : {
13481 6480 : for (list = OMP_LIST_FIRST; list < OMP_LIST_NUM;
13482 6318 : list = gfc_omp_list_type (list + 1))
13483 6574 : for (n = oc->clauses->lists[list]; n; n = n->next)
13484 : {
13485 256 : if (n->sym->mark)
13486 : {
13487 9 : gfc_error ("Symbol %qs present on multiple clauses at %L",
13488 : n->sym->name, &oc->loc);
13489 9 : continue;
13490 : }
13491 : else
13492 247 : n->sym->mark = 1;
13493 : }
13494 : }
13495 :
13496 290 : for (oc = ns->oacc_declare; oc; oc = oc->next)
13497 : {
13498 6480 : for (list = OMP_LIST_FIRST; list < OMP_LIST_NUM;
13499 6318 : list = gfc_omp_list_type (list + 1))
13500 6574 : for (n = oc->clauses->lists[list]; n; n = n->next)
13501 256 : n->sym->mark = 0;
13502 : }
13503 : }
13504 :
13505 :
13506 : void
13507 334285 : gfc_resolve_oacc_routines (gfc_namespace *ns)
13508 : {
13509 334285 : for (gfc_oacc_routine_name *orn = ns->oacc_routine_names;
13510 334385 : orn;
13511 100 : orn = orn->next)
13512 : {
13513 100 : gfc_symbol *sym = orn->sym;
13514 100 : if (!sym->attr.external
13515 29 : && !sym->attr.function
13516 27 : && !sym->attr.subroutine)
13517 : {
13518 7 : gfc_error ("NAME %qs does not refer to a subroutine or function"
13519 : " in !$ACC ROUTINE ( NAME ) at %L", sym->name, &orn->loc);
13520 7 : continue;
13521 : }
13522 93 : if (!gfc_add_omp_declare_target (&sym->attr, sym->name, &orn->loc))
13523 : {
13524 20 : gfc_error ("NAME %qs invalid"
13525 : " in !$ACC ROUTINE ( NAME ) at %L", sym->name, &orn->loc);
13526 20 : continue;
13527 : }
13528 : }
13529 334285 : }
13530 :
13531 :
13532 : void
13533 13168 : gfc_resolve_oacc_directive (gfc_code *code, gfc_namespace *ns ATTRIBUTE_UNUSED)
13534 : {
13535 13168 : resolve_oacc_directive_inside_omp_region (code);
13536 :
13537 13168 : switch (code->op)
13538 : {
13539 7353 : case EXEC_OACC_PARALLEL:
13540 7353 : case EXEC_OACC_KERNELS:
13541 7353 : case EXEC_OACC_SERIAL:
13542 7353 : case EXEC_OACC_DATA:
13543 7353 : case EXEC_OACC_HOST_DATA:
13544 7353 : case EXEC_OACC_UPDATE:
13545 7353 : case EXEC_OACC_ENTER_DATA:
13546 7353 : case EXEC_OACC_EXIT_DATA:
13547 7353 : case EXEC_OACC_WAIT:
13548 7353 : case EXEC_OACC_CACHE:
13549 7353 : resolve_omp_clauses (code, code->ext.omp_clauses, NULL, true);
13550 7353 : break;
13551 5272 : case EXEC_OACC_PARALLEL_LOOP:
13552 5272 : case EXEC_OACC_KERNELS_LOOP:
13553 5272 : case EXEC_OACC_SERIAL_LOOP:
13554 5272 : case EXEC_OACC_LOOP:
13555 5272 : resolve_oacc_loop (code);
13556 5272 : break;
13557 543 : case EXEC_OACC_ATOMIC:
13558 543 : resolve_omp_atomic (code);
13559 543 : break;
13560 : default:
13561 : break;
13562 : }
13563 13168 : }
13564 :
13565 :
13566 : static void
13567 2109 : resolve_omp_target (gfc_code *code)
13568 : {
13569 : #define GFC_IS_TEAMS_CONSTRUCT(op) \
13570 : (op == EXEC_OMP_TEAMS \
13571 : || op == EXEC_OMP_TEAMS_DISTRIBUTE \
13572 : || op == EXEC_OMP_TEAMS_DISTRIBUTE_SIMD \
13573 : || op == EXEC_OMP_TEAMS_DISTRIBUTE_PARALLEL_DO \
13574 : || op == EXEC_OMP_TEAMS_DISTRIBUTE_PARALLEL_DO_SIMD \
13575 : || op == EXEC_OMP_TEAMS_LOOP)
13576 :
13577 2109 : if (!code->ext.omp_clauses->contains_teams_construct)
13578 : return;
13579 203 : gfc_code *c = code->block->next;
13580 203 : if (c->op == EXEC_BLOCK)
13581 30 : c = c->ext.block.ns->code;
13582 203 : if (code->ext.omp_clauses->target_first_st_is_teams_or_meta)
13583 : {
13584 192 : if (c->op == EXEC_OMP_METADIRECTIVE)
13585 : {
13586 15 : struct gfc_omp_variant *mc
13587 : = c->ext.omp_variants;
13588 : /* All mc->(next...->)code should be identical with regards
13589 : to the diagnostic below. */
13590 16 : do
13591 : {
13592 16 : if (mc->stmt != ST_NONE
13593 15 : && GFC_IS_TEAMS_CONSTRUCT (mc->code->op))
13594 : {
13595 14 : if (c->next == NULL && mc->code->next == NULL)
13596 : return;
13597 : c = mc->code;
13598 : break;
13599 : }
13600 2 : mc = mc->next;
13601 : }
13602 2 : while (mc);
13603 : }
13604 177 : else if (GFC_IS_TEAMS_CONSTRUCT (c->op) && c->next == NULL)
13605 : return;
13606 : }
13607 :
13608 31 : while (c && !GFC_IS_TEAMS_CONSTRUCT (c->op))
13609 8 : c = c->next;
13610 23 : if (c)
13611 19 : gfc_error ("!$OMP TARGET region at %L with a nested TEAMS at %L may not "
13612 : "contain any other statement, declaration or directive outside "
13613 : "of the single TEAMS construct", &c->loc, &code->loc);
13614 : else
13615 4 : gfc_error ("!$OMP TARGET region at %L with a nested TEAMS may not "
13616 : "contain any other statement, declaration or directive outside "
13617 : "of the single TEAMS construct", &code->loc);
13618 : #undef GFC_IS_TEAMS_CONSTRUCT
13619 : }
13620 :
13621 : static void
13622 154 : resolve_omp_dispatch (gfc_code *code)
13623 : {
13624 154 : gfc_code *next = code->block->next;
13625 154 : if (next == NULL)
13626 : return;
13627 :
13628 151 : gfc_exec_op op = next->op;
13629 151 : gcc_assert (op == EXEC_CALL || op == EXEC_ASSIGN);
13630 151 : if (op != EXEC_CALL
13631 74 : && (op != EXEC_ASSIGN || next->expr2->expr_type != EXPR_FUNCTION))
13632 3 : gfc_error (
13633 : "%<OMP DISPATCH%> directive at %L must be followed by a procedure "
13634 : "call with optional assignment",
13635 : &code->loc);
13636 :
13637 77 : if ((op == EXEC_CALL && next->resolved_sym != NULL
13638 76 : && next->resolved_sym->attr.proc_pointer)
13639 150 : || (op == EXEC_ASSIGN && gfc_expr_attr (next->expr2).proc_pointer))
13640 1 : gfc_error ("%<OMP DISPATCH%> directive at %L cannot be followed by a "
13641 : "procedure pointer",
13642 : &code->loc);
13643 : }
13644 :
13645 : /* Resolve OpenMP directive clauses and check various requirements
13646 : of each directive. */
13647 :
13648 : void
13649 21062 : gfc_resolve_omp_directive (gfc_code *code, gfc_namespace *ns)
13650 : {
13651 21062 : resolve_omp_directive_inside_oacc_region (code);
13652 :
13653 21062 : if (code->op != EXEC_OMP_ATOMIC)
13654 18908 : gfc_maybe_initialize_eh ();
13655 :
13656 21062 : switch (code->op)
13657 : {
13658 5420 : case EXEC_OMP_DISTRIBUTE:
13659 5420 : case EXEC_OMP_DISTRIBUTE_PARALLEL_DO:
13660 5420 : case EXEC_OMP_DISTRIBUTE_PARALLEL_DO_SIMD:
13661 5420 : case EXEC_OMP_DISTRIBUTE_SIMD:
13662 5420 : case EXEC_OMP_DO:
13663 5420 : case EXEC_OMP_DO_SIMD:
13664 5420 : case EXEC_OMP_LOOP:
13665 5420 : case EXEC_OMP_PARALLEL_DO:
13666 5420 : case EXEC_OMP_PARALLEL_DO_SIMD:
13667 5420 : case EXEC_OMP_PARALLEL_LOOP:
13668 5420 : case EXEC_OMP_PARALLEL_MASKED_TASKLOOP:
13669 5420 : case EXEC_OMP_PARALLEL_MASKED_TASKLOOP_SIMD:
13670 5420 : case EXEC_OMP_PARALLEL_MASTER_TASKLOOP:
13671 5420 : case EXEC_OMP_PARALLEL_MASTER_TASKLOOP_SIMD:
13672 5420 : case EXEC_OMP_MASKED_TASKLOOP:
13673 5420 : case EXEC_OMP_MASKED_TASKLOOP_SIMD:
13674 5420 : case EXEC_OMP_MASTER_TASKLOOP:
13675 5420 : case EXEC_OMP_MASTER_TASKLOOP_SIMD:
13676 5420 : case EXEC_OMP_SIMD:
13677 5420 : case EXEC_OMP_TARGET_PARALLEL_DO:
13678 5420 : case EXEC_OMP_TARGET_PARALLEL_DO_SIMD:
13679 5420 : case EXEC_OMP_TARGET_PARALLEL_LOOP:
13680 5420 : case EXEC_OMP_TARGET_SIMD:
13681 5420 : case EXEC_OMP_TARGET_TEAMS_DISTRIBUTE:
13682 5420 : case EXEC_OMP_TARGET_TEAMS_DISTRIBUTE_PARALLEL_DO:
13683 5420 : case EXEC_OMP_TARGET_TEAMS_DISTRIBUTE_PARALLEL_DO_SIMD:
13684 5420 : case EXEC_OMP_TARGET_TEAMS_DISTRIBUTE_SIMD:
13685 5420 : case EXEC_OMP_TARGET_TEAMS_LOOP:
13686 5420 : case EXEC_OMP_TASKLOOP:
13687 5420 : case EXEC_OMP_TASKLOOP_SIMD:
13688 5420 : case EXEC_OMP_TEAMS_DISTRIBUTE:
13689 5420 : case EXEC_OMP_TEAMS_DISTRIBUTE_PARALLEL_DO:
13690 5420 : case EXEC_OMP_TEAMS_DISTRIBUTE_PARALLEL_DO_SIMD:
13691 5420 : case EXEC_OMP_TEAMS_DISTRIBUTE_SIMD:
13692 5420 : case EXEC_OMP_TEAMS_LOOP:
13693 5420 : case EXEC_OMP_TILE:
13694 5420 : case EXEC_OMP_UNROLL:
13695 5420 : resolve_omp_do (code);
13696 5420 : break;
13697 2109 : case EXEC_OMP_TARGET:
13698 2109 : resolve_omp_target (code);
13699 10115 : gcc_fallthrough ();
13700 10115 : case EXEC_OMP_ALLOCATE:
13701 10115 : case EXEC_OMP_ALLOCATORS:
13702 10115 : case EXEC_OMP_ASSUME:
13703 10115 : case EXEC_OMP_CANCEL:
13704 10115 : case EXEC_OMP_ERROR:
13705 10115 : case EXEC_OMP_INTEROP:
13706 10115 : case EXEC_OMP_MASKED:
13707 10115 : case EXEC_OMP_ORDERED:
13708 10115 : case EXEC_OMP_PARALLEL_WORKSHARE:
13709 10115 : case EXEC_OMP_PARALLEL:
13710 10115 : case EXEC_OMP_PARALLEL_MASKED:
13711 10115 : case EXEC_OMP_PARALLEL_MASTER:
13712 10115 : case EXEC_OMP_PARALLEL_SECTIONS:
13713 10115 : case EXEC_OMP_SCOPE:
13714 10115 : case EXEC_OMP_SECTIONS:
13715 10115 : case EXEC_OMP_SINGLE:
13716 10115 : case EXEC_OMP_TARGET_DATA:
13717 10115 : case EXEC_OMP_TARGET_ENTER_DATA:
13718 10115 : case EXEC_OMP_TARGET_EXIT_DATA:
13719 10115 : case EXEC_OMP_TARGET_PARALLEL:
13720 10115 : case EXEC_OMP_TARGET_TEAMS:
13721 10115 : case EXEC_OMP_TASK:
13722 10115 : case EXEC_OMP_TASKWAIT:
13723 10115 : case EXEC_OMP_TEAMS:
13724 10115 : case EXEC_OMP_WORKSHARE:
13725 10115 : case EXEC_OMP_DEPOBJ:
13726 10115 : if (code->ext.omp_clauses)
13727 9982 : resolve_omp_clauses (code, code->ext.omp_clauses, NULL);
13728 : break;
13729 1704 : case EXEC_OMP_TARGET_UPDATE:
13730 1704 : if (code->ext.omp_clauses)
13731 1704 : resolve_omp_clauses (code, code->ext.omp_clauses, NULL);
13732 1704 : if (code->ext.omp_clauses == NULL
13733 1704 : || (code->ext.omp_clauses->lists[OMP_LIST_TO] == NULL
13734 992 : && code->ext.omp_clauses->lists[OMP_LIST_FROM] == NULL))
13735 0 : gfc_error ("OMP TARGET UPDATE at %L requires at least one TO or "
13736 : "FROM clause", &code->loc);
13737 : break;
13738 2154 : case EXEC_OMP_ATOMIC:
13739 2154 : resolve_omp_clauses (code, code->block->ext.omp_clauses, NULL);
13740 2154 : resolve_omp_atomic (code);
13741 2154 : break;
13742 159 : case EXEC_OMP_CRITICAL:
13743 159 : resolve_omp_clauses (code, code->ext.omp_clauses, NULL);
13744 159 : if (!code->ext.omp_clauses->critical_name
13745 112 : && code->ext.omp_clauses->hint
13746 3 : && code->ext.omp_clauses->hint->ts.type == BT_INTEGER
13747 3 : && code->ext.omp_clauses->hint->expr_type == EXPR_CONSTANT
13748 3 : && mpz_sgn (code->ext.omp_clauses->hint->value.integer) != 0)
13749 1 : gfc_error ("OMP CRITICAL at %L with HINT clause requires a NAME, "
13750 : "except when omp_sync_hint_none is used", &code->loc);
13751 : break;
13752 49 : case EXEC_OMP_SCAN:
13753 : /* Flag is only used to checking, hence, it is unset afterwards. */
13754 49 : if (!code->ext.omp_clauses->if_present)
13755 10 : gfc_error ("Unexpected !$OMP SCAN at %L outside loop construct with "
13756 : "%<inscan%> REDUCTION clause", &code->loc);
13757 49 : code->ext.omp_clauses->if_present = false;
13758 49 : resolve_omp_clauses (code, code->ext.omp_clauses, ns);
13759 49 : break;
13760 154 : case EXEC_OMP_DISPATCH:
13761 154 : if (code->ext.omp_clauses)
13762 154 : resolve_omp_clauses (code, code->ext.omp_clauses, ns);
13763 154 : resolve_omp_dispatch (code);
13764 154 : break;
13765 138 : case EXEC_OMP_METADIRECTIVE:
13766 138 : resolve_omp_metadirective (code, ns);
13767 138 : break;
13768 : default:
13769 : break;
13770 : }
13771 21062 : }
13772 :
13773 : /* Resolve !$omp declare {variant|simd} constructs in NS.
13774 : Note that !$omp declare target is resolved in resolve_symbol. */
13775 :
13776 : void
13777 345787 : gfc_resolve_omp_declare (gfc_namespace *ns)
13778 : {
13779 345787 : gfc_omp_declare_simd *ods;
13780 346023 : for (ods = ns->omp_declare_simd; ods; ods = ods->next)
13781 : {
13782 236 : if (ods->proc_name != NULL
13783 196 : && ods->proc_name != ns->proc_name)
13784 6 : gfc_error ("!$OMP DECLARE SIMD should refer to containing procedure "
13785 : "%qs at %L", ns->proc_name->name, &ods->where);
13786 236 : if (ods->clauses)
13787 218 : resolve_omp_clauses (NULL, ods->clauses, ns);
13788 : }
13789 :
13790 345787 : gfc_omp_declare_variant *odv;
13791 345787 : gfc_omp_namelist *range_begin = NULL;
13792 :
13793 346241 : for (odv = ns->omp_declare_variant; odv; odv = odv->next)
13794 454 : gfc_resolve_omp_context_selector (odv->set_selectors, false, nullptr);
13795 346241 : for (odv = ns->omp_declare_variant; odv; odv = odv->next)
13796 657 : for (gfc_omp_namelist *n = odv->adjust_args_list; n != NULL; n = n->next)
13797 : {
13798 203 : if ((n->expr == NULL
13799 6 : && (range_begin
13800 4 : || n->u.adj_args.range_start
13801 1 : || n->u.adj_args.omp_num_args_plus
13802 1 : || n->u.adj_args.omp_num_args_minus))
13803 198 : || n->u.adj_args.error_p)
13804 : {
13805 : }
13806 197 : else if (range_begin
13807 191 : || n->u.adj_args.range_start
13808 186 : || n->u.adj_args.omp_num_args_plus
13809 186 : || n->u.adj_args.omp_num_args_minus)
13810 : {
13811 11 : if (!n->expr
13812 11 : || !gfc_resolve_expr (n->expr)
13813 11 : || n->expr->expr_type != EXPR_CONSTANT
13814 10 : || n->expr->ts.type != BT_INTEGER
13815 10 : || n->expr->rank != 0
13816 10 : || mpz_sgn (n->expr->value.integer) < 0
13817 20 : || ((n->u.adj_args.omp_num_args_plus
13818 8 : || n->u.adj_args.omp_num_args_minus)
13819 5 : && mpz_sgn (n->expr->value.integer) == 0))
13820 : {
13821 2 : if (n->u.adj_args.omp_num_args_plus
13822 2 : || n->u.adj_args.omp_num_args_minus)
13823 0 : gfc_error ("Expected constant non-negative scalar integer "
13824 : "offset expression at %L", &n->where);
13825 : else
13826 2 : gfc_error ("For range-based %<adjust_args%>, a constant "
13827 : "positive scalar integer expression is required "
13828 : "at %L", &n->where);
13829 : }
13830 : }
13831 186 : else if (n->expr
13832 186 : && n->expr->expr_type == EXPR_CONSTANT
13833 21 : && n->expr->ts.type == BT_INTEGER
13834 20 : && mpz_sgn (n->expr->value.integer) > 0)
13835 : {
13836 : }
13837 166 : else if (!n->expr
13838 166 : || !gfc_resolve_expr (n->expr)
13839 331 : || n->expr->expr_type != EXPR_VARIABLE)
13840 2 : gfc_error ("Expected dummy parameter name or a positive integer "
13841 : "at %L", &n->where);
13842 164 : else if (n->expr->expr_type == EXPR_VARIABLE)
13843 164 : n->sym = n->expr->symtree->n.sym;
13844 :
13845 203 : range_begin = n->u.adj_args.range_start ? n : NULL;
13846 : }
13847 345787 : }
13848 :
13849 : struct omp_udr_callback_data
13850 : {
13851 : gfc_omp_udr *omp_udr;
13852 : bool is_initializer;
13853 : };
13854 :
13855 : static int
13856 3598 : omp_udr_callback (gfc_expr **e, int *walk_subtrees ATTRIBUTE_UNUSED,
13857 : void *data)
13858 : {
13859 3598 : struct omp_udr_callback_data *cd = (struct omp_udr_callback_data *) data;
13860 3598 : if ((*e)->expr_type == EXPR_VARIABLE)
13861 : {
13862 2203 : if (cd->is_initializer)
13863 : {
13864 535 : if ((*e)->symtree->n.sym != cd->omp_udr->omp_priv
13865 140 : && (*e)->symtree->n.sym != cd->omp_udr->omp_orig)
13866 4 : gfc_error ("Variable other than OMP_PRIV or OMP_ORIG used in "
13867 : "INITIALIZER clause of !$OMP DECLARE REDUCTION at %L",
13868 : &(*e)->where);
13869 : }
13870 : else
13871 : {
13872 1668 : if ((*e)->symtree->n.sym != cd->omp_udr->omp_out
13873 597 : && (*e)->symtree->n.sym != cd->omp_udr->omp_in)
13874 6 : gfc_error ("Variable other than OMP_OUT or OMP_IN used in "
13875 : "combiner of !$OMP DECLARE REDUCTION at %L",
13876 : &(*e)->where);
13877 : }
13878 : }
13879 3598 : return 0;
13880 : }
13881 :
13882 : /* Resolve !$omp declare reduction constructs. */
13883 :
13884 : static void
13885 600 : gfc_resolve_omp_udr (gfc_omp_udr *omp_udr)
13886 : {
13887 600 : gfc_actual_arglist *a;
13888 600 : const char *predef_name = NULL;
13889 :
13890 600 : switch (omp_udr->rop)
13891 : {
13892 599 : case OMP_REDUCTION_PLUS:
13893 599 : case OMP_REDUCTION_TIMES:
13894 599 : case OMP_REDUCTION_MINUS:
13895 599 : case OMP_REDUCTION_AND:
13896 599 : case OMP_REDUCTION_OR:
13897 599 : case OMP_REDUCTION_EQV:
13898 599 : case OMP_REDUCTION_NEQV:
13899 599 : case OMP_REDUCTION_MAX:
13900 599 : case OMP_REDUCTION_USER:
13901 599 : break;
13902 1 : default:
13903 1 : gfc_error ("Invalid operator for !$OMP DECLARE REDUCTION %s at %L",
13904 : omp_udr->name, &omp_udr->where);
13905 22 : return;
13906 : }
13907 :
13908 599 : if (gfc_omp_udr_predef (omp_udr->rop, omp_udr->name,
13909 : &omp_udr->ts, &predef_name))
13910 : {
13911 18 : if (predef_name)
13912 18 : gfc_error_now ("Redefinition of predefined %s "
13913 : "!$OMP DECLARE REDUCTION at %L",
13914 : predef_name, &omp_udr->where);
13915 : else
13916 0 : gfc_error_now ("Redefinition of predefined "
13917 : "!$OMP DECLARE REDUCTION at %L", &omp_udr->where);
13918 18 : return;
13919 : }
13920 :
13921 581 : if (omp_udr->ts.type == BT_CHARACTER
13922 62 : && omp_udr->ts.u.cl->length
13923 32 : && omp_udr->ts.u.cl->length->expr_type != EXPR_CONSTANT)
13924 : {
13925 1 : gfc_error ("CHARACTER length in !$OMP DECLARE REDUCTION %s not "
13926 : "constant at %L", omp_udr->name, &omp_udr->where);
13927 1 : return;
13928 : }
13929 :
13930 580 : struct omp_udr_callback_data cd;
13931 580 : cd.omp_udr = omp_udr;
13932 580 : cd.is_initializer = false;
13933 580 : gfc_code_walker (&omp_udr->combiner_ns->code, gfc_dummy_code_callback,
13934 : omp_udr_callback, &cd);
13935 580 : if (omp_udr->combiner_ns->code->op == EXEC_CALL)
13936 : {
13937 346 : for (a = omp_udr->combiner_ns->code->ext.actual; a; a = a->next)
13938 237 : if (a->expr == NULL)
13939 : break;
13940 110 : if (a)
13941 1 : gfc_error ("Subroutine call with alternate returns in combiner "
13942 : "of !$OMP DECLARE REDUCTION at %L",
13943 : &omp_udr->combiner_ns->code->loc);
13944 : }
13945 580 : if (omp_udr->initializer_ns)
13946 : {
13947 373 : cd.is_initializer = true;
13948 373 : gfc_code_walker (&omp_udr->initializer_ns->code, gfc_dummy_code_callback,
13949 : omp_udr_callback, &cd);
13950 373 : if (omp_udr->initializer_ns->code->op == EXEC_CALL)
13951 : {
13952 377 : for (a = omp_udr->initializer_ns->code->ext.actual; a; a = a->next)
13953 243 : if (a->expr == NULL)
13954 : break;
13955 135 : if (a)
13956 1 : gfc_error ("Subroutine call with alternate returns in "
13957 : "INITIALIZER clause of !$OMP DECLARE REDUCTION "
13958 : "at %L", &omp_udr->initializer_ns->code->loc);
13959 136 : for (a = omp_udr->initializer_ns->code->ext.actual; a; a = a->next)
13960 135 : if (a->expr
13961 135 : && a->expr->expr_type == EXPR_VARIABLE
13962 135 : && a->expr->symtree->n.sym == omp_udr->omp_priv
13963 134 : && a->expr->ref == NULL)
13964 : break;
13965 135 : if (a == NULL)
13966 1 : gfc_error ("One of actual subroutine arguments in INITIALIZER "
13967 : "clause of !$OMP DECLARE REDUCTION must be OMP_PRIV "
13968 : "at %L", &omp_udr->initializer_ns->code->loc);
13969 : }
13970 : }
13971 207 : else if (omp_udr->ts.type == BT_DERIVED
13972 207 : && !gfc_has_default_initializer (omp_udr->ts.u.derived))
13973 : {
13974 1 : gfc_error ("Missing INITIALIZER clause for !$OMP DECLARE REDUCTION "
13975 : "of derived type without default initializer at %L",
13976 : &omp_udr->where);
13977 1 : return;
13978 : }
13979 : }
13980 :
13981 : void
13982 346795 : gfc_resolve_omp_udrs (gfc_symtree *st)
13983 : {
13984 346795 : gfc_omp_udr *omp_udr;
13985 :
13986 346795 : if (st == NULL)
13987 : return;
13988 504 : gfc_resolve_omp_udrs (st->left);
13989 504 : gfc_resolve_omp_udrs (st->right);
13990 1104 : for (omp_udr = st->n.omp_udr; omp_udr; omp_udr = omp_udr->next)
13991 600 : gfc_resolve_omp_udr (omp_udr);
13992 : }
13993 :
13994 : /* Resolve !$omp declare mapper constructs. */
13995 :
13996 : static void
13997 6 : gfc_resolve_omp_udm (gfc_omp_udm *omp_udm)
13998 : {
13999 6 : resolve_omp_clauses (NULL, omp_udm->clauses, omp_udm->mapper_ns);
14000 :
14001 6 : gfc_omp_namelist *n;
14002 8 : for (n = omp_udm->clauses->lists[OMP_LIST_MAP]; n; n = n->next)
14003 6 : if (n->sym == omp_udm->var_sym)
14004 : break;
14005 6 : if (!n)
14006 2 : gfc_error ("At least one %<map%> clause in !$OMP DECLARE MAPPER at %L must "
14007 : "map %qs or an element of it",
14008 2 : &omp_udm->where, omp_udm->var_sym->name);
14009 6 : }
14010 :
14011 : void
14012 345799 : gfc_resolve_omp_udms (gfc_symtree *st)
14013 : {
14014 345799 : gfc_omp_udm *omp_udm;
14015 :
14016 345799 : if (st == NULL)
14017 : return;
14018 6 : gfc_resolve_omp_udms (st->left);
14019 6 : gfc_resolve_omp_udms (st->right);
14020 12 : for (omp_udm = st->n.omp_udm; omp_udm; omp_udm = omp_udm->next)
14021 6 : gfc_resolve_omp_udm (omp_udm);
14022 : }
|
