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 55977 : gfc_match_omp_eos (void)
135 : {
136 55977 : locus old_loc;
137 55977 : char c;
138 :
139 55977 : old_loc = gfc_current_locus;
140 55977 : gfc_gobble_whitespace ();
141 :
142 55977 : if (gfc_matching_omp_context_selector)
143 : {
144 269 : if (gfc_peek_ascii_char () == ')')
145 : return MATCH_YES;
146 : }
147 : else
148 : {
149 55708 : c = gfc_next_ascii_char ();
150 55708 : 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 53960 : case '\n':
159 53960 : return MATCH_YES;
160 : }
161 : }
162 :
163 1749 : gfc_current_locus = old_loc;
164 1749 : return MATCH_NO;
165 : }
166 :
167 : match
168 13206 : gfc_match_omp_eos_error (void)
169 : {
170 13206 : 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 62205 : gfc_free_omp_clauses (gfc_omp_clauses *c)
182 : {
183 62205 : if (c == NULL)
184 : return;
185 :
186 35223 : gfc_free_expr (c->if_expr);
187 387453 : for (int i = 0; i < OMP_IF_LAST; i++)
188 352230 : gfc_free_expr (c->if_exprs[i]);
189 35223 : gfc_free_expr (c->self_expr);
190 35223 : gfc_free_expr (c->final_expr);
191 35223 : gfc_free_expr (c->chunk_size);
192 35223 : gfc_free_expr (c->safelen_expr);
193 35223 : gfc_free_expr (c->simdlen_expr);
194 35223 : gfc_free_expr (c->device);
195 35223 : gfc_free_expr (c->dyn_groupprivate);
196 35223 : gfc_free_expr (c->dist_chunk_size);
197 35223 : gfc_free_expr (c->grainsize);
198 35223 : gfc_free_expr (c->hint);
199 35223 : gfc_free_expr (c->num_tasks);
200 35223 : gfc_free_expr (c->priority);
201 35223 : gfc_free_expr (c->detach);
202 35223 : gfc_free_expr (c->novariants);
203 35223 : gfc_free_expr (c->nocontext);
204 35223 : gfc_free_expr (c->async_expr);
205 35223 : gfc_free_expr (c->gang_num_expr);
206 35223 : gfc_free_expr (c->gang_static_expr);
207 35223 : gfc_free_expr (c->worker_expr);
208 35223 : gfc_free_expr (c->vector_expr);
209 35223 : gfc_free_expr (c->num_gangs_expr);
210 35223 : gfc_free_expr (c->num_workers_expr);
211 35223 : gfc_free_expr (c->vector_length_expr);
212 35223 : gfc_free_expr (c->device_num_expr);
213 1408920 : for (enum gfc_omp_list_type t = OMP_LIST_FIRST; t < OMP_LIST_NUM;
214 1373697 : t = gfc_omp_list_type (t + 1))
215 1373697 : gfc_free_omp_namelist (c->lists[t], t);
216 35223 : gfc_free_expr_list (c->num_teams_list);
217 35223 : gfc_free_expr_list (c->thread_limit_list);
218 35223 : gfc_free_expr_list (c->num_threads_list);
219 35223 : gfc_free_expr_list (c->wait_list);
220 35223 : gfc_free_expr_list (c->tile_list);
221 35223 : gfc_free_expr_list (c->sizes_list);
222 35223 : free (const_cast<char *> (c->critical_name));
223 35223 : 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 35223 : 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 212357 : gfc_free_expr_list (gfc_expr_list *list)
255 : {
256 212357 : gfc_expr_list *n;
257 :
258 215145 : for (; list; list = n)
259 : {
260 2788 : n = list->next;
261 2788 : free (list);
262 : }
263 212357 : }
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 543391 : gfc_free_omp_declare_simd_list (gfc_omp_declare_simd *list)
279 : {
280 543627 : 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 543391 : }
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 543391 : gfc_free_omp_declare_variant_list (gfc_omp_declare_variant *list)
342 : {
343 543845 : 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 543391 : }
352 :
353 : /* Free an !$omp declare reduction. */
354 :
355 : void
356 1271 : gfc_free_omp_udr (gfc_omp_udr *omp_udr)
357 : {
358 1271 : if (omp_udr)
359 : {
360 685 : gfc_free_omp_udr (omp_udr->next);
361 685 : gfc_free_namespace (omp_udr->combiner_ns);
362 685 : if (omp_udr->initializer_ns)
363 386 : gfc_free_namespace (omp_udr->initializer_ns);
364 685 : free (omp_udr);
365 : }
366 1271 : }
367 :
368 : /* Free variants of an !$omp metadirective construct. */
369 :
370 : void
371 93 : gfc_free_omp_variants (gfc_omp_variant *variant)
372 : {
373 284 : while (variant)
374 : {
375 191 : gfc_omp_variant *next_variant = variant->next;
376 191 : gfc_free_omp_set_selector_list (variant->selectors);
377 191 : free (variant);
378 191 : variant = next_variant;
379 : }
380 93 : }
381 :
382 : /* Free an !$omp declare mapper. */
383 :
384 : void
385 46 : gfc_free_omp_udm (gfc_omp_udm *omp_udm)
386 : {
387 46 : if (omp_udm)
388 : {
389 23 : gfc_free_omp_udm (omp_udm->next);
390 23 : gfc_free_namespace (omp_udm->mapper_ns);
391 23 : free (omp_udm);
392 : }
393 46 : }
394 :
395 : static gfc_omp_udr *
396 4716 : gfc_find_omp_udr (gfc_namespace *ns, const char *name, gfc_typespec *ts)
397 : {
398 4716 : gfc_symtree *st;
399 :
400 4716 : if (ns == NULL)
401 470 : ns = gfc_current_ns;
402 5664 : do
403 : {
404 5664 : gfc_omp_udr *omp_udr;
405 :
406 5664 : st = gfc_find_symtree (ns->omp_udr_root, name);
407 5664 : if (st != NULL)
408 : {
409 941 : for (omp_udr = st->n.omp_udr; omp_udr; omp_udr = omp_udr->next)
410 941 : if (ts == NULL)
411 : return omp_udr;
412 571 : else if (gfc_compare_types (&omp_udr->ts, ts))
413 : {
414 482 : if (ts->type == BT_CHARACTER)
415 : {
416 60 : if (omp_udr->ts.u.cl->length == NULL)
417 : return omp_udr;
418 36 : if (ts->u.cl->length == NULL)
419 0 : continue;
420 36 : if (gfc_compare_expr (omp_udr->ts.u.cl->length,
421 : ts->u.cl->length,
422 : INTRINSIC_EQ) != 0)
423 12 : continue;
424 : }
425 446 : return omp_udr;
426 : }
427 : }
428 :
429 : /* Don't escape an interface block. */
430 4824 : if (ns && !ns->has_import_set
431 4824 : && ns->proc_name && ns->proc_name->attr.if_source == IFSRC_IFBODY)
432 : break;
433 :
434 4824 : ns = ns->parent;
435 : }
436 4824 : while (ns != NULL);
437 :
438 : return NULL;
439 : }
440 :
441 :
442 : /* Match a variable/common block list and construct a namelist from it;
443 : if has_all_memory != NULL, *has_all_memory is set and omp_all_memory
444 : yields a list->sym NULL entry. */
445 :
446 : static match
447 31751 : 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 31751 : gfc_omp_namelist *head, *tail, *p;
457 31751 : locus old_loc, cur_loc;
458 31751 : char n[GFC_MAX_SYMBOL_LEN+1];
459 31751 : gfc_symbol *sym;
460 31751 : match m;
461 31751 : gfc_symtree *st;
462 :
463 31751 : head = tail = NULL;
464 :
465 31751 : old_loc = gfc_current_locus;
466 31751 : if (has_all_memory)
467 708 : *has_all_memory = false;
468 31751 : m = gfc_match (str);
469 31751 : if (m != MATCH_YES)
470 : return m;
471 :
472 38493 : for (;;)
473 : {
474 38493 : gfc_gobble_whitespace ();
475 38493 : cur_loc = gfc_current_locus;
476 :
477 38493 : m = gfc_match_name (n);
478 38493 : if (m == MATCH_YES && strcmp (n, "omp_all_memory") == 0)
479 : {
480 23 : locus loc = gfc_get_location_range (NULL, 0, &cur_loc, 1,
481 : &gfc_current_locus);
482 23 : if (!has_all_memory)
483 : {
484 2 : gfc_error ("%<omp_all_memory%> at %L not permitted in this "
485 : "clause", &loc);
486 2 : goto cleanup;
487 : }
488 21 : *has_all_memory = true;
489 21 : p = gfc_get_omp_namelist ();
490 21 : if (head == NULL)
491 : head = tail = p;
492 : else
493 : {
494 3 : tail->next = p;
495 3 : tail = tail->next;
496 : }
497 21 : tail->where = loc;
498 21 : goto next_item;
499 : }
500 38214 : if (m == MATCH_YES)
501 : {
502 38214 : gfc_symtree *st;
503 38214 : if ((m = gfc_get_ha_sym_tree (n, &st) ? MATCH_ERROR : MATCH_YES)
504 : == MATCH_YES)
505 38214 : sym = st->n.sym;
506 : }
507 38470 : switch (m)
508 : {
509 38214 : case MATCH_YES:
510 38214 : gfc_expr *expr;
511 38214 : expr = NULL;
512 38214 : gfc_gobble_whitespace ();
513 23527 : if ((allow_sections && gfc_peek_ascii_char () == '(')
514 57379 : || (allow_derived && gfc_peek_ascii_char () == '%'))
515 : {
516 6602 : gfc_current_locus = cur_loc;
517 6602 : m = gfc_match_variable (&expr, 0);
518 6602 : switch (m)
519 : {
520 4 : case MATCH_ERROR:
521 12 : goto cleanup;
522 0 : case MATCH_NO:
523 0 : goto syntax;
524 6598 : default:
525 6598 : break;
526 : }
527 6598 : if (gfc_is_coindexed (expr))
528 : {
529 5 : gfc_error ("List item shall not be coindexed at %L",
530 5 : &expr->where);
531 5 : goto cleanup;
532 : }
533 : }
534 38205 : gfc_set_sym_referenced (sym);
535 38205 : p = gfc_get_omp_namelist ();
536 38205 : if (head == NULL)
537 : head = tail = p;
538 10165 : else if (reverse_order)
539 : {
540 57 : p->next = head;
541 57 : head = p;
542 : }
543 : else
544 : {
545 10108 : tail->next = p;
546 10108 : tail = tail->next;
547 : }
548 38205 : p->sym = sym;
549 38205 : p->expr = expr;
550 38205 : p->where = gfc_get_location_range (NULL, 0, &cur_loc, 1,
551 : &gfc_current_locus);
552 38205 : if (reject_common_vars && sym->attr.in_common)
553 : {
554 3 : gcc_assert (allow_common);
555 3 : gfc_error ("%qs at %L is part of the common block %</%s/%> and "
556 : "may only be specified implicitly via the named "
557 : "common block", sym->name, &cur_loc,
558 3 : sym->common_head->name);
559 3 : goto cleanup;
560 : }
561 38202 : goto next_item;
562 256 : case MATCH_NO:
563 256 : break;
564 0 : case MATCH_ERROR:
565 0 : goto cleanup;
566 : }
567 :
568 256 : if (!allow_common)
569 12 : goto syntax;
570 :
571 244 : m = gfc_match ("/ %n /", n);
572 244 : if (m == MATCH_ERROR)
573 0 : goto cleanup;
574 244 : if (m == MATCH_NO)
575 19 : goto syntax;
576 :
577 225 : cur_loc = gfc_get_location_range (NULL, 0, &cur_loc, 1,
578 : &gfc_current_locus);
579 225 : st = gfc_find_symtree (gfc_current_ns->common_root, n);
580 225 : if (st == NULL)
581 : {
582 2 : gfc_error ("COMMON block %</%s/%> not found at %L", n, &cur_loc);
583 2 : goto cleanup;
584 : }
585 724 : for (sym = st->n.common->head; sym; sym = sym->common_next)
586 : {
587 501 : gfc_set_sym_referenced (sym);
588 501 : p = gfc_get_omp_namelist ();
589 501 : if (head == NULL)
590 : head = tail = p;
591 325 : else if (reverse_order)
592 : {
593 0 : p->next = head;
594 0 : head = p;
595 : }
596 : else
597 : {
598 325 : tail->next = p;
599 325 : tail = tail->next;
600 : }
601 501 : p->sym = sym;
602 501 : p->where = cur_loc;
603 : }
604 :
605 223 : next_item:
606 38446 : if (end_colon && gfc_match_char (':') == MATCH_YES)
607 : {
608 793 : *end_colon = true;
609 793 : break;
610 : }
611 37653 : if (gfc_match_char (')') == MATCH_YES)
612 : break;
613 10236 : if (gfc_match_char (',') != MATCH_YES)
614 21 : goto syntax;
615 : }
616 :
617 38248 : while (*list)
618 10038 : list = &(*list)->next;
619 :
620 28210 : *list = head;
621 28210 : if (headp)
622 22317 : *headp = list;
623 : return MATCH_YES;
624 :
625 52 : syntax:
626 52 : gfc_error ("Syntax error in OpenMP variable list at %C");
627 :
628 68 : cleanup:
629 68 : gfc_free_omp_namelist (head, OMP_LIST_NONE);
630 68 : gfc_current_locus = old_loc;
631 68 : return MATCH_ERROR;
632 : }
633 :
634 : /* Match a variable/procedure/common block list and construct a namelist
635 : from it. */
636 :
637 : static match
638 363 : gfc_match_omp_to_link (const char *str, gfc_omp_namelist **list)
639 : {
640 363 : gfc_omp_namelist *head, *tail, *p;
641 363 : locus old_loc, cur_loc;
642 363 : char n[GFC_MAX_SYMBOL_LEN+1];
643 363 : gfc_symbol *sym;
644 363 : match m;
645 363 : gfc_symtree *st;
646 :
647 363 : head = tail = NULL;
648 :
649 363 : old_loc = gfc_current_locus;
650 :
651 363 : m = gfc_match (str);
652 363 : if (m != MATCH_YES)
653 : return m;
654 :
655 549 : for (;;)
656 : {
657 549 : cur_loc = gfc_current_locus;
658 549 : m = gfc_match_symbol (&sym, 1);
659 549 : switch (m)
660 : {
661 508 : case MATCH_YES:
662 508 : p = gfc_get_omp_namelist ();
663 508 : if (head == NULL)
664 : head = tail = p;
665 : else
666 : {
667 194 : tail->next = p;
668 194 : tail = tail->next;
669 : }
670 508 : tail->sym = sym;
671 508 : tail->where = cur_loc;
672 508 : goto next_item;
673 : case MATCH_NO:
674 : break;
675 0 : case MATCH_ERROR:
676 0 : goto cleanup;
677 : }
678 :
679 41 : m = gfc_match (" / %n /", n);
680 41 : if (m == MATCH_ERROR)
681 0 : goto cleanup;
682 41 : if (m == MATCH_NO)
683 0 : goto syntax;
684 :
685 41 : st = gfc_find_symtree (gfc_current_ns->common_root, n);
686 41 : if (st == NULL)
687 : {
688 0 : gfc_error ("COMMON block /%s/ not found at %C", n);
689 0 : goto cleanup;
690 : }
691 41 : p = gfc_get_omp_namelist ();
692 41 : if (head == NULL)
693 : head = tail = p;
694 : else
695 : {
696 4 : tail->next = p;
697 4 : tail = tail->next;
698 : }
699 41 : tail->u.common = st->n.common;
700 41 : tail->where = cur_loc;
701 :
702 549 : next_item:
703 549 : if (gfc_match_char (')') == MATCH_YES)
704 : break;
705 198 : if (gfc_match_char (',') != MATCH_YES)
706 0 : goto syntax;
707 : }
708 :
709 362 : while (*list)
710 11 : list = &(*list)->next;
711 :
712 351 : *list = head;
713 351 : return MATCH_YES;
714 :
715 0 : syntax:
716 0 : gfc_error ("Syntax error in OpenMP variable list at %C");
717 :
718 0 : cleanup:
719 0 : gfc_free_omp_namelist (head, OMP_LIST_NONE);
720 0 : gfc_current_locus = old_loc;
721 0 : return MATCH_ERROR;
722 : }
723 :
724 : /* Match detach(event-handle). */
725 :
726 : static match
727 126 : gfc_match_omp_detach (gfc_expr **expr)
728 : {
729 126 : locus old_loc = gfc_current_locus;
730 :
731 126 : if (gfc_match ("detach ( ") != MATCH_YES)
732 0 : goto syntax_error;
733 :
734 126 : if (gfc_match_variable (expr, 0) != MATCH_YES)
735 0 : goto syntax_error;
736 :
737 126 : if (gfc_match_char (')') != MATCH_YES)
738 0 : goto syntax_error;
739 :
740 : return MATCH_YES;
741 :
742 0 : syntax_error:
743 0 : gfc_error ("Syntax error in OpenMP detach clause at %C");
744 0 : gfc_current_locus = old_loc;
745 0 : return MATCH_ERROR;
746 :
747 : }
748 :
749 : /* Match doacross(sink : ...) construct a namelist from it;
750 : if depend is true, match legacy 'depend(sink : ...)'. */
751 :
752 : static match
753 241 : gfc_match_omp_doacross_sink (gfc_omp_namelist **list, bool depend)
754 : {
755 241 : char n[GFC_MAX_SYMBOL_LEN+1];
756 241 : gfc_omp_namelist *head, *tail, *p;
757 241 : locus old_loc, cur_loc;
758 241 : gfc_symbol *sym;
759 :
760 241 : head = tail = NULL;
761 :
762 241 : old_loc = gfc_current_locus;
763 :
764 2231 : for (;;)
765 : {
766 1236 : gfc_gobble_whitespace ();
767 1236 : cur_loc = gfc_current_locus;
768 :
769 1236 : if (gfc_match_name (n) != MATCH_YES)
770 1 : goto syntax;
771 1235 : locus loc = gfc_get_location_range (NULL, 0, &cur_loc, 1,
772 : &gfc_current_locus);
773 1235 : if (UNLIKELY (strcmp (n, "omp_all_memory") == 0))
774 : {
775 1 : gfc_error ("%<omp_all_memory%> used with dependence-type "
776 : "other than OUT or INOUT at %L", &loc);
777 1 : goto cleanup;
778 : }
779 1234 : sym = NULL;
780 1234 : if (!(strcmp (n, "omp_cur_iteration") == 0))
781 : {
782 1229 : gfc_symtree *st;
783 1229 : if (gfc_get_ha_sym_tree (n, &st))
784 0 : goto syntax;
785 1229 : sym = st->n.sym;
786 1229 : gfc_set_sym_referenced (sym);
787 : }
788 1234 : p = gfc_get_omp_namelist ();
789 1234 : if (head == NULL)
790 : {
791 239 : head = tail = p;
792 253 : head->u.depend_doacross_op = (depend ? OMP_DEPEND_SINK_FIRST
793 : : OMP_DOACROSS_SINK_FIRST);
794 : }
795 : else
796 : {
797 995 : tail->next = p;
798 995 : tail = tail->next;
799 995 : tail->u.depend_doacross_op = OMP_DOACROSS_SINK;
800 : }
801 1234 : tail->sym = sym;
802 1234 : tail->expr = NULL;
803 1234 : tail->where = loc;
804 1234 : if (gfc_match_char ('+') == MATCH_YES)
805 : {
806 154 : if (gfc_match_literal_constant (&tail->expr, 0) != MATCH_YES)
807 0 : goto syntax;
808 : }
809 1080 : else if (gfc_match_char ('-') == MATCH_YES)
810 : {
811 418 : if (gfc_match_literal_constant (&tail->expr, 0) != MATCH_YES)
812 1 : goto syntax;
813 417 : tail->expr = gfc_uminus (tail->expr);
814 : }
815 1233 : if (gfc_match_char (')') == MATCH_YES)
816 : break;
817 995 : if (gfc_match_char (',') != MATCH_YES)
818 0 : goto syntax;
819 995 : }
820 :
821 1030 : while (*list)
822 792 : list = &(*list)->next;
823 :
824 238 : *list = head;
825 238 : return MATCH_YES;
826 :
827 2 : syntax:
828 2 : gfc_error ("Syntax error in OpenMP SINK dependence-type list at %C");
829 :
830 3 : cleanup:
831 3 : gfc_free_omp_namelist (head, OMP_LIST_DEPEND);
832 3 : gfc_current_locus = old_loc;
833 3 : return MATCH_ERROR;
834 : }
835 :
836 : static int
837 332 : match_oacc_device_type_kind (void)
838 : {
839 332 : char name[GFC_MAX_SYMBOL_LEN + 1];
840 :
841 : /* Since device_type arg accept * as all,
842 : we need to check first the case when
843 : the user inputs * as the parameter. */
844 332 : gfc_gobble_whitespace ();
845 332 : name[0] = (char) gfc_next_char ();
846 :
847 332 : if (name[0] == '*')
848 : return GOMP_DEVICE_NONE;
849 :
850 : /* If is not *, we try to match the
851 : pre-defined names. */
852 :
853 332 : match m = gfc_match (" %n ", name + 1);
854 :
855 332 : if (m != MATCH_YES)
856 : return -1;
857 :
858 332 : if (strcmp (name ,"host") == 0)
859 : return GOMP_DEVICE_HOST;
860 144 : if (strcmp (name, "nvidia") == 0)
861 : return GOMP_DEVICE_NVIDIA_PTX;
862 72 : if (strcmp (name, "radeon") == 0)
863 69 : return GOMP_DEVICE_GCN;
864 :
865 : return -1;
866 : }
867 :
868 : static match
869 332 : match_oacc_device_type (gfc_omp_clauses *c)
870 : {
871 332 : locus old_loc = gfc_current_locus;
872 :
873 332 : int result = match_oacc_device_type_kind ();
874 332 : match m;
875 :
876 332 : if (result == -1)
877 3 : goto syntax;
878 :
879 329 : m = gfc_match_char (')', true);
880 :
881 329 : if (m != MATCH_YES)
882 3 : goto single_argument;
883 :
884 326 : c->oacc_device_type = (unsigned) result;
885 326 : c->oacc_device_type_present = 1;
886 :
887 326 : return MATCH_YES;
888 :
889 3 : single_argument:
890 3 : gfc_error ("OpenACC %<DEVICE_TYPE%> clause only accepts one argument, "
891 : "unexpected char at %C");
892 3 : goto cleanup;
893 :
894 3 : syntax:
895 3 : gfc_error ("Syntax error in OpenACC %<DEVICE_TYPE%> argument at %C. Expected "
896 : "host, radeon, nvidia or * as argument.");
897 :
898 6 : cleanup:
899 6 : gfc_current_locus = old_loc;
900 6 : return MATCH_ERROR;
901 : }
902 :
903 : static match
904 1960 : match_omp_oacc_expr_list (const char *str, gfc_expr_list **list,
905 : bool allow_asterisk, bool is_omp)
906 : {
907 1960 : gfc_expr_list *head, *tail, *p;
908 1960 : locus old_loc;
909 1960 : gfc_expr *expr;
910 1960 : match m;
911 :
912 1960 : head = tail = NULL;
913 :
914 1960 : old_loc = gfc_current_locus;
915 :
916 1960 : if (str && (m = gfc_match (str)) != MATCH_YES)
917 : return m;
918 :
919 2237 : for (;;)
920 : {
921 2237 : m = gfc_match_expr (&expr);
922 2237 : if (m == MATCH_YES || allow_asterisk)
923 : {
924 2220 : p = gfc_get_expr_list ();
925 2220 : if (head == NULL)
926 : head = tail = p;
927 : else
928 : {
929 400 : tail->next = p;
930 400 : tail = tail->next;
931 : }
932 2220 : if (m == MATCH_YES)
933 2087 : tail->expr = expr;
934 133 : else if (gfc_match (" *") != MATCH_YES)
935 18 : goto syntax;
936 2202 : goto next_item;
937 : }
938 17 : if (m == MATCH_ERROR)
939 0 : goto cleanup;
940 17 : goto syntax;
941 :
942 2202 : next_item:
943 2202 : if (gfc_match_char (')') == MATCH_YES)
944 : break;
945 422 : if (gfc_match_char (',') != MATCH_YES)
946 17 : goto syntax;
947 : }
948 :
949 1786 : while (*list)
950 6 : list = &(*list)->next;
951 :
952 1780 : *list = head;
953 1780 : return MATCH_YES;
954 :
955 52 : syntax:
956 52 : if (is_omp)
957 23 : gfc_error ("Syntax error in OpenMP expression list at %C");
958 : else
959 29 : gfc_error ("Syntax error in OpenACC expression list at %C");
960 :
961 52 : cleanup:
962 52 : gfc_free_expr_list (head);
963 52 : gfc_current_locus = old_loc;
964 52 : return MATCH_ERROR;
965 : }
966 :
967 : static match
968 3056 : match_oacc_clause_gwv (gfc_omp_clauses *cp, unsigned gwv)
969 : {
970 3056 : match ret = MATCH_YES;
971 :
972 3056 : if (gfc_match (" ( ") != MATCH_YES)
973 : return MATCH_NO;
974 :
975 470 : if (gwv == GOMP_DIM_GANG)
976 : {
977 : /* The gang clause accepts two optional arguments, num and static.
978 : The num argument may either be explicit (num: <val>) or
979 : implicit without (<val> without num:). */
980 :
981 457 : while (ret == MATCH_YES)
982 : {
983 236 : if (gfc_match (" static :") == MATCH_YES)
984 : {
985 114 : if (cp->gang_static)
986 : return MATCH_ERROR;
987 : else
988 113 : cp->gang_static = true;
989 113 : if (gfc_match_char ('*') == MATCH_YES)
990 18 : cp->gang_static_expr = NULL;
991 95 : else if (gfc_match (" %e ", &cp->gang_static_expr) != MATCH_YES)
992 : return MATCH_ERROR;
993 : }
994 : else
995 : {
996 122 : if (cp->gang_num_expr)
997 : return MATCH_ERROR;
998 :
999 : /* The 'num' argument is optional. */
1000 121 : gfc_match (" num :");
1001 :
1002 121 : if (gfc_match (" %e ", &cp->gang_num_expr) != MATCH_YES)
1003 : return MATCH_ERROR;
1004 : }
1005 :
1006 231 : ret = gfc_match (" , ");
1007 : }
1008 : }
1009 244 : else if (gwv == GOMP_DIM_WORKER)
1010 : {
1011 : /* The 'num' argument is optional. */
1012 107 : gfc_match (" num :");
1013 :
1014 107 : if (gfc_match (" %e ", &cp->worker_expr) != MATCH_YES)
1015 : return MATCH_ERROR;
1016 : }
1017 137 : else if (gwv == GOMP_DIM_VECTOR)
1018 : {
1019 : /* The 'length' argument is optional. */
1020 137 : gfc_match (" length :");
1021 :
1022 137 : if (gfc_match (" %e ", &cp->vector_expr) != MATCH_YES)
1023 : return MATCH_ERROR;
1024 : }
1025 : else
1026 0 : gfc_fatal_error ("Unexpected OpenACC parallelism.");
1027 :
1028 459 : return gfc_match (" )");
1029 : }
1030 :
1031 : static match
1032 8 : gfc_match_oacc_clause_link (const char *str, gfc_omp_namelist **list)
1033 : {
1034 8 : gfc_omp_namelist *head = NULL;
1035 8 : gfc_omp_namelist *tail, *p;
1036 8 : locus old_loc;
1037 8 : char n[GFC_MAX_SYMBOL_LEN+1];
1038 8 : gfc_symbol *sym;
1039 8 : match m;
1040 8 : gfc_symtree *st;
1041 :
1042 8 : old_loc = gfc_current_locus;
1043 :
1044 8 : m = gfc_match (str);
1045 8 : if (m != MATCH_YES)
1046 : return m;
1047 :
1048 8 : m = gfc_match (" (");
1049 :
1050 14 : for (;;)
1051 : {
1052 14 : m = gfc_match_symbol (&sym, 0);
1053 14 : switch (m)
1054 : {
1055 8 : case MATCH_YES:
1056 8 : if (sym->attr.in_common)
1057 : {
1058 2 : gfc_error_now ("Variable at %C is an element of a COMMON block");
1059 2 : goto cleanup;
1060 : }
1061 6 : gfc_set_sym_referenced (sym);
1062 6 : p = gfc_get_omp_namelist ();
1063 6 : if (head == NULL)
1064 : head = tail = p;
1065 : else
1066 : {
1067 4 : tail->next = p;
1068 4 : tail = tail->next;
1069 : }
1070 6 : tail->sym = sym;
1071 6 : tail->expr = NULL;
1072 6 : tail->where = gfc_current_locus;
1073 6 : goto next_item;
1074 : case MATCH_NO:
1075 : break;
1076 :
1077 0 : case MATCH_ERROR:
1078 0 : goto cleanup;
1079 : }
1080 :
1081 6 : m = gfc_match (" / %n /", n);
1082 6 : if (m == MATCH_ERROR)
1083 0 : goto cleanup;
1084 6 : if (m == MATCH_NO || n[0] == '\0')
1085 0 : goto syntax;
1086 :
1087 6 : st = gfc_find_symtree (gfc_current_ns->common_root, n);
1088 6 : if (st == NULL)
1089 : {
1090 1 : gfc_error ("COMMON block /%s/ not found at %C", n);
1091 1 : goto cleanup;
1092 : }
1093 :
1094 20 : for (sym = st->n.common->head; sym; sym = sym->common_next)
1095 : {
1096 15 : gfc_set_sym_referenced (sym);
1097 15 : p = gfc_get_omp_namelist ();
1098 15 : if (head == NULL)
1099 : head = tail = p;
1100 : else
1101 : {
1102 12 : tail->next = p;
1103 12 : tail = tail->next;
1104 : }
1105 15 : tail->sym = sym;
1106 15 : tail->where = gfc_current_locus;
1107 : }
1108 :
1109 5 : next_item:
1110 11 : if (gfc_match_char (')') == MATCH_YES)
1111 : break;
1112 6 : if (gfc_match_char (',') != MATCH_YES)
1113 0 : goto syntax;
1114 : }
1115 :
1116 5 : if (gfc_match_omp_eos () != MATCH_YES)
1117 : {
1118 1 : gfc_error ("Unexpected junk after !$ACC DECLARE at %C");
1119 1 : goto cleanup;
1120 : }
1121 :
1122 4 : while (*list)
1123 0 : list = &(*list)->next;
1124 4 : *list = head;
1125 4 : return MATCH_YES;
1126 :
1127 0 : syntax:
1128 0 : gfc_error ("Syntax error in !$ACC DECLARE list at %C");
1129 :
1130 4 : cleanup:
1131 4 : gfc_current_locus = old_loc;
1132 4 : return MATCH_ERROR;
1133 : }
1134 :
1135 : /* OpenMP clauses. */
1136 : enum omp_mask1
1137 : {
1138 : OMP_CLAUSE_PRIVATE,
1139 : OMP_CLAUSE_FIRSTPRIVATE,
1140 : OMP_CLAUSE_LASTPRIVATE,
1141 : OMP_CLAUSE_COPYPRIVATE,
1142 : OMP_CLAUSE_SHARED,
1143 : OMP_CLAUSE_COPYIN,
1144 : OMP_CLAUSE_REDUCTION,
1145 : OMP_CLAUSE_IN_REDUCTION,
1146 : OMP_CLAUSE_TASK_REDUCTION,
1147 : OMP_CLAUSE_IF,
1148 : OMP_CLAUSE_NUM_THREADS,
1149 : OMP_CLAUSE_SCHEDULE,
1150 : OMP_CLAUSE_DEFAULT,
1151 : OMP_CLAUSE_ORDER,
1152 : OMP_CLAUSE_ORDERED,
1153 : OMP_CLAUSE_COLLAPSE,
1154 : OMP_CLAUSE_UNTIED,
1155 : OMP_CLAUSE_FINAL,
1156 : OMP_CLAUSE_MERGEABLE,
1157 : OMP_CLAUSE_ALIGNED,
1158 : OMP_CLAUSE_DEPEND,
1159 : OMP_CLAUSE_INBRANCH,
1160 : OMP_CLAUSE_LINEAR,
1161 : OMP_CLAUSE_NOTINBRANCH,
1162 : OMP_CLAUSE_PROC_BIND,
1163 : OMP_CLAUSE_SAFELEN,
1164 : OMP_CLAUSE_SIMDLEN,
1165 : OMP_CLAUSE_UNIFORM,
1166 : OMP_CLAUSE_DEVICE,
1167 : OMP_CLAUSE_MAP,
1168 : OMP_CLAUSE_TO,
1169 : OMP_CLAUSE_FROM,
1170 : OMP_CLAUSE_NUM_TEAMS,
1171 : OMP_CLAUSE_THREAD_LIMIT,
1172 : OMP_CLAUSE_DIST_SCHEDULE,
1173 : OMP_CLAUSE_DEFAULTMAP,
1174 : OMP_CLAUSE_GRAINSIZE,
1175 : OMP_CLAUSE_HINT,
1176 : OMP_CLAUSE_IS_DEVICE_PTR,
1177 : OMP_CLAUSE_LINK,
1178 : OMP_CLAUSE_NOGROUP,
1179 : OMP_CLAUSE_NOTEMPORAL,
1180 : OMP_CLAUSE_NUM_TASKS,
1181 : OMP_CLAUSE_PRIORITY,
1182 : OMP_CLAUSE_SIMD,
1183 : OMP_CLAUSE_THREADS,
1184 : OMP_CLAUSE_USE_DEVICE_PTR,
1185 : OMP_CLAUSE_USE_DEVICE_ADDR, /* OpenMP 5.0. */
1186 : OMP_CLAUSE_DEVICE_TYPE, /* OpenMP 5.0. */
1187 : OMP_CLAUSE_ATOMIC, /* OpenMP 5.0. */
1188 : OMP_CLAUSE_CAPTURE, /* OpenMP 5.0. */
1189 : OMP_CLAUSE_MEMORDER, /* OpenMP 5.0. */
1190 : OMP_CLAUSE_DETACH, /* OpenMP 5.0. */
1191 : OMP_CLAUSE_AFFINITY, /* OpenMP 5.0. */
1192 : OMP_CLAUSE_ALLOCATE, /* OpenMP 5.0. */
1193 : OMP_CLAUSE_BIND, /* OpenMP 5.0. */
1194 : OMP_CLAUSE_FILTER, /* OpenMP 5.1. */
1195 : OMP_CLAUSE_AT, /* OpenMP 5.1. */
1196 : OMP_CLAUSE_MESSAGE, /* OpenMP 5.1. */
1197 : OMP_CLAUSE_SEVERITY, /* OpenMP 5.1. */
1198 : OMP_CLAUSE_COMPARE, /* OpenMP 5.1. */
1199 : OMP_CLAUSE_FAIL, /* OpenMP 5.1. */
1200 : OMP_CLAUSE_WEAK, /* OpenMP 5.1. */
1201 : OMP_CLAUSE_NOWAIT,
1202 : /* This must come last. */
1203 : OMP_MASK1_LAST
1204 : };
1205 :
1206 : /* More OpenMP clauses and OpenACC 2.0+ specific clauses. */
1207 : enum omp_mask2
1208 : {
1209 : OMP_CLAUSE_ASYNC,
1210 : OMP_CLAUSE_NUM_GANGS,
1211 : OMP_CLAUSE_NUM_WORKERS,
1212 : OMP_CLAUSE_VECTOR_LENGTH,
1213 : OMP_CLAUSE_COPY,
1214 : OMP_CLAUSE_COPYOUT,
1215 : OMP_CLAUSE_CREATE,
1216 : OMP_CLAUSE_NO_CREATE,
1217 : OMP_CLAUSE_PRESENT,
1218 : OMP_CLAUSE_DEVICEPTR,
1219 : OMP_CLAUSE_GANG,
1220 : OMP_CLAUSE_WORKER,
1221 : OMP_CLAUSE_VECTOR,
1222 : OMP_CLAUSE_SEQ,
1223 : OMP_CLAUSE_INDEPENDENT,
1224 : OMP_CLAUSE_USE_DEVICE,
1225 : OMP_CLAUSE_DEVICE_RESIDENT,
1226 : OMP_CLAUSE_SELF,
1227 : OMP_CLAUSE_HOST,
1228 : OMP_CLAUSE_WAIT,
1229 : OMP_CLAUSE_DELETE,
1230 : OMP_CLAUSE_AUTO,
1231 : OMP_CLAUSE_TILE,
1232 : OMP_CLAUSE_IF_PRESENT,
1233 : OMP_CLAUSE_FINALIZE,
1234 : OMP_CLAUSE_ATTACH,
1235 : OMP_CLAUSE_NOHOST,
1236 : OMP_CLAUSE_HAS_DEVICE_ADDR, /* OpenMP 5.1 */
1237 : OMP_CLAUSE_ENTER, /* OpenMP 5.2 */
1238 : OMP_CLAUSE_DOACROSS, /* OpenMP 5.2 */
1239 : OMP_CLAUSE_ASSUMPTIONS, /* OpenMP 5.1. */
1240 : OMP_CLAUSE_USES_ALLOCATORS, /* OpenMP 5.0 */
1241 : OMP_CLAUSE_INDIRECT, /* OpenMP 5.1 */
1242 : OMP_CLAUSE_FULL, /* OpenMP 5.1. */
1243 : OMP_CLAUSE_PARTIAL, /* OpenMP 5.1. */
1244 : OMP_CLAUSE_SIZES, /* OpenMP 5.1. */
1245 : OMP_CLAUSE_INIT, /* OpenMP 5.1. */
1246 : OMP_CLAUSE_DESTROY, /* OpenMP 5.1. */
1247 : OMP_CLAUSE_USE, /* OpenMP 5.1. */
1248 : OMP_CLAUSE_NOVARIANTS, /* OpenMP 5.1 */
1249 : OMP_CLAUSE_NOCONTEXT, /* OpenMP 5.1 */
1250 : OMP_CLAUSE_INTEROP, /* OpenMP 5.1 */
1251 : OMP_CLAUSE_LOCAL, /* OpenMP 6.0 */
1252 : OMP_CLAUSE_DYN_GROUPPRIVATE, /* OpenMP 6.1 */
1253 : OMP_CLAUSE_DEVICE_NUM,
1254 : /* This must come last. */
1255 : OMP_MASK2_LAST
1256 : };
1257 :
1258 : struct omp_inv_mask;
1259 :
1260 : /* Customized bitset for up to 128-bits.
1261 : The two enums above provide bit numbers to use, and which of the
1262 : two enums it is determines which of the two mask fields is used.
1263 : Supported operations are defining a mask, like:
1264 : #define XXX_CLAUSES \
1265 : (omp_mask (OMP_CLAUSE_XXX) | OMP_CLAUSE_YYY | OMP_CLAUSE_ZZZ)
1266 : oring such bitsets together or removing selected bits:
1267 : (XXX_CLAUSES | YYY_CLAUSES) & ~(omp_mask (OMP_CLAUSE_VVV))
1268 : and testing individual bits:
1269 : if (mask & OMP_CLAUSE_UUU) */
1270 :
1271 : struct omp_mask {
1272 : const uint64_t mask1;
1273 : const uint64_t mask2;
1274 : inline omp_mask ();
1275 : inline omp_mask (omp_mask1);
1276 : inline omp_mask (omp_mask2);
1277 : inline omp_mask (uint64_t, uint64_t);
1278 : inline omp_mask operator| (omp_mask1) const;
1279 : inline omp_mask operator| (omp_mask2) const;
1280 : inline omp_mask operator| (omp_mask) const;
1281 : inline omp_mask operator& (const omp_inv_mask &) const;
1282 : inline bool operator& (omp_mask1) const;
1283 : inline bool operator& (omp_mask2) const;
1284 : inline omp_inv_mask operator~ () const;
1285 : };
1286 :
1287 : struct omp_inv_mask : public omp_mask {
1288 : inline omp_inv_mask (const omp_mask &);
1289 : };
1290 :
1291 : omp_mask::omp_mask () : mask1 (0), mask2 (0)
1292 : {
1293 : }
1294 :
1295 32873 : omp_mask::omp_mask (omp_mask1 m) : mask1 (((uint64_t) 1) << m), mask2 (0)
1296 : {
1297 : }
1298 :
1299 2205 : omp_mask::omp_mask (omp_mask2 m) : mask1 (0), mask2 (((uint64_t) 1) << m)
1300 : {
1301 : }
1302 :
1303 33755 : omp_mask::omp_mask (uint64_t m1, uint64_t m2) : mask1 (m1), mask2 (m2)
1304 : {
1305 : }
1306 :
1307 : omp_mask
1308 32804 : omp_mask::operator| (omp_mask1 m) const
1309 : {
1310 32804 : return omp_mask (mask1 | (((uint64_t) 1) << m), mask2);
1311 : }
1312 :
1313 : omp_mask
1314 17264 : omp_mask::operator| (omp_mask2 m) const
1315 : {
1316 17264 : return omp_mask (mask1, mask2 | (((uint64_t) 1) << m));
1317 : }
1318 :
1319 : omp_mask
1320 4374 : omp_mask::operator| (omp_mask m) const
1321 : {
1322 4374 : return omp_mask (mask1 | m.mask1, mask2 | m.mask2);
1323 : }
1324 :
1325 : omp_mask
1326 2031 : omp_mask::operator& (const omp_inv_mask &m) const
1327 : {
1328 2031 : return omp_mask (mask1 & ~m.mask1, mask2 & ~m.mask2);
1329 : }
1330 :
1331 : bool
1332 129578 : omp_mask::operator& (omp_mask1 m) const
1333 : {
1334 129578 : return (mask1 & (((uint64_t) 1) << m)) != 0;
1335 : }
1336 :
1337 : bool
1338 92329 : omp_mask::operator& (omp_mask2 m) const
1339 : {
1340 92329 : return (mask2 & (((uint64_t) 1) << m)) != 0;
1341 : }
1342 :
1343 : omp_inv_mask
1344 2031 : omp_mask::operator~ () const
1345 : {
1346 2031 : return omp_inv_mask (*this);
1347 : }
1348 :
1349 2031 : omp_inv_mask::omp_inv_mask (const omp_mask &m) : omp_mask (m)
1350 : {
1351 : }
1352 :
1353 : /* Helper function for OpenACC and OpenMP clauses involving memory
1354 : mapping. */
1355 :
1356 : static bool
1357 5544 : gfc_match_omp_map_clause (gfc_omp_namelist **list, gfc_omp_map_op map_op,
1358 : bool allow_common, bool allow_derived)
1359 : {
1360 5544 : gfc_omp_namelist **head = NULL;
1361 5544 : if (gfc_match_omp_variable_list ("", list, allow_common, NULL, &head, true,
1362 : allow_derived)
1363 : == MATCH_YES)
1364 : {
1365 5535 : gfc_omp_namelist *n;
1366 13409 : for (n = *head; n; n = n->next)
1367 7874 : n->u.map.op = map_op;
1368 : return true;
1369 : }
1370 :
1371 : return false;
1372 : }
1373 :
1374 : static match
1375 8729 : gfc_match_iterator (gfc_namespace **ns, bool permit_var)
1376 : {
1377 8729 : locus old_loc = gfc_current_locus;
1378 :
1379 8729 : if (gfc_match ("iterator ( ") != MATCH_YES)
1380 : return MATCH_NO;
1381 :
1382 142 : gfc_typespec ts;
1383 142 : gfc_symbol *last = NULL;
1384 142 : gfc_expr *begin, *end, *step;
1385 142 : *ns = gfc_build_block_ns (gfc_current_ns);
1386 161 : char name[GFC_MAX_SYMBOL_LEN + 1];
1387 180 : while (true)
1388 : {
1389 161 : locus prev_loc = gfc_current_locus;
1390 161 : if (gfc_match_type_spec (&ts) == MATCH_YES
1391 161 : && gfc_match (" :: ") == MATCH_YES)
1392 : {
1393 5 : if (ts.type != BT_INTEGER)
1394 : {
1395 2 : gfc_error ("Expected INTEGER type at %L", &prev_loc);
1396 5 : return MATCH_ERROR;
1397 : }
1398 : permit_var = false;
1399 : }
1400 : else
1401 : {
1402 156 : ts.type = BT_INTEGER;
1403 156 : ts.kind = gfc_default_integer_kind;
1404 156 : gfc_current_locus = prev_loc;
1405 : }
1406 159 : prev_loc = gfc_current_locus;
1407 159 : if (gfc_match_name (name) != MATCH_YES)
1408 : {
1409 4 : gfc_error ("Expected identifier at %C");
1410 4 : goto failed;
1411 : }
1412 155 : if (gfc_find_symtree ((*ns)->sym_root, name))
1413 : {
1414 2 : gfc_error ("Same identifier %qs specified again at %C", name);
1415 2 : goto failed;
1416 : }
1417 :
1418 153 : gfc_symbol *sym = gfc_new_symbol (name, *ns);
1419 153 : if (last)
1420 17 : last->tlink = sym;
1421 : else
1422 136 : (*ns)->omp_affinity_iterators = sym;
1423 153 : last = sym;
1424 153 : sym->declared_at = prev_loc;
1425 153 : sym->ts = ts;
1426 153 : sym->attr.flavor = FL_VARIABLE;
1427 153 : sym->attr.artificial = 1;
1428 153 : sym->attr.referenced = 1;
1429 153 : sym->refs++;
1430 153 : gfc_symtree *st = gfc_new_symtree (&(*ns)->sym_root, name);
1431 153 : st->n.sym = sym;
1432 :
1433 153 : prev_loc = gfc_current_locus;
1434 153 : if (gfc_match (" = ") != MATCH_YES)
1435 3 : goto failed;
1436 150 : permit_var = false;
1437 150 : begin = end = step = NULL;
1438 150 : if (gfc_match ("%e : ", &begin) != MATCH_YES
1439 150 : || gfc_match ("%e ", &end) != MATCH_YES)
1440 : {
1441 3 : gfc_error ("Expected range-specification at %C");
1442 3 : gfc_free_expr (begin);
1443 3 : gfc_free_expr (end);
1444 3 : return MATCH_ERROR;
1445 : }
1446 147 : if (':' == gfc_peek_ascii_char ())
1447 : {
1448 23 : if (gfc_match (": %e ", &step) != MATCH_YES)
1449 : {
1450 5 : gfc_free_expr (begin);
1451 5 : gfc_free_expr (end);
1452 5 : gfc_free_expr (step);
1453 5 : goto failed;
1454 : }
1455 : }
1456 :
1457 142 : gfc_expr *e = gfc_get_expr ();
1458 142 : e->where = prev_loc;
1459 142 : e->expr_type = EXPR_ARRAY;
1460 142 : e->ts = ts;
1461 142 : e->rank = 1;
1462 142 : e->shape = gfc_get_shape (1);
1463 266 : mpz_init_set_ui (e->shape[0], step ? 3 : 2);
1464 142 : gfc_constructor_append_expr (&e->value.constructor, begin, &begin->where);
1465 142 : gfc_constructor_append_expr (&e->value.constructor, end, &end->where);
1466 142 : if (step)
1467 18 : gfc_constructor_append_expr (&e->value.constructor, step, &step->where);
1468 142 : sym->value = e;
1469 :
1470 142 : if (gfc_match (") ") == MATCH_YES)
1471 : break;
1472 19 : if (gfc_match (", ") != MATCH_YES)
1473 0 : goto failed;
1474 19 : }
1475 123 : return MATCH_YES;
1476 :
1477 14 : failed:
1478 14 : gfc_namespace *prev_ns = NULL;
1479 14 : for (gfc_namespace *it = gfc_current_ns->contained; it; it = it->sibling)
1480 : {
1481 0 : if (it == *ns)
1482 : {
1483 0 : if (prev_ns)
1484 0 : prev_ns->sibling = it->sibling;
1485 : else
1486 0 : gfc_current_ns->contained = it->sibling;
1487 0 : gfc_free_namespace (it);
1488 0 : break;
1489 : }
1490 0 : prev_ns = it;
1491 : }
1492 14 : *ns = NULL;
1493 14 : if (!permit_var)
1494 : return MATCH_ERROR;
1495 4 : gfc_current_locus = old_loc;
1496 4 : return MATCH_NO;
1497 : }
1498 :
1499 : /* Match target update's to/from( [present:] var-list). */
1500 :
1501 : static match
1502 1736 : gfc_match_motion_var_list (const char *str, gfc_omp_namelist **list,
1503 : gfc_omp_namelist ***headp)
1504 : {
1505 1736 : match m = gfc_match (str);
1506 1736 : if (m != MATCH_YES)
1507 : return m;
1508 :
1509 1736 : gfc_namespace *ns_iter = NULL, *ns_curr = gfc_current_ns;
1510 1736 : locus old_loc = gfc_current_locus;
1511 1736 : int present_modifier = 0;
1512 1736 : int iterator_modifier = 0;
1513 1736 : locus second_present_locus = old_loc;
1514 1736 : locus second_iterator_locus = old_loc;
1515 1736 : bool saw_modifier = false;
1516 :
1517 1748 : for (;;)
1518 : {
1519 1742 : locus current_locus = gfc_current_locus;
1520 1742 : if (gfc_match ("present ") == MATCH_YES)
1521 : {
1522 8 : if (present_modifier++ == 1)
1523 0 : second_present_locus = current_locus;
1524 : }
1525 1734 : else if (gfc_match_iterator (&ns_iter, true) == MATCH_YES)
1526 : {
1527 20 : if (iterator_modifier++ == 1)
1528 1 : second_iterator_locus = current_locus;
1529 : }
1530 1714 : else if (!saw_modifier)
1531 : break;
1532 : else
1533 : {
1534 2 : gfc_error ("Expected clause modifier at %C");
1535 4 : return MATCH_ERROR;
1536 : }
1537 :
1538 : /* OpenMP 5.1 syntax mistakenly allowed commas to be optional
1539 : between and after modifiers in a clause. This was corrected
1540 : in 5.2 and later specifications: they're now required between
1541 : modifiers and a trailing comma is not permitted. We implement
1542 : the 5.2 syntax here. */
1543 28 : saw_modifier = true;
1544 28 : if (gfc_match (" : ") == MATCH_YES)
1545 : break;
1546 8 : else if (gfc_match (", ") == MATCH_YES)
1547 6 : continue;
1548 : else
1549 : {
1550 2 : gfc_error ("Expected %<,%> or %<:%> after clause modifier at %C");
1551 2 : return MATCH_ERROR;
1552 : }
1553 : }
1554 :
1555 1732 : if (!saw_modifier)
1556 : {
1557 1712 : gfc_current_locus = old_loc;
1558 1712 : present_modifier = 0;
1559 1712 : iterator_modifier = 0;
1560 : }
1561 :
1562 1732 : if (present_modifier > 1)
1563 : {
1564 0 : gfc_error ("Too many %<present%> modifiers at %L", &second_present_locus);
1565 0 : return MATCH_ERROR;
1566 : }
1567 1732 : if (iterator_modifier > 1)
1568 : {
1569 1 : gfc_error ("Too many %<iterator%> modifiers at %L",
1570 : &second_iterator_locus);
1571 1 : return MATCH_ERROR;
1572 : }
1573 :
1574 1731 : if (ns_iter)
1575 14 : gfc_current_ns = ns_iter;
1576 :
1577 1731 : m = gfc_match_omp_variable_list ("", list, false, NULL, headp, true, true);
1578 1731 : gfc_current_ns = ns_curr;
1579 1731 : if (m != MATCH_YES)
1580 : return m;
1581 1729 : gfc_omp_namelist *n;
1582 3532 : for (n = **headp; n; n = n->next)
1583 : {
1584 1803 : if (present_modifier)
1585 6 : n->u.present_modifier = true;
1586 1803 : if (iterator_modifier)
1587 : {
1588 18 : n->u2.ns = ns_iter;
1589 18 : ns_iter->refs++;
1590 : }
1591 : }
1592 : return MATCH_YES;
1593 : }
1594 :
1595 : /* reduction ( reduction-modifier, reduction-operator : variable-list )
1596 : in_reduction ( reduction-operator : variable-list )
1597 : task_reduction ( reduction-operator : variable-list ) */
1598 :
1599 : static match
1600 4360 : gfc_match_omp_clause_reduction (char pc, gfc_omp_clauses *c, bool openacc,
1601 : bool allow_derived, bool openmp_target = false)
1602 : {
1603 4360 : if (pc == 'r' && gfc_match ("reduction ( ") != MATCH_YES)
1604 : return MATCH_NO;
1605 4360 : else if (pc == 'i' && gfc_match ("in_reduction ( ") != MATCH_YES)
1606 : return MATCH_NO;
1607 4248 : else if (pc == 't' && gfc_match ("task_reduction ( ") != MATCH_YES)
1608 : return MATCH_NO;
1609 :
1610 4248 : locus old_loc = gfc_current_locus;
1611 4248 : enum gfc_omp_list_type list_idx = OMP_LIST_NONE;
1612 :
1613 4248 : if (pc == 'r' && !openacc)
1614 : {
1615 2121 : if (gfc_match ("inscan") == MATCH_YES)
1616 : list_idx = OMP_LIST_REDUCTION_INSCAN;
1617 2051 : else if (gfc_match ("task") == MATCH_YES)
1618 : list_idx = OMP_LIST_REDUCTION_TASK;
1619 1946 : else if (gfc_match ("default") == MATCH_YES)
1620 : list_idx = OMP_LIST_REDUCTION;
1621 231 : if (list_idx != OMP_LIST_NONE && gfc_match (", ") != MATCH_YES)
1622 : {
1623 1 : gfc_error ("Comma expected at %C");
1624 1 : gfc_current_locus = old_loc;
1625 1 : return MATCH_NO;
1626 : }
1627 2120 : if (list_idx == OMP_LIST_NONE)
1628 3834 : list_idx = OMP_LIST_REDUCTION;
1629 : }
1630 2127 : else if (pc == 'i')
1631 : list_idx = OMP_LIST_IN_REDUCTION;
1632 2009 : else if (pc == 't')
1633 : list_idx = OMP_LIST_TASK_REDUCTION;
1634 : else
1635 3834 : list_idx = OMP_LIST_REDUCTION;
1636 :
1637 4247 : gfc_omp_reduction_op rop = OMP_REDUCTION_NONE;
1638 4247 : char buffer[GFC_MAX_SYMBOL_LEN + 3];
1639 4247 : if (gfc_match_char ('+') == MATCH_YES)
1640 : rop = OMP_REDUCTION_PLUS;
1641 2223 : else if (gfc_match_char ('*') == MATCH_YES)
1642 : rop = OMP_REDUCTION_TIMES;
1643 1991 : else if (gfc_match_char ('-') == MATCH_YES)
1644 : {
1645 171 : if (!openacc)
1646 16 : gfc_warning (OPT_Wdeprecated_openmp,
1647 : "%<-%> operator at %C for reductions deprecated in "
1648 : "OpenMP 5.2");
1649 : rop = OMP_REDUCTION_MINUS;
1650 : }
1651 1820 : else if (gfc_match (".and.") == MATCH_YES)
1652 : rop = OMP_REDUCTION_AND;
1653 1714 : else if (gfc_match (".or.") == MATCH_YES)
1654 : rop = OMP_REDUCTION_OR;
1655 929 : else if (gfc_match (".eqv.") == MATCH_YES)
1656 : rop = OMP_REDUCTION_EQV;
1657 831 : else if (gfc_match (".neqv.") == MATCH_YES)
1658 : rop = OMP_REDUCTION_NEQV;
1659 736 : if (rop != OMP_REDUCTION_NONE)
1660 3511 : snprintf (buffer, sizeof buffer, "operator %s",
1661 : gfc_op2string ((gfc_intrinsic_op) rop));
1662 736 : else if (gfc_match_defined_op_name (buffer + 1, 1) == MATCH_YES)
1663 : {
1664 38 : buffer[0] = '.';
1665 38 : strcat (buffer, ".");
1666 : }
1667 698 : else if (gfc_match_name (buffer) == MATCH_YES)
1668 : {
1669 697 : gfc_symbol *sym;
1670 697 : const char *n = buffer;
1671 :
1672 697 : gfc_find_symbol (buffer, NULL, 1, &sym);
1673 697 : if (sym != NULL)
1674 : {
1675 216 : if (sym->attr.intrinsic)
1676 139 : n = sym->name;
1677 77 : else if ((sym->attr.flavor != FL_UNKNOWN
1678 75 : && sym->attr.flavor != FL_PROCEDURE)
1679 75 : || sym->attr.external
1680 64 : || sym->attr.generic
1681 64 : || sym->attr.entry
1682 64 : || sym->attr.result
1683 64 : || sym->attr.dummy
1684 64 : || sym->attr.subroutine
1685 63 : || sym->attr.pointer
1686 63 : || sym->attr.target
1687 63 : || sym->attr.cray_pointer
1688 63 : || sym->attr.cray_pointee
1689 63 : || (sym->attr.proc != PROC_UNKNOWN
1690 1 : && sym->attr.proc != PROC_INTRINSIC)
1691 62 : || sym->attr.if_source != IFSRC_UNKNOWN
1692 62 : || sym == sym->ns->proc_name)
1693 : {
1694 : sym = NULL;
1695 : n = NULL;
1696 : }
1697 : else
1698 62 : n = sym->name;
1699 : }
1700 201 : if (n == NULL)
1701 : rop = OMP_REDUCTION_NONE;
1702 682 : else if (strcmp (n, "max") == 0)
1703 : rop = OMP_REDUCTION_MAX;
1704 517 : else if (strcmp (n, "min") == 0)
1705 : rop = OMP_REDUCTION_MIN;
1706 376 : else if (strcmp (n, "iand") == 0)
1707 : rop = OMP_REDUCTION_IAND;
1708 321 : else if (strcmp (n, "ior") == 0)
1709 : rop = OMP_REDUCTION_IOR;
1710 255 : else if (strcmp (n, "ieor") == 0)
1711 : rop = OMP_REDUCTION_IEOR;
1712 : if (rop != OMP_REDUCTION_NONE
1713 477 : && sym != NULL
1714 200 : && ! sym->attr.intrinsic
1715 61 : && ! sym->attr.use_assoc
1716 61 : && ((sym->attr.flavor == FL_UNKNOWN
1717 2 : && !gfc_add_flavor (&sym->attr, FL_PROCEDURE,
1718 : sym->name, NULL))
1719 61 : || !gfc_add_intrinsic (&sym->attr, NULL)))
1720 : rop = OMP_REDUCTION_NONE;
1721 : }
1722 : else
1723 1 : buffer[0] = '\0';
1724 4247 : gfc_omp_udr *udr = (buffer[0] ? gfc_find_omp_udr (gfc_current_ns, buffer, NULL)
1725 : : NULL);
1726 4247 : gfc_omp_namelist **head = NULL;
1727 4247 : if (rop == OMP_REDUCTION_NONE && udr)
1728 250 : rop = OMP_REDUCTION_USER;
1729 :
1730 4247 : if (gfc_match_omp_variable_list (" :", &c->lists[list_idx], false, NULL,
1731 : &head, openacc, allow_derived) != MATCH_YES)
1732 : {
1733 9 : gfc_current_locus = old_loc;
1734 9 : return MATCH_NO;
1735 : }
1736 4238 : gfc_omp_namelist *n;
1737 4238 : if (rop == OMP_REDUCTION_NONE)
1738 : {
1739 6 : n = *head;
1740 6 : *head = NULL;
1741 6 : gfc_error_now ("!$OMP DECLARE REDUCTION %s not found at %L",
1742 : buffer, &old_loc);
1743 6 : gfc_free_omp_namelist (n, OMP_LIST_NONE);
1744 : }
1745 : else
1746 9116 : for (n = *head; n; n = n->next)
1747 : {
1748 4884 : n->u.reduction_op = rop;
1749 4884 : if (udr)
1750 : {
1751 476 : n->u2.udr = gfc_get_omp_namelist_udr ();
1752 476 : n->u2.udr->udr = udr;
1753 : }
1754 4884 : if (openmp_target && list_idx == OMP_LIST_IN_REDUCTION)
1755 : {
1756 40 : gfc_omp_namelist *p = gfc_get_omp_namelist (), **tl;
1757 40 : p->sym = n->sym;
1758 40 : p->where = n->where;
1759 40 : p->u.map.op = OMP_MAP_ALWAYS_TOFROM;
1760 :
1761 40 : tl = &c->lists[OMP_LIST_MAP];
1762 52 : while (*tl)
1763 12 : tl = &((*tl)->next);
1764 40 : *tl = p;
1765 40 : p->next = NULL;
1766 : }
1767 : }
1768 : return MATCH_YES;
1769 : }
1770 :
1771 : static match
1772 40 : gfc_omp_absent_contains_clause (gfc_omp_assumptions **assume, bool is_absent)
1773 : {
1774 40 : if (*assume == NULL)
1775 15 : *assume = gfc_get_omp_assumptions ();
1776 62 : do
1777 : {
1778 51 : gfc_statement st = ST_NONE;
1779 51 : gfc_gobble_whitespace ();
1780 51 : locus old_loc = gfc_current_locus;
1781 51 : char c = gfc_peek_ascii_char ();
1782 51 : enum gfc_omp_directive_kind kind
1783 : = GFC_OMP_DIR_DECLARATIVE; /* Silence warning. */
1784 1585 : for (size_t i = 0; i < ARRAY_SIZE (gfc_omp_directives); i++)
1785 : {
1786 1585 : if (gfc_omp_directives[i].name[0] > c)
1787 : break;
1788 1534 : if (gfc_omp_directives[i].name[0] != c)
1789 1182 : continue;
1790 352 : if (gfc_match (gfc_omp_directives[i].name) == MATCH_YES)
1791 : {
1792 51 : st = gfc_omp_directives[i].st;
1793 51 : kind = gfc_omp_directives[i].kind;
1794 : }
1795 : }
1796 51 : gfc_gobble_whitespace ();
1797 51 : c = gfc_peek_ascii_char ();
1798 51 : if (st == ST_NONE || (c != ',' && c != ')'))
1799 : {
1800 0 : if (st == ST_NONE)
1801 0 : gfc_error ("Unknown directive at %L", &old_loc);
1802 : else
1803 0 : gfc_error ("Invalid combined or composite directive at %L",
1804 : &old_loc);
1805 4 : return MATCH_ERROR;
1806 : }
1807 51 : if (kind == GFC_OMP_DIR_DECLARATIVE
1808 51 : || kind == GFC_OMP_DIR_INFORMATIONAL
1809 : || kind == GFC_OMP_DIR_META)
1810 : {
1811 5 : gfc_error ("Invalid %qs directive at %L in %s clause: declarative, "
1812 : "informational, and meta directives not permitted",
1813 : gfc_ascii_statement (st, true), &old_loc,
1814 : is_absent ? "ABSENT" : "CONTAINS");
1815 4 : return MATCH_ERROR;
1816 : }
1817 47 : if (is_absent)
1818 : {
1819 : /* Use exponential allocation; equivalent to pow2p(x). */
1820 33 : int i = (*assume)->n_absent;
1821 33 : int size = ((i == 0) ? 4
1822 10 : : pow2p_hwi (i) == 1 ? i*2 : 0);
1823 8 : if (size != 0)
1824 31 : (*assume)->absent = XRESIZEVEC (gfc_statement,
1825 : (*assume)->absent, size);
1826 33 : (*assume)->absent[(*assume)->n_absent++] = st;
1827 : }
1828 : else
1829 : {
1830 14 : int i = (*assume)->n_contains;
1831 14 : int size = ((i == 0) ? 4
1832 4 : : pow2p_hwi (i) == 1 ? i*2 : 0);
1833 4 : if (size != 0)
1834 14 : (*assume)->contains = XRESIZEVEC (gfc_statement,
1835 : (*assume)->contains, size);
1836 14 : (*assume)->contains[(*assume)->n_contains++] = st;
1837 : }
1838 47 : gfc_gobble_whitespace ();
1839 47 : if (gfc_match(",") == MATCH_YES)
1840 11 : continue;
1841 36 : if (gfc_match(")") == MATCH_YES)
1842 : break;
1843 0 : gfc_error ("Expected %<,%> or %<)%> at %C");
1844 0 : return MATCH_ERROR;
1845 : }
1846 : while (true);
1847 :
1848 36 : return MATCH_YES;
1849 : }
1850 :
1851 : /* Check 'check' argument for duplicated statements in absent and/or contains
1852 : clauses. If 'merge', merge them from check to 'merge'. */
1853 :
1854 : static match
1855 43 : omp_verify_merge_absent_contains (gfc_statement st, gfc_omp_assumptions *check,
1856 : gfc_omp_assumptions *merge, locus *loc)
1857 : {
1858 43 : if (check == NULL)
1859 : return MATCH_YES;
1860 43 : bitmap_head absent_head, contains_head;
1861 43 : bitmap_obstack_initialize (NULL);
1862 43 : bitmap_initialize (&absent_head, &bitmap_default_obstack);
1863 43 : bitmap_initialize (&contains_head, &bitmap_default_obstack);
1864 :
1865 43 : match m = MATCH_YES;
1866 76 : for (int i = 0; i < check->n_absent; i++)
1867 33 : if (!bitmap_set_bit (&absent_head, check->absent[i]))
1868 : {
1869 2 : gfc_error ("%qs directive mentioned multiple times in %s clause in %s "
1870 : "directive at %L",
1871 2 : gfc_ascii_statement (check->absent[i], true),
1872 : "ABSENT", gfc_ascii_statement (st), loc);
1873 2 : m = MATCH_ERROR;
1874 : }
1875 57 : for (int i = 0; i < check->n_contains; i++)
1876 : {
1877 14 : if (!bitmap_set_bit (&contains_head, check->contains[i]))
1878 : {
1879 2 : gfc_error ("%qs directive mentioned multiple times in %s clause in %s "
1880 : "directive at %L",
1881 2 : gfc_ascii_statement (check->contains[i], true),
1882 : "CONTAINS", gfc_ascii_statement (st), loc);
1883 2 : m = MATCH_ERROR;
1884 : }
1885 14 : if (bitmap_bit_p (&absent_head, check->contains[i]))
1886 : {
1887 2 : gfc_error ("%qs directive mentioned both times in ABSENT and CONTAINS "
1888 : "clauses in %s directive at %L",
1889 2 : gfc_ascii_statement (check->absent[i], true),
1890 : gfc_ascii_statement (st), loc);
1891 2 : m = MATCH_ERROR;
1892 : }
1893 : }
1894 :
1895 43 : if (m == MATCH_ERROR)
1896 : return MATCH_ERROR;
1897 37 : if (merge == NULL)
1898 : return MATCH_YES;
1899 2 : if (merge->absent == NULL && check->absent)
1900 : {
1901 1 : merge->n_absent = check->n_absent;
1902 1 : merge->absent = check->absent;
1903 1 : check->absent = NULL;
1904 : }
1905 1 : else if (merge->absent && check->absent)
1906 : {
1907 0 : check->absent = XRESIZEVEC (gfc_statement, check->absent,
1908 : merge->n_absent + check->n_absent);
1909 0 : for (int i = 0; i < merge->n_absent; i++)
1910 0 : if (!bitmap_bit_p (&absent_head, merge->absent[i]))
1911 0 : check->absent[check->n_absent++] = merge->absent[i];
1912 0 : free (merge->absent);
1913 0 : merge->absent = check->absent;
1914 0 : merge->n_absent = check->n_absent;
1915 0 : check->absent = NULL;
1916 : }
1917 2 : if (merge->contains == NULL && check->contains)
1918 : {
1919 0 : merge->n_contains = check->n_contains;
1920 0 : merge->contains = check->contains;
1921 0 : check->contains = NULL;
1922 : }
1923 2 : else if (merge->contains && check->contains)
1924 : {
1925 0 : check->contains = XRESIZEVEC (gfc_statement, check->contains,
1926 : merge->n_contains + check->n_contains);
1927 0 : for (int i = 0; i < merge->n_contains; i++)
1928 0 : if (!bitmap_bit_p (&contains_head, merge->contains[i]))
1929 0 : check->contains[check->n_contains++] = merge->contains[i];
1930 0 : free (merge->contains);
1931 0 : merge->contains = check->contains;
1932 0 : merge->n_contains = check->n_contains;
1933 0 : check->contains = NULL;
1934 : }
1935 : return MATCH_YES;
1936 : }
1937 :
1938 : /* OpenMP 5.0
1939 : uses_allocators ( allocator-list )
1940 :
1941 : allocator:
1942 : predefined-allocator
1943 : variable ( traits-array )
1944 :
1945 : OpenMP 5.2 deprecated, 6.0 deleted: 'variable ( traits-array )'
1946 :
1947 : OpenMP 5.2:
1948 : uses_allocators ( [modifier-list :] allocator-list )
1949 :
1950 : OpenMP 6.0:
1951 : uses_allocators ( [modifier-list :] allocator-list [; ...])
1952 :
1953 : allocator:
1954 : variable or predefined-allocator
1955 : modifier:
1956 : traits ( traits-array )
1957 : memspace ( mem-space-handle ) */
1958 :
1959 : static match
1960 78 : gfc_match_omp_clause_uses_allocators (gfc_omp_clauses *c)
1961 : {
1962 82 : parse_next:
1963 82 : gfc_symbol *memspace_sym = NULL;
1964 82 : gfc_symbol *traits_sym = NULL;
1965 82 : gfc_omp_namelist *head = NULL;
1966 82 : gfc_omp_namelist *p, *tail, **list;
1967 82 : int ntraits, nmemspace;
1968 82 : bool has_modifiers;
1969 82 : locus old_loc, cur_loc;
1970 :
1971 82 : gfc_gobble_whitespace ();
1972 82 : old_loc = gfc_current_locus;
1973 82 : ntraits = nmemspace = 0;
1974 126 : do
1975 : {
1976 104 : cur_loc = gfc_current_locus;
1977 104 : if (gfc_match ("traits ( %S ) ", &traits_sym) == MATCH_YES)
1978 34 : ntraits++;
1979 70 : else if (gfc_match ("memspace ( %S ) ", &memspace_sym) == MATCH_YES)
1980 33 : nmemspace++;
1981 104 : if (ntraits > 1 || nmemspace > 1)
1982 : {
1983 5 : gfc_error ("Duplicate %s modifier at %L in USES_ALLOCATORS clause",
1984 : ntraits > 1 ? "TRAITS" : "MEMSPACE", &cur_loc);
1985 5 : return MATCH_ERROR;
1986 : }
1987 99 : if (gfc_match (", ") == MATCH_YES)
1988 22 : continue;
1989 77 : if (gfc_match (": ") != MATCH_YES)
1990 : {
1991 : /* Assume no modifier. */
1992 39 : memspace_sym = traits_sym = NULL;
1993 39 : gfc_current_locus = old_loc;
1994 39 : break;
1995 : }
1996 : break;
1997 : } while (true);
1998 :
1999 115 : has_modifiers = traits_sym != NULL || memspace_sym != NULL;
2000 179 : do
2001 : {
2002 128 : p = gfc_get_omp_namelist ();
2003 128 : p->where = gfc_current_locus;
2004 128 : if (head == NULL)
2005 : head = tail = p;
2006 : else
2007 : {
2008 51 : tail->next = p;
2009 51 : tail = tail->next;
2010 : }
2011 128 : if (gfc_match ("%S ", &p->sym) != MATCH_YES)
2012 1 : goto error;
2013 127 : if (!has_modifiers)
2014 : {
2015 83 : if (gfc_match ("( %S ) ", &p->u2.traits_sym) == MATCH_YES)
2016 22 : gfc_warning (OPT_Wdeprecated_openmp,
2017 : "The specification of arguments to "
2018 : "%<uses_allocators%> at %L where each item is of "
2019 : "the form %<allocator(traits)%> is deprecated since "
2020 : "OpenMP 5.2; instead use %<uses_allocators(traits(%s"
2021 22 : "): %s)%>", &p->where, p->u2.traits_sym->name,
2022 22 : p->sym->name);
2023 : }
2024 44 : else if (gfc_peek_ascii_char () == '(')
2025 : {
2026 1 : gfc_error ("Unexpected %<(%> at %C");
2027 1 : goto error;
2028 : }
2029 : else
2030 : {
2031 43 : p->u.memspace_sym = memspace_sym;
2032 43 : p->u2.traits_sym = traits_sym;
2033 : }
2034 126 : gfc_gobble_whitespace ();
2035 126 : const char c = gfc_peek_ascii_char ();
2036 126 : if (c == ';' || c == ')')
2037 : break;
2038 53 : if (c != ',')
2039 : {
2040 2 : gfc_error ("Expected %<,%>, %<)%> or %<;%> at %C");
2041 2 : goto error;
2042 : }
2043 51 : gfc_match_char (',');
2044 51 : gfc_gobble_whitespace ();
2045 51 : } while (true);
2046 :
2047 73 : list = &c->lists[OMP_LIST_USES_ALLOCATORS];
2048 91 : while (*list)
2049 18 : list = &(*list)->next;
2050 73 : *list = head;
2051 :
2052 73 : if (gfc_match_char (';') == MATCH_YES)
2053 4 : goto parse_next;
2054 :
2055 69 : gfc_match_char (')');
2056 69 : return MATCH_YES;
2057 :
2058 4 : error:
2059 4 : gfc_free_omp_namelist (head, OMP_LIST_USES_ALLOCATORS);
2060 4 : return MATCH_ERROR;
2061 : }
2062 :
2063 :
2064 : /* Match the 'prefer_type' modifier of the interop 'init' clause:
2065 : with either OpenMP 5.1's
2066 : prefer_type ( <const-int-expr|string literal> [, ...]
2067 : or
2068 : prefer_type ( '{' <fr(...) | attr (...)>, ...] '}' [, '{' ... '}' ] )
2069 : where 'fr' takes a constant expression or a string literal
2070 : and 'attr takes a list of string literals, starting with 'ompx_')
2071 :
2072 : For the foreign runtime identifiers, string values are converted to
2073 : their integer value; unknown string or integer values are set to
2074 : GOMP_INTEROP_IFR_KNOWN.
2075 :
2076 : Data format:
2077 : For the foreign runtime identifiers, string values are converted to
2078 : their integer value; unknown string or integer values are set to 0.
2079 :
2080 : Each item (a) GOMP_INTEROP_IFR_SEPARATOR
2081 : (b) for any 'fr', its integer value.
2082 : Note: Spec only permits 1 'fr' entry (6.0; changed after TR13)
2083 : (c) GOMP_INTEROP_IFR_SEPARATOR
2084 : (d) list of \0-terminated non-empty strings for 'attr'
2085 : (e) '\0'
2086 : Tailing '\0'. */
2087 :
2088 : static match
2089 82 : gfc_match_omp_prefer_type (char **type_str, int *type_str_len)
2090 : {
2091 82 : gfc_expr *e;
2092 82 : std::string type_string, attr_string;
2093 : /* New syntax. */
2094 82 : if (gfc_peek_ascii_char () == '{')
2095 115 : do
2096 : {
2097 85 : attr_string.clear ();
2098 85 : type_string += (char) GOMP_INTEROP_IFR_SEPARATOR;
2099 85 : if (gfc_match ("{ ") != MATCH_YES)
2100 : {
2101 1 : gfc_error ("Expected %<{%> at %C");
2102 1 : return MATCH_ERROR;
2103 : }
2104 : bool fr_found = false;
2105 148 : do
2106 : {
2107 116 : if (gfc_match ("fr ( ") == MATCH_YES)
2108 : {
2109 62 : if (fr_found)
2110 : {
2111 1 : gfc_error ("Duplicated %<fr%> preference-selector-name "
2112 : "at %C");
2113 1 : return MATCH_ERROR;
2114 : }
2115 61 : fr_found = true;
2116 61 : do
2117 : {
2118 61 : bool found_literal = false;
2119 61 : match m = MATCH_YES;
2120 61 : if (gfc_match_literal_constant (&e, false) == MATCH_YES)
2121 : found_literal = true;
2122 : else
2123 12 : m = gfc_match_expr (&e);
2124 12 : if (m != MATCH_YES
2125 61 : || !gfc_resolve_expr (e)
2126 61 : || e->rank != 0
2127 60 : || e->expr_type != EXPR_CONSTANT
2128 59 : || (e->ts.type != BT_INTEGER
2129 43 : && (!found_literal || e->ts.type != BT_CHARACTER))
2130 58 : || (e->ts.type == BT_INTEGER
2131 16 : && !mpz_fits_sint_p (e->value.integer))
2132 70 : || (e->ts.type == BT_CHARACTER
2133 42 : && (e->ts.kind != gfc_default_character_kind
2134 41 : || e->value.character.length == 0)))
2135 : {
2136 5 : gfc_error ("Expected constant scalar integer expression"
2137 : " or non-empty default-kind character "
2138 5 : "literal at %L", &e->where);
2139 5 : gfc_free_expr (e);
2140 5 : return MATCH_ERROR;
2141 : }
2142 56 : gfc_gobble_whitespace ();
2143 56 : int val;
2144 56 : if (e->ts.type == BT_INTEGER)
2145 : {
2146 16 : val = mpz_get_si (e->value.integer);
2147 16 : if (val < 1 || val > GOMP_INTEROP_IFR_LAST)
2148 : {
2149 0 : gfc_warning_now (OPT_Wopenmp,
2150 : "Unknown foreign runtime "
2151 : "identifier %qd at %L",
2152 : val, &e->where);
2153 0 : val = GOMP_INTEROP_IFR_UNKNOWN;
2154 : }
2155 : }
2156 : else
2157 : {
2158 40 : char *str = XALLOCAVEC (char,
2159 : e->value.character.length+1);
2160 229 : for (int i = 0; i < e->value.character.length + 1; i++)
2161 189 : str[i] = e->value.character.string[i];
2162 40 : if (memchr (str, '\0', e->value.character.length) != 0)
2163 : {
2164 0 : gfc_error ("Unexpected null character in character "
2165 : "literal at %L", &e->where);
2166 0 : return MATCH_ERROR;
2167 : }
2168 40 : val = omp_get_fr_id_from_name (str);
2169 40 : if (val == GOMP_INTEROP_IFR_UNKNOWN)
2170 2 : gfc_warning_now (OPT_Wopenmp,
2171 : "Unknown foreign runtime identifier "
2172 2 : "%qs at %L", str, &e->where);
2173 : }
2174 :
2175 56 : type_string += (char) val;
2176 56 : if (gfc_match (") ") == MATCH_YES)
2177 : break;
2178 4 : gfc_error ("Expected %<)%> at %C");
2179 4 : return MATCH_ERROR;
2180 : }
2181 : while (true);
2182 : }
2183 54 : else if (gfc_match ("attr ( ") == MATCH_YES)
2184 : {
2185 60 : do
2186 : {
2187 57 : if (gfc_match_literal_constant (&e, false) != MATCH_YES
2188 56 : || !gfc_resolve_expr (e)
2189 56 : || e->expr_type != EXPR_CONSTANT
2190 56 : || e->rank != 0
2191 56 : || e->ts.type != BT_CHARACTER
2192 113 : || e->ts.kind != gfc_default_character_kind)
2193 : {
2194 1 : gfc_error ("Expected default-kind character literal "
2195 1 : "at %L", &e->where);
2196 1 : gfc_free_expr (e);
2197 1 : return MATCH_ERROR;
2198 : }
2199 56 : gfc_gobble_whitespace ();
2200 56 : char *str = XALLOCAVEC (char, e->value.character.length+1);
2201 564 : for (int i = 0; i < e->value.character.length + 1; i++)
2202 508 : str[i] = e->value.character.string[i];
2203 56 : if (!startswith (str, "ompx_"))
2204 : {
2205 1 : gfc_error ("Character literal at %L must start with "
2206 : "%<ompx_%>", &e->where);
2207 1 : gfc_free_expr (e);
2208 1 : return MATCH_ERROR;
2209 : }
2210 55 : if (memchr (str, '\0', e->value.character.length) != 0
2211 55 : || memchr (str, ',', e->value.character.length) != 0)
2212 : {
2213 1 : gfc_error ("Unexpected null or %<,%> character in "
2214 : "character literal at %L", &e->where);
2215 1 : return MATCH_ERROR;
2216 : }
2217 54 : attr_string += str;
2218 54 : attr_string += '\0';
2219 54 : if (gfc_match (", ") == MATCH_YES)
2220 3 : continue;
2221 51 : if (gfc_match (") ") == MATCH_YES)
2222 : break;
2223 0 : gfc_error ("Expected %<,%> or %<)%> at %C");
2224 0 : return MATCH_ERROR;
2225 3 : }
2226 : while (true);
2227 : }
2228 : else
2229 : {
2230 0 : gfc_error ("Expected %<fr(%> or %<attr(%> at %C");
2231 0 : return MATCH_ERROR;
2232 : }
2233 103 : if (gfc_match (", ") == MATCH_YES)
2234 32 : continue;
2235 71 : if (gfc_match ("} ") == MATCH_YES)
2236 : break;
2237 2 : gfc_error ("Expected %<,%> or %<}%> at %C");
2238 2 : return MATCH_ERROR;
2239 32 : }
2240 : while (true);
2241 69 : type_string += (char) GOMP_INTEROP_IFR_SEPARATOR;
2242 69 : type_string += attr_string;
2243 69 : type_string += '\0';
2244 69 : if (gfc_match (", ") == MATCH_YES)
2245 30 : continue;
2246 39 : if (gfc_match (") ") == MATCH_YES)
2247 : break;
2248 1 : gfc_error ("Expected %<,%> or %<)%> at %C");
2249 1 : return MATCH_ERROR;
2250 30 : }
2251 : while (true);
2252 : else
2253 75 : do
2254 : {
2255 51 : type_string += (char) GOMP_INTEROP_IFR_SEPARATOR;
2256 51 : bool found_literal = false;
2257 51 : match m = MATCH_YES;
2258 51 : if (gfc_match_literal_constant (&e, false) == MATCH_YES)
2259 : found_literal = true;
2260 : else
2261 19 : m = gfc_match_expr (&e);
2262 19 : if (m != MATCH_YES
2263 51 : || !gfc_resolve_expr (e)
2264 51 : || e->rank != 0
2265 50 : || e->expr_type != EXPR_CONSTANT
2266 49 : || (e->ts.type != BT_INTEGER
2267 28 : && (!found_literal || e->ts.type != BT_CHARACTER))
2268 48 : || (e->ts.type == BT_INTEGER
2269 21 : && !mpz_fits_sint_p (e->value.integer))
2270 67 : || (e->ts.type == BT_CHARACTER
2271 27 : && (e->ts.kind != gfc_default_character_kind
2272 27 : || e->value.character.length == 0)))
2273 : {
2274 3 : gfc_error ("Expected constant scalar integer expression or "
2275 3 : "non-empty default-kind character literal at %L", &e->where);
2276 3 : gfc_free_expr (e);
2277 3 : return MATCH_ERROR;
2278 : }
2279 48 : gfc_gobble_whitespace ();
2280 48 : int val;
2281 48 : if (e->ts.type == BT_INTEGER)
2282 : {
2283 21 : val = mpz_get_si (e->value.integer);
2284 21 : if (val < 1 || val > GOMP_INTEROP_IFR_LAST)
2285 : {
2286 3 : gfc_warning_now (OPT_Wopenmp,
2287 : "Unknown foreign runtime identifier %qd at %L",
2288 : val, &e->where);
2289 3 : val = 0;
2290 : }
2291 : }
2292 : else
2293 : {
2294 27 : char *str = XALLOCAVEC (char, e->value.character.length+1);
2295 169 : for (int i = 0; i < e->value.character.length + 1; i++)
2296 142 : str[i] = e->value.character.string[i];
2297 27 : if (memchr (str, '\0', e->value.character.length) != 0)
2298 : {
2299 0 : gfc_error ("Unexpected null character in character "
2300 : "literal at %L", &e->where);
2301 0 : return MATCH_ERROR;
2302 : }
2303 27 : val = omp_get_fr_id_from_name (str);
2304 27 : if (val == GOMP_INTEROP_IFR_UNKNOWN)
2305 5 : gfc_warning_now (OPT_Wopenmp,
2306 : "Unknown foreign runtime identifier %qs at %L",
2307 5 : str, &e->where);
2308 : }
2309 48 : type_string += (char) val;
2310 48 : type_string += (char) GOMP_INTEROP_IFR_SEPARATOR;
2311 48 : type_string += '\0';
2312 48 : gfc_free_expr (e);
2313 48 : if (gfc_match (", ") == MATCH_YES)
2314 24 : continue;
2315 24 : if (gfc_match (") ") == MATCH_YES)
2316 : break;
2317 2 : gfc_error ("Expected %<,%> or %<)%> at %C");
2318 2 : return MATCH_ERROR;
2319 24 : }
2320 : while (true);
2321 60 : type_string += '\0';
2322 60 : *type_str_len = type_string.length();
2323 60 : *type_str = XNEWVEC (char, type_string.length ());
2324 60 : memcpy (*type_str, type_string.data (), type_string.length ());
2325 60 : return MATCH_YES;
2326 82 : }
2327 :
2328 :
2329 : /* Match OpenMP 5.1's 'init'-clause modifiers, used by the 'init' clause of
2330 : the 'interop' directive and the 'append_args' directive of 'declare variant'.
2331 : [prefer_type(...)][,][<target|targetsync>, ...])
2332 :
2333 : If is_init_clause, the modifier parsing ends with a ':'.
2334 : If not is_init_clause (i.e. append_args), the parsing ends with ')'. */
2335 :
2336 : static match
2337 164 : gfc_parser_omp_clause_init_modifiers (bool &target, bool &targetsync,
2338 : char **type_str, int &type_str_len,
2339 : bool is_init_clause)
2340 : {
2341 164 : target = false;
2342 164 : targetsync = false;
2343 164 : *type_str = NULL;
2344 164 : type_str_len = 0;
2345 286 : match m;
2346 :
2347 286 : do
2348 : {
2349 286 : if (gfc_match ("prefer_type ( ") == MATCH_YES)
2350 : {
2351 83 : if (*type_str)
2352 : {
2353 1 : gfc_error ("Duplicate %<prefer_type%> modifier at %C");
2354 1 : return MATCH_ERROR;
2355 : }
2356 82 : m = gfc_match_omp_prefer_type (type_str, &type_str_len);
2357 82 : if (m != MATCH_YES)
2358 : return m;
2359 60 : if (gfc_match (", ") == MATCH_YES)
2360 14 : continue;
2361 46 : if (is_init_clause)
2362 : {
2363 24 : if (gfc_match (": ") == MATCH_YES)
2364 : break;
2365 0 : gfc_error ("Expected %<,%> or %<:%> at %C");
2366 : }
2367 : else
2368 : {
2369 22 : if (gfc_match (") ") == MATCH_YES)
2370 : break;
2371 0 : gfc_error ("Expected %<,%> or %<)%> at %C");
2372 : }
2373 0 : return MATCH_ERROR;
2374 : }
2375 :
2376 203 : if (gfc_match ("prefer_type ") == MATCH_YES)
2377 : {
2378 2 : gfc_error ("Expected %<(%> after %<prefer_type%> at %C");
2379 2 : return MATCH_ERROR;
2380 : }
2381 :
2382 201 : if (gfc_match ("targetsync ") == MATCH_YES)
2383 : {
2384 57 : if (targetsync)
2385 : {
2386 3 : gfc_error ("Duplicate %<targetsync%> at %C");
2387 3 : return MATCH_ERROR;
2388 : }
2389 54 : targetsync = true;
2390 54 : if (gfc_match (", ") == MATCH_YES)
2391 13 : continue;
2392 41 : if (!is_init_clause)
2393 : {
2394 23 : if (gfc_match (") ") == MATCH_YES)
2395 : break;
2396 0 : gfc_error ("Expected %<,%> or %<)%> at %C");
2397 0 : return MATCH_ERROR;
2398 : }
2399 18 : if (gfc_match (": ") == MATCH_YES)
2400 : break;
2401 1 : gfc_error ("Expected %<,%> or %<:%> at %C");
2402 1 : return MATCH_ERROR;
2403 : }
2404 144 : if (gfc_match ("target ") == MATCH_YES)
2405 : {
2406 135 : if (target)
2407 : {
2408 3 : gfc_error ("Duplicate %<target%> at %C");
2409 3 : return MATCH_ERROR;
2410 : }
2411 132 : target = true;
2412 132 : if (gfc_match (", ") == MATCH_YES)
2413 95 : continue;
2414 37 : if (!is_init_clause)
2415 : {
2416 11 : if (gfc_match (") ") == MATCH_YES)
2417 : break;
2418 0 : gfc_error ("Expected %<,%> or %<)%> at %C");
2419 0 : return MATCH_ERROR;
2420 : }
2421 26 : if (gfc_match (": ") == MATCH_YES)
2422 : break;
2423 1 : gfc_error ("Expected %<,%> or %<:%> at %C");
2424 1 : return MATCH_ERROR;
2425 : }
2426 9 : gfc_error ("Expected %<prefer_type%>, %<target%>, or %<targetsync%> "
2427 : "at %C");
2428 9 : return MATCH_ERROR;
2429 : }
2430 : while (true);
2431 :
2432 122 : if (!target && !targetsync)
2433 : {
2434 4 : gfc_error ("Missing required %<target%> and/or %<targetsync%> "
2435 : "modifier at %C");
2436 4 : return MATCH_ERROR;
2437 : }
2438 : return MATCH_YES;
2439 : }
2440 :
2441 : /* Match OpenMP 5.1's 'init' clause for 'interop' objects:
2442 : init([prefer_type(...)][,][<target|targetsync>, ...] :] interop-obj-list) */
2443 :
2444 : static match
2445 108 : gfc_match_omp_init (gfc_omp_namelist **list)
2446 : {
2447 108 : bool target, targetsync;
2448 108 : char *type_str = NULL;
2449 108 : int type_str_len;
2450 108 : if (gfc_parser_omp_clause_init_modifiers (target, targetsync, &type_str,
2451 : type_str_len, true) == MATCH_ERROR)
2452 : return MATCH_ERROR;
2453 :
2454 64 : gfc_omp_namelist **head = NULL;
2455 64 : if (gfc_match_omp_variable_list ("", list, false, NULL, &head) != MATCH_YES)
2456 : return MATCH_ERROR;
2457 147 : for (gfc_omp_namelist *n = *head; n; n = n->next)
2458 : {
2459 84 : n->u.init.target = target;
2460 84 : n->u.init.targetsync = targetsync;
2461 84 : n->u.init.len = type_str_len;
2462 84 : n->u2.init_interop = type_str;
2463 : }
2464 : return MATCH_YES;
2465 : }
2466 :
2467 :
2468 : /* Match with duplicate check. Matches 'name'. If expr != NULL, it
2469 : then matches '(expr)', otherwise, if open_parens is true,
2470 : it matches a ' ( ' after 'name'.
2471 : dupl_message requires '%qs %L' - and is used by
2472 : gfc_match_dupl_memorder and gfc_match_dupl_atomic. */
2473 :
2474 : static match
2475 23277 : gfc_match_dupl_check (bool not_dupl, const char *name, bool open_parens = false,
2476 : gfc_expr **expr = NULL, const char *dupl_msg = NULL)
2477 : {
2478 23277 : match m;
2479 23277 : char c;
2480 23277 : locus old_loc = gfc_current_locus;
2481 23277 : if ((m = gfc_match (name)) != MATCH_YES)
2482 : return m;
2483 : /* Ensure that no partial string is matched. */
2484 18171 : if (gfc_current_form == FORM_FREE
2485 17673 : && gfc_match_eos () != MATCH_YES
2486 31705 : && ((c = gfc_peek_ascii_char ()) == '_' || ISALNUM (c)))
2487 : {
2488 13 : gfc_current_locus = old_loc;
2489 13 : return MATCH_NO;
2490 : }
2491 18158 : if (!not_dupl)
2492 : {
2493 53 : if (dupl_msg)
2494 2 : gfc_error (dupl_msg, name, &old_loc);
2495 : else
2496 51 : gfc_error ("Duplicated %qs clause at %L", name, &old_loc);
2497 53 : return MATCH_ERROR;
2498 : }
2499 18105 : if (open_parens || expr)
2500 : {
2501 10108 : if (gfc_match (" ( ") != MATCH_YES)
2502 : {
2503 25 : gfc_error ("Expected %<(%> after %qs at %C", name);
2504 25 : return MATCH_ERROR;
2505 : }
2506 10083 : if (expr)
2507 : {
2508 3396 : if (gfc_match ("%e )", expr) != MATCH_YES)
2509 : {
2510 9 : gfc_error ("Invalid expression after %<%s(%> at %C", name);
2511 9 : return MATCH_ERROR;
2512 : }
2513 : }
2514 : }
2515 : return MATCH_YES;
2516 : }
2517 :
2518 : static match
2519 211 : gfc_match_dupl_memorder (bool not_dupl, const char *name)
2520 : {
2521 0 : return gfc_match_dupl_check (not_dupl, name, false, NULL,
2522 : "Duplicated memory-order clause: unexpected %s "
2523 0 : "clause at %L");
2524 : }
2525 :
2526 : static match
2527 1175 : gfc_match_dupl_atomic (bool not_dupl, const char *name)
2528 : {
2529 0 : return gfc_match_dupl_check (not_dupl, name, false, NULL,
2530 : "Duplicated atomic clause: unexpected %s "
2531 0 : "clause at %L");
2532 : }
2533 :
2534 :
2535 : /* Search upwards though namespace NS and its parents to find an
2536 : !$omp declare mapper named MAPPER_ID, for typespec TS. The default
2537 : mapper has mapper_id == "". */
2538 :
2539 : gfc_omp_udm *
2540 999 : gfc_find_omp_udm (gfc_namespace *ns, const char *mapper_id, gfc_typespec *ts)
2541 : {
2542 999 : gfc_symtree *st;
2543 :
2544 999 : if (ns == NULL)
2545 0 : ns = gfc_current_ns;
2546 :
2547 1177 : do
2548 : {
2549 1177 : gfc_omp_udm *omp_udm;
2550 :
2551 1177 : st = gfc_find_symtree (ns->omp_udm_root, mapper_id);
2552 :
2553 1177 : if (st != NULL)
2554 : {
2555 28 : for (omp_udm = st->n.omp_udm; omp_udm; omp_udm = omp_udm->next)
2556 28 : if (gfc_compare_types (&omp_udm->ts, ts))
2557 : return omp_udm;
2558 : }
2559 :
2560 : /* Don't escape an interface block. */
2561 1151 : if (ns && !ns->has_import_set
2562 1151 : && ns->proc_name && ns->proc_name->attr.if_source == IFSRC_IFBODY)
2563 : break;
2564 :
2565 1151 : ns = ns->parent;
2566 : }
2567 1151 : while (ns != NULL);
2568 :
2569 : return NULL;
2570 : }
2571 :
2572 :
2573 : /* Match OpenMP and OpenACC directive clauses. MASK is a bitmask of
2574 : clauses that are allowed for a particular directive. */
2575 :
2576 : static match
2577 35078 : gfc_match_omp_clauses (gfc_omp_clauses **cp, const omp_mask mask,
2578 : bool first = true, bool needs_space = true,
2579 : bool openacc = false, bool openmp_target = false,
2580 : gfc_omp_map_op default_map_op = OMP_MAP_TOFROM)
2581 : {
2582 35078 : bool error = false;
2583 35078 : gfc_omp_clauses *c = gfc_get_omp_clauses ();
2584 35078 : locus old_loc;
2585 : /* Determine whether we're dealing with an OpenACC directive that permits
2586 : derived type member accesses. This in particular disallows
2587 : "!$acc declare" from using such accesses, because it's not clear if/how
2588 : that should work. */
2589 35078 : bool allow_derived = (openacc
2590 35078 : && ((mask & OMP_CLAUSE_ATTACH)
2591 6326 : || (mask & OMP_CLAUSE_DETACH)));
2592 :
2593 35078 : gcc_checking_assert (OMP_MASK1_LAST <= 64 && OMP_MASK2_LAST <= 64);
2594 35078 : *cp = NULL;
2595 128862 : while (1)
2596 : {
2597 81970 : match m = MATCH_NO;
2598 61056 : if ((first || (m = gfc_match_char (',')) != MATCH_YES)
2599 142670 : && (needs_space && gfc_match_space () != MATCH_YES))
2600 : break;
2601 77404 : needs_space = false;
2602 77404 : first = false;
2603 77404 : gfc_gobble_whitespace ();
2604 77404 : bool end_colon;
2605 77404 : gfc_omp_namelist **head;
2606 77404 : old_loc = gfc_current_locus;
2607 77404 : char pc = gfc_peek_ascii_char ();
2608 77404 : if (pc == '\n' && m == MATCH_YES)
2609 : {
2610 1 : gfc_error ("Clause expected at %C after trailing comma");
2611 1 : goto error;
2612 : }
2613 77403 : switch (pc)
2614 : {
2615 1317 : case 'a':
2616 1317 : end_colon = false;
2617 1317 : head = NULL;
2618 1341 : if ((mask & OMP_CLAUSE_ASSUMPTIONS)
2619 1317 : && gfc_match ("absent ( ") == MATCH_YES)
2620 : {
2621 27 : if (gfc_omp_absent_contains_clause (&c->assume, true)
2622 : != MATCH_YES)
2623 3 : goto error;
2624 24 : continue;
2625 : }
2626 1290 : if ((mask & OMP_CLAUSE_ALIGNED)
2627 1290 : && gfc_match_omp_variable_list ("aligned (",
2628 : &c->lists[OMP_LIST_ALIGNED],
2629 : false, &end_colon,
2630 : &head) == MATCH_YES)
2631 : {
2632 112 : gfc_expr *alignment = NULL;
2633 112 : gfc_omp_namelist *n;
2634 :
2635 112 : if (end_colon && gfc_match (" %e )", &alignment) != MATCH_YES)
2636 : {
2637 0 : gfc_free_omp_namelist (*head, OMP_LIST_ALIGNED);
2638 0 : gfc_current_locus = old_loc;
2639 0 : *head = NULL;
2640 0 : break;
2641 : }
2642 268 : for (n = *head; n; n = n->next)
2643 156 : if (n->next && alignment)
2644 42 : n->expr = gfc_copy_expr (alignment);
2645 : else
2646 114 : n->expr = alignment;
2647 112 : continue;
2648 112 : }
2649 1188 : if ((mask & OMP_CLAUSE_MEMORDER)
2650 1195 : && (m = gfc_match_dupl_memorder ((c->memorder
2651 17 : == OMP_MEMORDER_UNSET),
2652 : "acq_rel")) != MATCH_NO)
2653 : {
2654 10 : if (m == MATCH_ERROR)
2655 0 : goto error;
2656 10 : c->memorder = OMP_MEMORDER_ACQ_REL;
2657 10 : continue;
2658 : }
2659 1175 : if ((mask & OMP_CLAUSE_MEMORDER)
2660 1175 : && (m = gfc_match_dupl_memorder ((c->memorder
2661 7 : == OMP_MEMORDER_UNSET),
2662 : "acquire")) != MATCH_NO)
2663 : {
2664 7 : if (m == MATCH_ERROR)
2665 0 : goto error;
2666 7 : c->memorder = OMP_MEMORDER_ACQUIRE;
2667 7 : continue;
2668 : }
2669 1161 : if ((mask & OMP_CLAUSE_AFFINITY)
2670 1161 : && gfc_match ("affinity ( ") == MATCH_YES)
2671 : {
2672 41 : gfc_namespace *ns_iter = NULL, *ns_curr = gfc_current_ns;
2673 41 : m = gfc_match_iterator (&ns_iter, true);
2674 41 : if (m == MATCH_ERROR)
2675 : break;
2676 31 : if (m == MATCH_YES && gfc_match (" : ") != MATCH_YES)
2677 : {
2678 1 : gfc_error ("Expected %<:%> at %C");
2679 1 : break;
2680 : }
2681 30 : if (ns_iter)
2682 18 : gfc_current_ns = ns_iter;
2683 30 : head = NULL;
2684 30 : m = gfc_match_omp_variable_list ("", &c->lists[OMP_LIST_AFFINITY],
2685 : false, NULL, &head, true);
2686 30 : gfc_current_ns = ns_curr;
2687 30 : if (m == MATCH_ERROR)
2688 : break;
2689 27 : if (ns_iter)
2690 : {
2691 45 : for (gfc_omp_namelist *n = *head; n; n = n->next)
2692 : {
2693 27 : n->u2.ns = ns_iter;
2694 27 : ns_iter->refs++;
2695 : }
2696 : }
2697 27 : continue;
2698 27 : }
2699 1120 : if ((mask & OMP_CLAUSE_ALLOCATE)
2700 1120 : && gfc_match ("allocate ( ") == MATCH_YES)
2701 : {
2702 281 : gfc_expr *allocator = NULL;
2703 281 : gfc_expr *align = NULL;
2704 281 : old_loc = gfc_current_locus;
2705 281 : if ((m = gfc_match ("allocator ( %e )", &allocator)) == MATCH_YES)
2706 50 : gfc_match (" , align ( %e )", &align);
2707 231 : else if ((m = gfc_match ("align ( %e )", &align)) == MATCH_YES)
2708 29 : gfc_match (" , allocator ( %e )", &allocator);
2709 :
2710 281 : if (m == MATCH_YES)
2711 : {
2712 79 : if (gfc_match (" : ") != MATCH_YES)
2713 : {
2714 5 : gfc_error ("Expected %<:%> at %C");
2715 8 : goto error;
2716 : }
2717 : }
2718 : else
2719 : {
2720 202 : m = gfc_match_expr (&allocator);
2721 202 : if (m == MATCH_YES && gfc_match (" : ") != MATCH_YES)
2722 : {
2723 : /* If no ":" then there is no allocator, we backtrack
2724 : and read the variable list. */
2725 101 : gfc_free_expr (allocator);
2726 101 : allocator = NULL;
2727 101 : gfc_current_locus = old_loc;
2728 : }
2729 : }
2730 276 : gfc_omp_namelist **head = NULL;
2731 276 : m = gfc_match_omp_variable_list ("", &c->lists[OMP_LIST_ALLOCATE],
2732 : true, NULL, &head);
2733 :
2734 276 : if (m != MATCH_YES)
2735 : {
2736 3 : gfc_free_expr (allocator);
2737 3 : gfc_free_expr (align);
2738 3 : gfc_error ("Expected variable list at %C");
2739 3 : goto error;
2740 : }
2741 :
2742 729 : for (gfc_omp_namelist *n = *head; n; n = n->next)
2743 : {
2744 456 : n->u2.allocator = allocator;
2745 456 : n->u.align = (align) ? gfc_copy_expr (align) : NULL;
2746 : }
2747 273 : gfc_free_expr (align);
2748 273 : continue;
2749 273 : }
2750 899 : if ((mask & OMP_CLAUSE_AT)
2751 839 : && (m = gfc_match_dupl_check (c->at == OMP_AT_UNSET, "at", true))
2752 : != MATCH_NO)
2753 : {
2754 66 : if (m == MATCH_ERROR)
2755 2 : goto error;
2756 64 : if (gfc_match ("compilation )") == MATCH_YES)
2757 15 : c->at = OMP_AT_COMPILATION;
2758 49 : else if (gfc_match ("execution )") == MATCH_YES)
2759 45 : c->at = OMP_AT_EXECUTION;
2760 : else
2761 : {
2762 4 : gfc_error ("Expected COMPILATION or EXECUTION in AT clause "
2763 : "at %C");
2764 4 : goto error;
2765 : }
2766 60 : continue;
2767 : }
2768 1416 : if ((mask & OMP_CLAUSE_ASYNC)
2769 773 : && (m = gfc_match_dupl_check (!c->async, "async")) != MATCH_NO)
2770 : {
2771 643 : if (m == MATCH_ERROR)
2772 0 : goto error;
2773 643 : c->async = true;
2774 643 : m = gfc_match (" ( %e )", &c->async_expr);
2775 643 : if (m == MATCH_ERROR)
2776 : {
2777 0 : gfc_current_locus = old_loc;
2778 0 : break;
2779 : }
2780 643 : else if (m == MATCH_NO)
2781 : {
2782 133 : c->async_expr
2783 133 : = gfc_get_constant_expr (BT_INTEGER,
2784 : gfc_default_integer_kind,
2785 : &gfc_current_locus);
2786 133 : mpz_set_si (c->async_expr->value.integer, GOMP_ASYNC_NOVAL);
2787 : }
2788 643 : continue;
2789 : }
2790 193 : if ((mask & OMP_CLAUSE_AUTO)
2791 130 : && (m = gfc_match_dupl_check (!c->par_auto, "auto"))
2792 : != MATCH_NO)
2793 : {
2794 63 : if (m == MATCH_ERROR)
2795 0 : goto error;
2796 63 : c->par_auto = true;
2797 63 : continue;
2798 : }
2799 128 : if ((mask & OMP_CLAUSE_ATTACH)
2800 62 : && gfc_match ("attach ( ") == MATCH_YES
2801 128 : && gfc_match_omp_map_clause (&c->lists[OMP_LIST_MAP],
2802 : OMP_MAP_ATTACH, false,
2803 : allow_derived))
2804 61 : continue;
2805 : break;
2806 36 : case 'b':
2807 70 : if ((mask & OMP_CLAUSE_BIND)
2808 36 : && (m = gfc_match_dupl_check (c->bind == OMP_BIND_UNSET, "bind",
2809 : true)) != MATCH_NO)
2810 : {
2811 36 : if (m == MATCH_ERROR)
2812 1 : goto error;
2813 35 : if (gfc_match ("teams )") == MATCH_YES)
2814 11 : c->bind = OMP_BIND_TEAMS;
2815 24 : else if (gfc_match ("parallel )") == MATCH_YES)
2816 15 : c->bind = OMP_BIND_PARALLEL;
2817 9 : else if (gfc_match ("thread )") == MATCH_YES)
2818 8 : c->bind = OMP_BIND_THREAD;
2819 : else
2820 : {
2821 1 : gfc_error ("Expected TEAMS, PARALLEL or THREAD as binding in "
2822 : "BIND at %C");
2823 1 : break;
2824 : }
2825 34 : continue;
2826 : }
2827 : break;
2828 7110 : case 'c':
2829 7383 : if ((mask & OMP_CLAUSE_CAPTURE)
2830 7110 : && (m = gfc_match_dupl_check (!c->capture, "capture"))
2831 : != MATCH_NO)
2832 : {
2833 274 : if (m == MATCH_ERROR)
2834 1 : goto error;
2835 273 : c->capture = true;
2836 273 : continue;
2837 : }
2838 6836 : if (mask & OMP_CLAUSE_COLLAPSE)
2839 : {
2840 1996 : gfc_expr *cexpr = NULL;
2841 1996 : if ((m = gfc_match_dupl_check (!c->collapse, "collapse", true,
2842 : &cexpr)) != MATCH_NO)
2843 : {
2844 1506 : int collapse;
2845 1506 : if (m == MATCH_ERROR)
2846 0 : goto error;
2847 1506 : if (gfc_extract_int (cexpr, &collapse, -1))
2848 4 : collapse = 1;
2849 1502 : else if (collapse <= 0)
2850 : {
2851 8 : gfc_error_now ("COLLAPSE clause argument not constant "
2852 : "positive integer at %C");
2853 8 : collapse = 1;
2854 : }
2855 1506 : gfc_free_expr (cexpr);
2856 1506 : c->collapse = collapse;
2857 1506 : continue;
2858 1506 : }
2859 : }
2860 5496 : if ((mask & OMP_CLAUSE_COMPARE)
2861 5330 : && (m = gfc_match_dupl_check (!c->compare, "compare"))
2862 : != MATCH_NO)
2863 : {
2864 167 : if (m == MATCH_ERROR)
2865 1 : goto error;
2866 166 : c->compare = true;
2867 166 : continue;
2868 : }
2869 5175 : if ((mask & OMP_CLAUSE_ASSUMPTIONS)
2870 5163 : && gfc_match ("contains ( ") == MATCH_YES)
2871 : {
2872 13 : if (gfc_omp_absent_contains_clause (&c->assume, false)
2873 : != MATCH_YES)
2874 1 : goto error;
2875 12 : continue;
2876 : }
2877 7266 : if ((mask & OMP_CLAUSE_COPY)
2878 3723 : && gfc_match ("copy ( ") == MATCH_YES
2879 7267 : && gfc_match_omp_map_clause (&c->lists[OMP_LIST_MAP],
2880 : OMP_MAP_TOFROM, true,
2881 : allow_derived))
2882 2116 : continue;
2883 3034 : if (mask & OMP_CLAUSE_COPYIN)
2884 : {
2885 2628 : if (openacc)
2886 : {
2887 2529 : if (gfc_match ("copyin ( ") == MATCH_YES)
2888 : {
2889 1458 : bool readonly = gfc_match ("readonly : ") == MATCH_YES;
2890 1458 : head = NULL;
2891 1458 : if (gfc_match_omp_variable_list ("",
2892 : &c->lists[OMP_LIST_MAP],
2893 : true, NULL, &head, true,
2894 : allow_derived)
2895 : == MATCH_YES)
2896 : {
2897 1452 : gfc_omp_namelist *n;
2898 3349 : for (n = *head; n; n = n->next)
2899 : {
2900 1897 : n->u.map.op = OMP_MAP_TO;
2901 1897 : n->u.map.readonly = readonly;
2902 : }
2903 1452 : continue;
2904 1452 : }
2905 : }
2906 : }
2907 99 : else if (gfc_match_omp_variable_list ("copyin (",
2908 : &c->lists[OMP_LIST_COPYIN],
2909 : true) == MATCH_YES)
2910 97 : continue;
2911 : }
2912 2556 : if ((mask & OMP_CLAUSE_COPYOUT)
2913 1216 : && gfc_match ("copyout ( ") == MATCH_YES
2914 2556 : && gfc_match_omp_map_clause (&c->lists[OMP_LIST_MAP],
2915 : OMP_MAP_FROM, true, allow_derived))
2916 1071 : continue;
2917 498 : if ((mask & OMP_CLAUSE_COPYPRIVATE)
2918 414 : && gfc_match_omp_variable_list ("copyprivate (",
2919 : &c->lists[OMP_LIST_COPYPRIVATE],
2920 : true) == MATCH_YES)
2921 84 : continue;
2922 651 : if ((mask & OMP_CLAUSE_CREATE)
2923 328 : && gfc_match ("create ( ") == MATCH_YES
2924 651 : && gfc_match_omp_map_clause (&c->lists[OMP_LIST_MAP],
2925 : OMP_MAP_ALLOC, true, allow_derived))
2926 321 : continue;
2927 : break;
2928 4186 : case 'd':
2929 4186 : if ((mask & OMP_CLAUSE_DEFAULTMAP)
2930 4186 : && gfc_match ("defaultmap ( ") == MATCH_YES)
2931 : {
2932 181 : enum gfc_omp_defaultmap behavior;
2933 181 : gfc_omp_defaultmap_category category
2934 : = OMP_DEFAULTMAP_CAT_UNCATEGORIZED;
2935 181 : if (gfc_match ("alloc ") == MATCH_YES)
2936 : behavior = OMP_DEFAULTMAP_ALLOC;
2937 175 : else if (gfc_match ("tofrom ") == MATCH_YES)
2938 : behavior = OMP_DEFAULTMAP_TOFROM;
2939 143 : else if (gfc_match ("to ") == MATCH_YES)
2940 : behavior = OMP_DEFAULTMAP_TO;
2941 133 : else if (gfc_match ("from ") == MATCH_YES)
2942 : behavior = OMP_DEFAULTMAP_FROM;
2943 130 : else if (gfc_match ("firstprivate ") == MATCH_YES)
2944 : behavior = OMP_DEFAULTMAP_FIRSTPRIVATE;
2945 95 : else if (gfc_match ("present ") == MATCH_YES)
2946 : behavior = OMP_DEFAULTMAP_PRESENT;
2947 91 : else if (gfc_match ("none ") == MATCH_YES)
2948 : behavior = OMP_DEFAULTMAP_NONE;
2949 10 : else if (gfc_match ("default ") == MATCH_YES)
2950 : behavior = OMP_DEFAULTMAP_DEFAULT;
2951 : else
2952 : {
2953 1 : gfc_error ("Expected ALLOC, TO, FROM, TOFROM, FIRSTPRIVATE, "
2954 : "PRESENT, NONE or DEFAULT at %C");
2955 1 : break;
2956 : }
2957 180 : if (')' == gfc_peek_ascii_char ())
2958 : ;
2959 102 : else if (gfc_match (": ") != MATCH_YES)
2960 : break;
2961 : else
2962 : {
2963 102 : if (gfc_match ("scalar ") == MATCH_YES)
2964 : category = OMP_DEFAULTMAP_CAT_SCALAR;
2965 67 : else if (gfc_match ("aggregate ") == MATCH_YES)
2966 : category = OMP_DEFAULTMAP_CAT_AGGREGATE;
2967 43 : else if (gfc_match ("allocatable ") == MATCH_YES)
2968 : category = OMP_DEFAULTMAP_CAT_ALLOCATABLE;
2969 31 : else if (gfc_match ("pointer ") == MATCH_YES)
2970 : category = OMP_DEFAULTMAP_CAT_POINTER;
2971 14 : else if (gfc_match ("all ") == MATCH_YES)
2972 : category = OMP_DEFAULTMAP_CAT_ALL;
2973 : else
2974 : {
2975 1 : gfc_error ("Expected SCALAR, AGGREGATE, ALLOCATABLE, "
2976 : "POINTER or ALL at %C");
2977 1 : break;
2978 : }
2979 : }
2980 1200 : for (int i = 0; i < OMP_DEFAULTMAP_CAT_NUM; ++i)
2981 : {
2982 1034 : if (i != category
2983 1034 : && category != OMP_DEFAULTMAP_CAT_UNCATEGORIZED
2984 486 : && category != OMP_DEFAULTMAP_CAT_ALL
2985 486 : && i != OMP_DEFAULTMAP_CAT_UNCATEGORIZED
2986 341 : && i != OMP_DEFAULTMAP_CAT_ALL)
2987 254 : continue;
2988 780 : if (c->defaultmap[i] != OMP_DEFAULTMAP_UNSET)
2989 : {
2990 13 : const char *pcategory = NULL;
2991 13 : switch (i)
2992 : {
2993 : case OMP_DEFAULTMAP_CAT_UNCATEGORIZED: break;
2994 : case OMP_DEFAULTMAP_CAT_ALL: pcategory = "ALL"; break;
2995 1 : case OMP_DEFAULTMAP_CAT_SCALAR: pcategory = "SCALAR"; break;
2996 2 : case OMP_DEFAULTMAP_CAT_AGGREGATE:
2997 2 : pcategory = "AGGREGATE";
2998 2 : break;
2999 1 : case OMP_DEFAULTMAP_CAT_ALLOCATABLE:
3000 1 : pcategory = "ALLOCATABLE";
3001 1 : break;
3002 2 : case OMP_DEFAULTMAP_CAT_POINTER:
3003 2 : pcategory = "POINTER";
3004 2 : break;
3005 : default: gcc_unreachable ();
3006 : }
3007 6 : if (i == OMP_DEFAULTMAP_CAT_UNCATEGORIZED)
3008 4 : gfc_error ("DEFAULTMAP at %C but prior DEFAULTMAP with "
3009 : "unspecified category");
3010 : else
3011 9 : gfc_error ("DEFAULTMAP at %C but prior DEFAULTMAP for "
3012 : "category %s", pcategory);
3013 13 : goto error;
3014 : }
3015 : }
3016 166 : c->defaultmap[category] = behavior;
3017 166 : if (gfc_match (")") != MATCH_YES)
3018 : break;
3019 166 : continue;
3020 166 : }
3021 4972 : if ((mask & OMP_CLAUSE_DEFAULT)
3022 4005 : && (m = gfc_match_dupl_check (c->default_sharing
3023 : == OMP_DEFAULT_UNKNOWN, "default",
3024 : true)) != MATCH_NO)
3025 : {
3026 1012 : if (m == MATCH_ERROR)
3027 6 : goto error;
3028 1006 : if (gfc_match ("none") == MATCH_YES)
3029 596 : c->default_sharing = OMP_DEFAULT_NONE;
3030 410 : else if (openacc)
3031 : {
3032 225 : if (gfc_match ("present") == MATCH_YES)
3033 195 : c->default_sharing = OMP_DEFAULT_PRESENT;
3034 : }
3035 : else
3036 : {
3037 185 : if (gfc_match ("firstprivate") == MATCH_YES)
3038 8 : c->default_sharing = OMP_DEFAULT_FIRSTPRIVATE;
3039 177 : else if (gfc_match ("private") == MATCH_YES)
3040 24 : c->default_sharing = OMP_DEFAULT_PRIVATE;
3041 153 : else if (gfc_match ("shared") == MATCH_YES)
3042 153 : c->default_sharing = OMP_DEFAULT_SHARED;
3043 : }
3044 1006 : if (c->default_sharing == OMP_DEFAULT_UNKNOWN)
3045 : {
3046 30 : if (openacc)
3047 30 : gfc_error ("Expected NONE or PRESENT in DEFAULT clause "
3048 : "at %C");
3049 : else
3050 0 : gfc_error ("Expected NONE, FIRSTPRIVATE, PRIVATE or SHARED "
3051 : "in DEFAULT clause at %C");
3052 30 : goto error;
3053 : }
3054 976 : if (gfc_match (" )") != MATCH_YES)
3055 9 : goto error;
3056 967 : continue;
3057 : }
3058 3301 : if ((mask & OMP_CLAUSE_DELETE)
3059 345 : && gfc_match ("delete ( ") == MATCH_YES
3060 3301 : && gfc_match_omp_map_clause (&c->lists[OMP_LIST_MAP],
3061 : OMP_MAP_RELEASE, true,
3062 : allow_derived))
3063 308 : continue;
3064 : /* DOACROSS: match 'doacross' and 'depend' with sink/source.
3065 : DEPEND: match 'depend' but not sink/source. */
3066 2685 : m = MATCH_NO;
3067 2685 : if (((mask & OMP_CLAUSE_DOACROSS)
3068 383 : && gfc_match ("doacross ( ") == MATCH_YES)
3069 3041 : || (((mask & OMP_CLAUSE_DEPEND) || (mask & OMP_CLAUSE_DOACROSS))
3070 1600 : && (m = gfc_match ("depend ( ")) == MATCH_YES))
3071 : {
3072 1100 : bool has_omp_all_memory;
3073 1100 : bool is_depend = m == MATCH_YES;
3074 1100 : gfc_namespace *ns_iter = NULL, *ns_curr = gfc_current_ns;
3075 1100 : match m_it = MATCH_NO;
3076 1100 : if (is_depend)
3077 1073 : m_it = gfc_match_iterator (&ns_iter, false);
3078 1073 : if (m_it == MATCH_ERROR)
3079 : break;
3080 1095 : if (m_it == MATCH_YES && gfc_match (" , ") != MATCH_YES)
3081 : break;
3082 1095 : m = MATCH_YES;
3083 1095 : gfc_omp_depend_doacross_op depend_op = OMP_DEPEND_OUT;
3084 1095 : if (gfc_match ("inoutset") == MATCH_YES)
3085 : depend_op = OMP_DEPEND_INOUTSET;
3086 1083 : else if (gfc_match ("inout") == MATCH_YES)
3087 : depend_op = OMP_DEPEND_INOUT;
3088 991 : else if (gfc_match ("in") == MATCH_YES)
3089 : depend_op = OMP_DEPEND_IN;
3090 704 : else if (gfc_match ("out") == MATCH_YES)
3091 : depend_op = OMP_DEPEND_OUT;
3092 442 : else if (gfc_match ("mutexinoutset") == MATCH_YES)
3093 : depend_op = OMP_DEPEND_MUTEXINOUTSET;
3094 424 : else if (gfc_match ("depobj") == MATCH_YES)
3095 : depend_op = OMP_DEPEND_DEPOBJ;
3096 387 : else if (gfc_match ("source") == MATCH_YES)
3097 : {
3098 143 : if (m_it == MATCH_YES)
3099 : {
3100 1 : gfc_error ("ITERATOR may not be combined with SOURCE "
3101 : "at %C");
3102 17 : goto error;
3103 : }
3104 142 : if (!(mask & OMP_CLAUSE_DOACROSS))
3105 : {
3106 1 : gfc_error ("SOURCE at %C not permitted as dependence-type"
3107 : " for this directive");
3108 1 : goto error;
3109 : }
3110 141 : if (c->doacross_source)
3111 : {
3112 0 : gfc_error ("Duplicated clause with SOURCE dependence-type"
3113 : " at %C");
3114 0 : goto error;
3115 : }
3116 141 : gfc_gobble_whitespace ();
3117 141 : m = gfc_match (": ");
3118 141 : if (m != MATCH_YES && !is_depend)
3119 : {
3120 1 : gfc_error ("Expected %<:%> at %C");
3121 1 : goto error;
3122 : }
3123 140 : if (gfc_match (")") != MATCH_YES
3124 146 : && !(m == MATCH_YES
3125 6 : && gfc_match ("omp_cur_iteration )") == MATCH_YES))
3126 : {
3127 2 : gfc_error ("Expected %<)%> or %<omp_cur_iteration)%> "
3128 : "at %C");
3129 2 : goto error;
3130 : }
3131 138 : if (is_depend)
3132 130 : gfc_warning (OPT_Wdeprecated_openmp,
3133 : "%<source%> modifier with %<depend%> clause "
3134 : "at %L deprecated since OpenMP 5.2, use with "
3135 : "%<doacross%>", &old_loc);
3136 138 : c->doacross_source = true;
3137 138 : c->depend_source = is_depend;
3138 1078 : continue;
3139 : }
3140 244 : else if (gfc_match ("sink ") == MATCH_YES)
3141 : {
3142 244 : if (!(mask & OMP_CLAUSE_DOACROSS))
3143 : {
3144 2 : gfc_error ("SINK at %C not permitted as dependence-type "
3145 : "for this directive");
3146 2 : goto error;
3147 : }
3148 242 : if (gfc_match (": ") != MATCH_YES)
3149 : {
3150 1 : gfc_error ("Expected %<:%> at %C");
3151 1 : goto error;
3152 : }
3153 241 : if (m_it == MATCH_YES)
3154 : {
3155 0 : gfc_error ("ITERATOR may not be combined with SINK "
3156 : "at %C");
3157 0 : goto error;
3158 : }
3159 241 : if (is_depend)
3160 226 : gfc_warning (OPT_Wdeprecated_openmp,
3161 : "%<sink%> modifier with %<depend%> clause at "
3162 : "%L deprecated since OpenMP 5.2, use with "
3163 : "%<doacross%>", &old_loc);
3164 241 : m = gfc_match_omp_doacross_sink (&c->lists[OMP_LIST_DEPEND],
3165 : is_depend);
3166 241 : if (m == MATCH_YES)
3167 238 : continue;
3168 3 : goto error;
3169 : }
3170 : else
3171 : m = MATCH_NO;
3172 708 : if (!(mask & OMP_CLAUSE_DEPEND))
3173 : {
3174 0 : gfc_error ("Expected dependence-type SINK or SOURCE at %C");
3175 0 : goto error;
3176 : }
3177 708 : head = NULL;
3178 708 : if (ns_iter)
3179 40 : gfc_current_ns = ns_iter;
3180 708 : if (m == MATCH_YES)
3181 708 : m = gfc_match_omp_variable_list (" : ",
3182 : &c->lists[OMP_LIST_DEPEND],
3183 : false, NULL, &head, true,
3184 : false, &has_omp_all_memory);
3185 708 : if (m != MATCH_YES)
3186 2 : goto error;
3187 706 : gfc_current_ns = ns_curr;
3188 706 : if (has_omp_all_memory && depend_op != OMP_DEPEND_INOUT
3189 21 : && depend_op != OMP_DEPEND_OUT)
3190 : {
3191 4 : gfc_error ("%<omp_all_memory%> used with DEPEND kind "
3192 : "other than OUT or INOUT at %C");
3193 4 : goto error;
3194 : }
3195 702 : gfc_omp_namelist *n;
3196 1435 : for (n = *head; n; n = n->next)
3197 : {
3198 733 : n->u.depend_doacross_op = depend_op;
3199 733 : n->u2.ns = ns_iter;
3200 733 : if (ns_iter)
3201 39 : ns_iter->refs++;
3202 : }
3203 702 : continue;
3204 702 : }
3205 1606 : if ((mask & OMP_CLAUSE_DESTROY)
3206 1585 : && gfc_match_omp_variable_list ("destroy (",
3207 : &c->lists[OMP_LIST_DESTROY],
3208 : true) == MATCH_YES)
3209 21 : continue;
3210 1690 : if ((mask & OMP_CLAUSE_DETACH)
3211 164 : && !openacc
3212 127 : && !c->detach
3213 1690 : && gfc_match_omp_detach (&c->detach) == MATCH_YES)
3214 126 : continue;
3215 1475 : if ((mask & OMP_CLAUSE_DETACH)
3216 38 : && openacc
3217 37 : && gfc_match ("detach ( ") == MATCH_YES
3218 1475 : && gfc_match_omp_map_clause (&c->lists[OMP_LIST_MAP],
3219 : OMP_MAP_DETACH, false,
3220 : allow_derived))
3221 37 : continue;
3222 1437 : if ((mask & OMP_CLAUSE_DEVICEPTR)
3223 87 : && gfc_match ("deviceptr ( ") == MATCH_YES
3224 1439 : && gfc_match_omp_map_clause (&c->lists[OMP_LIST_MAP],
3225 : OMP_MAP_FORCE_DEVICEPTR, false,
3226 : allow_derived))
3227 36 : continue;
3228 820 : if ((mask & OMP_CLAUSE_DEVICE_TYPE) && openacc
3229 444 : && gfc_match_dupl_check (!c->oacc_device_type_present,
3230 : "device_type", true) == MATCH_YES
3231 1697 : && match_oacc_device_type (c) == MATCH_YES)
3232 326 : continue;
3233 494 : if ((mask & OMP_CLAUSE_DEVICE_TYPE) && !openacc
3234 1415 : && gfc_match_dupl_check (c->device_type == OMP_DEVICE_TYPE_UNSET,
3235 : "device_type", true) == MATCH_YES)
3236 : {
3237 92 : if (gfc_match ("host") == MATCH_YES)
3238 32 : c->device_type = OMP_DEVICE_TYPE_HOST;
3239 60 : else if (gfc_match ("nohost") == MATCH_YES)
3240 21 : c->device_type = OMP_DEVICE_TYPE_NOHOST;
3241 39 : else if (gfc_match ("any") == MATCH_YES)
3242 38 : c->device_type = OMP_DEVICE_TYPE_ANY;
3243 : else
3244 : {
3245 1 : gfc_error ("Expected HOST, NOHOST or ANY at %C");
3246 1 : break;
3247 : }
3248 91 : if (gfc_match (" )") != MATCH_YES)
3249 : break;
3250 91 : continue;
3251 : }
3252 1054 : if ((mask & OMP_CLAUSE_DEVICE_NUM)
3253 947 : && (m = gfc_match_dupl_check (!c->device_num_expr,
3254 : "device_num")) != MATCH_NO)
3255 : {
3256 109 : if (m == MATCH_ERROR)
3257 2 : goto error;
3258 107 : if (gfc_match ("( %e )", &c->device_num_expr) != MATCH_YES)
3259 0 : goto error;
3260 107 : continue;
3261 : }
3262 886 : if ((mask & OMP_CLAUSE_DEVICE_RESIDENT)
3263 887 : && gfc_match_omp_variable_list
3264 49 : ("device_resident (",
3265 : &c->lists[OMP_LIST_DEVICE_RESIDENT], true) == MATCH_YES)
3266 48 : continue;
3267 1102 : if ((mask & OMP_CLAUSE_DEVICE)
3268 705 : && openacc
3269 314 : && gfc_match ("device ( ") == MATCH_YES
3270 1103 : && gfc_match_omp_map_clause (&c->lists[OMP_LIST_MAP],
3271 : OMP_MAP_FORCE_TO, true,
3272 : /* allow_derived = */ true))
3273 312 : continue;
3274 478 : if ((mask & OMP_CLAUSE_DEVICE)
3275 393 : && !openacc
3276 869 : && ((m = gfc_match_dupl_check (!c->device, "device", true))
3277 : != MATCH_NO))
3278 : {
3279 351 : if (m == MATCH_ERROR)
3280 0 : goto error;
3281 351 : c->ancestor = false;
3282 351 : if (gfc_match ("device_num : ") == MATCH_YES)
3283 : {
3284 18 : if (gfc_match ("%e )", &c->device) != MATCH_YES)
3285 : {
3286 1 : gfc_error ("Expected integer expression at %C");
3287 1 : break;
3288 : }
3289 : }
3290 333 : else if (gfc_match ("ancestor : ") == MATCH_YES)
3291 : {
3292 45 : bool has_requires = false;
3293 45 : c->ancestor = true;
3294 82 : for (gfc_namespace *ns = gfc_current_ns; ns; ns = ns->parent)
3295 80 : if (ns->omp_requires & OMP_REQ_REVERSE_OFFLOAD)
3296 : {
3297 : has_requires = true;
3298 : break;
3299 : }
3300 45 : if (!has_requires)
3301 : {
3302 2 : gfc_error ("%<ancestor%> device modifier not "
3303 : "preceded by %<requires%> directive "
3304 : "with %<reverse_offload%> clause at %C");
3305 5 : break;
3306 : }
3307 43 : locus old_loc2 = gfc_current_locus;
3308 43 : if (gfc_match ("%e )", &c->device) == MATCH_YES)
3309 : {
3310 43 : int device = 0;
3311 43 : if (!gfc_extract_int (c->device, &device) && device != 1)
3312 : {
3313 1 : gfc_current_locus = old_loc2;
3314 1 : gfc_error ("the %<device%> clause expression must "
3315 : "evaluate to %<1%> at %C");
3316 1 : break;
3317 : }
3318 : }
3319 : else
3320 : {
3321 0 : gfc_error ("Expected integer expression at %C");
3322 0 : break;
3323 : }
3324 : }
3325 288 : else if (gfc_match ("%e )", &c->device) != MATCH_YES)
3326 : {
3327 13 : gfc_error ("Expected integer expression or a single device-"
3328 : "modifier %<device_num%> or %<ancestor%> at %C");
3329 13 : break;
3330 : }
3331 334 : continue;
3332 334 : }
3333 127 : if ((mask & OMP_CLAUSE_DIST_SCHEDULE)
3334 97 : && c->dist_sched_kind == OMP_SCHED_NONE
3335 224 : && gfc_match ("dist_schedule ( static") == MATCH_YES)
3336 : {
3337 97 : m = MATCH_NO;
3338 97 : c->dist_sched_kind = OMP_SCHED_STATIC;
3339 97 : m = gfc_match (" , %e )", &c->dist_chunk_size);
3340 97 : if (m != MATCH_YES)
3341 14 : m = gfc_match_char (')');
3342 14 : if (m != MATCH_YES)
3343 : {
3344 0 : c->dist_sched_kind = OMP_SCHED_NONE;
3345 0 : gfc_current_locus = old_loc;
3346 : }
3347 : else
3348 97 : continue;
3349 : }
3350 41 : if ((mask & OMP_CLAUSE_DYN_GROUPPRIVATE)
3351 30 : && gfc_match_dupl_check (!c->dyn_groupprivate,
3352 : "dyn_groupprivate", true) == MATCH_YES)
3353 : {
3354 12 : if (gfc_match ("fallback ( abort ) : ") == MATCH_YES)
3355 1 : c->fallback = OMP_FALLBACK_ABORT;
3356 11 : else if (gfc_match ("fallback ( default_mem ) : ") == MATCH_YES)
3357 1 : c->fallback = OMP_FALLBACK_DEFAULT_MEM;
3358 10 : else if (gfc_match ("fallback ( null ) : ") == MATCH_YES)
3359 1 : c->fallback = OMP_FALLBACK_NULL;
3360 12 : if (gfc_match_expr (&c->dyn_groupprivate) != MATCH_YES)
3361 0 : return MATCH_ERROR;
3362 12 : if (gfc_match (" )") != MATCH_YES)
3363 1 : goto error;
3364 11 : continue;
3365 : }
3366 : break;
3367 90 : case 'e':
3368 90 : if ((mask & OMP_CLAUSE_ENTER))
3369 : {
3370 90 : m = gfc_match_omp_to_link ("enter (", &c->lists[OMP_LIST_ENTER]);
3371 90 : if (m == MATCH_ERROR)
3372 0 : goto error;
3373 90 : if (m == MATCH_YES)
3374 90 : continue;
3375 : }
3376 : break;
3377 2309 : case 'f':
3378 2358 : if ((mask & OMP_CLAUSE_FAIL)
3379 2309 : && (m = gfc_match_dupl_check (c->fail == OMP_MEMORDER_UNSET,
3380 : "fail", true)) != MATCH_NO)
3381 : {
3382 58 : if (m == MATCH_ERROR)
3383 3 : goto error;
3384 55 : if (gfc_match ("seq_cst") == MATCH_YES)
3385 6 : c->fail = OMP_MEMORDER_SEQ_CST;
3386 49 : else if (gfc_match ("acquire") == MATCH_YES)
3387 14 : c->fail = OMP_MEMORDER_ACQUIRE;
3388 35 : else if (gfc_match ("relaxed") == MATCH_YES)
3389 30 : c->fail = OMP_MEMORDER_RELAXED;
3390 : else
3391 : {
3392 5 : gfc_error ("Expected SEQ_CST, ACQUIRE or RELAXED at %C");
3393 5 : break;
3394 : }
3395 50 : if (gfc_match (" )") != MATCH_YES)
3396 1 : goto error;
3397 49 : continue;
3398 : }
3399 2294 : if ((mask & OMP_CLAUSE_FILTER)
3400 2251 : && (m = gfc_match_dupl_check (!c->filter, "filter", true,
3401 : &c->filter)) != MATCH_NO)
3402 : {
3403 44 : if (m == MATCH_ERROR)
3404 1 : goto error;
3405 43 : continue;
3406 : }
3407 2271 : if ((mask & OMP_CLAUSE_FINAL)
3408 2207 : && (m = gfc_match_dupl_check (!c->final_expr, "final", true,
3409 : &c->final_expr)) != MATCH_NO)
3410 : {
3411 64 : if (m == MATCH_ERROR)
3412 0 : goto error;
3413 64 : continue;
3414 : }
3415 2169 : if ((mask & OMP_CLAUSE_FINALIZE)
3416 2143 : && (m = gfc_match_dupl_check (!c->finalize, "finalize"))
3417 : != MATCH_NO)
3418 : {
3419 26 : if (m == MATCH_ERROR)
3420 0 : goto error;
3421 26 : c->finalize = true;
3422 26 : continue;
3423 : }
3424 3155 : if ((mask & OMP_CLAUSE_FIRSTPRIVATE)
3425 2117 : && gfc_match_omp_variable_list ("firstprivate (",
3426 : &c->lists[OMP_LIST_FIRSTPRIVATE],
3427 : true) == MATCH_YES)
3428 1038 : continue;
3429 2080 : if ((mask & OMP_CLAUSE_FROM)
3430 1079 : && gfc_match_motion_var_list ("from (", &c->lists[OMP_LIST_FROM],
3431 : &head) == MATCH_YES)
3432 1001 : continue;
3433 143 : if ((mask & OMP_CLAUSE_FULL)
3434 78 : && (m = gfc_match_dupl_check (!c->full, "full")) != MATCH_NO)
3435 : {
3436 65 : if (m == MATCH_ERROR)
3437 0 : goto error;
3438 65 : c->full = true;
3439 65 : continue;
3440 : }
3441 : break;
3442 1231 : case 'g':
3443 2423 : if ((mask & OMP_CLAUSE_GANG)
3444 1231 : && (m = gfc_match_dupl_check (!c->gang, "gang")) != MATCH_NO)
3445 : {
3446 1197 : if (m == MATCH_ERROR)
3447 0 : goto error;
3448 1197 : c->gang = true;
3449 1197 : m = match_oacc_clause_gwv (c, GOMP_DIM_GANG);
3450 1197 : if (m == MATCH_ERROR)
3451 : {
3452 5 : gfc_current_locus = old_loc;
3453 5 : break;
3454 : }
3455 1192 : continue;
3456 : }
3457 68 : if ((mask & OMP_CLAUSE_GRAINSIZE)
3458 34 : && (m = gfc_match_dupl_check (!c->grainsize, "grainsize", true))
3459 : != MATCH_NO)
3460 : {
3461 34 : if (m == MATCH_ERROR)
3462 0 : goto error;
3463 34 : if (gfc_match ("strict : ") == MATCH_YES)
3464 1 : c->grainsize_strict = true;
3465 34 : if (gfc_match (" %e )", &c->grainsize) != MATCH_YES)
3466 0 : goto error;
3467 34 : continue;
3468 : }
3469 : break;
3470 465 : case 'h':
3471 513 : if ((mask & OMP_CLAUSE_HAS_DEVICE_ADDR)
3472 513 : && gfc_match_omp_variable_list
3473 48 : ("has_device_addr (", &c->lists[OMP_LIST_HAS_DEVICE_ADDR],
3474 : false, NULL, NULL, true) == MATCH_YES)
3475 48 : continue;
3476 460 : if ((mask & OMP_CLAUSE_HINT)
3477 417 : && (m = gfc_match_dupl_check (!c->hint, "hint", true, &c->hint))
3478 : != MATCH_NO)
3479 : {
3480 43 : if (m == MATCH_ERROR)
3481 0 : goto error;
3482 43 : continue;
3483 : }
3484 374 : if ((mask & OMP_CLAUSE_ASSUMPTIONS)
3485 374 : && gfc_match ("holds ( ") == MATCH_YES)
3486 : {
3487 19 : gfc_expr *e;
3488 19 : if (gfc_match ("%e )", &e) != MATCH_YES)
3489 0 : goto error;
3490 19 : if (c->assume == NULL)
3491 12 : c->assume = gfc_get_omp_assumptions ();
3492 19 : gfc_expr_list *el = XCNEW (gfc_expr_list);
3493 19 : el->expr = e;
3494 19 : el->next = c->assume->holds;
3495 19 : c->assume->holds = el;
3496 19 : continue;
3497 19 : }
3498 709 : if ((mask & OMP_CLAUSE_HOST)
3499 355 : && gfc_match ("host ( ") == MATCH_YES
3500 710 : && gfc_match_omp_map_clause (&c->lists[OMP_LIST_MAP],
3501 : OMP_MAP_FORCE_FROM, true,
3502 : /* allow_derived = */ true))
3503 354 : continue;
3504 : break;
3505 2243 : case 'i':
3506 2266 : if ((mask & OMP_CLAUSE_IF_PRESENT)
3507 2243 : && (m = gfc_match_dupl_check (!c->if_present, "if_present"))
3508 : != MATCH_NO)
3509 : {
3510 23 : if (m == MATCH_ERROR)
3511 0 : goto error;
3512 23 : c->if_present = true;
3513 23 : continue;
3514 : }
3515 2220 : if ((mask & OMP_CLAUSE_IF)
3516 2220 : && (m = gfc_match_dupl_check (!c->if_expr, "if", true))
3517 : != MATCH_NO)
3518 : {
3519 1466 : if (m == MATCH_ERROR)
3520 14 : goto error;
3521 1452 : if (!openacc)
3522 : {
3523 : /* This should match the enum gfc_omp_if_kind order. */
3524 : static const char *ifs[OMP_IF_LAST] = {
3525 : "cancel : %e )",
3526 : "parallel : %e )",
3527 : "simd : %e )",
3528 : "task : %e )",
3529 : "taskloop : %e )",
3530 : "target : %e )",
3531 : "target data : %e )",
3532 : "target update : %e )",
3533 : "target enter data : %e )",
3534 : "target exit data : %e )" };
3535 : int i;
3536 4907 : for (i = 0; i < OMP_IF_LAST; i++)
3537 4503 : if (c->if_exprs[i] == NULL
3538 4503 : && gfc_match (ifs[i], &c->if_exprs[i]) == MATCH_YES)
3539 : break;
3540 542 : if (i < OMP_IF_LAST)
3541 138 : continue;
3542 : }
3543 1314 : if (gfc_match (" %e )", &c->if_expr) == MATCH_YES)
3544 1309 : continue;
3545 5 : goto error;
3546 : }
3547 871 : if ((mask & OMP_CLAUSE_IN_REDUCTION)
3548 754 : && gfc_match_omp_clause_reduction (pc, c, openacc, allow_derived,
3549 : openmp_target) == MATCH_YES)
3550 117 : continue;
3551 662 : if ((mask & OMP_CLAUSE_INBRANCH)
3552 637 : && (m = gfc_match_dupl_check (!c->inbranch && !c->notinbranch,
3553 : "inbranch")) != MATCH_NO)
3554 : {
3555 25 : if (m == MATCH_ERROR)
3556 0 : goto error;
3557 25 : c->inbranch = true;
3558 25 : continue;
3559 : }
3560 854 : if ((mask & OMP_CLAUSE_INDEPENDENT)
3561 612 : && (m = gfc_match_dupl_check (!c->independent, "independent"))
3562 : != MATCH_NO)
3563 : {
3564 242 : if (m == MATCH_ERROR)
3565 0 : goto error;
3566 242 : c->independent = true;
3567 242 : continue;
3568 : }
3569 370 : if ((mask & OMP_CLAUSE_INDIRECT)
3570 370 : && (m = gfc_match_dupl_check (!c->indirect, "indirect"))
3571 : != MATCH_NO)
3572 : {
3573 61 : if (m == MATCH_ERROR)
3574 5 : goto error;
3575 60 : gfc_expr *indirect_expr = NULL;
3576 60 : m = gfc_match (" ( %e )", &indirect_expr);
3577 60 : if (m == MATCH_YES)
3578 : {
3579 13 : if (!gfc_resolve_expr (indirect_expr)
3580 13 : || indirect_expr->ts.type != BT_LOGICAL
3581 23 : || indirect_expr->expr_type != EXPR_CONSTANT)
3582 : {
3583 4 : gfc_error ("INDIRECT clause at %C requires a constant "
3584 : "logical expression");
3585 4 : gfc_free_expr (indirect_expr);
3586 4 : goto error;
3587 : }
3588 9 : c->indirect = indirect_expr->value.logical;
3589 9 : gfc_free_expr (indirect_expr);
3590 : }
3591 : else
3592 47 : c->indirect = 1;
3593 56 : continue;
3594 56 : }
3595 309 : if ((mask & OMP_CLAUSE_INIT)
3596 309 : && gfc_match ("init ( ") == MATCH_YES)
3597 : {
3598 108 : m = gfc_match_omp_init (&c->lists[OMP_LIST_INIT]);
3599 108 : if (m == MATCH_YES)
3600 63 : continue;
3601 45 : goto error;
3602 : }
3603 201 : if ((mask & OMP_CLAUSE_INTEROP)
3604 201 : && (m = gfc_match_dupl_check (!c->lists[OMP_LIST_INTEROP],
3605 : "interop", true)) != MATCH_NO)
3606 : {
3607 : /* Note: the interop objects are saved in reverse order to match
3608 : the order in C/C++. */
3609 125 : if (m == MATCH_YES
3610 63 : && (gfc_match_omp_variable_list ("",
3611 : &c->lists[OMP_LIST_INTEROP],
3612 : false, NULL, NULL, false,
3613 : false, NULL, false, true)
3614 : == MATCH_YES))
3615 62 : continue;
3616 1 : goto error;
3617 : }
3618 258 : if ((mask & OMP_CLAUSE_IS_DEVICE_PTR)
3619 258 : && gfc_match_omp_variable_list
3620 120 : ("is_device_ptr (",
3621 : &c->lists[OMP_LIST_IS_DEVICE_PTR], false) == MATCH_YES)
3622 120 : continue;
3623 : break;
3624 2336 : case 'l':
3625 2336 : if ((mask & OMP_CLAUSE_LASTPRIVATE)
3626 2336 : && gfc_match ("lastprivate ( ") == MATCH_YES)
3627 : {
3628 1433 : bool conditional = gfc_match ("conditional : ") == MATCH_YES;
3629 1433 : head = NULL;
3630 1433 : if (gfc_match_omp_variable_list ("",
3631 : &c->lists[OMP_LIST_LASTPRIVATE],
3632 : false, NULL, &head) == MATCH_YES)
3633 : {
3634 1433 : gfc_omp_namelist *n;
3635 3741 : for (n = *head; n; n = n->next)
3636 2308 : n->u.lastprivate_conditional = conditional;
3637 1433 : continue;
3638 1433 : }
3639 0 : gfc_current_locus = old_loc;
3640 0 : break;
3641 : }
3642 903 : end_colon = false;
3643 903 : head = NULL;
3644 903 : if ((mask & OMP_CLAUSE_LINEAR)
3645 903 : && gfc_match ("linear (") == MATCH_YES)
3646 : {
3647 836 : bool old_linear_modifier = false;
3648 836 : gfc_omp_linear_op linear_op = OMP_LINEAR_DEFAULT;
3649 836 : gfc_expr *step = NULL;
3650 836 : locus saved_loc = gfc_current_locus;
3651 :
3652 836 : if (gfc_match_omp_variable_list (" ref (",
3653 : &c->lists[OMP_LIST_LINEAR],
3654 : false, NULL, &head)
3655 : == MATCH_YES)
3656 : {
3657 : linear_op = OMP_LINEAR_REF;
3658 : old_linear_modifier = true;
3659 : }
3660 808 : else if (gfc_match_omp_variable_list (" val (",
3661 : &c->lists[OMP_LIST_LINEAR],
3662 : false, NULL, &head)
3663 : == MATCH_YES)
3664 : {
3665 : linear_op = OMP_LINEAR_VAL;
3666 : old_linear_modifier = true;
3667 : }
3668 797 : else if (gfc_match_omp_variable_list (" uval (",
3669 : &c->lists[OMP_LIST_LINEAR],
3670 : false, NULL, &head)
3671 : == MATCH_YES)
3672 : {
3673 : linear_op = OMP_LINEAR_UVAL;
3674 : old_linear_modifier = true;
3675 : }
3676 788 : else if (gfc_match_omp_variable_list ("",
3677 : &c->lists[OMP_LIST_LINEAR],
3678 : false, &end_colon, &head)
3679 : == MATCH_YES)
3680 : linear_op = OMP_LINEAR_DEFAULT;
3681 : else
3682 : {
3683 2 : gfc_current_locus = old_loc;
3684 2 : break;
3685 : }
3686 : if (linear_op != OMP_LINEAR_DEFAULT)
3687 : {
3688 48 : if (gfc_match (" :") == MATCH_YES)
3689 31 : end_colon = true;
3690 17 : else if (gfc_match (" )") != MATCH_YES)
3691 : {
3692 0 : gfc_free_omp_namelist (*head, OMP_LIST_LINEAR);
3693 0 : gfc_current_locus = old_loc;
3694 0 : *head = NULL;
3695 0 : break;
3696 : }
3697 : }
3698 834 : gfc_gobble_whitespace ();
3699 834 : if (old_linear_modifier && end_colon)
3700 : {
3701 31 : if (gfc_match (" %e )", &step) != MATCH_YES)
3702 : {
3703 1 : gfc_free_omp_namelist (*head, OMP_LIST_LINEAR);
3704 1 : gfc_current_locus = old_loc;
3705 1 : *head = NULL;
3706 5 : goto error;
3707 : }
3708 : }
3709 833 : if (old_linear_modifier)
3710 : {
3711 47 : char var_names[512]{};
3712 47 : int count, offset = 0;
3713 106 : for (gfc_omp_namelist *n = *head; n; n = n->next)
3714 : {
3715 59 : if (!n->next)
3716 47 : count = snprintf (var_names + offset,
3717 47 : sizeof (var_names) - offset,
3718 47 : "%s", n->sym->name);
3719 : else
3720 12 : count = snprintf (var_names + offset,
3721 12 : sizeof (var_names) - offset,
3722 12 : "%s, ", n->sym->name);
3723 59 : if (count < 0 || count >= ((int)sizeof (var_names))
3724 59 : - offset)
3725 : {
3726 0 : snprintf (var_names, 512, "%s, ..., ",
3727 0 : (*head)->sym->name);
3728 0 : while (n->next)
3729 : n = n->next;
3730 0 : offset = strlen (var_names);
3731 0 : snprintf (var_names + offset,
3732 0 : sizeof (var_names) - offset,
3733 0 : "%s", n->sym->name);
3734 0 : break;
3735 : }
3736 59 : offset += count;
3737 : }
3738 47 : char *var_names_for_warn = var_names;
3739 47 : const char *op_name;
3740 47 : switch (linear_op)
3741 : {
3742 : case OMP_LINEAR_REF: op_name = "ref"; break;
3743 10 : case OMP_LINEAR_VAL: op_name = "val"; break;
3744 9 : case OMP_LINEAR_UVAL: op_name = "uval"; break;
3745 0 : default: gcc_unreachable ();
3746 : }
3747 47 : gfc_warning (OPT_Wdeprecated_openmp,
3748 : "Specification of the list items as "
3749 : "arguments to the modifiers at %L is "
3750 : "deprecated; since OpenMP 5.2, use "
3751 : "%<linear(%s : %s%s)%>", &saved_loc,
3752 : var_names_for_warn, op_name,
3753 47 : step == nullptr ? "" : ", step(...)");
3754 : }
3755 786 : else if (end_colon)
3756 : {
3757 713 : bool has_error = false;
3758 : bool has_modifiers = false;
3759 : bool has_step = false;
3760 713 : bool duplicate_step = false;
3761 713 : bool duplicate_mod = false;
3762 713 : while (true)
3763 : {
3764 713 : old_loc = gfc_current_locus;
3765 713 : bool close_paren = gfc_match ("val )") == MATCH_YES;
3766 713 : if (close_paren || gfc_match ("val , ") == MATCH_YES)
3767 : {
3768 17 : if (linear_op != OMP_LINEAR_DEFAULT)
3769 : {
3770 : duplicate_mod = true;
3771 : break;
3772 : }
3773 16 : linear_op = OMP_LINEAR_VAL;
3774 16 : has_modifiers = true;
3775 16 : if (close_paren)
3776 : break;
3777 10 : continue;
3778 : }
3779 696 : close_paren = gfc_match ("uval )") == MATCH_YES;
3780 696 : if (close_paren || gfc_match ("uval , ") == MATCH_YES)
3781 : {
3782 7 : if (linear_op != OMP_LINEAR_DEFAULT)
3783 : {
3784 : duplicate_mod = true;
3785 : break;
3786 : }
3787 7 : linear_op = OMP_LINEAR_UVAL;
3788 7 : has_modifiers = true;
3789 7 : if (close_paren)
3790 : break;
3791 2 : continue;
3792 : }
3793 689 : close_paren = gfc_match ("ref )") == MATCH_YES;
3794 689 : if (close_paren || gfc_match ("ref , ") == MATCH_YES)
3795 : {
3796 16 : if (linear_op != OMP_LINEAR_DEFAULT)
3797 : {
3798 : duplicate_mod = true;
3799 : break;
3800 : }
3801 15 : linear_op = OMP_LINEAR_REF;
3802 15 : has_modifiers = true;
3803 15 : if (close_paren)
3804 : break;
3805 7 : continue;
3806 : }
3807 673 : close_paren = (gfc_match ("step ( %e ) )", &step)
3808 : == MATCH_YES);
3809 684 : if (close_paren
3810 673 : || gfc_match ("step ( %e ) , ", &step) == MATCH_YES)
3811 : {
3812 38 : if (has_step)
3813 : {
3814 : duplicate_step = true;
3815 : break;
3816 : }
3817 37 : has_modifiers = has_step = true;
3818 37 : if (close_paren)
3819 : break;
3820 11 : continue;
3821 : }
3822 635 : if (!has_modifiers
3823 635 : && gfc_match ("%e )", &step) == MATCH_YES)
3824 : {
3825 635 : if ((step->expr_type == EXPR_FUNCTION
3826 634 : || step->expr_type == EXPR_VARIABLE)
3827 31 : && strcmp (step->symtree->name, "step") == 0)
3828 : {
3829 1 : gfc_current_locus = old_loc;
3830 1 : gfc_match ("step (");
3831 1 : has_error = true;
3832 : }
3833 : break;
3834 : }
3835 : has_error = true;
3836 : break;
3837 : }
3838 49 : if (duplicate_mod || duplicate_step)
3839 : {
3840 3 : gfc_error ("Multiple %qs modifiers specified at %C",
3841 : duplicate_mod ? "linear" : "step");
3842 3 : has_error = true;
3843 : }
3844 683 : if (has_error)
3845 : {
3846 4 : gfc_free_omp_namelist (*head, OMP_LIST_LINEAR);
3847 4 : *head = NULL;
3848 4 : goto error;
3849 : }
3850 : }
3851 829 : if (step == NULL)
3852 : {
3853 130 : step = gfc_get_constant_expr (BT_INTEGER,
3854 : gfc_default_integer_kind,
3855 : &old_loc);
3856 130 : mpz_set_si (step->value.integer, 1);
3857 : }
3858 829 : (*head)->expr = step;
3859 829 : if (linear_op != OMP_LINEAR_DEFAULT || old_linear_modifier)
3860 176 : for (gfc_omp_namelist *n = *head; n; n = n->next)
3861 : {
3862 94 : n->u.linear.op = linear_op;
3863 94 : n->u.linear.old_modifier = old_linear_modifier;
3864 : }
3865 829 : continue;
3866 829 : }
3867 71 : if ((mask & OMP_CLAUSE_LINK)
3868 67 : && openacc
3869 75 : && (gfc_match_oacc_clause_link ("link (",
3870 : &c->lists[OMP_LIST_LINK])
3871 : == MATCH_YES))
3872 4 : continue;
3873 110 : else if ((mask & OMP_CLAUSE_LINK)
3874 63 : && !openacc
3875 122 : && (gfc_match_omp_to_link ("link (",
3876 : &c->lists[OMP_LIST_LINK])
3877 : == MATCH_YES))
3878 47 : continue;
3879 28 : if ((mask & OMP_CLAUSE_LOCAL)
3880 16 : && (gfc_match_omp_to_link ("local (", &c->lists[OMP_LIST_LOCAL])
3881 : == MATCH_YES))
3882 12 : continue;
3883 : break;
3884 5942 : case 'm':
3885 5942 : if ((mask & OMP_CLAUSE_MAP)
3886 5942 : && gfc_match ("map ( ") == MATCH_YES)
3887 : {
3888 5839 : locus old_loc2 = gfc_current_locus;
3889 5839 : int always_modifier = 0;
3890 5839 : int close_modifier = 0;
3891 5839 : int present_modifier = 0;
3892 5839 : int mapper_modifier = 0;
3893 5839 : int iterator_modifier = 0;
3894 5839 : gfc_namespace *ns_iter = NULL, *ns_curr = gfc_current_ns;
3895 5839 : locus second_always_locus = old_loc2;
3896 5839 : locus second_close_locus = old_loc2;
3897 5839 : locus second_mapper_locus = old_loc2;
3898 5839 : locus second_present_locus = old_loc2;
3899 5839 : char mapper_id[GFC_MAX_SYMBOL_LEN + 1] = { '\0' };
3900 5839 : locus second_iterator_locus = old_loc2;
3901 :
3902 6505 : for (;;)
3903 : {
3904 6172 : locus current_locus = gfc_current_locus;
3905 6172 : if (gfc_match ("always ") == MATCH_YES)
3906 : {
3907 148 : if (always_modifier++ == 1)
3908 5 : second_always_locus = current_locus;
3909 : }
3910 6024 : else if (gfc_match ("close ") == MATCH_YES)
3911 : {
3912 69 : if (close_modifier++ == 1)
3913 5 : second_close_locus = current_locus;
3914 : }
3915 5955 : else if (gfc_match ("present ") == MATCH_YES)
3916 : {
3917 67 : if (present_modifier++ == 1)
3918 4 : second_present_locus = current_locus;
3919 : }
3920 5888 : else if (gfc_match ("mapper ( ") == MATCH_YES)
3921 : {
3922 7 : if (mapper_modifier++ == 1)
3923 0 : second_mapper_locus = current_locus;
3924 7 : m = gfc_match (" %n ) ", mapper_id);
3925 7 : if (m != MATCH_YES)
3926 0 : goto error;
3927 7 : if (strcmp (mapper_id, "default") == 0)
3928 3 : mapper_id[0] = '\0';
3929 : }
3930 5881 : else if (gfc_match_iterator (&ns_iter, true) == MATCH_YES)
3931 : {
3932 42 : if (iterator_modifier++ == 1)
3933 1 : second_iterator_locus = current_locus;
3934 : }
3935 : else
3936 : break;
3937 333 : if (gfc_match (", ") != MATCH_YES)
3938 62 : gfc_warning (OPT_Wdeprecated_openmp,
3939 : "The specification of modifiers without "
3940 : "comma separators for the %<map%> clause "
3941 : "at %C has been deprecated since "
3942 : "OpenMP 5.2");
3943 333 : }
3944 :
3945 5839 : gfc_omp_map_op map_op = default_map_op;
3946 5839 : int always_present_modifier
3947 5839 : = always_modifier && present_modifier;
3948 :
3949 5839 : if (gfc_match ("alloc : ") == MATCH_YES)
3950 799 : map_op = (present_modifier ? OMP_MAP_PRESENT_ALLOC
3951 : : OMP_MAP_ALLOC);
3952 5040 : else if (gfc_match ("tofrom : ") == MATCH_YES)
3953 954 : map_op = (always_present_modifier ? OMP_MAP_ALWAYS_PRESENT_TOFROM
3954 950 : : present_modifier ? OMP_MAP_PRESENT_TOFROM
3955 945 : : always_modifier ? OMP_MAP_ALWAYS_TOFROM
3956 : : OMP_MAP_TOFROM);
3957 4086 : else if (gfc_match ("to : ") == MATCH_YES)
3958 1814 : map_op = (always_present_modifier ? OMP_MAP_ALWAYS_PRESENT_TO
3959 1808 : : present_modifier ? OMP_MAP_PRESENT_TO
3960 1796 : : always_modifier ? OMP_MAP_ALWAYS_TO
3961 : : OMP_MAP_TO);
3962 2272 : else if (gfc_match ("from : ") == MATCH_YES)
3963 1654 : map_op = (always_present_modifier ? OMP_MAP_ALWAYS_PRESENT_FROM
3964 1650 : : present_modifier ? OMP_MAP_PRESENT_FROM
3965 1645 : : always_modifier ? OMP_MAP_ALWAYS_FROM
3966 : : OMP_MAP_FROM);
3967 618 : else if (gfc_match ("release : ") == MATCH_YES)
3968 : map_op = OMP_MAP_RELEASE;
3969 564 : else if (gfc_match ("delete : ") == MATCH_YES)
3970 : map_op = OMP_MAP_DELETE;
3971 : else
3972 : {
3973 487 : gfc_current_locus = old_loc2;
3974 487 : always_modifier = 0;
3975 487 : close_modifier = 0;
3976 487 : mapper_modifier = 0;
3977 : }
3978 :
3979 1565 : if (always_modifier > 1)
3980 : {
3981 5 : gfc_error ("too many %<always%> modifiers at %L",
3982 : &second_always_locus);
3983 24 : break;
3984 : }
3985 5834 : if (close_modifier > 1)
3986 : {
3987 4 : gfc_error ("too many %<close%> modifiers at %L",
3988 : &second_close_locus);
3989 4 : break;
3990 : }
3991 5830 : if (present_modifier > 1)
3992 : {
3993 4 : gfc_error ("too many %<present%> modifiers at %L",
3994 : &second_present_locus);
3995 4 : break;
3996 : }
3997 5826 : if (mapper_modifier > 1)
3998 : {
3999 0 : gfc_error ("too many %<mapper%> modifiers at %L",
4000 : &second_mapper_locus);
4001 0 : break;
4002 : }
4003 5826 : if (iterator_modifier > 1)
4004 : {
4005 1 : gfc_error ("too many %<iterator%> modifiers at %L",
4006 : &second_iterator_locus);
4007 1 : break;
4008 : }
4009 :
4010 5825 : head = NULL;
4011 5825 : if (ns_iter)
4012 40 : gfc_current_ns = ns_iter;
4013 5825 : m = gfc_match_omp_variable_list ("", &c->lists[OMP_LIST_MAP],
4014 : false, NULL, &head, true, true);
4015 5825 : gfc_current_ns = ns_curr;
4016 5825 : if (m == MATCH_YES)
4017 : {
4018 5820 : gfc_omp_namelist *n;
4019 13223 : for (n = *head; n; n = n->next)
4020 : {
4021 7403 : n->u.map.op = map_op;
4022 7403 : if (mapper_id[0] != '\0')
4023 : {
4024 4 : n->u3.udm = gfc_get_omp_namelist_udm ();
4025 4 : n->u3.udm->requested_mapper_id
4026 4 : = gfc_get_string ("%s", mapper_id);
4027 : }
4028 7403 : n->u2.ns = ns_iter;
4029 7403 : if (ns_iter)
4030 42 : ns_iter->refs++;
4031 : }
4032 5820 : continue;
4033 5820 : }
4034 5 : gfc_current_locus = old_loc;
4035 5 : break;
4036 : }
4037 137 : if ((mask & OMP_CLAUSE_MERGEABLE)
4038 103 : && (m = gfc_match_dupl_check (!c->mergeable, "mergeable"))
4039 : != MATCH_NO)
4040 : {
4041 34 : if (m == MATCH_ERROR)
4042 0 : goto error;
4043 34 : c->mergeable = true;
4044 34 : continue;
4045 : }
4046 133 : if ((mask & OMP_CLAUSE_MESSAGE)
4047 69 : && (m = gfc_match_dupl_check (!c->message, "message", true,
4048 : &c->message)) != MATCH_NO)
4049 : {
4050 69 : if (m == MATCH_ERROR)
4051 5 : goto error;
4052 64 : continue;
4053 : }
4054 : break;
4055 3013 : case 'n':
4056 3065 : if ((mask & OMP_CLAUSE_NO_CREATE)
4057 1343 : && gfc_match ("no_create ( ") == MATCH_YES
4058 3065 : && gfc_match_omp_map_clause (&c->lists[OMP_LIST_MAP],
4059 : OMP_MAP_IF_PRESENT, true,
4060 : allow_derived))
4061 52 : continue;
4062 2962 : if ((mask & OMP_CLAUSE_ASSUMPTIONS)
4063 2987 : && (m = gfc_match_dupl_check (!c->assume
4064 26 : || !c->assume->no_openmp_constructs,
4065 : "no_openmp_constructs")) != MATCH_NO)
4066 : {
4067 2 : if (m == MATCH_ERROR)
4068 1 : goto error;
4069 1 : if (c->assume == NULL)
4070 0 : c->assume = gfc_get_omp_assumptions ();
4071 1 : c->assume->no_openmp_constructs = true;
4072 1 : continue;
4073 : }
4074 2972 : if ((mask & OMP_CLAUSE_ASSUMPTIONS)
4075 2983 : && (m = gfc_match_dupl_check (!c->assume
4076 24 : || !c->assume->no_openmp_routines,
4077 : "no_openmp_routines")) != MATCH_NO)
4078 : {
4079 13 : if (m == MATCH_ERROR)
4080 0 : goto error;
4081 13 : if (c->assume == NULL)
4082 12 : c->assume = gfc_get_omp_assumptions ();
4083 13 : c->assume->no_openmp_routines = true;
4084 13 : continue;
4085 : }
4086 2950 : if ((mask & OMP_CLAUSE_ASSUMPTIONS)
4087 2956 : && (m = gfc_match_dupl_check (!c->assume || !c->assume->no_openmp,
4088 : "no_openmp")) != MATCH_NO)
4089 : {
4090 4 : if (m == MATCH_ERROR)
4091 0 : goto error;
4092 4 : if (c->assume == NULL)
4093 4 : c->assume = gfc_get_omp_assumptions ();
4094 4 : c->assume->no_openmp = true;
4095 4 : continue;
4096 : }
4097 2948 : if ((mask & OMP_CLAUSE_ASSUMPTIONS)
4098 2949 : && (m = gfc_match_dupl_check (!c->assume
4099 7 : || !c->assume->no_parallelism,
4100 : "no_parallelism")) != MATCH_NO)
4101 : {
4102 6 : if (m == MATCH_ERROR)
4103 0 : goto error;
4104 6 : if (c->assume == NULL)
4105 6 : c->assume = gfc_get_omp_assumptions ();
4106 6 : c->assume->no_parallelism = true;
4107 6 : continue;
4108 : }
4109 :
4110 2946 : if ((mask & OMP_CLAUSE_NOVARIANTS)
4111 2936 : && (m = gfc_match_dupl_check (!c->novariants, "novariants", true,
4112 : &c->novariants))
4113 : != MATCH_NO)
4114 : {
4115 12 : if (m == MATCH_ERROR)
4116 2 : goto error;
4117 10 : continue;
4118 : }
4119 2937 : if ((mask & OMP_CLAUSE_NOCONTEXT)
4120 2924 : && (m = gfc_match_dupl_check (!c->nocontext, "nocontext", true,
4121 : &c->nocontext))
4122 : != MATCH_NO)
4123 : {
4124 15 : if (m == MATCH_ERROR)
4125 2 : goto error;
4126 13 : continue;
4127 : }
4128 2923 : if ((mask & OMP_CLAUSE_NOGROUP)
4129 2909 : && (m = gfc_match_dupl_check (!c->nogroup, "nogroup"))
4130 : != MATCH_NO)
4131 : {
4132 14 : if (m == MATCH_ERROR)
4133 0 : goto error;
4134 14 : c->nogroup = true;
4135 14 : continue;
4136 : }
4137 3045 : if ((mask & OMP_CLAUSE_NOHOST)
4138 2895 : && (m = gfc_match_dupl_check (!c->nohost, "nohost")) != MATCH_NO)
4139 : {
4140 151 : if (m == MATCH_ERROR)
4141 1 : goto error;
4142 150 : c->nohost = true;
4143 150 : continue;
4144 : }
4145 2786 : if ((mask & OMP_CLAUSE_NOTEMPORAL)
4146 2744 : && gfc_match_omp_variable_list ("nontemporal (",
4147 : &c->lists[OMP_LIST_NONTEMPORAL],
4148 : true) == MATCH_YES)
4149 42 : continue;
4150 2726 : if ((mask & OMP_CLAUSE_NOTINBRANCH)
4151 2703 : && (m = gfc_match_dupl_check (!c->notinbranch && !c->inbranch,
4152 : "notinbranch")) != MATCH_NO)
4153 : {
4154 25 : if (m == MATCH_ERROR)
4155 1 : goto error;
4156 24 : c->notinbranch = true;
4157 24 : continue;
4158 : }
4159 2806 : if ((mask & OMP_CLAUSE_NOWAIT)
4160 2677 : && (m = gfc_match_dupl_check (!c->nowait, "nowait")) != MATCH_NO)
4161 : {
4162 132 : if (m == MATCH_ERROR)
4163 3 : goto error;
4164 129 : c->nowait = true;
4165 129 : continue;
4166 : }
4167 3227 : if ((mask & OMP_CLAUSE_NUM_GANGS)
4168 2545 : && (m = gfc_match_dupl_check (!c->num_gangs_expr, "num_gangs",
4169 : true)) != MATCH_NO)
4170 : {
4171 686 : if (m == MATCH_ERROR)
4172 2 : goto error;
4173 684 : if (gfc_match (" %e )", &c->num_gangs_expr) != MATCH_YES)
4174 2 : goto error;
4175 682 : continue;
4176 : }
4177 1885 : if ((mask & OMP_CLAUSE_NUM_TASKS)
4178 1859 : && (m = gfc_match_dupl_check (!c->num_tasks, "num_tasks", true))
4179 : != MATCH_NO)
4180 : {
4181 26 : if (m == MATCH_ERROR)
4182 0 : goto error;
4183 26 : if (gfc_match ("strict : ") == MATCH_YES)
4184 1 : c->num_tasks_strict = true;
4185 26 : if (gfc_match (" %e )", &c->num_tasks) != MATCH_YES)
4186 0 : goto error;
4187 26 : continue;
4188 : }
4189 1833 : if ((mask & OMP_CLAUSE_NUM_TEAMS)
4190 1833 : && (m = gfc_match_dupl_check (!c->num_teams_list,
4191 : "num_teams", true)) != MATCH_NO)
4192 : {
4193 174 : if (m == MATCH_ERROR)
4194 20 : goto error;
4195 172 : gfc_expr *expr;
4196 172 : if (gfc_match ("dims ( %e ) : ", &expr) == MATCH_YES
4197 172 : && match_omp_oacc_expr_list (NULL, &c->num_teams_list,
4198 : false, true) == MATCH_YES)
4199 : {
4200 19 : int num = 0;
4201 19 : gfc_expr_list *el;
4202 55 : for (el = c->num_teams_list; el; el = el->next)
4203 36 : ++num;
4204 19 : if (!gfc_resolve_expr (expr)
4205 19 : || expr->ts.type != BT_INTEGER
4206 18 : || expr->rank != 0
4207 17 : || expr->expr_type != EXPR_CONSTANT
4208 34 : || mpz_sgn (expr->value.integer) <= 0)
4209 : {
4210 5 : gfc_error ("DIMS must be a constant positive integer "
4211 5 : "at %L", &expr->where);
4212 5 : goto error;
4213 : }
4214 14 : if (mpz_cmp_si (expr->value.integer, num) != 0)
4215 : {
4216 1 : gfc_error ("The number of arguments (%d) must be the same"
4217 : " as specified for DIMS at %L", num,
4218 : &expr->where);
4219 1 : goto error;
4220 : }
4221 13 : c->num_teams_dims = true;
4222 154 : continue;
4223 13 : }
4224 153 : else if (gfc_match ("%e ", &expr) == MATCH_YES)
4225 : {
4226 150 : c->num_teams_list = gfc_get_expr_list();
4227 150 : c->num_teams_list->expr = expr;
4228 150 : if (gfc_peek_ascii_char () == ':')
4229 : {
4230 30 : expr = NULL;
4231 30 : if (gfc_match (": %e ", &expr) == MATCH_YES)
4232 : {
4233 29 : c->num_teams_list->next = gfc_get_expr_list();
4234 29 : c->num_teams_list->next->expr = expr;
4235 29 : if (gfc_match (") ") == MATCH_YES)
4236 27 : continue;
4237 : }
4238 : }
4239 120 : else if (gfc_match (") ") == MATCH_YES)
4240 114 : continue;
4241 : }
4242 12 : gfc_error ("Expected either %<[lower-expr : ] upper-expr%> or "
4243 : "%<dims(N): expr-list%> at %C");
4244 12 : goto error;
4245 : }
4246 1659 : if ((mask & OMP_CLAUSE_NUM_THREADS)
4247 1659 : && (m = gfc_match_dupl_check (!c->num_threads_list,
4248 : "num_threads", true, NULL))
4249 : != MATCH_NO)
4250 : {
4251 1018 : int nstrict = 0, nrelaxed = 0, ndims = 0;
4252 1018 : bool fail = false;
4253 1018 : gfc_expr *dims = NULL;
4254 1018 : locus old_loc = gfc_current_locus;
4255 :
4256 1018 : if (m == MATCH_ERROR)
4257 27 : goto error;
4258 1068 : while (true)
4259 : {
4260 1042 : if (gfc_match ("strict ") == MATCH_YES)
4261 16 : nstrict++;
4262 1026 : else if (gfc_match ("relaxed ") == MATCH_YES)
4263 21 : nrelaxed++;
4264 1005 : else if (gfc_match ("dims ") == MATCH_YES)
4265 : {
4266 32 : ndims++;
4267 32 : if (dims)
4268 3 : gfc_free_expr (dims);
4269 32 : if (gfc_match ("( %e ) ", &dims) != MATCH_YES)
4270 : break;
4271 : }
4272 : else
4273 : {
4274 : fail = true;
4275 : break;
4276 : }
4277 68 : if (gfc_match (", ") == MATCH_YES)
4278 26 : continue;
4279 : break;
4280 : }
4281 1016 : if (gfc_match (" : ") == MATCH_YES)
4282 : {
4283 40 : if (nstrict + nrelaxed + ndims == 0 || fail)
4284 : {
4285 1 : gfc_error ("Expected STRICT, RELAXED or DIMS modifier at "
4286 : "%C");
4287 1 : goto error;
4288 : }
4289 39 : else if (nstrict + nrelaxed > 1)
4290 : {
4291 8 : gfc_error ("Only one STRICT or RELAXED modifier permitted"
4292 : " at %L", &old_loc);
4293 8 : goto error;
4294 : }
4295 31 : if (ndims > 1)
4296 : {
4297 3 : gfc_error ("Duplicated DIMS expression at %L",
4298 3 : &dims->where);
4299 3 : goto error;
4300 : }
4301 28 : if (nstrict || (dims && !nrelaxed))
4302 17 : c->num_threads_strict = true;
4303 : }
4304 : else
4305 : {
4306 976 : gfc_free_expr (dims);
4307 976 : dims = NULL;
4308 976 : gfc_current_locus = old_loc;
4309 : }
4310 :
4311 1004 : m = match_omp_oacc_expr_list (NULL, &c->num_threads_list, false,
4312 : true);
4313 1004 : if (m != MATCH_YES)
4314 : {
4315 7 : gfc_error ("Expected a list of integer expressions followed "
4316 : "by a %<)%> and optionally preceded by the STRICT,"
4317 : " RELAXED, or DIMS as modifiers and a colon at %C");
4318 7 : goto error;
4319 : }
4320 997 : if (dims)
4321 : {
4322 17 : int num = 0;
4323 17 : gfc_expr_list *el;
4324 46 : for (el = c->num_threads_list; el; el = el->next)
4325 29 : ++num;
4326 17 : if (!gfc_resolve_expr (dims)
4327 17 : || dims->ts.type != BT_INTEGER
4328 16 : || dims->rank != 0
4329 15 : || dims->expr_type != EXPR_CONSTANT
4330 30 : || mpz_sgn (dims->value.integer) <= 0)
4331 : {
4332 5 : gfc_error ("DIMS must be a constant positive integer "
4333 5 : "at %L", &dims->where);
4334 5 : goto error;
4335 : }
4336 12 : if (mpz_cmp_si (dims->value.integer, num) != 0)
4337 : {
4338 1 : gfc_error ("The number of arguments (%d) must be the same"
4339 : " as specified for DIMS at %L", num,
4340 : &dims->where);
4341 1 : goto error;
4342 : }
4343 11 : c->num_threads_dims = true;
4344 : }
4345 991 : continue;
4346 991 : }
4347 1240 : if ((mask & OMP_CLAUSE_NUM_WORKERS)
4348 641 : && (m = gfc_match_dupl_check (!c->num_workers_expr, "num_workers",
4349 : true, &c->num_workers_expr))
4350 : != MATCH_NO)
4351 : {
4352 603 : if (m == MATCH_ERROR)
4353 4 : goto error;
4354 599 : continue;
4355 : }
4356 : break;
4357 591 : case 'o':
4358 591 : if ((mask & OMP_CLAUSE_ORDERED)
4359 591 : && (m = gfc_match_dupl_check (!c->ordered, "ordered"))
4360 : != MATCH_NO)
4361 : {
4362 343 : if (m == MATCH_ERROR)
4363 0 : goto error;
4364 343 : gfc_expr *cexpr = NULL;
4365 343 : m = gfc_match (" ( %e )", &cexpr);
4366 :
4367 343 : c->ordered = true;
4368 343 : if (m == MATCH_YES)
4369 : {
4370 144 : int ordered = 0;
4371 144 : if (gfc_extract_int (cexpr, &ordered, -1))
4372 0 : ordered = 0;
4373 144 : else if (ordered <= 0)
4374 : {
4375 0 : gfc_error_now ("ORDERED clause argument not"
4376 : " constant positive integer at %C");
4377 0 : ordered = 0;
4378 : }
4379 144 : c->orderedc = ordered;
4380 144 : gfc_free_expr (cexpr);
4381 144 : continue;
4382 144 : }
4383 :
4384 199 : continue;
4385 199 : }
4386 482 : if ((mask & OMP_CLAUSE_ORDER)
4387 248 : && (m = gfc_match_dupl_check (!c->order_concurrent, "order", true))
4388 : != MATCH_NO)
4389 : {
4390 247 : if (m == MATCH_ERROR)
4391 10 : goto error;
4392 237 : if (gfc_match (" reproducible : concurrent )") == MATCH_YES)
4393 55 : c->order_reproducible = true;
4394 182 : else if (gfc_match (" concurrent )") == MATCH_YES)
4395 : ;
4396 50 : else if (gfc_match (" unconstrained : concurrent )") == MATCH_YES)
4397 47 : c->order_unconstrained = true;
4398 : else
4399 : {
4400 3 : gfc_error ("Expected ORDER(CONCURRENT) at %C "
4401 : "with optional %<reproducible%> or "
4402 : "%<unconstrained%> modifier");
4403 3 : goto error;
4404 : }
4405 234 : c->order_concurrent = true;
4406 234 : continue;
4407 : }
4408 : break;
4409 3101 : case 'p':
4410 3101 : if (mask & OMP_CLAUSE_PARTIAL)
4411 : {
4412 276 : if ((m = gfc_match_dupl_check (!c->partial, "partial"))
4413 : != MATCH_NO)
4414 : {
4415 276 : int expr;
4416 276 : if (m == MATCH_ERROR)
4417 0 : goto error;
4418 :
4419 276 : c->partial = -1;
4420 :
4421 276 : gfc_expr *cexpr = NULL;
4422 276 : m = gfc_match (" ( %e )", &cexpr);
4423 276 : if (m == MATCH_NO)
4424 : ;
4425 251 : else if (m == MATCH_YES
4426 251 : && !gfc_extract_int (cexpr, &expr, -1)
4427 502 : && expr > 0)
4428 247 : c->partial = expr;
4429 : else
4430 4 : gfc_error_now ("PARTIAL clause argument not constant "
4431 : "positive integer at %C");
4432 276 : gfc_free_expr (cexpr);
4433 276 : continue;
4434 276 : }
4435 : }
4436 2894 : if ((mask & OMP_CLAUSE_COPY)
4437 877 : && gfc_match ("pcopy ( ") == MATCH_YES
4438 2895 : && gfc_match_omp_map_clause (&c->lists[OMP_LIST_MAP],
4439 : OMP_MAP_TOFROM, true, allow_derived))
4440 69 : continue;
4441 2830 : if ((mask & OMP_CLAUSE_COPYIN)
4442 1910 : && gfc_match ("pcopyin ( ") == MATCH_YES
4443 2830 : && gfc_match_omp_map_clause (&c->lists[OMP_LIST_MAP],
4444 : OMP_MAP_TO, true, allow_derived))
4445 74 : continue;
4446 2755 : if ((mask & OMP_CLAUSE_COPYOUT)
4447 735 : && gfc_match ("pcopyout ( ") == MATCH_YES
4448 2755 : && gfc_match_omp_map_clause (&c->lists[OMP_LIST_MAP],
4449 : OMP_MAP_FROM, true, allow_derived))
4450 73 : continue;
4451 2624 : if ((mask & OMP_CLAUSE_CREATE)
4452 672 : && gfc_match ("pcreate ( ") == MATCH_YES
4453 2624 : && gfc_match_omp_map_clause (&c->lists[OMP_LIST_MAP],
4454 : OMP_MAP_ALLOC, true, allow_derived))
4455 15 : continue;
4456 3010 : if ((mask & OMP_CLAUSE_PRESENT)
4457 647 : && gfc_match ("present ( ") == MATCH_YES
4458 3012 : && gfc_match_omp_map_clause (&c->lists[OMP_LIST_MAP],
4459 : OMP_MAP_FORCE_PRESENT, false,
4460 : allow_derived))
4461 416 : continue;
4462 2201 : if ((mask & OMP_CLAUSE_COPY)
4463 231 : && gfc_match ("present_or_copy ( ") == MATCH_YES
4464 2201 : && gfc_match_omp_map_clause (&c->lists[OMP_LIST_MAP],
4465 : OMP_MAP_TOFROM, true,
4466 : allow_derived))
4467 23 : continue;
4468 2195 : if ((mask & OMP_CLAUSE_COPYIN)
4469 1309 : && gfc_match ("present_or_copyin ( ") == MATCH_YES
4470 2195 : && gfc_match_omp_map_clause (&c->lists[OMP_LIST_MAP],
4471 : OMP_MAP_TO, true, allow_derived))
4472 40 : continue;
4473 2150 : if ((mask & OMP_CLAUSE_COPYOUT)
4474 173 : && gfc_match ("present_or_copyout ( ") == MATCH_YES
4475 2150 : && gfc_match_omp_map_clause (&c->lists[OMP_LIST_MAP],
4476 : OMP_MAP_FROM, true, allow_derived))
4477 35 : continue;
4478 2108 : if ((mask & OMP_CLAUSE_CREATE)
4479 143 : && gfc_match ("present_or_create ( ") == MATCH_YES
4480 2108 : && gfc_match_omp_map_clause (&c->lists[OMP_LIST_MAP],
4481 : OMP_MAP_ALLOC, true, allow_derived))
4482 28 : continue;
4483 2086 : if ((mask & OMP_CLAUSE_PRIORITY)
4484 2052 : && (m = gfc_match_dupl_check (!c->priority, "priority", true,
4485 : &c->priority)) != MATCH_NO)
4486 : {
4487 34 : if (m == MATCH_ERROR)
4488 0 : goto error;
4489 34 : continue;
4490 : }
4491 3959 : if ((mask & OMP_CLAUSE_PRIVATE)
4492 2018 : && gfc_match_omp_variable_list ("private (",
4493 : &c->lists[OMP_LIST_PRIVATE],
4494 : true) == MATCH_YES)
4495 1941 : continue;
4496 141 : if ((mask & OMP_CLAUSE_PROC_BIND)
4497 141 : && (m = gfc_match_dupl_check ((c->proc_bind
4498 64 : == OMP_PROC_BIND_UNKNOWN),
4499 : "proc_bind", true)) != MATCH_NO)
4500 : {
4501 64 : if (m == MATCH_ERROR)
4502 0 : goto error;
4503 64 : if (gfc_match ("primary )") == MATCH_YES)
4504 1 : c->proc_bind = OMP_PROC_BIND_PRIMARY;
4505 63 : else if (gfc_match ("master )") == MATCH_YES)
4506 : {
4507 9 : gfc_warning (OPT_Wdeprecated_openmp,
4508 : "%<master%> affinity policy at %C deprecated "
4509 : "since OpenMP 5.1, use %<primary%>");
4510 9 : c->proc_bind = OMP_PROC_BIND_MASTER;
4511 : }
4512 54 : else if (gfc_match ("spread )") == MATCH_YES)
4513 53 : c->proc_bind = OMP_PROC_BIND_SPREAD;
4514 1 : else if (gfc_match ("close )") == MATCH_YES)
4515 1 : c->proc_bind = OMP_PROC_BIND_CLOSE;
4516 : else
4517 0 : goto error;
4518 64 : continue;
4519 : }
4520 : break;
4521 4583 : case 'r':
4522 5073 : if ((mask & OMP_CLAUSE_ATOMIC)
4523 4583 : && (m = gfc_match_dupl_atomic ((c->atomic_op
4524 : == GFC_OMP_ATOMIC_UNSET),
4525 : "read")) != MATCH_NO)
4526 : {
4527 490 : if (m == MATCH_ERROR)
4528 0 : goto error;
4529 490 : c->atomic_op = GFC_OMP_ATOMIC_READ;
4530 490 : continue;
4531 : }
4532 8149 : if ((mask & OMP_CLAUSE_REDUCTION)
4533 4093 : && gfc_match_omp_clause_reduction (pc, c, openacc,
4534 : allow_derived) == MATCH_YES)
4535 4056 : continue;
4536 47 : if ((mask & OMP_CLAUSE_MEMORDER)
4537 65 : && (m = gfc_match_dupl_memorder ((c->memorder
4538 28 : == OMP_MEMORDER_UNSET),
4539 : "relaxed")) != MATCH_NO)
4540 : {
4541 10 : if (m == MATCH_ERROR)
4542 0 : goto error;
4543 10 : c->memorder = OMP_MEMORDER_RELAXED;
4544 10 : continue;
4545 : }
4546 44 : if ((mask & OMP_CLAUSE_MEMORDER)
4547 45 : && (m = gfc_match_dupl_memorder ((c->memorder
4548 18 : == OMP_MEMORDER_UNSET),
4549 : "release")) != MATCH_NO)
4550 : {
4551 18 : if (m == MATCH_ERROR)
4552 1 : goto error;
4553 17 : c->memorder = OMP_MEMORDER_RELEASE;
4554 17 : continue;
4555 : }
4556 : break;
4557 3048 : case 's':
4558 3141 : if ((mask & OMP_CLAUSE_SAFELEN)
4559 3048 : && (m = gfc_match_dupl_check (!c->safelen_expr, "safelen",
4560 : true, &c->safelen_expr))
4561 : != MATCH_NO)
4562 : {
4563 93 : if (m == MATCH_ERROR)
4564 0 : goto error;
4565 93 : continue;
4566 : }
4567 2955 : if ((mask & OMP_CLAUSE_SCHEDULE)
4568 2955 : && (m = gfc_match_dupl_check (c->sched_kind == OMP_SCHED_NONE,
4569 : "schedule", true)) != MATCH_NO)
4570 : {
4571 809 : if (m == MATCH_ERROR)
4572 0 : goto error;
4573 809 : int nmodifiers = 0;
4574 809 : locus old_loc2 = gfc_current_locus;
4575 827 : do
4576 : {
4577 818 : if (gfc_match ("simd") == MATCH_YES)
4578 : {
4579 18 : c->sched_simd = true;
4580 18 : nmodifiers++;
4581 : }
4582 800 : else if (gfc_match ("monotonic") == MATCH_YES)
4583 : {
4584 30 : c->sched_monotonic = true;
4585 30 : nmodifiers++;
4586 : }
4587 770 : else if (gfc_match ("nonmonotonic") == MATCH_YES)
4588 : {
4589 35 : c->sched_nonmonotonic = true;
4590 35 : nmodifiers++;
4591 : }
4592 : else
4593 : {
4594 735 : if (nmodifiers)
4595 0 : gfc_current_locus = old_loc2;
4596 : break;
4597 : }
4598 92 : if (nmodifiers == 1
4599 83 : && gfc_match (" , ") == MATCH_YES)
4600 9 : continue;
4601 74 : else if (gfc_match (" : ") == MATCH_YES)
4602 : break;
4603 0 : gfc_current_locus = old_loc2;
4604 0 : break;
4605 : }
4606 : while (1);
4607 809 : if (gfc_match ("static") == MATCH_YES)
4608 425 : c->sched_kind = OMP_SCHED_STATIC;
4609 384 : else if (gfc_match ("dynamic") == MATCH_YES)
4610 164 : c->sched_kind = OMP_SCHED_DYNAMIC;
4611 220 : else if (gfc_match ("guided") == MATCH_YES)
4612 127 : c->sched_kind = OMP_SCHED_GUIDED;
4613 93 : else if (gfc_match ("runtime") == MATCH_YES)
4614 85 : c->sched_kind = OMP_SCHED_RUNTIME;
4615 8 : else if (gfc_match ("auto") == MATCH_YES)
4616 8 : c->sched_kind = OMP_SCHED_AUTO;
4617 809 : if (c->sched_kind != OMP_SCHED_NONE)
4618 : {
4619 809 : m = MATCH_NO;
4620 809 : if (c->sched_kind != OMP_SCHED_RUNTIME
4621 724 : && c->sched_kind != OMP_SCHED_AUTO)
4622 716 : m = gfc_match (" , %e )", &c->chunk_size);
4623 716 : if (m != MATCH_YES)
4624 299 : m = gfc_match_char (')');
4625 299 : if (m != MATCH_YES)
4626 0 : c->sched_kind = OMP_SCHED_NONE;
4627 : }
4628 809 : if (c->sched_kind != OMP_SCHED_NONE)
4629 809 : continue;
4630 : else
4631 0 : gfc_current_locus = old_loc;
4632 : }
4633 2329 : if ((mask & OMP_CLAUSE_SELF)
4634 335 : && !(mask & OMP_CLAUSE_HOST) /* OpenACC compute construct */
4635 2386 : && (m = gfc_match_dupl_check (!c->self_expr, "self"))
4636 : != MATCH_NO)
4637 : {
4638 186 : if (m == MATCH_ERROR)
4639 3 : goto error;
4640 183 : m = gfc_match (" ( %e )", &c->self_expr);
4641 183 : if (m == MATCH_ERROR)
4642 : {
4643 0 : gfc_current_locus = old_loc;
4644 0 : break;
4645 : }
4646 183 : else if (m == MATCH_NO)
4647 9 : c->self_expr = gfc_get_logical_expr (gfc_default_logical_kind,
4648 : NULL, true);
4649 183 : continue;
4650 : }
4651 2054 : if ((mask & OMP_CLAUSE_SELF)
4652 149 : && (mask & OMP_CLAUSE_HOST) /* OpenACC 'update' directive */
4653 95 : && gfc_match ("self ( ") == MATCH_YES
4654 2055 : && gfc_match_omp_map_clause (&c->lists[OMP_LIST_MAP],
4655 : OMP_MAP_FORCE_FROM, true,
4656 : /* allow_derived = */ true))
4657 94 : continue;
4658 2214 : if ((mask & OMP_CLAUSE_SEQ)
4659 1866 : && (m = gfc_match_dupl_check (!c->seq, "seq")) != MATCH_NO)
4660 : {
4661 348 : if (m == MATCH_ERROR)
4662 0 : goto error;
4663 348 : c->seq = true;
4664 348 : continue;
4665 : }
4666 1659 : if ((mask & OMP_CLAUSE_MEMORDER)
4667 1659 : && (m = gfc_match_dupl_memorder ((c->memorder
4668 141 : == OMP_MEMORDER_UNSET),
4669 : "seq_cst")) != MATCH_NO)
4670 : {
4671 141 : if (m == MATCH_ERROR)
4672 0 : goto error;
4673 141 : c->memorder = OMP_MEMORDER_SEQ_CST;
4674 141 : continue;
4675 : }
4676 2352 : if ((mask & OMP_CLAUSE_SHARED)
4677 1377 : && gfc_match_omp_variable_list ("shared (",
4678 : &c->lists[OMP_LIST_SHARED],
4679 : true) == MATCH_YES)
4680 975 : continue;
4681 520 : if ((mask & OMP_CLAUSE_SIMDLEN)
4682 402 : && (m = gfc_match_dupl_check (!c->simdlen_expr, "simdlen", true,
4683 : &c->simdlen_expr)) != MATCH_NO)
4684 : {
4685 118 : if (m == MATCH_ERROR)
4686 0 : goto error;
4687 118 : continue;
4688 : }
4689 306 : if ((mask & OMP_CLAUSE_SIMD)
4690 284 : && (m = gfc_match_dupl_check (!c->simd, "simd")) != MATCH_NO)
4691 : {
4692 22 : if (m == MATCH_ERROR)
4693 0 : goto error;
4694 22 : c->simd = true;
4695 22 : continue;
4696 : }
4697 313 : if ((mask & OMP_CLAUSE_SEVERITY)
4698 262 : && (m = gfc_match_dupl_check (!c->severity, "severity", true))
4699 : != MATCH_NO)
4700 : {
4701 57 : if (m == MATCH_ERROR)
4702 2 : goto error;
4703 55 : if (gfc_match ("fatal )") == MATCH_YES)
4704 15 : c->severity = OMP_SEVERITY_FATAL;
4705 40 : else if (gfc_match ("warning )") == MATCH_YES)
4706 36 : c->severity = OMP_SEVERITY_WARNING;
4707 : else
4708 : {
4709 4 : gfc_error ("Expected FATAL or WARNING in SEVERITY clause "
4710 : "at %C");
4711 4 : goto error;
4712 : }
4713 51 : continue;
4714 : }
4715 205 : if ((mask & OMP_CLAUSE_SIZES)
4716 205 : && ((m = gfc_match_dupl_check (!c->sizes_list, "sizes"))
4717 : != MATCH_NO))
4718 : {
4719 203 : if (m == MATCH_ERROR)
4720 0 : goto error;
4721 203 : m = match_omp_oacc_expr_list (" (", &c->sizes_list, false, true);
4722 203 : if (m == MATCH_ERROR)
4723 7 : goto error;
4724 196 : if (m == MATCH_YES)
4725 195 : continue;
4726 1 : gfc_error ("Expected %<(%> after %qs at %C", "sizes");
4727 1 : goto error;
4728 : }
4729 : break;
4730 1281 : case 't':
4731 1346 : if ((mask & OMP_CLAUSE_TASK_REDUCTION)
4732 1281 : && gfc_match_omp_clause_reduction (pc, c, openacc,
4733 : allow_derived) == MATCH_YES)
4734 65 : continue;
4735 1216 : if ((mask & OMP_CLAUSE_THREAD_LIMIT)
4736 1216 : && (m = gfc_match_dupl_check (!c->thread_limit_list, "thread_limit",
4737 : true, NULL)) != MATCH_NO)
4738 : {
4739 131 : int nstrict = 0, nrelaxed = 0, ndims = 0;
4740 131 : bool fail = false;
4741 131 : gfc_expr *dims = NULL;
4742 131 : locus old_loc = gfc_current_locus;
4743 :
4744 131 : if (m == MATCH_ERROR)
4745 28 : goto error;
4746 177 : while (true)
4747 : {
4748 153 : if (gfc_match ("strict ") == MATCH_YES)
4749 15 : nstrict++;
4750 138 : else if (gfc_match ("relaxed ") == MATCH_YES)
4751 25 : nrelaxed++;
4752 113 : else if (gfc_match ("dims ") == MATCH_YES)
4753 : {
4754 31 : ndims++;
4755 31 : if (dims)
4756 3 : gfc_free_expr (dims);
4757 31 : if (gfc_match ("( %e ) ", &dims) != MATCH_YES)
4758 : break;
4759 : }
4760 : else
4761 : {
4762 : fail = true;
4763 : break;
4764 : }
4765 70 : if (gfc_match (", ") == MATCH_YES)
4766 24 : continue;
4767 : break;
4768 : }
4769 129 : if (gfc_match (" : ") == MATCH_YES)
4770 : {
4771 44 : if (nstrict + nrelaxed + ndims == 0 || fail)
4772 : {
4773 1 : gfc_error ("Expected STRICT, RELAXED or DIMS modifier at "
4774 : "%C");
4775 1 : goto error;
4776 : }
4777 43 : else if (nstrict + nrelaxed > 1)
4778 : {
4779 8 : gfc_error ("Only one STRICT or RELAXED modifier permitted"
4780 : " at %L", &old_loc);
4781 8 : goto error;
4782 : }
4783 35 : if (ndims > 1)
4784 : {
4785 3 : gfc_error ("Duplicated DIMS expression at %L",
4786 3 : &dims->where);
4787 3 : goto error;
4788 : }
4789 : }
4790 : else
4791 : {
4792 85 : gfc_free_expr (dims);
4793 85 : dims = NULL;
4794 85 : gfc_current_locus = old_loc;
4795 : }
4796 :
4797 117 : m = match_omp_oacc_expr_list (NULL, &c->thread_limit_list,
4798 : false, true);
4799 117 : if (m != MATCH_YES)
4800 : {
4801 7 : gfc_error ("Expected a list of integer expressions followed "
4802 : "by a %<)%> and optionally preceded by the STRICT,"
4803 : " RELAXED, or DIMS as modifiers and a colon at %C");
4804 7 : goto error;
4805 : }
4806 110 : c->thread_limit_strict = (nstrict != 0) || (dims && !nrelaxed);
4807 :
4808 110 : if (!dims && c->thread_limit_list->next)
4809 : {
4810 1 : gfc_error ("Without the DIM modifier, only a single integer "
4811 : "expression may be specified at %L",
4812 1 : &c->thread_limit_list->next->expr->where);
4813 1 : goto error;
4814 : }
4815 109 : else if (dims)
4816 : {
4817 16 : int num = 0;
4818 16 : gfc_expr_list *el;
4819 53 : for (el = c->thread_limit_list; el; el = el->next)
4820 37 : ++num;
4821 16 : if (!gfc_resolve_expr (dims)
4822 16 : || dims->ts.type != BT_INTEGER
4823 15 : || dims->rank != 0
4824 14 : || dims->expr_type != EXPR_CONSTANT
4825 28 : || mpz_sgn (dims->value.integer) <= 0)
4826 : {
4827 5 : gfc_error ("DIMS must be a constant positive integer "
4828 5 : "at %L", &dims->where);
4829 5 : goto error;
4830 : }
4831 11 : if (mpz_cmp_si (dims->value.integer, num) != 0)
4832 : {
4833 1 : gfc_error ("The number of arguments (%d) must be the same"
4834 : " as specified for DIMS at %L", num,
4835 : &dims->where);
4836 1 : goto error;
4837 : }
4838 10 : c->thread_limit_dims = true;
4839 : }
4840 103 : continue;
4841 103 : }
4842 1098 : if ((mask & OMP_CLAUSE_THREADS)
4843 1085 : && (m = gfc_match_dupl_check (!c->threads, "threads"))
4844 : != MATCH_NO)
4845 : {
4846 13 : if (m == MATCH_ERROR)
4847 0 : goto error;
4848 13 : c->threads = true;
4849 13 : continue;
4850 : }
4851 1269 : if ((mask & OMP_CLAUSE_TILE)
4852 221 : && !c->tile_list
4853 1293 : && match_omp_oacc_expr_list ("tile (", &c->tile_list,
4854 : true, false) == MATCH_YES)
4855 197 : continue;
4856 875 : if ((mask & OMP_CLAUSE_TO) && (mask & OMP_CLAUSE_LINK))
4857 : {
4858 : /* Declare target: 'to' is an alias for 'enter';
4859 : 'to' is deprecated since 5.2. */
4860 116 : m = gfc_match_omp_to_link ("to (", &c->lists[OMP_LIST_TO]);
4861 116 : if (m == MATCH_ERROR)
4862 0 : goto error;
4863 116 : if (m == MATCH_YES)
4864 : {
4865 116 : gfc_warning (OPT_Wdeprecated_openmp,
4866 : "%<to%> clause with %<declare target%> at %L "
4867 : "deprecated since OpenMP 5.2, use %<enter%>",
4868 : &old_loc);
4869 116 : continue;
4870 : }
4871 : }
4872 1487 : else if ((mask & OMP_CLAUSE_TO)
4873 759 : && gfc_match_motion_var_list ("to (", &c->lists[OMP_LIST_TO],
4874 : &head) == MATCH_YES)
4875 728 : continue;
4876 : break;
4877 1538 : case 'u':
4878 1596 : if ((mask & OMP_CLAUSE_UNIFORM)
4879 1538 : && gfc_match_omp_variable_list ("uniform (",
4880 : &c->lists[OMP_LIST_UNIFORM],
4881 : false) == MATCH_YES)
4882 58 : continue;
4883 1621 : if ((mask & OMP_CLAUSE_UNTIED)
4884 1480 : && (m = gfc_match_dupl_check (!c->untied, "untied")) != MATCH_NO)
4885 : {
4886 141 : if (m == MATCH_ERROR)
4887 0 : goto error;
4888 141 : c->untied = true;
4889 141 : continue;
4890 : }
4891 1583 : if ((mask & OMP_CLAUSE_ATOMIC)
4892 1339 : && (m = gfc_match_dupl_atomic ((c->atomic_op
4893 : == GFC_OMP_ATOMIC_UNSET),
4894 : "update")) != MATCH_NO)
4895 : {
4896 245 : if (m == MATCH_ERROR)
4897 1 : goto error;
4898 244 : c->atomic_op = GFC_OMP_ATOMIC_UPDATE;
4899 244 : continue;
4900 : }
4901 1116 : if ((mask & OMP_CLAUSE_USE)
4902 1094 : && gfc_match_omp_variable_list ("use (",
4903 : &c->lists[OMP_LIST_USE],
4904 : true) == MATCH_YES)
4905 22 : continue;
4906 1132 : if ((mask & OMP_CLAUSE_USE_DEVICE)
4907 1072 : && gfc_match_omp_variable_list ("use_device (",
4908 : &c->lists[OMP_LIST_USE_DEVICE],
4909 : true) == MATCH_YES)
4910 60 : continue;
4911 1175 : if ((mask & OMP_CLAUSE_USE_DEVICE_PTR)
4912 1940 : && gfc_match_omp_variable_list
4913 928 : ("use_device_ptr (",
4914 : &c->lists[OMP_LIST_USE_DEVICE_PTR], false) == MATCH_YES)
4915 163 : continue;
4916 1614 : if ((mask & OMP_CLAUSE_USE_DEVICE_ADDR)
4917 1614 : && gfc_match_omp_variable_list
4918 765 : ("use_device_addr (", &c->lists[OMP_LIST_USE_DEVICE_ADDR],
4919 : false, NULL, NULL, true) == MATCH_YES)
4920 765 : continue;
4921 153 : if ((mask & OMP_CLAUSE_USES_ALLOCATORS)
4922 84 : && (gfc_match ("uses_allocators ( ") == MATCH_YES))
4923 : {
4924 78 : if (gfc_match_omp_clause_uses_allocators (c) != MATCH_YES)
4925 9 : goto error;
4926 69 : continue;
4927 : }
4928 : break;
4929 1570 : case 'v':
4930 : /* VECTOR_LENGTH must be matched before VECTOR, because the latter
4931 : doesn't unconditionally match '('. */
4932 2139 : if ((mask & OMP_CLAUSE_VECTOR_LENGTH)
4933 1570 : && (m = gfc_match_dupl_check (!c->vector_length_expr,
4934 : "vector_length", true,
4935 : &c->vector_length_expr))
4936 : != MATCH_NO)
4937 : {
4938 573 : if (m == MATCH_ERROR)
4939 4 : goto error;
4940 569 : continue;
4941 : }
4942 1989 : if ((mask & OMP_CLAUSE_VECTOR)
4943 997 : && (m = gfc_match_dupl_check (!c->vector, "vector")) != MATCH_NO)
4944 : {
4945 995 : if (m == MATCH_ERROR)
4946 0 : goto error;
4947 995 : c->vector = true;
4948 995 : m = match_oacc_clause_gwv (c, GOMP_DIM_VECTOR);
4949 995 : if (m == MATCH_ERROR)
4950 3 : goto error;
4951 992 : continue;
4952 : }
4953 : break;
4954 1485 : case 'w':
4955 1485 : if ((mask & OMP_CLAUSE_WAIT)
4956 1485 : && gfc_match ("wait") == MATCH_YES)
4957 : {
4958 192 : m = match_omp_oacc_expr_list (" (", &c->wait_list, false, false);
4959 192 : if (m == MATCH_ERROR)
4960 9 : goto error;
4961 183 : else if (m == MATCH_NO)
4962 : {
4963 47 : gfc_expr *expr
4964 47 : = gfc_get_constant_expr (BT_INTEGER,
4965 : gfc_default_integer_kind,
4966 : &gfc_current_locus);
4967 47 : mpz_set_si (expr->value.integer, GOMP_ASYNC_NOVAL);
4968 47 : gfc_expr_list **expr_list = &c->wait_list;
4969 56 : while (*expr_list)
4970 9 : expr_list = &(*expr_list)->next;
4971 47 : *expr_list = gfc_get_expr_list ();
4972 47 : (*expr_list)->expr = expr;
4973 47 : needs_space = true;
4974 : }
4975 183 : continue;
4976 183 : }
4977 1306 : if ((mask & OMP_CLAUSE_WEAK)
4978 1293 : && (m = gfc_match_dupl_check (!c->weak, "weak"))
4979 : != MATCH_NO)
4980 : {
4981 14 : if (m == MATCH_ERROR)
4982 1 : goto error;
4983 13 : c->weak = true;
4984 13 : continue;
4985 : }
4986 2140 : if ((mask & OMP_CLAUSE_WORKER)
4987 1279 : && (m = gfc_match_dupl_check (!c->worker, "worker")) != MATCH_NO)
4988 : {
4989 864 : if (m == MATCH_ERROR)
4990 0 : goto error;
4991 864 : c->worker = true;
4992 864 : m = match_oacc_clause_gwv (c, GOMP_DIM_WORKER);
4993 864 : if (m == MATCH_ERROR)
4994 3 : goto error;
4995 861 : continue;
4996 : }
4997 827 : if ((mask & OMP_CLAUSE_ATOMIC)
4998 415 : && (m = gfc_match_dupl_atomic ((c->atomic_op
4999 : == GFC_OMP_ATOMIC_UNSET),
5000 : "write")) != MATCH_NO)
5001 : {
5002 412 : if (m == MATCH_ERROR)
5003 0 : goto error;
5004 412 : c->atomic_op = GFC_OMP_ATOMIC_WRITE;
5005 412 : continue;
5006 : }
5007 : break;
5008 : }
5009 : break;
5010 46892 : }
5011 :
5012 35078 : end:
5013 34739 : if (error || gfc_match_omp_eos () != MATCH_YES)
5014 : {
5015 636 : if (!gfc_error_flag_test ())
5016 149 : gfc_error ("Failed to match clause at %C");
5017 636 : gfc_free_omp_clauses (c);
5018 636 : return MATCH_ERROR;
5019 : }
5020 :
5021 34442 : *cp = c;
5022 34442 : return MATCH_YES;
5023 :
5024 339 : error:
5025 339 : error = true;
5026 339 : goto end;
5027 : }
5028 :
5029 :
5030 : #define OACC_PARALLEL_CLAUSES \
5031 : (omp_mask (OMP_CLAUSE_IF) | OMP_CLAUSE_ASYNC | OMP_CLAUSE_NUM_GANGS \
5032 : | OMP_CLAUSE_NUM_WORKERS | OMP_CLAUSE_VECTOR_LENGTH | OMP_CLAUSE_REDUCTION \
5033 : | OMP_CLAUSE_COPY | OMP_CLAUSE_COPYIN | OMP_CLAUSE_COPYOUT \
5034 : | OMP_CLAUSE_CREATE | OMP_CLAUSE_NO_CREATE | OMP_CLAUSE_PRESENT \
5035 : | OMP_CLAUSE_DEVICEPTR | OMP_CLAUSE_PRIVATE | OMP_CLAUSE_FIRSTPRIVATE \
5036 : | OMP_CLAUSE_DEFAULT | OMP_CLAUSE_WAIT | OMP_CLAUSE_ATTACH \
5037 : | OMP_CLAUSE_SELF)
5038 : #define OACC_KERNELS_CLAUSES \
5039 : (omp_mask (OMP_CLAUSE_IF) | OMP_CLAUSE_ASYNC | OMP_CLAUSE_NUM_GANGS \
5040 : | OMP_CLAUSE_NUM_WORKERS | OMP_CLAUSE_VECTOR_LENGTH | OMP_CLAUSE_DEVICEPTR \
5041 : | OMP_CLAUSE_COPY | OMP_CLAUSE_COPYIN | OMP_CLAUSE_COPYOUT \
5042 : | OMP_CLAUSE_CREATE | OMP_CLAUSE_NO_CREATE | OMP_CLAUSE_PRESENT \
5043 : | OMP_CLAUSE_DEFAULT | OMP_CLAUSE_WAIT | OMP_CLAUSE_ATTACH \
5044 : | OMP_CLAUSE_SELF)
5045 : #define OACC_SERIAL_CLAUSES \
5046 : (omp_mask (OMP_CLAUSE_IF) | OMP_CLAUSE_ASYNC | OMP_CLAUSE_REDUCTION \
5047 : | OMP_CLAUSE_COPY | OMP_CLAUSE_COPYIN | OMP_CLAUSE_COPYOUT \
5048 : | OMP_CLAUSE_CREATE | OMP_CLAUSE_NO_CREATE | OMP_CLAUSE_PRESENT \
5049 : | OMP_CLAUSE_DEVICEPTR | OMP_CLAUSE_PRIVATE | OMP_CLAUSE_FIRSTPRIVATE \
5050 : | OMP_CLAUSE_DEFAULT | OMP_CLAUSE_WAIT | OMP_CLAUSE_ATTACH \
5051 : | OMP_CLAUSE_SELF)
5052 : #define OACC_DATA_CLAUSES \
5053 : (omp_mask (OMP_CLAUSE_IF) | OMP_CLAUSE_DEVICEPTR | OMP_CLAUSE_COPY \
5054 : | OMP_CLAUSE_COPYIN | OMP_CLAUSE_COPYOUT | OMP_CLAUSE_CREATE \
5055 : | OMP_CLAUSE_NO_CREATE | OMP_CLAUSE_PRESENT | OMP_CLAUSE_ATTACH \
5056 : | OMP_CLAUSE_DEFAULT)
5057 : #define OACC_LOOP_CLAUSES \
5058 : (omp_mask (OMP_CLAUSE_COLLAPSE) | OMP_CLAUSE_GANG | OMP_CLAUSE_WORKER \
5059 : | OMP_CLAUSE_VECTOR | OMP_CLAUSE_SEQ | OMP_CLAUSE_INDEPENDENT \
5060 : | OMP_CLAUSE_PRIVATE | OMP_CLAUSE_REDUCTION | OMP_CLAUSE_AUTO \
5061 : | OMP_CLAUSE_TILE)
5062 : #define OACC_PARALLEL_LOOP_CLAUSES \
5063 : (OACC_LOOP_CLAUSES | OACC_PARALLEL_CLAUSES)
5064 : #define OACC_KERNELS_LOOP_CLAUSES \
5065 : (OACC_LOOP_CLAUSES | OACC_KERNELS_CLAUSES)
5066 : #define OACC_SERIAL_LOOP_CLAUSES \
5067 : (OACC_LOOP_CLAUSES | OACC_SERIAL_CLAUSES)
5068 : #define OACC_HOST_DATA_CLAUSES \
5069 : (omp_mask (OMP_CLAUSE_USE_DEVICE) \
5070 : | OMP_CLAUSE_IF \
5071 : | OMP_CLAUSE_IF_PRESENT)
5072 : #define OACC_DECLARE_CLAUSES \
5073 : (omp_mask (OMP_CLAUSE_COPY) | OMP_CLAUSE_COPYIN | OMP_CLAUSE_COPYOUT \
5074 : | OMP_CLAUSE_CREATE | OMP_CLAUSE_DEVICEPTR | OMP_CLAUSE_DEVICE_RESIDENT \
5075 : | OMP_CLAUSE_PRESENT \
5076 : | OMP_CLAUSE_LINK)
5077 : #define OACC_UPDATE_CLAUSES \
5078 : (omp_mask (OMP_CLAUSE_IF) | OMP_CLAUSE_ASYNC | OMP_CLAUSE_HOST \
5079 : | OMP_CLAUSE_DEVICE | OMP_CLAUSE_WAIT | OMP_CLAUSE_IF_PRESENT \
5080 : | OMP_CLAUSE_SELF)
5081 : #define OACC_ENTER_DATA_CLAUSES \
5082 : (omp_mask (OMP_CLAUSE_IF) | OMP_CLAUSE_ASYNC | OMP_CLAUSE_WAIT \
5083 : | OMP_CLAUSE_COPYIN | OMP_CLAUSE_CREATE | OMP_CLAUSE_ATTACH)
5084 : #define OACC_EXIT_DATA_CLAUSES \
5085 : (omp_mask (OMP_CLAUSE_IF) | OMP_CLAUSE_ASYNC | OMP_CLAUSE_WAIT \
5086 : | OMP_CLAUSE_COPYOUT | OMP_CLAUSE_DELETE | OMP_CLAUSE_FINALIZE \
5087 : | OMP_CLAUSE_DETACH)
5088 : #define OACC_WAIT_CLAUSES \
5089 : omp_mask (OMP_CLAUSE_ASYNC) | OMP_CLAUSE_IF
5090 : #define OACC_ROUTINE_CLAUSES \
5091 : (omp_mask (OMP_CLAUSE_GANG) | OMP_CLAUSE_WORKER | OMP_CLAUSE_VECTOR \
5092 : | OMP_CLAUSE_SEQ \
5093 : | OMP_CLAUSE_NOHOST)
5094 : #define OACC_INIT_CLAUSES \
5095 : (omp_mask (OMP_CLAUSE_IF) | OMP_CLAUSE_DEVICE_NUM | OMP_CLAUSE_DEVICE_TYPE)
5096 : #define OACC_SHUTDOWN_CLAUSES \
5097 : (omp_mask (OMP_CLAUSE_IF) | OMP_CLAUSE_DEVICE_NUM | OMP_CLAUSE_DEVICE_TYPE)
5098 : #define OACC_SET_CLAUSES \
5099 : (omp_mask (OMP_CLAUSE_IF) | OMP_CLAUSE_DEVICE_NUM | OMP_CLAUSE_DEVICE_TYPE)
5100 :
5101 :
5102 : static match
5103 12198 : match_acc (gfc_exec_op op, const omp_mask mask)
5104 : {
5105 12198 : gfc_omp_clauses *c;
5106 12198 : if (gfc_match_omp_clauses (&c, mask, false, false, true) != MATCH_YES)
5107 : return MATCH_ERROR;
5108 11969 : new_st.op = op;
5109 11969 : new_st.ext.omp_clauses = c;
5110 11969 : return MATCH_YES;
5111 : }
5112 :
5113 : match
5114 1378 : gfc_match_oacc_parallel_loop (void)
5115 : {
5116 1378 : return match_acc (EXEC_OACC_PARALLEL_LOOP, OACC_PARALLEL_LOOP_CLAUSES);
5117 : }
5118 :
5119 :
5120 : match
5121 2974 : gfc_match_oacc_parallel (void)
5122 : {
5123 2974 : return match_acc (EXEC_OACC_PARALLEL, OACC_PARALLEL_CLAUSES);
5124 : }
5125 :
5126 :
5127 : match
5128 129 : gfc_match_oacc_kernels_loop (void)
5129 : {
5130 129 : return match_acc (EXEC_OACC_KERNELS_LOOP, OACC_KERNELS_LOOP_CLAUSES);
5131 : }
5132 :
5133 :
5134 : match
5135 906 : gfc_match_oacc_kernels (void)
5136 : {
5137 906 : return match_acc (EXEC_OACC_KERNELS, OACC_KERNELS_CLAUSES);
5138 : }
5139 :
5140 :
5141 : match
5142 230 : gfc_match_oacc_serial_loop (void)
5143 : {
5144 230 : return match_acc (EXEC_OACC_SERIAL_LOOP, OACC_SERIAL_LOOP_CLAUSES);
5145 : }
5146 :
5147 :
5148 : match
5149 359 : gfc_match_oacc_serial (void)
5150 : {
5151 359 : return match_acc (EXEC_OACC_SERIAL, OACC_SERIAL_CLAUSES);
5152 : }
5153 :
5154 :
5155 : match
5156 689 : gfc_match_oacc_data (void)
5157 : {
5158 689 : return match_acc (EXEC_OACC_DATA, OACC_DATA_CLAUSES);
5159 : }
5160 :
5161 :
5162 : match
5163 65 : gfc_match_oacc_host_data (void)
5164 : {
5165 65 : return match_acc (EXEC_OACC_HOST_DATA, OACC_HOST_DATA_CLAUSES);
5166 : }
5167 :
5168 :
5169 : match
5170 3585 : gfc_match_oacc_loop (void)
5171 : {
5172 3585 : return match_acc (EXEC_OACC_LOOP, OACC_LOOP_CLAUSES);
5173 : }
5174 :
5175 :
5176 : match
5177 178 : gfc_match_oacc_declare (void)
5178 : {
5179 178 : gfc_omp_clauses *c;
5180 178 : gfc_omp_namelist *n;
5181 178 : gfc_namespace *ns = gfc_current_ns;
5182 178 : gfc_oacc_declare *new_oc;
5183 178 : bool module_var = false;
5184 178 : locus where = gfc_current_locus;
5185 :
5186 178 : if (gfc_match_omp_clauses (&c, OACC_DECLARE_CLAUSES, false, false, true)
5187 : != MATCH_YES)
5188 : return MATCH_ERROR;
5189 :
5190 262 : for (n = c->lists[OMP_LIST_DEVICE_RESIDENT]; n != NULL; n = n->next)
5191 90 : n->sym->attr.oacc_declare_device_resident = 1;
5192 :
5193 192 : for (n = c->lists[OMP_LIST_LINK]; n != NULL; n = n->next)
5194 20 : n->sym->attr.oacc_declare_link = 1;
5195 :
5196 318 : for (n = c->lists[OMP_LIST_MAP]; n != NULL; n = n->next)
5197 : {
5198 156 : gfc_symbol *s = n->sym;
5199 :
5200 156 : if (gfc_current_ns->proc_name
5201 156 : && gfc_current_ns->proc_name->attr.flavor == FL_MODULE)
5202 : {
5203 52 : if (n->u.map.op != OMP_MAP_ALLOC && n->u.map.op != OMP_MAP_TO)
5204 : {
5205 6 : gfc_error ("Invalid clause in module with !$ACC DECLARE at %L",
5206 : &where);
5207 6 : return MATCH_ERROR;
5208 : }
5209 :
5210 : module_var = true;
5211 : }
5212 :
5213 150 : if (s->attr.use_assoc)
5214 : {
5215 0 : gfc_error ("Variable is USE-associated with !$ACC DECLARE at %L",
5216 : &where);
5217 0 : return MATCH_ERROR;
5218 : }
5219 :
5220 150 : if ((s->result == s && s->ns->contained != gfc_current_ns)
5221 150 : || ((s->attr.flavor == FL_UNKNOWN || s->attr.flavor == FL_VARIABLE)
5222 135 : && s->ns != gfc_current_ns))
5223 : {
5224 2 : gfc_error ("Variable %qs shall be declared in the same scoping unit "
5225 : "as !$ACC DECLARE at %L", s->name, &where);
5226 2 : return MATCH_ERROR;
5227 : }
5228 :
5229 148 : if ((s->attr.dimension || s->attr.codimension)
5230 76 : && s->attr.dummy && s->as->type != AS_EXPLICIT)
5231 : {
5232 2 : gfc_error ("Assumed-size dummy array with !$ACC DECLARE at %L",
5233 : &where);
5234 2 : return MATCH_ERROR;
5235 : }
5236 :
5237 146 : switch (n->u.map.op)
5238 : {
5239 49 : case OMP_MAP_FORCE_ALLOC:
5240 49 : case OMP_MAP_ALLOC:
5241 49 : s->attr.oacc_declare_create = 1;
5242 49 : break;
5243 :
5244 63 : case OMP_MAP_FORCE_TO:
5245 63 : case OMP_MAP_TO:
5246 63 : s->attr.oacc_declare_copyin = 1;
5247 63 : break;
5248 :
5249 1 : case OMP_MAP_FORCE_DEVICEPTR:
5250 1 : s->attr.oacc_declare_deviceptr = 1;
5251 1 : break;
5252 :
5253 : default:
5254 : break;
5255 : }
5256 : }
5257 :
5258 162 : new_oc = gfc_get_oacc_declare ();
5259 162 : new_oc->next = ns->oacc_declare;
5260 162 : new_oc->module_var = module_var;
5261 162 : new_oc->clauses = c;
5262 162 : new_oc->loc = gfc_current_locus;
5263 162 : ns->oacc_declare = new_oc;
5264 :
5265 162 : return MATCH_YES;
5266 : }
5267 :
5268 :
5269 : match
5270 760 : gfc_match_oacc_update (void)
5271 : {
5272 760 : gfc_omp_clauses *c;
5273 760 : locus here = gfc_current_locus;
5274 :
5275 760 : if (gfc_match_omp_clauses (&c, OACC_UPDATE_CLAUSES, false, false, true)
5276 : != MATCH_YES)
5277 : return MATCH_ERROR;
5278 :
5279 756 : if (!c->lists[OMP_LIST_MAP])
5280 : {
5281 1 : gfc_error ("%<acc update%> must contain at least one "
5282 : "%<device%> or %<host%> or %<self%> clause at %L", &here);
5283 1 : return MATCH_ERROR;
5284 : }
5285 :
5286 755 : new_st.op = EXEC_OACC_UPDATE;
5287 755 : new_st.ext.omp_clauses = c;
5288 755 : return MATCH_YES;
5289 : }
5290 :
5291 :
5292 : match
5293 877 : gfc_match_oacc_enter_data (void)
5294 : {
5295 877 : return match_acc (EXEC_OACC_ENTER_DATA, OACC_ENTER_DATA_CLAUSES);
5296 : }
5297 :
5298 :
5299 : match
5300 612 : gfc_match_oacc_exit_data (void)
5301 : {
5302 612 : return match_acc (EXEC_OACC_EXIT_DATA, OACC_EXIT_DATA_CLAUSES);
5303 : }
5304 :
5305 :
5306 : match
5307 202 : gfc_match_oacc_wait (void)
5308 : {
5309 202 : gfc_omp_clauses *c = gfc_get_omp_clauses ();
5310 202 : gfc_expr_list *wait_list = NULL, *el;
5311 202 : bool space = true;
5312 202 : match m;
5313 :
5314 202 : m = match_omp_oacc_expr_list (" (", &wait_list, true, false);
5315 202 : if (m == MATCH_ERROR)
5316 : return m;
5317 196 : else if (m == MATCH_YES)
5318 126 : space = false;
5319 :
5320 196 : if (gfc_match_omp_clauses (&c, OACC_WAIT_CLAUSES, space, space, true)
5321 : == MATCH_ERROR)
5322 : return MATCH_ERROR;
5323 :
5324 184 : if (wait_list)
5325 261 : for (el = wait_list; el; el = el->next)
5326 : {
5327 140 : if (el->expr == NULL)
5328 : {
5329 2 : gfc_error ("Invalid argument to !$ACC WAIT at %C");
5330 2 : return MATCH_ERROR;
5331 : }
5332 :
5333 138 : if (!gfc_resolve_expr (el->expr)
5334 138 : || el->expr->ts.type != BT_INTEGER || el->expr->rank != 0)
5335 : {
5336 3 : gfc_error ("WAIT clause at %L requires a scalar INTEGER expression",
5337 3 : &el->expr->where);
5338 :
5339 3 : return MATCH_ERROR;
5340 : }
5341 : }
5342 179 : c->wait_list = wait_list;
5343 179 : new_st.op = EXEC_OACC_WAIT;
5344 179 : new_st.ext.omp_clauses = c;
5345 179 : return MATCH_YES;
5346 : }
5347 :
5348 :
5349 : match
5350 97 : gfc_match_oacc_cache (void)
5351 : {
5352 97 : bool readonly = false;
5353 97 : gfc_omp_clauses *c = gfc_get_omp_clauses ();
5354 : /* The OpenACC cache directive explicitly only allows "array elements or
5355 : subarrays", which we're currently not checking here. Either check this
5356 : after the call of gfc_match_omp_variable_list, or add something like a
5357 : only_sections variant next to its allow_sections parameter. */
5358 97 : match m = gfc_match (" ( ");
5359 97 : if (m != MATCH_YES)
5360 : {
5361 0 : gfc_free_omp_clauses(c);
5362 0 : return m;
5363 : }
5364 :
5365 97 : if (gfc_match ("readonly : ") == MATCH_YES)
5366 8 : readonly = true;
5367 :
5368 97 : gfc_omp_namelist **head = NULL;
5369 97 : m = gfc_match_omp_variable_list ("", &c->lists[OMP_LIST_CACHE], true,
5370 : NULL, &head, true);
5371 97 : if (m != MATCH_YES)
5372 : {
5373 2 : gfc_free_omp_clauses(c);
5374 2 : return m;
5375 : }
5376 :
5377 95 : if (readonly)
5378 24 : for (gfc_omp_namelist *n = *head; n; n = n->next)
5379 16 : n->u.map.readonly = true;
5380 :
5381 95 : if (gfc_current_state() != COMP_DO
5382 56 : && gfc_current_state() != COMP_DO_CONCURRENT)
5383 : {
5384 2 : gfc_error ("ACC CACHE directive must be inside of loop %C");
5385 2 : gfc_free_omp_clauses(c);
5386 2 : return MATCH_ERROR;
5387 : }
5388 :
5389 93 : new_st.op = EXEC_OACC_CACHE;
5390 93 : new_st.ext.omp_clauses = c;
5391 93 : return MATCH_YES;
5392 : }
5393 :
5394 : match
5395 134 : gfc_match_oacc_init (void)
5396 : {
5397 134 : return match_acc (EXEC_OACC_INIT, OACC_INIT_CLAUSES);
5398 : }
5399 :
5400 : match
5401 130 : gfc_match_oacc_shutdown (void)
5402 : {
5403 130 : return match_acc (EXEC_OACC_SHUTDOWN, OACC_SHUTDOWN_CLAUSES);
5404 : }
5405 :
5406 : match
5407 130 : gfc_match_oacc_set (void)
5408 : {
5409 130 : return match_acc (EXEC_OACC_SET, OACC_SET_CLAUSES);
5410 : }
5411 :
5412 : /* Determine the OpenACC 'routine' directive's level of parallelism. */
5413 :
5414 : static oacc_routine_lop
5415 734 : gfc_oacc_routine_lop (gfc_omp_clauses *clauses)
5416 : {
5417 734 : oacc_routine_lop ret = OACC_ROUTINE_LOP_SEQ;
5418 :
5419 734 : if (clauses)
5420 : {
5421 584 : unsigned n_lop_clauses = 0;
5422 :
5423 584 : if (clauses->gang)
5424 : {
5425 164 : ++n_lop_clauses;
5426 164 : ret = OACC_ROUTINE_LOP_GANG;
5427 : }
5428 584 : if (clauses->worker)
5429 : {
5430 114 : ++n_lop_clauses;
5431 114 : ret = OACC_ROUTINE_LOP_WORKER;
5432 : }
5433 584 : if (clauses->vector)
5434 : {
5435 116 : ++n_lop_clauses;
5436 116 : ret = OACC_ROUTINE_LOP_VECTOR;
5437 : }
5438 584 : if (clauses->seq)
5439 : {
5440 206 : ++n_lop_clauses;
5441 206 : ret = OACC_ROUTINE_LOP_SEQ;
5442 : }
5443 :
5444 584 : if (n_lop_clauses > 1)
5445 47 : ret = OACC_ROUTINE_LOP_ERROR;
5446 : }
5447 :
5448 734 : return ret;
5449 : }
5450 :
5451 : match
5452 698 : gfc_match_oacc_routine (void)
5453 : {
5454 698 : locus old_loc;
5455 698 : match m;
5456 698 : gfc_intrinsic_sym *isym = NULL;
5457 698 : gfc_symbol *sym = NULL;
5458 698 : gfc_omp_clauses *c = NULL;
5459 698 : gfc_oacc_routine_name *n = NULL;
5460 698 : oacc_routine_lop lop = OACC_ROUTINE_LOP_NONE;
5461 698 : bool nohost;
5462 :
5463 698 : old_loc = gfc_current_locus;
5464 :
5465 698 : m = gfc_match (" (");
5466 :
5467 698 : if (gfc_current_ns->proc_name
5468 696 : && gfc_current_ns->proc_name->attr.if_source == IFSRC_IFBODY
5469 90 : && m == MATCH_YES)
5470 : {
5471 3 : gfc_error ("Only the !$ACC ROUTINE form without "
5472 : "list is allowed in interface block at %C");
5473 3 : goto cleanup;
5474 : }
5475 :
5476 608 : if (m == MATCH_YES)
5477 : {
5478 295 : char buffer[GFC_MAX_SYMBOL_LEN + 1];
5479 :
5480 295 : m = gfc_match_name (buffer);
5481 295 : if (m == MATCH_YES)
5482 : {
5483 294 : gfc_symtree *st = NULL;
5484 :
5485 : /* First look for an intrinsic symbol. */
5486 294 : isym = gfc_find_function (buffer);
5487 294 : if (!isym)
5488 294 : isym = gfc_find_subroutine (buffer);
5489 : /* If no intrinsic symbol found, search the current namespace. */
5490 294 : if (!isym)
5491 276 : st = gfc_find_symtree (gfc_current_ns->sym_root, buffer);
5492 276 : if (st)
5493 : {
5494 270 : sym = st->n.sym;
5495 : /* If the name in a 'routine' directive refers to the containing
5496 : subroutine or function, then make sure that we'll later handle
5497 : this accordingly. */
5498 270 : if (gfc_current_ns->proc_name != NULL
5499 270 : && strcmp (sym->name, gfc_current_ns->proc_name->name) == 0)
5500 294 : sym = NULL;
5501 : }
5502 :
5503 294 : if (isym == NULL && st == NULL)
5504 : {
5505 6 : gfc_error ("Invalid NAME %qs in !$ACC ROUTINE ( NAME ) at %C",
5506 : buffer);
5507 6 : gfc_current_locus = old_loc;
5508 9 : return MATCH_ERROR;
5509 : }
5510 : }
5511 : else
5512 : {
5513 1 : gfc_error ("Syntax error in !$ACC ROUTINE ( NAME ) at %C");
5514 1 : gfc_current_locus = old_loc;
5515 1 : return MATCH_ERROR;
5516 : }
5517 :
5518 288 : if (gfc_match_char (')') != MATCH_YES)
5519 : {
5520 2 : gfc_error ("Syntax error in !$ACC ROUTINE ( NAME ) at %C, expecting"
5521 : " %<)%> after NAME");
5522 2 : gfc_current_locus = old_loc;
5523 2 : return MATCH_ERROR;
5524 : }
5525 : }
5526 :
5527 686 : if (gfc_match_omp_eos () != MATCH_YES
5528 686 : && (gfc_match_omp_clauses (&c, OACC_ROUTINE_CLAUSES, false, false, true)
5529 : != MATCH_YES))
5530 : return MATCH_ERROR;
5531 :
5532 683 : lop = gfc_oacc_routine_lop (c);
5533 683 : if (lop == OACC_ROUTINE_LOP_ERROR)
5534 : {
5535 47 : gfc_error ("Multiple loop axes specified for routine at %C");
5536 47 : goto cleanup;
5537 : }
5538 636 : nohost = c ? c->nohost : false;
5539 :
5540 636 : if (isym != NULL)
5541 : {
5542 : /* Diagnose any OpenACC 'routine' directive that doesn't match the
5543 : (implicit) one with a 'seq' clause. */
5544 16 : if (c && (c->gang || c->worker || c->vector))
5545 : {
5546 10 : gfc_error ("Intrinsic symbol specified in !$ACC ROUTINE ( NAME )"
5547 : " at %C marked with incompatible GANG, WORKER, or VECTOR"
5548 : " clause");
5549 10 : goto cleanup;
5550 : }
5551 : /* ..., and no 'nohost' clause. */
5552 6 : if (nohost)
5553 : {
5554 2 : gfc_error ("Intrinsic symbol specified in !$ACC ROUTINE ( NAME )"
5555 : " at %C marked with incompatible NOHOST clause");
5556 2 : goto cleanup;
5557 : }
5558 : }
5559 620 : else if (sym != NULL)
5560 : {
5561 151 : bool add = true;
5562 :
5563 : /* For a repeated OpenACC 'routine' directive, diagnose if it doesn't
5564 : match the first one. */
5565 151 : for (gfc_oacc_routine_name *n_p = gfc_current_ns->oacc_routine_names;
5566 346 : n_p;
5567 195 : n_p = n_p->next)
5568 235 : if (n_p->sym == sym)
5569 : {
5570 51 : add = false;
5571 51 : bool nohost_p = n_p->clauses ? n_p->clauses->nohost : false;
5572 51 : if (lop != gfc_oacc_routine_lop (n_p->clauses)
5573 51 : || nohost != nohost_p)
5574 : {
5575 40 : gfc_error ("!$ACC ROUTINE already applied at %C");
5576 40 : goto cleanup;
5577 : }
5578 : }
5579 :
5580 111 : if (add)
5581 : {
5582 100 : sym->attr.oacc_routine_lop = lop;
5583 100 : sym->attr.oacc_routine_nohost = nohost;
5584 :
5585 100 : n = gfc_get_oacc_routine_name ();
5586 100 : n->sym = sym;
5587 100 : n->clauses = c;
5588 100 : n->next = gfc_current_ns->oacc_routine_names;
5589 100 : n->loc = old_loc;
5590 100 : gfc_current_ns->oacc_routine_names = n;
5591 : }
5592 : }
5593 469 : else if (gfc_current_ns->proc_name)
5594 : {
5595 : /* For a repeated OpenACC 'routine' directive, diagnose if it doesn't
5596 : match the first one. */
5597 468 : oacc_routine_lop lop_p = gfc_current_ns->proc_name->attr.oacc_routine_lop;
5598 468 : bool nohost_p = gfc_current_ns->proc_name->attr.oacc_routine_nohost;
5599 468 : if (lop_p != OACC_ROUTINE_LOP_NONE
5600 86 : && (lop != lop_p
5601 86 : || nohost != nohost_p))
5602 : {
5603 56 : gfc_error ("!$ACC ROUTINE already applied at %C");
5604 56 : goto cleanup;
5605 : }
5606 :
5607 412 : if (!gfc_add_omp_declare_target (&gfc_current_ns->proc_name->attr,
5608 : gfc_current_ns->proc_name->name,
5609 : &old_loc))
5610 1 : goto cleanup;
5611 411 : gfc_current_ns->proc_name->attr.oacc_routine_lop = lop;
5612 411 : gfc_current_ns->proc_name->attr.oacc_routine_nohost = nohost;
5613 : }
5614 : else
5615 : /* Something has gone wrong, possibly a syntax error. */
5616 1 : goto cleanup;
5617 :
5618 526 : if (gfc_pure (NULL) && c && (c->gang || c->worker || c->vector))
5619 : {
5620 6 : gfc_error ("!$ACC ROUTINE with GANG, WORKER, or VECTOR clause is not "
5621 : "permitted in PURE procedure at %C");
5622 6 : goto cleanup;
5623 : }
5624 :
5625 :
5626 520 : if (n)
5627 100 : n->clauses = c;
5628 420 : else if (gfc_current_ns->oacc_routine)
5629 0 : gfc_current_ns->oacc_routine_clauses = c;
5630 :
5631 520 : new_st.op = EXEC_OACC_ROUTINE;
5632 520 : new_st.ext.omp_clauses = c;
5633 520 : return MATCH_YES;
5634 :
5635 166 : cleanup:
5636 166 : gfc_current_locus = old_loc;
5637 166 : return MATCH_ERROR;
5638 : }
5639 :
5640 :
5641 : #define OMP_PARALLEL_CLAUSES \
5642 : (omp_mask (OMP_CLAUSE_PRIVATE) | OMP_CLAUSE_FIRSTPRIVATE \
5643 : | OMP_CLAUSE_SHARED | OMP_CLAUSE_COPYIN | OMP_CLAUSE_REDUCTION \
5644 : | OMP_CLAUSE_IF | OMP_CLAUSE_NUM_THREADS | OMP_CLAUSE_DEFAULT \
5645 : | OMP_CLAUSE_PROC_BIND | OMP_CLAUSE_ALLOCATE | OMP_CLAUSE_MESSAGE \
5646 : | OMP_CLAUSE_SEVERITY)
5647 : #define OMP_DECLARE_SIMD_CLAUSES \
5648 : (omp_mask (OMP_CLAUSE_SIMDLEN) | OMP_CLAUSE_LINEAR \
5649 : | OMP_CLAUSE_UNIFORM | OMP_CLAUSE_ALIGNED | OMP_CLAUSE_INBRANCH \
5650 : | OMP_CLAUSE_NOTINBRANCH)
5651 : #define OMP_DO_CLAUSES \
5652 : (omp_mask (OMP_CLAUSE_PRIVATE) | OMP_CLAUSE_FIRSTPRIVATE \
5653 : | OMP_CLAUSE_LASTPRIVATE | OMP_CLAUSE_REDUCTION \
5654 : | OMP_CLAUSE_SCHEDULE | OMP_CLAUSE_ORDERED | OMP_CLAUSE_COLLAPSE \
5655 : | OMP_CLAUSE_LINEAR | OMP_CLAUSE_ORDER | OMP_CLAUSE_ALLOCATE \
5656 : | OMP_CLAUSE_NOWAIT)
5657 : #define OMP_LOOP_CLAUSES \
5658 : (omp_mask (OMP_CLAUSE_BIND) | OMP_CLAUSE_COLLAPSE | OMP_CLAUSE_ORDER \
5659 : | OMP_CLAUSE_PRIVATE | OMP_CLAUSE_LASTPRIVATE | OMP_CLAUSE_REDUCTION)
5660 :
5661 : #define OMP_SCOPE_CLAUSES \
5662 : (omp_mask (OMP_CLAUSE_PRIVATE) |OMP_CLAUSE_FIRSTPRIVATE \
5663 : | OMP_CLAUSE_REDUCTION | OMP_CLAUSE_ALLOCATE | OMP_CLAUSE_NOWAIT)
5664 : #define OMP_SECTIONS_CLAUSES \
5665 : (omp_mask (OMP_CLAUSE_PRIVATE) | OMP_CLAUSE_FIRSTPRIVATE \
5666 : | OMP_CLAUSE_LASTPRIVATE | OMP_CLAUSE_REDUCTION \
5667 : | OMP_CLAUSE_ALLOCATE | OMP_CLAUSE_NOWAIT)
5668 : #define OMP_SIMD_CLAUSES \
5669 : (omp_mask (OMP_CLAUSE_PRIVATE) | OMP_CLAUSE_LASTPRIVATE \
5670 : | OMP_CLAUSE_REDUCTION | OMP_CLAUSE_COLLAPSE | OMP_CLAUSE_SAFELEN \
5671 : | OMP_CLAUSE_LINEAR | OMP_CLAUSE_ALIGNED | OMP_CLAUSE_SIMDLEN \
5672 : | OMP_CLAUSE_IF | OMP_CLAUSE_ORDER | OMP_CLAUSE_NOTEMPORAL)
5673 : #define OMP_TASK_CLAUSES \
5674 : (omp_mask (OMP_CLAUSE_PRIVATE) | OMP_CLAUSE_FIRSTPRIVATE \
5675 : | OMP_CLAUSE_SHARED | OMP_CLAUSE_IF | OMP_CLAUSE_DEFAULT \
5676 : | OMP_CLAUSE_UNTIED | OMP_CLAUSE_FINAL | OMP_CLAUSE_MERGEABLE \
5677 : | OMP_CLAUSE_DEPEND | OMP_CLAUSE_PRIORITY | OMP_CLAUSE_IN_REDUCTION \
5678 : | OMP_CLAUSE_DETACH | OMP_CLAUSE_AFFINITY | OMP_CLAUSE_ALLOCATE)
5679 : #define OMP_TASKLOOP_CLAUSES \
5680 : (omp_mask (OMP_CLAUSE_PRIVATE) | OMP_CLAUSE_FIRSTPRIVATE \
5681 : | OMP_CLAUSE_LASTPRIVATE | OMP_CLAUSE_SHARED | OMP_CLAUSE_IF \
5682 : | OMP_CLAUSE_DEFAULT | OMP_CLAUSE_UNTIED | OMP_CLAUSE_FINAL \
5683 : | OMP_CLAUSE_MERGEABLE | OMP_CLAUSE_PRIORITY | OMP_CLAUSE_GRAINSIZE \
5684 : | OMP_CLAUSE_NUM_TASKS | OMP_CLAUSE_COLLAPSE | OMP_CLAUSE_NOGROUP \
5685 : | OMP_CLAUSE_REDUCTION | OMP_CLAUSE_IN_REDUCTION | OMP_CLAUSE_ALLOCATE)
5686 : #define OMP_TASKGROUP_CLAUSES \
5687 : (omp_mask (OMP_CLAUSE_TASK_REDUCTION) | OMP_CLAUSE_ALLOCATE)
5688 : #define OMP_TARGET_CLAUSES \
5689 : (omp_mask (OMP_CLAUSE_DEVICE) | OMP_CLAUSE_MAP | OMP_CLAUSE_IF \
5690 : | OMP_CLAUSE_DEPEND | OMP_CLAUSE_NOWAIT | OMP_CLAUSE_PRIVATE \
5691 : | OMP_CLAUSE_FIRSTPRIVATE | OMP_CLAUSE_DEFAULTMAP \
5692 : | OMP_CLAUSE_IS_DEVICE_PTR | OMP_CLAUSE_IN_REDUCTION \
5693 : | OMP_CLAUSE_THREAD_LIMIT | OMP_CLAUSE_ALLOCATE \
5694 : | OMP_CLAUSE_HAS_DEVICE_ADDR | OMP_CLAUSE_USES_ALLOCATORS \
5695 : | OMP_CLAUSE_DYN_GROUPPRIVATE | OMP_CLAUSE_DEVICE_TYPE \
5696 : | OMP_CLAUSE_MESSAGE | OMP_CLAUSE_SEVERITY)
5697 : #define OMP_TARGET_DATA_CLAUSES \
5698 : (omp_mask (OMP_CLAUSE_DEVICE) | OMP_CLAUSE_MAP | OMP_CLAUSE_IF \
5699 : | OMP_CLAUSE_USE_DEVICE_PTR | OMP_CLAUSE_USE_DEVICE_ADDR)
5700 : #define OMP_TARGET_ENTER_DATA_CLAUSES \
5701 : (omp_mask (OMP_CLAUSE_DEVICE) | OMP_CLAUSE_MAP | OMP_CLAUSE_IF \
5702 : | OMP_CLAUSE_DEPEND | OMP_CLAUSE_NOWAIT)
5703 : #define OMP_TARGET_EXIT_DATA_CLAUSES \
5704 : (omp_mask (OMP_CLAUSE_DEVICE) | OMP_CLAUSE_MAP | OMP_CLAUSE_IF \
5705 : | OMP_CLAUSE_DEPEND | OMP_CLAUSE_NOWAIT)
5706 : #define OMP_TARGET_UPDATE_CLAUSES \
5707 : (omp_mask (OMP_CLAUSE_DEVICE) | OMP_CLAUSE_IF | OMP_CLAUSE_TO \
5708 : | OMP_CLAUSE_FROM | OMP_CLAUSE_DEPEND | OMP_CLAUSE_NOWAIT)
5709 : #define OMP_TEAMS_CLAUSES \
5710 : (omp_mask (OMP_CLAUSE_NUM_TEAMS) | OMP_CLAUSE_THREAD_LIMIT \
5711 : | OMP_CLAUSE_DEFAULT | OMP_CLAUSE_PRIVATE | OMP_CLAUSE_FIRSTPRIVATE \
5712 : | OMP_CLAUSE_SHARED | OMP_CLAUSE_REDUCTION | OMP_CLAUSE_ALLOCATE \
5713 : | OMP_CLAUSE_MESSAGE | OMP_CLAUSE_SEVERITY)
5714 : #define OMP_DISTRIBUTE_CLAUSES \
5715 : (omp_mask (OMP_CLAUSE_PRIVATE) | OMP_CLAUSE_FIRSTPRIVATE \
5716 : | OMP_CLAUSE_LASTPRIVATE | OMP_CLAUSE_COLLAPSE | OMP_CLAUSE_DIST_SCHEDULE \
5717 : | OMP_CLAUSE_ORDER | OMP_CLAUSE_ALLOCATE)
5718 : #define OMP_SINGLE_CLAUSES \
5719 : (omp_mask (OMP_CLAUSE_PRIVATE) | OMP_CLAUSE_FIRSTPRIVATE \
5720 : | OMP_CLAUSE_ALLOCATE | OMP_CLAUSE_NOWAIT | OMP_CLAUSE_COPYPRIVATE)
5721 : #define OMP_ORDERED_CLAUSES \
5722 : (omp_mask (OMP_CLAUSE_THREADS) | OMP_CLAUSE_SIMD)
5723 : #define OMP_DECLARE_TARGET_CLAUSES \
5724 : (omp_mask (OMP_CLAUSE_ENTER) | OMP_CLAUSE_LINK | OMP_CLAUSE_DEVICE_TYPE \
5725 : | OMP_CLAUSE_TO | OMP_CLAUSE_INDIRECT | OMP_CLAUSE_LOCAL)
5726 : #define OMP_ATOMIC_CLAUSES \
5727 : (omp_mask (OMP_CLAUSE_ATOMIC) | OMP_CLAUSE_CAPTURE | OMP_CLAUSE_HINT \
5728 : | OMP_CLAUSE_MEMORDER | OMP_CLAUSE_COMPARE | OMP_CLAUSE_FAIL \
5729 : | OMP_CLAUSE_WEAK)
5730 : #define OMP_MASKED_CLAUSES \
5731 : (omp_mask (OMP_CLAUSE_FILTER))
5732 : #define OMP_ERROR_CLAUSES \
5733 : (omp_mask (OMP_CLAUSE_AT) | OMP_CLAUSE_MESSAGE | OMP_CLAUSE_SEVERITY)
5734 : #define OMP_WORKSHARE_CLAUSES \
5735 : omp_mask (OMP_CLAUSE_NOWAIT)
5736 : #define OMP_UNROLL_CLAUSES \
5737 : (omp_mask (OMP_CLAUSE_FULL) | OMP_CLAUSE_PARTIAL)
5738 : #define OMP_TILE_CLAUSES \
5739 : (omp_mask (OMP_CLAUSE_SIZES))
5740 : #define OMP_ALLOCATORS_CLAUSES \
5741 : omp_mask (OMP_CLAUSE_ALLOCATE)
5742 : #define OMP_INTEROP_CLAUSES \
5743 : (omp_mask (OMP_CLAUSE_DEPEND) | OMP_CLAUSE_NOWAIT | OMP_CLAUSE_DEVICE \
5744 : | OMP_CLAUSE_INIT | OMP_CLAUSE_DESTROY | OMP_CLAUSE_USE)
5745 : #define OMP_DISPATCH_CLAUSES \
5746 : (omp_mask (OMP_CLAUSE_DEVICE) | OMP_CLAUSE_DEPEND | OMP_CLAUSE_NOVARIANTS \
5747 : | OMP_CLAUSE_NOCONTEXT | OMP_CLAUSE_IS_DEVICE_PTR | OMP_CLAUSE_NOWAIT \
5748 : | OMP_CLAUSE_HAS_DEVICE_ADDR | OMP_CLAUSE_INTEROP)
5749 :
5750 :
5751 : static match
5752 17341 : match_omp (gfc_exec_op op, const omp_mask mask)
5753 : {
5754 17341 : gfc_omp_clauses *c;
5755 17341 : if (gfc_match_omp_clauses (&c, mask, true, true, false,
5756 : op == EXEC_OMP_TARGET) != MATCH_YES)
5757 : return MATCH_ERROR;
5758 17003 : new_st.op = op;
5759 17003 : new_st.ext.omp_clauses = c;
5760 17003 : return MATCH_YES;
5761 : }
5762 :
5763 : /* Handles both declarative and (deprecated) executable ALLOCATE directive;
5764 : accepts optional list (for executable) and common blocks.
5765 : If no variables have been provided, the single omp namelist has sym == NULL.
5766 :
5767 : Note that the executable ALLOCATE directive permits structure elements only
5768 : in OpenMP 5.0 and 5.1 but not longer in 5.2. See also the comment on the
5769 : 'omp allocators' directive below. The accidental change was reverted for
5770 : OpenMP TR12, permitting them again. See also gfc_match_omp_allocators.
5771 :
5772 : Hence, structure elements are rejected for now, also to make resolving
5773 : OMP_LIST_ALLOCATE simpler (check for duplicates, same symbol in
5774 : Fortran allocate stmt). TODO: Permit structure elements. */
5775 :
5776 : match
5777 274 : gfc_match_omp_allocate (void)
5778 : {
5779 274 : match m;
5780 274 : bool first = true;
5781 274 : gfc_omp_namelist *vars = NULL;
5782 274 : gfc_expr *align = NULL;
5783 274 : gfc_expr *allocator = NULL;
5784 274 : locus loc = gfc_current_locus;
5785 :
5786 274 : m = gfc_match_omp_variable_list (" (", &vars, true, NULL, NULL, true, true,
5787 : NULL, true);
5788 :
5789 274 : if (m == MATCH_ERROR)
5790 : return m;
5791 :
5792 502 : while (true)
5793 : {
5794 502 : gfc_gobble_whitespace ();
5795 502 : if (gfc_match_omp_eos () == MATCH_YES)
5796 : break;
5797 234 : if (!first)
5798 28 : gfc_match (", ");
5799 234 : first = false;
5800 234 : if ((m = gfc_match_dupl_check (!align, "align", true, &align))
5801 : != MATCH_NO)
5802 : {
5803 62 : if (m == MATCH_ERROR)
5804 1 : goto error;
5805 61 : continue;
5806 : }
5807 172 : if ((m = gfc_match_dupl_check (!allocator, "allocator",
5808 : true, &allocator)) != MATCH_NO)
5809 : {
5810 171 : if (m == MATCH_ERROR)
5811 1 : goto error;
5812 170 : continue;
5813 : }
5814 1 : gfc_error ("Expected ALIGN or ALLOCATOR clause at %C");
5815 1 : return MATCH_ERROR;
5816 : }
5817 541 : for (gfc_omp_namelist *n = vars; n; n = n->next)
5818 276 : if (n->expr)
5819 : {
5820 3 : if ((n->expr->ref && n->expr->ref->type == REF_COMPONENT)
5821 3 : || (n->expr->ref->next && n->expr->ref->type == REF_COMPONENT))
5822 1 : gfc_error ("Sorry, structure-element list item at %L in ALLOCATE "
5823 : "directive is not yet supported", &n->expr->where);
5824 : else
5825 2 : gfc_error ("Unexpected expression as list item at %L in ALLOCATE "
5826 : "directive", &n->expr->where);
5827 :
5828 3 : gfc_free_omp_namelist (vars, OMP_LIST_ALLOCATE);
5829 3 : goto error;
5830 : }
5831 :
5832 265 : new_st.op = EXEC_OMP_ALLOCATE;
5833 265 : new_st.ext.omp_clauses = gfc_get_omp_clauses ();
5834 265 : if (vars == NULL)
5835 : {
5836 27 : vars = gfc_get_omp_namelist ();
5837 27 : vars->where = loc;
5838 27 : vars->u.align = align;
5839 27 : vars->u2.allocator = allocator;
5840 27 : new_st.ext.omp_clauses->lists[OMP_LIST_ALLOCATE] = vars;
5841 : }
5842 : else
5843 : {
5844 238 : new_st.ext.omp_clauses->lists[OMP_LIST_ALLOCATE] = vars;
5845 511 : for (; vars; vars = vars->next)
5846 : {
5847 273 : vars->u.align = (align) ? gfc_copy_expr (align) : NULL;
5848 273 : vars->u2.allocator = allocator;
5849 : }
5850 238 : gfc_free_expr (align);
5851 : }
5852 : return MATCH_YES;
5853 :
5854 5 : error:
5855 5 : gfc_free_expr (align);
5856 5 : gfc_free_expr (allocator);
5857 5 : return MATCH_ERROR;
5858 : }
5859 :
5860 : /* In line with OpenMP 5.2 derived-type components are rejected.
5861 : See also comment before gfc_match_omp_allocate. */
5862 :
5863 : match
5864 26 : gfc_match_omp_allocators (void)
5865 : {
5866 26 : return match_omp (EXEC_OMP_ALLOCATORS, OMP_ALLOCATORS_CLAUSES);
5867 : }
5868 :
5869 :
5870 : match
5871 23 : gfc_match_omp_assume (void)
5872 : {
5873 23 : gfc_omp_clauses *c;
5874 23 : locus loc = gfc_current_locus;
5875 23 : if ((gfc_match_omp_clauses (&c, omp_mask (OMP_CLAUSE_ASSUMPTIONS))
5876 : != MATCH_YES)
5877 23 : || (omp_verify_merge_absent_contains (ST_OMP_ASSUME, c->assume, NULL,
5878 : &loc) != MATCH_YES))
5879 7 : return MATCH_ERROR;
5880 16 : new_st.op = EXEC_OMP_ASSUME;
5881 16 : new_st.ext.omp_clauses = c;
5882 16 : return MATCH_YES;
5883 : }
5884 :
5885 :
5886 : match
5887 28 : gfc_match_omp_assumes (void)
5888 : {
5889 28 : gfc_omp_clauses *c;
5890 28 : locus loc = gfc_current_locus;
5891 28 : if (!gfc_current_ns->proc_name
5892 27 : || (gfc_current_ns->proc_name->attr.flavor != FL_MODULE
5893 23 : && !gfc_current_ns->proc_name->attr.subroutine
5894 10 : && !gfc_current_ns->proc_name->attr.function))
5895 : {
5896 2 : gfc_error ("!$OMP ASSUMES at %C must be in the specification part of a "
5897 : "subprogram or module");
5898 2 : return MATCH_ERROR;
5899 : }
5900 26 : if ((gfc_match_omp_clauses (&c, omp_mask (OMP_CLAUSE_ASSUMPTIONS))
5901 : != MATCH_YES)
5902 50 : || (omp_verify_merge_absent_contains (ST_OMP_ASSUMES, c->assume,
5903 24 : gfc_current_ns->omp_assumes, &loc)
5904 : != MATCH_YES))
5905 5 : return MATCH_ERROR;
5906 21 : if (gfc_current_ns->omp_assumes == NULL)
5907 : {
5908 19 : gfc_current_ns->omp_assumes = c->assume;
5909 19 : c->assume = NULL;
5910 : }
5911 2 : else if (gfc_current_ns->omp_assumes && c->assume)
5912 : {
5913 2 : gfc_current_ns->omp_assumes->no_openmp |= c->assume->no_openmp;
5914 2 : gfc_current_ns->omp_assumes->no_openmp_routines
5915 2 : |= c->assume->no_openmp_routines;
5916 2 : gfc_current_ns->omp_assumes->no_openmp_constructs
5917 2 : |= c->assume->no_openmp_constructs;
5918 2 : gfc_current_ns->omp_assumes->no_parallelism |= c->assume->no_parallelism;
5919 2 : if (gfc_current_ns->omp_assumes->holds && c->assume->holds)
5920 : {
5921 : gfc_expr_list *el = gfc_current_ns->omp_assumes->holds;
5922 1 : for ( ; el->next ; el = el->next)
5923 : ;
5924 1 : el->next = c->assume->holds;
5925 1 : }
5926 1 : else if (c->assume->holds)
5927 0 : gfc_current_ns->omp_assumes->holds = c->assume->holds;
5928 2 : c->assume->holds = NULL;
5929 : }
5930 21 : gfc_free_omp_clauses (c);
5931 21 : return MATCH_YES;
5932 : }
5933 :
5934 :
5935 : match
5936 162 : gfc_match_omp_critical (void)
5937 : {
5938 162 : char n[GFC_MAX_SYMBOL_LEN+1];
5939 162 : gfc_omp_clauses *c = NULL;
5940 :
5941 162 : if (gfc_match (" ( %n )", n) != MATCH_YES)
5942 115 : n[0] = '\0';
5943 :
5944 162 : if (gfc_match_omp_clauses (&c, omp_mask (OMP_CLAUSE_HINT),
5945 162 : /* first = */ n[0] == '\0') != MATCH_YES)
5946 : return MATCH_ERROR;
5947 :
5948 160 : new_st.op = EXEC_OMP_CRITICAL;
5949 160 : new_st.ext.omp_clauses = c;
5950 160 : if (n[0])
5951 47 : c->critical_name = xstrdup (n);
5952 : return MATCH_YES;
5953 : }
5954 :
5955 :
5956 : match
5957 160 : gfc_match_omp_end_critical (void)
5958 : {
5959 160 : char n[GFC_MAX_SYMBOL_LEN+1];
5960 :
5961 160 : if (gfc_match (" ( %n )", n) != MATCH_YES)
5962 113 : n[0] = '\0';
5963 160 : if (gfc_match_omp_eos () != MATCH_YES)
5964 : {
5965 1 : gfc_error ("Unexpected junk after $OMP CRITICAL statement at %C");
5966 1 : return MATCH_ERROR;
5967 : }
5968 :
5969 159 : new_st.op = EXEC_OMP_END_CRITICAL;
5970 159 : new_st.ext.omp_name = n[0] ? xstrdup (n) : NULL;
5971 159 : return MATCH_YES;
5972 : }
5973 :
5974 : /* depobj(depobj) depend(dep-type:loc)|destroy|update(dep-type)
5975 : dep-type = in/out/inout/mutexinoutset/depobj/source/sink
5976 : depend: !source, !sink
5977 : update: !source, !sink, !depobj
5978 : locator = exactly one list item .*/
5979 : match
5980 125 : gfc_match_omp_depobj (void)
5981 : {
5982 125 : gfc_omp_clauses *c = NULL;
5983 125 : gfc_expr *depobj;
5984 :
5985 125 : if (gfc_match (" ( %v ) ", &depobj) != MATCH_YES)
5986 : {
5987 2 : gfc_error ("Expected %<( depobj )%> at %C");
5988 2 : return MATCH_ERROR;
5989 : }
5990 123 : if (gfc_match ("update ( ") == MATCH_YES)
5991 : {
5992 12 : c = gfc_get_omp_clauses ();
5993 12 : if (gfc_match ("inoutset )") == MATCH_YES)
5994 2 : c->depobj_update = OMP_DEPEND_INOUTSET;
5995 10 : else if (gfc_match ("inout )") == MATCH_YES)
5996 1 : c->depobj_update = OMP_DEPEND_INOUT;
5997 9 : else if (gfc_match ("in )") == MATCH_YES)
5998 2 : c->depobj_update = OMP_DEPEND_IN;
5999 7 : else if (gfc_match ("out )") == MATCH_YES)
6000 2 : c->depobj_update = OMP_DEPEND_OUT;
6001 5 : else if (gfc_match ("mutexinoutset )") == MATCH_YES)
6002 2 : c->depobj_update = OMP_DEPEND_MUTEXINOUTSET;
6003 : else
6004 : {
6005 3 : gfc_error ("Expected IN, OUT, INOUT, INOUTSET or MUTEXINOUTSET "
6006 : "followed by %<)%> at %C");
6007 3 : goto error;
6008 : }
6009 : }
6010 111 : else if (gfc_match ("destroy ") == MATCH_YES)
6011 : {
6012 16 : gfc_expr *destroyobj = NULL;
6013 16 : c = gfc_get_omp_clauses ();
6014 16 : c->destroy = true;
6015 :
6016 16 : if (gfc_match (" ( %v ) ", &destroyobj) == MATCH_YES)
6017 : {
6018 3 : if (destroyobj->symtree != depobj->symtree)
6019 2 : gfc_warning (OPT_Wopenmp, "The same depend object should be used as"
6020 : " DEPOBJ argument at %L and as DESTROY argument at %L",
6021 : &depobj->where, &destroyobj->where);
6022 3 : gfc_free_expr (destroyobj);
6023 : }
6024 : }
6025 95 : else if (gfc_match_omp_clauses (&c, omp_mask (OMP_CLAUSE_DEPEND), true, false)
6026 : != MATCH_YES)
6027 2 : goto error;
6028 :
6029 118 : if (c->depobj_update == OMP_DEPEND_UNSET && !c->destroy)
6030 : {
6031 93 : if (!c->doacross_source && !c->lists[OMP_LIST_DEPEND])
6032 : {
6033 1 : gfc_error ("Expected DEPEND, UPDATE, or DESTROY clause at %C");
6034 1 : goto error;
6035 : }
6036 92 : if (c->lists[OMP_LIST_DEPEND]->u.depend_doacross_op == OMP_DEPEND_DEPOBJ)
6037 : {
6038 1 : gfc_error ("DEPEND clause at %L of OMP DEPOBJ construct shall not "
6039 : "have dependence-type DEPOBJ",
6040 : c->lists[OMP_LIST_DEPEND]
6041 : ? &c->lists[OMP_LIST_DEPEND]->where : &gfc_current_locus);
6042 1 : goto error;
6043 : }
6044 91 : if (c->lists[OMP_LIST_DEPEND]->next)
6045 : {
6046 1 : gfc_error ("DEPEND clause at %L of OMP DEPOBJ construct shall have "
6047 : "only a single locator",
6048 : &c->lists[OMP_LIST_DEPEND]->next->where);
6049 1 : goto error;
6050 : }
6051 : }
6052 :
6053 115 : c->depobj = depobj;
6054 115 : new_st.op = EXEC_OMP_DEPOBJ;
6055 115 : new_st.ext.omp_clauses = c;
6056 115 : return MATCH_YES;
6057 :
6058 8 : error:
6059 8 : gfc_free_expr (depobj);
6060 8 : gfc_free_omp_clauses (c);
6061 8 : return MATCH_ERROR;
6062 : }
6063 :
6064 : match
6065 160 : gfc_match_omp_dispatch (void)
6066 : {
6067 160 : return match_omp (EXEC_OMP_DISPATCH, OMP_DISPATCH_CLAUSES);
6068 : }
6069 :
6070 : match
6071 57 : gfc_match_omp_distribute (void)
6072 : {
6073 57 : return match_omp (EXEC_OMP_DISTRIBUTE, OMP_DISTRIBUTE_CLAUSES);
6074 : }
6075 :
6076 :
6077 : match
6078 44 : gfc_match_omp_distribute_parallel_do (void)
6079 : {
6080 44 : return match_omp (EXEC_OMP_DISTRIBUTE_PARALLEL_DO,
6081 44 : (OMP_DISTRIBUTE_CLAUSES | OMP_PARALLEL_CLAUSES
6082 44 : | OMP_DO_CLAUSES)
6083 44 : & ~(omp_mask (OMP_CLAUSE_ORDERED)
6084 44 : | OMP_CLAUSE_LINEAR | OMP_CLAUSE_NOWAIT));
6085 : }
6086 :
6087 :
6088 : match
6089 34 : gfc_match_omp_distribute_parallel_do_simd (void)
6090 : {
6091 34 : return match_omp (EXEC_OMP_DISTRIBUTE_PARALLEL_DO_SIMD,
6092 34 : (OMP_DISTRIBUTE_CLAUSES | OMP_PARALLEL_CLAUSES
6093 34 : | OMP_DO_CLAUSES | OMP_SIMD_CLAUSES)
6094 34 : & ~(omp_mask (OMP_CLAUSE_ORDERED) | OMP_CLAUSE_NOWAIT));
6095 : }
6096 :
6097 :
6098 : match
6099 52 : gfc_match_omp_distribute_simd (void)
6100 : {
6101 52 : return match_omp (EXEC_OMP_DISTRIBUTE_SIMD,
6102 52 : OMP_DISTRIBUTE_CLAUSES | OMP_SIMD_CLAUSES);
6103 : }
6104 :
6105 :
6106 : match
6107 1253 : gfc_match_omp_do (void)
6108 : {
6109 1253 : return match_omp (EXEC_OMP_DO, OMP_DO_CLAUSES);
6110 : }
6111 :
6112 :
6113 : match
6114 137 : gfc_match_omp_do_simd (void)
6115 : {
6116 137 : return match_omp (EXEC_OMP_DO_SIMD, OMP_DO_CLAUSES | OMP_SIMD_CLAUSES);
6117 : }
6118 :
6119 :
6120 : match
6121 70 : gfc_match_omp_loop (void)
6122 : {
6123 70 : return match_omp (EXEC_OMP_LOOP, OMP_LOOP_CLAUSES);
6124 : }
6125 :
6126 :
6127 : match
6128 35 : gfc_match_omp_teams_loop (void)
6129 : {
6130 35 : return match_omp (EXEC_OMP_TEAMS_LOOP, OMP_TEAMS_CLAUSES | OMP_LOOP_CLAUSES);
6131 : }
6132 :
6133 :
6134 : match
6135 18 : gfc_match_omp_target_teams_loop (void)
6136 : {
6137 18 : return match_omp (EXEC_OMP_TARGET_TEAMS_LOOP,
6138 18 : OMP_TARGET_CLAUSES | OMP_TEAMS_CLAUSES | OMP_LOOP_CLAUSES);
6139 : }
6140 :
6141 :
6142 : match
6143 31 : gfc_match_omp_parallel_loop (void)
6144 : {
6145 31 : return match_omp (EXEC_OMP_PARALLEL_LOOP,
6146 31 : OMP_PARALLEL_CLAUSES | OMP_LOOP_CLAUSES);
6147 : }
6148 :
6149 :
6150 : match
6151 16 : gfc_match_omp_target_parallel_loop (void)
6152 : {
6153 16 : return match_omp (EXEC_OMP_TARGET_PARALLEL_LOOP,
6154 16 : (OMP_TARGET_CLAUSES | OMP_PARALLEL_CLAUSES
6155 16 : | OMP_LOOP_CLAUSES));
6156 : }
6157 :
6158 :
6159 : match
6160 101 : gfc_match_omp_error (void)
6161 : {
6162 101 : locus loc = gfc_current_locus;
6163 101 : match m = match_omp (EXEC_OMP_ERROR, OMP_ERROR_CLAUSES);
6164 101 : if (m != MATCH_YES)
6165 : return m;
6166 :
6167 82 : gfc_omp_clauses *c = new_st.ext.omp_clauses;
6168 82 : if (c->severity == OMP_SEVERITY_UNSET)
6169 45 : c->severity = OMP_SEVERITY_FATAL;
6170 82 : if (new_st.ext.omp_clauses->at == OMP_AT_EXECUTION)
6171 : return MATCH_YES;
6172 37 : if (c->message
6173 37 : && (!gfc_resolve_expr (c->message)
6174 16 : || c->message->ts.type != BT_CHARACTER
6175 14 : || c->message->ts.kind != gfc_default_character_kind
6176 13 : || c->message->rank != 0))
6177 : {
6178 4 : gfc_error ("MESSAGE clause at %L requires a scalar default-kind "
6179 : "CHARACTER expression",
6180 4 : &new_st.ext.omp_clauses->message->where);
6181 4 : return MATCH_ERROR;
6182 : }
6183 33 : if (c->message && !gfc_is_constant_expr (c->message))
6184 : {
6185 2 : gfc_error ("Constant character expression required in MESSAGE clause "
6186 2 : "at %L", &new_st.ext.omp_clauses->message->where);
6187 2 : return MATCH_ERROR;
6188 : }
6189 31 : if (c->message)
6190 : {
6191 10 : const char *msg = G_("$OMP ERROR encountered at %L: %s");
6192 10 : gcc_assert (c->message->expr_type == EXPR_CONSTANT);
6193 10 : gfc_charlen_t slen = c->message->value.character.length;
6194 10 : int i = gfc_validate_kind (BT_CHARACTER, gfc_default_character_kind,
6195 : false);
6196 10 : size_t size = slen * gfc_character_kinds[i].bit_size / 8;
6197 10 : unsigned char *s = XCNEWVAR (unsigned char, size + 1);
6198 10 : gfc_encode_character (gfc_default_character_kind, slen,
6199 10 : c->message->value.character.string,
6200 : (unsigned char *) s, size);
6201 10 : s[size] = '\0';
6202 10 : if (c->severity == OMP_SEVERITY_WARNING)
6203 6 : gfc_warning_now (0, msg, &loc, s);
6204 : else
6205 4 : gfc_error_now (msg, &loc, s);
6206 10 : free (s);
6207 : }
6208 : else
6209 : {
6210 21 : const char *msg = G_("$OMP ERROR encountered at %L");
6211 21 : if (c->severity == OMP_SEVERITY_WARNING)
6212 7 : gfc_warning_now (0, msg, &loc);
6213 : else
6214 14 : gfc_error_now (msg, &loc);
6215 : }
6216 : return MATCH_YES;
6217 : }
6218 :
6219 : match
6220 86 : gfc_match_omp_flush (void)
6221 : {
6222 86 : gfc_omp_namelist *list = NULL;
6223 86 : gfc_omp_clauses *c = NULL;
6224 86 : gfc_gobble_whitespace ();
6225 86 : enum gfc_omp_memorder mo = OMP_MEMORDER_UNSET;
6226 86 : if (gfc_match_omp_eos () == MATCH_NO && gfc_peek_ascii_char () != '(')
6227 : {
6228 14 : if (gfc_match ("seq_cst") == MATCH_YES)
6229 : mo = OMP_MEMORDER_SEQ_CST;
6230 11 : else if (gfc_match ("acq_rel") == MATCH_YES)
6231 : mo = OMP_MEMORDER_ACQ_REL;
6232 8 : else if (gfc_match ("release") == MATCH_YES)
6233 : mo = OMP_MEMORDER_RELEASE;
6234 5 : else if (gfc_match ("acquire") == MATCH_YES)
6235 : mo = OMP_MEMORDER_ACQUIRE;
6236 : else
6237 : {
6238 2 : gfc_error ("Expected SEQ_CST, AQC_REL, RELEASE, or ACQUIRE at %C");
6239 2 : return MATCH_ERROR;
6240 : }
6241 12 : c = gfc_get_omp_clauses ();
6242 12 : c->memorder = mo;
6243 : }
6244 84 : gfc_match_omp_variable_list (" (", &list, true);
6245 84 : if (list && mo != OMP_MEMORDER_UNSET)
6246 : {
6247 4 : gfc_error ("List specified together with memory order clause in FLUSH "
6248 : "directive at %C");
6249 4 : gfc_free_omp_namelist (list, OMP_LIST_NONE);
6250 4 : gfc_free_omp_clauses (c);
6251 4 : return MATCH_ERROR;
6252 : }
6253 80 : if (gfc_match_omp_eos () != MATCH_YES)
6254 : {
6255 0 : gfc_error ("Unexpected junk after $OMP FLUSH statement at %C");
6256 0 : gfc_free_omp_namelist (list, OMP_LIST_NONE);
6257 0 : gfc_free_omp_clauses (c);
6258 0 : return MATCH_ERROR;
6259 : }
6260 80 : new_st.op = EXEC_OMP_FLUSH;
6261 80 : new_st.ext.omp_namelist = list;
6262 80 : new_st.ext.omp_clauses = c;
6263 80 : return MATCH_YES;
6264 : }
6265 :
6266 :
6267 : match
6268 188 : gfc_match_omp_declare_simd (void)
6269 : {
6270 188 : locus where = gfc_current_locus;
6271 188 : gfc_symbol *proc_name;
6272 188 : gfc_omp_clauses *c;
6273 188 : gfc_omp_declare_simd *ods;
6274 188 : bool needs_space = false;
6275 :
6276 188 : switch (gfc_match (" ( "))
6277 : {
6278 144 : case MATCH_YES:
6279 144 : if (gfc_match_symbol (&proc_name, /* host assoc = */ true) != MATCH_YES
6280 144 : || gfc_match (" ) ") != MATCH_YES)
6281 0 : return MATCH_ERROR;
6282 : break;
6283 44 : case MATCH_NO: proc_name = NULL; needs_space = true; break;
6284 : case MATCH_ERROR: return MATCH_ERROR;
6285 : }
6286 :
6287 188 : if (gfc_match_omp_clauses (&c, OMP_DECLARE_SIMD_CLAUSES, true,
6288 : needs_space) != MATCH_YES)
6289 : return MATCH_ERROR;
6290 :
6291 183 : if (gfc_current_ns->is_block_data)
6292 : {
6293 1 : gfc_free_omp_clauses (c);
6294 1 : return MATCH_YES;
6295 : }
6296 :
6297 182 : ods = gfc_get_omp_declare_simd ();
6298 182 : ods->where = where;
6299 182 : ods->proc_name = proc_name;
6300 182 : ods->clauses = c;
6301 182 : ods->next = gfc_current_ns->omp_declare_simd;
6302 182 : gfc_current_ns->omp_declare_simd = ods;
6303 182 : return MATCH_YES;
6304 : }
6305 :
6306 :
6307 : /* Find a matching "!$omp declare mapper" for typespec TS in symtree ST. */
6308 :
6309 : gfc_omp_udm *
6310 30 : gfc_omp_udm_find (gfc_symtree *st, gfc_typespec *ts)
6311 : {
6312 30 : gfc_omp_udm *omp_udm;
6313 :
6314 30 : if (st == NULL)
6315 : return NULL;
6316 :
6317 14 : gfc_symbol *dt = (ts->type == BT_CLASS
6318 0 : ? CLASS_DATA (ts->u.derived)->ts.u.derived
6319 : : ts->u.derived);
6320 15 : for (omp_udm = st->n.omp_udm; omp_udm; omp_udm = omp_udm->next)
6321 : {
6322 5 : if (dt == omp_udm->ts.u.derived)
6323 : return omp_udm;
6324 : /* Special case for comparing derived types across namespaces. If the
6325 : true names and module names are the same and the module name is
6326 : nonnull, then they are equal. */
6327 1 : if (dt->module && omp_udm->ts.u.derived->module
6328 1 : && strcmp (dt->name, omp_udm->ts.u.derived->name) == 0
6329 1 : && strcmp (dt->module, omp_udm->ts.u.derived->module) == 0)
6330 : return omp_udm;
6331 : }
6332 :
6333 : return NULL;
6334 : }
6335 :
6336 :
6337 : /* Match !$omp declare mapper([ mapper-identifier : ] type :: var) clauses-list */
6338 :
6339 : match
6340 28 : gfc_match_omp_declare_mapper (void)
6341 : {
6342 28 : match m;
6343 28 : gfc_typespec ts;
6344 28 : char mapper_id[GFC_MAX_SYMBOL_LEN + 1];
6345 28 : char var[GFC_MAX_SYMBOL_LEN + 1];
6346 28 : gfc_namespace *mapper_ns = NULL;
6347 28 : gfc_symtree *var_st;
6348 28 : gfc_symtree *st;
6349 28 : gfc_omp_udm *omp_udm = NULL, *prev_udm = NULL;
6350 28 : locus where = gfc_current_locus;
6351 :
6352 28 : if (gfc_match_char ('(') != MATCH_YES)
6353 : {
6354 1 : gfc_error ("Expected %<(%> at %C");
6355 1 : return MATCH_ERROR;
6356 : }
6357 :
6358 27 : locus old_locus = gfc_current_locus;
6359 :
6360 27 : m = gfc_match (" %n : ", mapper_id);
6361 :
6362 27 : if (m == MATCH_ERROR)
6363 : return MATCH_ERROR;
6364 :
6365 : /* As a special case, a mapper named "default" and an unnamed mapper are
6366 : both the default mapper for a given type. */
6367 27 : if (strcmp (mapper_id, "default") == 0)
6368 0 : mapper_id[0] = '\0';
6369 :
6370 27 : if (gfc_peek_ascii_char () == ':')
6371 : {
6372 : /* If we see '::', the user did not name the mapper, and instead we just
6373 : saw the type. So backtrack and try parsing as a type instead. */
6374 14 : mapper_id[0] = '\0';
6375 14 : gfc_current_locus = old_locus;
6376 : }
6377 27 : old_locus = gfc_current_locus;
6378 :
6379 27 : m = gfc_match_type_spec (&ts);
6380 27 : if (m != MATCH_YES)
6381 : {
6382 4 : gfc_error ("Expected either a type name at %L or a map-type "
6383 : "identifier, a colon, or a type name", &old_locus);
6384 4 : return MATCH_ERROR;
6385 : }
6386 :
6387 23 : if (ts.type != BT_DERIVED)
6388 : {
6389 1 : gfc_error ("!$OMP DECLARE MAPPER with non-derived type at %L", &old_locus);
6390 1 : return MATCH_ERROR;
6391 : }
6392 :
6393 22 : if (gfc_match (" :: ") != MATCH_YES)
6394 : {
6395 0 : gfc_error ("Expected %<::%> at %C");
6396 0 : return MATCH_ERROR;
6397 : }
6398 :
6399 22 : if (gfc_match_name (var) != MATCH_YES)
6400 : {
6401 1 : gfc_error ("Expected variable name at %C");
6402 1 : return MATCH_ERROR;
6403 : }
6404 :
6405 21 : if (gfc_match_char (')') != MATCH_YES)
6406 : {
6407 2 : gfc_error ("Expected %<)%> at %C");
6408 2 : return MATCH_ERROR;
6409 : }
6410 :
6411 19 : st = gfc_find_symtree (gfc_current_ns->omp_udm_root, mapper_id);
6412 :
6413 : /* Now we need to set up a new namespace, and create a new sym_tree for our
6414 : dummy variable so we can use it in the following list of mapping
6415 : clauses. */
6416 :
6417 19 : gfc_current_ns = mapper_ns = gfc_get_namespace (gfc_current_ns, 1);
6418 19 : mapper_ns->proc_name = mapper_ns->parent->proc_name;
6419 19 : mapper_ns->omp_udm_ns = 1;
6420 :
6421 19 : gfc_get_sym_tree (var, mapper_ns, &var_st, false);
6422 19 : var_st->n.sym->ts = ts;
6423 19 : var_st->n.sym->attr.omp_udm_artificial_var = 1;
6424 19 : var_st->n.sym->attr.flavor = FL_VARIABLE;
6425 19 : gfc_commit_symbols ();
6426 :
6427 19 : gfc_omp_clauses *clauses = NULL;
6428 :
6429 19 : m = gfc_match_omp_clauses (&clauses, omp_mask (OMP_CLAUSE_MAP), true, true,
6430 : false, false, OMP_MAP_UNSET);
6431 19 : if (m != MATCH_YES)
6432 1 : goto failure;
6433 :
6434 18 : omp_udm = gfc_get_omp_udm ();
6435 18 : omp_udm->next = NULL;
6436 18 : omp_udm->where = where;
6437 18 : omp_udm->mapper_id = gfc_get_string ("%s", mapper_id);
6438 18 : omp_udm->ts = ts;
6439 18 : omp_udm->var_sym = var_st->n.sym;
6440 18 : omp_udm->mapper_ns = mapper_ns;
6441 18 : omp_udm->clauses = clauses;
6442 :
6443 18 : gfc_current_ns = mapper_ns->parent;
6444 :
6445 18 : prev_udm = gfc_omp_udm_find (st, &ts);
6446 18 : if (prev_udm)
6447 : {
6448 2 : if (mapper_id[0])
6449 1 : gfc_error ("Redefinition of !$OMP DECLARE MAPPER at %L for type %qs with id %qs",
6450 : &where, gfc_typename (&ts), mapper_id);
6451 : else
6452 1 : gfc_error ("Redefinition of !$OMP DECLARE MAPPER at %L for type %qs",
6453 : &where, gfc_typename (&ts));
6454 2 : inform (gfc_get_location (&prev_udm->where),
6455 : "Previous !$OMP DECLARE MAPPER here");
6456 2 : return MATCH_ERROR;
6457 : }
6458 16 : else if (st)
6459 : {
6460 0 : omp_udm->next = st->n.omp_udm;
6461 0 : st->n.omp_udm = omp_udm;
6462 : }
6463 : else
6464 : {
6465 16 : st = gfc_new_symtree (&gfc_current_ns->omp_udm_root, mapper_id);
6466 16 : st->n.omp_udm = omp_udm;
6467 : }
6468 :
6469 : return MATCH_YES;
6470 :
6471 1 : failure:
6472 1 : if (mapper_ns)
6473 1 : gfc_current_ns = mapper_ns->parent;
6474 1 : gfc_free_omp_udm (omp_udm);
6475 :
6476 1 : return MATCH_ERROR;
6477 : }
6478 :
6479 : /* For 'declare reduction', matches either the combiner or initializer
6480 : expression, either can be an assignment of 'omp_sym1 = ...'
6481 : or a subroutine call, i.e. 'subroutine-name(argument-list)'. */
6482 :
6483 : static bool
6484 922 : match_udr_expr (gfc_symtree *omp_sym1, gfc_symtree *omp_sym2)
6485 : {
6486 922 : match m;
6487 922 : locus old_loc = gfc_current_locus;
6488 922 : char sname[GFC_MAX_SYMBOL_LEN + 1];
6489 922 : gfc_symbol *sym;
6490 922 : gfc_namespace *ns = gfc_current_ns;
6491 922 : gfc_expr *lvalue = NULL, *rvalue = NULL;
6492 922 : gfc_symtree *st;
6493 922 : gfc_actual_arglist *arglist;
6494 :
6495 922 : m = gfc_match (" %v =", &lvalue);
6496 922 : if (m != MATCH_YES)
6497 210 : gfc_current_locus = old_loc;
6498 : else
6499 : {
6500 712 : m = gfc_match (" %e )", &rvalue);
6501 712 : if (m == MATCH_YES)
6502 : {
6503 702 : ns->code = gfc_get_code (EXEC_ASSIGN);
6504 702 : ns->code->expr1 = lvalue;
6505 702 : ns->code->expr2 = rvalue;
6506 702 : ns->code->loc = old_loc;
6507 702 : return true;
6508 : }
6509 :
6510 10 : gfc_current_locus = old_loc;
6511 10 : gfc_free_expr (lvalue);
6512 : }
6513 :
6514 220 : m = gfc_match (" %n", sname);
6515 220 : if (m != MATCH_YES)
6516 4 : goto syntax;
6517 :
6518 216 : if (strcmp (sname, omp_sym1->name) == 0
6519 203 : || strcmp (sname, omp_sym2->name) == 0)
6520 14 : goto syntax;
6521 :
6522 202 : gfc_current_ns = ns->parent;
6523 202 : if (gfc_get_ha_sym_tree (sname, &st))
6524 0 : goto syntax;
6525 :
6526 202 : sym = st->n.sym;
6527 202 : if (sym->attr.flavor != FL_PROCEDURE
6528 74 : && sym->attr.flavor != FL_UNKNOWN)
6529 1 : goto syntax;
6530 :
6531 201 : if (!sym->attr.generic
6532 191 : && !sym->attr.subroutine
6533 73 : && !sym->attr.function)
6534 : {
6535 73 : if (!(sym->attr.external && !sym->attr.referenced))
6536 : {
6537 : /* ...create a symbol in this scope... */
6538 73 : if (sym->ns != gfc_current_ns
6539 73 : && gfc_get_sym_tree (sname, NULL, &st, false) == 1)
6540 0 : goto syntax;
6541 :
6542 73 : if (sym != st->n.sym)
6543 73 : sym = st->n.sym;
6544 : }
6545 :
6546 : /* ...and then to try to make the symbol into a subroutine. */
6547 73 : if (!gfc_add_subroutine (&sym->attr, sym->name, NULL))
6548 0 : goto syntax;
6549 : }
6550 :
6551 201 : gfc_set_sym_referenced (sym);
6552 201 : gfc_gobble_whitespace ();
6553 201 : if (gfc_peek_ascii_char () != '(')
6554 6 : goto syntax;
6555 :
6556 195 : gfc_current_ns = ns;
6557 195 : m = gfc_match_actual_arglist (1, &arglist);
6558 195 : if (m != MATCH_YES)
6559 0 : goto syntax;
6560 :
6561 195 : if (gfc_match_char (')') != MATCH_YES)
6562 0 : goto syntax;
6563 :
6564 195 : gfc_clear_error ();
6565 195 : ns->code = gfc_get_code (EXEC_CALL);
6566 195 : ns->code->symtree = st;
6567 195 : ns->code->ext.actual = arglist;
6568 195 : ns->code->loc = old_loc;
6569 195 : return true;
6570 25 : syntax:
6571 25 : gfc_clear_error ();
6572 25 : gfc_error ("Expected either %<%s = expr%> or %<subroutine-name(argument-list)"
6573 : "%> followed by %<)%> at %L", omp_sym1->name, &old_loc);
6574 25 : return false;
6575 : }
6576 :
6577 : static bool
6578 1203 : gfc_omp_udr_predef (gfc_omp_reduction_op rop, const char *name,
6579 : gfc_typespec *ts, const char **n)
6580 : {
6581 1203 : if (!gfc_numeric_ts (ts) && ts->type != BT_LOGICAL)
6582 : return false;
6583 :
6584 673 : switch (rop)
6585 : {
6586 19 : case OMP_REDUCTION_PLUS:
6587 19 : case OMP_REDUCTION_MINUS:
6588 19 : case OMP_REDUCTION_TIMES:
6589 19 : return ts->type != BT_LOGICAL;
6590 12 : case OMP_REDUCTION_AND:
6591 12 : case OMP_REDUCTION_OR:
6592 12 : case OMP_REDUCTION_EQV:
6593 12 : case OMP_REDUCTION_NEQV:
6594 12 : return ts->type == BT_LOGICAL;
6595 641 : case OMP_REDUCTION_USER:
6596 641 : if (name[0] != '.' && (ts->type == BT_INTEGER || ts->type == BT_REAL))
6597 : {
6598 569 : gfc_symbol *sym;
6599 :
6600 569 : gfc_find_symbol (name, NULL, 1, &sym);
6601 569 : if (sym != NULL)
6602 : {
6603 93 : if (sym->attr.intrinsic)
6604 0 : *n = sym->name;
6605 93 : else if ((sym->attr.flavor != FL_UNKNOWN
6606 81 : && sym->attr.flavor != FL_PROCEDURE)
6607 69 : || sym->attr.external
6608 54 : || sym->attr.generic
6609 54 : || sym->attr.entry
6610 54 : || sym->attr.result
6611 54 : || sym->attr.dummy
6612 54 : || sym->attr.subroutine
6613 50 : || sym->attr.pointer
6614 50 : || sym->attr.target
6615 50 : || sym->attr.cray_pointer
6616 50 : || sym->attr.cray_pointee
6617 50 : || (sym->attr.proc != PROC_UNKNOWN
6618 0 : && sym->attr.proc != PROC_INTRINSIC)
6619 50 : || sym->attr.if_source != IFSRC_UNKNOWN
6620 50 : || sym == sym->ns->proc_name)
6621 43 : *n = NULL;
6622 : else
6623 50 : *n = sym->name;
6624 : }
6625 : else
6626 476 : *n = name;
6627 569 : if (*n
6628 526 : && (strcmp (*n, "max") == 0 || strcmp (*n, "min") == 0))
6629 56 : return true;
6630 531 : else if (*n
6631 488 : && ts->type == BT_INTEGER
6632 402 : && (strcmp (*n, "iand") == 0
6633 396 : || strcmp (*n, "ior") == 0
6634 390 : || strcmp (*n, "ieor") == 0))
6635 : return true;
6636 : }
6637 : break;
6638 : default:
6639 : break;
6640 : }
6641 : return false;
6642 : }
6643 :
6644 : gfc_omp_udr *
6645 666 : gfc_omp_udr_find (gfc_symtree *st, gfc_typespec *ts)
6646 : {
6647 666 : gfc_omp_udr *omp_udr;
6648 :
6649 666 : if (st == NULL)
6650 : return NULL;
6651 :
6652 112 : gfc_symbol *dt = NULL;
6653 112 : if (ts->type == BT_DERIVED || ts->type == BT_CLASS)
6654 25 : dt = (ts->type == BT_CLASS
6655 0 : ? CLASS_DATA (ts->u.derived)->ts.u.derived : ts->u.derived);
6656 260 : for (omp_udr = st->n.omp_udr; omp_udr; omp_udr = omp_udr->next)
6657 161 : if (omp_udr->ts.type == ts->type
6658 91 : || (dt && omp_udr->ts.type == BT_DERIVED))
6659 : {
6660 70 : if (dt && omp_udr->ts.type == BT_DERIVED)
6661 : {
6662 15 : gfc_symbol *dtu = omp_udr->ts.u.derived;
6663 15 : if (dt == dtu)
6664 : return omp_udr;
6665 : /* Special case for comparing derived types across namespaces. If
6666 : the true names and module names are the same and the module name
6667 : is nonnull, then they are equal. */
6668 7 : if (dt->module && dtu->module
6669 1 : && strcmp (dt->name, dtu->name) == 0
6670 1 : && strcmp (dt->module, dtu->module) == 0)
6671 : return omp_udr;
6672 : }
6673 55 : else if (omp_udr->ts.kind == ts->kind)
6674 : {
6675 20 : if (omp_udr->ts.type == BT_CHARACTER)
6676 : {
6677 17 : if (omp_udr->ts.u.cl->length == NULL
6678 15 : || ts->u.cl->length == NULL)
6679 : return omp_udr;
6680 15 : if (omp_udr->ts.u.cl->length->expr_type != EXPR_CONSTANT)
6681 : return omp_udr;
6682 15 : if (ts->u.cl->length->expr_type != EXPR_CONSTANT)
6683 : return omp_udr;
6684 15 : if (omp_udr->ts.u.cl->length->ts.type != BT_INTEGER)
6685 : return omp_udr;
6686 15 : if (ts->u.cl->length->ts.type != BT_INTEGER)
6687 : return omp_udr;
6688 15 : if (gfc_compare_expr (omp_udr->ts.u.cl->length,
6689 : ts->u.cl->length, INTRINSIC_EQ) != 0)
6690 15 : continue;
6691 : }
6692 3 : return omp_udr;
6693 : }
6694 : }
6695 : return NULL;
6696 : }
6697 :
6698 : match
6699 587 : gfc_match_omp_declare_reduction (void)
6700 : {
6701 587 : match m;
6702 587 : gfc_intrinsic_op op;
6703 587 : char name[GFC_MAX_SYMBOL_LEN + 3];
6704 587 : auto_vec<gfc_typespec, 5> tss;
6705 587 : gfc_typespec ts;
6706 587 : unsigned int i;
6707 587 : gfc_symtree *st;
6708 587 : locus where = gfc_current_locus;
6709 587 : locus end_loc = gfc_current_locus;
6710 587 : bool end_loc_set = false;
6711 587 : gfc_omp_reduction_op rop = OMP_REDUCTION_NONE;
6712 :
6713 587 : if (gfc_match_char ('(') != MATCH_YES)
6714 : {
6715 4 : gfc_error ("Expected %<(%> at %C");
6716 4 : return MATCH_ERROR;
6717 : }
6718 :
6719 583 : m = gfc_match (" %o : ", &op);
6720 583 : if (m == MATCH_ERROR)
6721 : return MATCH_ERROR;
6722 583 : if (m == MATCH_YES)
6723 : {
6724 142 : snprintf (name, sizeof name, "operator %s", gfc_op2string (op));
6725 142 : rop = (gfc_omp_reduction_op) op;
6726 : }
6727 : else
6728 : {
6729 441 : m = gfc_match_defined_op_name (name + 1, 1);
6730 441 : if (m == MATCH_ERROR)
6731 : return MATCH_ERROR;
6732 440 : if (m == MATCH_YES)
6733 : {
6734 41 : name[0] = '.';
6735 41 : strcat (name, ".");
6736 41 : if (gfc_match (" : ") != MATCH_YES)
6737 : {
6738 0 : gfc_error ("Expected %<:%> at %C");
6739 0 : return MATCH_ERROR;
6740 : }
6741 : }
6742 : else
6743 : {
6744 399 : if (gfc_match (" %n : ", name) != MATCH_YES)
6745 : {
6746 4 : gfc_error ("Expected an identfifier or operator as reduction "
6747 : "identifier followed by a colon at %C");
6748 4 : return MATCH_ERROR;
6749 : }
6750 : }
6751 : rop = OMP_REDUCTION_USER;
6752 : }
6753 :
6754 578 : m = gfc_match_type_spec (&ts);
6755 578 : if (m != MATCH_YES)
6756 : {
6757 4 : gfc_error ("Expected type spec at %C");
6758 4 : return MATCH_ERROR;
6759 : }
6760 : /* Treat len=: the same as len=*. */
6761 574 : if (ts.type == BT_CHARACTER)
6762 61 : ts.deferred = false;
6763 574 : tss.safe_push (ts);
6764 :
6765 1189 : while (gfc_match_char (',') == MATCH_YES)
6766 : {
6767 42 : m = gfc_match_type_spec (&ts);
6768 42 : if (m != MATCH_YES)
6769 : {
6770 1 : gfc_error ("Expected type spec at %C");
6771 1 : return MATCH_ERROR;
6772 : }
6773 41 : tss.safe_push (ts);
6774 : }
6775 573 : if (gfc_match_char (':') != MATCH_YES)
6776 : {
6777 6 : gfc_error ("Expected %<:%> or %<,%> at %C");
6778 6 : return MATCH_ERROR;
6779 : }
6780 :
6781 567 : st = gfc_find_symtree (gfc_current_ns->omp_udr_root, name);
6782 1111 : for (i = 0; i < tss.length (); i++)
6783 : {
6784 603 : gfc_symtree *omp_out, *omp_in;
6785 603 : gfc_symtree *omp_priv = NULL, *omp_orig = NULL;
6786 603 : gfc_namespace *combiner_ns, *initializer_ns = NULL;
6787 603 : gfc_omp_udr *prev_udr, *omp_udr;
6788 603 : const char *predef_name = NULL;
6789 :
6790 603 : omp_udr = gfc_get_omp_udr ();
6791 603 : omp_udr->name = gfc_get_string ("%s", name);
6792 603 : omp_udr->rop = rop;
6793 603 : omp_udr->ts = tss[i];
6794 603 : omp_udr->where = where;
6795 :
6796 603 : gfc_current_ns = combiner_ns = gfc_get_namespace (gfc_current_ns, 1);
6797 603 : combiner_ns->proc_name = combiner_ns->parent->proc_name;
6798 :
6799 603 : gfc_get_sym_tree ("omp_out", combiner_ns, &omp_out, false);
6800 603 : gfc_get_sym_tree ("omp_in", combiner_ns, &omp_in, false);
6801 603 : combiner_ns->omp_udr_ns = 1;
6802 603 : omp_out->n.sym->ts = tss[i];
6803 603 : omp_in->n.sym->ts = tss[i];
6804 603 : omp_out->n.sym->attr.omp_udr_artificial_var = 1;
6805 603 : omp_in->n.sym->attr.omp_udr_artificial_var = 1;
6806 603 : omp_out->n.sym->attr.flavor = FL_VARIABLE;
6807 603 : omp_in->n.sym->attr.flavor = FL_VARIABLE;
6808 603 : gfc_commit_symbols ();
6809 603 : omp_udr->combiner_ns = combiner_ns;
6810 603 : omp_udr->omp_out = omp_out->n.sym;
6811 603 : omp_udr->omp_in = omp_in->n.sym;
6812 :
6813 603 : locus old_loc = gfc_current_locus;
6814 :
6815 603 : if (!match_udr_expr (omp_out, omp_in))
6816 : {
6817 19 : syntax:
6818 59 : gfc_current_ns = combiner_ns->parent;
6819 59 : gfc_undo_symbols ();
6820 59 : gfc_free_omp_udr (omp_udr);
6821 59 : return MATCH_ERROR;
6822 : }
6823 :
6824 584 : if (gfc_match (" initializer ( ") == MATCH_YES)
6825 : {
6826 319 : gfc_current_ns = combiner_ns->parent;
6827 319 : initializer_ns = gfc_get_namespace (gfc_current_ns, 1);
6828 319 : gfc_current_ns = initializer_ns;
6829 319 : initializer_ns->proc_name = initializer_ns->parent->proc_name;
6830 :
6831 319 : gfc_get_sym_tree ("omp_priv", initializer_ns, &omp_priv, false);
6832 319 : gfc_get_sym_tree ("omp_orig", initializer_ns, &omp_orig, false);
6833 319 : initializer_ns->omp_udr_ns = 1;
6834 319 : omp_priv->n.sym->ts = tss[i];
6835 319 : omp_orig->n.sym->ts = tss[i];
6836 319 : omp_priv->n.sym->attr.omp_udr_artificial_var = 1;
6837 319 : omp_orig->n.sym->attr.omp_udr_artificial_var = 1;
6838 319 : omp_priv->n.sym->attr.flavor = FL_VARIABLE;
6839 319 : omp_orig->n.sym->attr.flavor = FL_VARIABLE;
6840 319 : gfc_commit_symbols ();
6841 319 : omp_udr->initializer_ns = initializer_ns;
6842 319 : omp_udr->omp_priv = omp_priv->n.sym;
6843 319 : omp_udr->omp_orig = omp_orig->n.sym;
6844 :
6845 319 : if (!match_udr_expr (omp_priv, omp_orig))
6846 6 : goto syntax;
6847 : }
6848 :
6849 578 : gfc_current_ns = combiner_ns->parent;
6850 578 : if (!end_loc_set)
6851 : {
6852 542 : end_loc_set = true;
6853 542 : end_loc = gfc_current_locus;
6854 : }
6855 578 : gfc_current_locus = old_loc;
6856 :
6857 578 : prev_udr = gfc_omp_udr_find (st, &tss[i]);
6858 578 : if (gfc_omp_udr_predef (rop, name, &tss[i], &predef_name)
6859 : /* Don't error on !$omp declare reduction (min : integer : ...)
6860 : just yet, there could be integer :: min afterwards,
6861 : making it valid. When the UDR is resolved, we'll get
6862 : to it again. */
6863 578 : && (rop != OMP_REDUCTION_USER || name[0] == '.'))
6864 : {
6865 27 : if (predef_name)
6866 0 : gfc_error_now ("Redefinition of predefined %qs in "
6867 : "!$OMP DECLARE REDUCTION at %L",
6868 : predef_name, &where);
6869 : else
6870 27 : gfc_error_now ("Redefinition of predefined %qs in "
6871 : "!$OMP DECLARE REDUCTION at %L", name, &where);
6872 27 : goto syntax;
6873 : }
6874 551 : else if (prev_udr)
6875 : {
6876 7 : gfc_error_now ("Redefinition of %qs in !$OMP DECLARE REDUCTION at %L",
6877 : name, &where);
6878 7 : inform (gfc_get_location (&prev_udr->where),
6879 : "Previous !$OMP DECLARE REDUCTION");
6880 7 : goto syntax;
6881 : }
6882 544 : else if (st)
6883 : {
6884 98 : omp_udr->next = st->n.omp_udr;
6885 98 : st->n.omp_udr = omp_udr;
6886 : }
6887 : else
6888 : {
6889 446 : st = gfc_new_symtree (&gfc_current_ns->omp_udr_root, name);
6890 446 : st->n.omp_udr = omp_udr;
6891 : }
6892 : }
6893 :
6894 508 : if (end_loc_set)
6895 : {
6896 508 : gfc_current_locus = end_loc;
6897 508 : if (gfc_match_omp_eos () != MATCH_YES)
6898 : {
6899 4 : gfc_error ("Unexpected junk at %C");
6900 4 : return MATCH_ERROR;
6901 : }
6902 : return MATCH_YES;
6903 : }
6904 : return MATCH_ERROR;
6905 587 : }
6906 :
6907 :
6908 : match
6909 472 : gfc_match_omp_declare_target (void)
6910 : {
6911 472 : locus old_loc;
6912 472 : match m;
6913 472 : gfc_omp_clauses *c = NULL;
6914 472 : enum gfc_omp_list_type list;
6915 472 : gfc_omp_namelist *n;
6916 472 : gfc_symbol *s;
6917 :
6918 472 : old_loc = gfc_current_locus;
6919 :
6920 472 : if (gfc_current_ns->proc_name
6921 472 : && gfc_match_omp_eos () == MATCH_YES)
6922 : {
6923 138 : if (!gfc_add_omp_declare_target (&gfc_current_ns->proc_name->attr,
6924 138 : gfc_current_ns->proc_name->name,
6925 : &old_loc))
6926 0 : goto cleanup;
6927 : return MATCH_YES;
6928 : }
6929 :
6930 334 : if (gfc_current_ns->proc_name
6931 334 : && gfc_current_ns->proc_name->attr.if_source == IFSRC_IFBODY)
6932 : {
6933 2 : gfc_error ("Only the !$OMP DECLARE TARGET form without "
6934 : "clauses is allowed in interface block at %C");
6935 2 : goto cleanup;
6936 : }
6937 :
6938 332 : m = gfc_match (" (");
6939 332 : if (m == MATCH_YES)
6940 : {
6941 86 : c = gfc_get_omp_clauses ();
6942 86 : gfc_current_locus = old_loc;
6943 86 : m = gfc_match_omp_to_link (" (", &c->lists[OMP_LIST_ENTER]);
6944 86 : if (m != MATCH_YES)
6945 0 : goto syntax;
6946 86 : if (gfc_match_omp_eos () != MATCH_YES)
6947 : {
6948 0 : gfc_error ("Unexpected junk after !$OMP DECLARE TARGET at %C");
6949 0 : goto cleanup;
6950 : }
6951 : }
6952 246 : else if (gfc_match_omp_clauses (&c, OMP_DECLARE_TARGET_CLAUSES) != MATCH_YES)
6953 : return MATCH_ERROR;
6954 :
6955 326 : gfc_buffer_error (false);
6956 :
6957 326 : static const enum gfc_omp_list_type to_enter_link_lists[]
6958 : = { OMP_LIST_TO, OMP_LIST_ENTER, OMP_LIST_LINK, OMP_LIST_LOCAL };
6959 1630 : for (size_t listn = 0; listn < ARRAY_SIZE (to_enter_link_lists)
6960 1630 : && (list = to_enter_link_lists[listn], true); ++listn)
6961 1849 : for (n = c->lists[list]; n; n = n->next)
6962 545 : if (n->sym)
6963 504 : n->sym->mark = 0;
6964 41 : else if (n->u.common->head)
6965 41 : n->u.common->head->mark = 0;
6966 :
6967 326 : if (c->device_type == OMP_DEVICE_TYPE_UNSET)
6968 258 : c->device_type = OMP_DEVICE_TYPE_ANY;
6969 1304 : for (size_t listn = 0; listn < ARRAY_SIZE (to_enter_link_lists)
6970 1630 : && (list = to_enter_link_lists[listn], true); ++listn)
6971 1849 : for (n = c->lists[list]; n; n = n->next)
6972 545 : if (n->sym)
6973 : {
6974 504 : if (n->sym->attr.in_common)
6975 1 : gfc_error_now ("OMP DECLARE TARGET variable at %L is an "
6976 : "element of a COMMON block", &n->where);
6977 503 : else if (n->sym->attr.omp_groupprivate && list != OMP_LIST_LOCAL)
6978 12 : gfc_error_now ("List item %qs at %L not appear in the %qs clause "
6979 : "as it was previously specified in a GROUPPRIVATE "
6980 : "directive", n->sym->name, &n->where,
6981 : list == OMP_LIST_LINK
6982 5 : ? "link" : list == OMP_LIST_TO ? "to" : "enter");
6983 496 : else if (n->sym->mark)
6984 9 : gfc_error_now ("Variable at %L mentioned multiple times in "
6985 : "clauses of the same OMP DECLARE TARGET directive",
6986 : &n->where);
6987 487 : else if ((n->sym->attr.omp_declare_target_link
6988 482 : || n->sym->attr.omp_declare_target_local)
6989 : && list != OMP_LIST_LINK
6990 7 : && list != OMP_LIST_LOCAL)
6991 1 : gfc_error_now ("OMP DECLARE TARGET variable at %L previously "
6992 : "mentioned in %s clause and later in %s clause",
6993 : &n->where,
6994 : n->sym->attr.omp_declare_target_link ? "LINK"
6995 : : "LOCAL",
6996 : list == OMP_LIST_TO ? "TO" : "ENTER");
6997 486 : else if (n->sym->attr.omp_declare_target
6998 14 : && (list == OMP_LIST_LINK || list == OMP_LIST_LOCAL))
6999 1 : gfc_error_now ("OMP DECLARE TARGET variable at %L previously "
7000 : "mentioned in TO or ENTER clause and later in "
7001 : "%s clause", &n->where,
7002 : list == OMP_LIST_LINK ? "LINK" : "LOCAL");
7003 : else
7004 : {
7005 485 : if (list == OMP_LIST_TO || list == OMP_LIST_ENTER)
7006 446 : gfc_add_omp_declare_target (&n->sym->attr, n->sym->name,
7007 : &n->sym->declared_at);
7008 485 : if (list == OMP_LIST_LINK)
7009 30 : gfc_add_omp_declare_target_link (&n->sym->attr, n->sym->name,
7010 30 : &n->sym->declared_at);
7011 485 : if (list == OMP_LIST_LOCAL)
7012 9 : gfc_add_omp_declare_target_local (&n->sym->attr, n->sym->name,
7013 9 : &n->sym->declared_at);
7014 : }
7015 504 : if (n->sym->attr.omp_device_type != OMP_DEVICE_TYPE_UNSET
7016 36 : && n->sym->attr.omp_device_type != c->device_type)
7017 : {
7018 12 : const char *dt = "any";
7019 12 : if (n->sym->attr.omp_device_type == OMP_DEVICE_TYPE_NOHOST)
7020 : dt = "nohost";
7021 8 : else if (n->sym->attr.omp_device_type == OMP_DEVICE_TYPE_HOST)
7022 4 : dt = "host";
7023 12 : if (n->sym->attr.omp_groupprivate)
7024 1 : gfc_error_now ("List item %qs at %L set in previous OMP "
7025 : "GROUPPRIVATE directive to the different "
7026 : "DEVICE_TYPE %qs", n->sym->name, &n->where, dt);
7027 : else
7028 11 : gfc_error_now ("List item %qs at %L set in previous OMP "
7029 : "DECLARE TARGET directive to the different "
7030 : "DEVICE_TYPE %qs", n->sym->name, &n->where, dt);
7031 : }
7032 504 : n->sym->attr.omp_device_type = c->device_type;
7033 504 : if (c->indirect && c->device_type != OMP_DEVICE_TYPE_ANY)
7034 : {
7035 1 : gfc_error_now ("DEVICE_TYPE must be ANY when used with INDIRECT "
7036 : "at %L", &n->where);
7037 1 : c->indirect = 0;
7038 : }
7039 504 : n->sym->attr.omp_declare_target_indirect = c->indirect;
7040 504 : if (list == OMP_LIST_LINK && c->device_type == OMP_DEVICE_TYPE_NOHOST)
7041 3 : gfc_error_now ("List item %qs at %L set with NOHOST specified may "
7042 : "not appear in a LINK clause", n->sym->name,
7043 : &n->where);
7044 504 : n->sym->mark = 1;
7045 : }
7046 : else /* common block */
7047 : {
7048 41 : if (n->u.common->omp_groupprivate && list != OMP_LIST_LOCAL)
7049 7 : gfc_error_now ("Common block %</%s/%> at %L not appear in the %qs "
7050 : "clause as it was previously specified in a "
7051 : "GROUPPRIVATE directive",
7052 7 : n->u.common->name, &n->where,
7053 : list == OMP_LIST_LINK
7054 5 : ? "link" : list == OMP_LIST_TO ? "to" : "enter");
7055 34 : else if (n->u.common->head && n->u.common->head->mark)
7056 4 : gfc_error_now ("Common block %</%s/%> at %L mentioned multiple "
7057 : "times in clauses of the same OMP DECLARE TARGET "
7058 4 : "directive", n->u.common->name, &n->where);
7059 30 : else if ((n->u.common->omp_declare_target_link
7060 26 : || n->u.common->omp_declare_target_local)
7061 : && list != OMP_LIST_LINK
7062 6 : && list != OMP_LIST_LOCAL)
7063 2 : gfc_error_now ("Common block %</%s/%> at %L previously mentioned "
7064 : "in %s clause and later in %s clause",
7065 1 : n->u.common->name, &n->where,
7066 : n->u.common->omp_declare_target_link ? "LINK"
7067 : : "LOCAL",
7068 : list == OMP_LIST_TO ? "TO" : "ENTER");
7069 29 : else if (n->u.common->omp_declare_target
7070 4 : && (list == OMP_LIST_LINK || list == OMP_LIST_LOCAL))
7071 1 : gfc_error_now ("Common block %</%s/%> at %L previously mentioned "
7072 : "in TO or ENTER clause and later in %s clause",
7073 1 : n->u.common->name, &n->where,
7074 : list == OMP_LIST_LINK ? "LINK" : "LOCAL");
7075 41 : if (n->u.common->omp_device_type != OMP_DEVICE_TYPE_UNSET
7076 21 : && n->u.common->omp_device_type != c->device_type)
7077 : {
7078 1 : const char *dt = "any";
7079 1 : if (n->u.common->omp_device_type == OMP_DEVICE_TYPE_NOHOST)
7080 : dt = "nohost";
7081 0 : else if (n->u.common->omp_device_type == OMP_DEVICE_TYPE_HOST)
7082 0 : dt = "host";
7083 1 : if (n->u.common->omp_groupprivate)
7084 1 : gfc_error_now ("Common block %</%s/%> at %L set in previous OMP "
7085 : "GROUPPRIVATE directive to the different "
7086 1 : "DEVICE_TYPE %qs", n->u.common->name, &n->where,
7087 : dt);
7088 : else
7089 0 : gfc_error_now ("Common block %</%s/%> at %L set in previous OMP "
7090 : "DECLARE TARGET directive to the different "
7091 0 : "DEVICE_TYPE %qs", n->u.common->name, &n->where,
7092 : dt);
7093 : }
7094 41 : n->u.common->omp_device_type = c->device_type;
7095 :
7096 41 : if (c->indirect && c->device_type != OMP_DEVICE_TYPE_ANY)
7097 : {
7098 0 : gfc_error_now ("DEVICE_TYPE must be ANY when used with INDIRECT "
7099 : "at %L", &n->where);
7100 0 : c->indirect = 0;
7101 : }
7102 41 : if (list == OMP_LIST_LINK && c->device_type == OMP_DEVICE_TYPE_NOHOST)
7103 1 : gfc_error_now ("Common block %</%s/%> at %L set with NOHOST "
7104 : "specified may not appear in a LINK clause",
7105 1 : n->u.common->name, &n->where);
7106 :
7107 41 : if (list == OMP_LIST_TO || list == OMP_LIST_ENTER)
7108 21 : n->u.common->omp_declare_target = 1;
7109 41 : if (list == OMP_LIST_LINK)
7110 15 : n->u.common->omp_declare_target_link = 1;
7111 41 : if (list == OMP_LIST_LOCAL)
7112 5 : n->u.common->omp_declare_target_local = 1;
7113 :
7114 110 : for (s = n->u.common->head; s; s = s->common_next)
7115 : {
7116 69 : s->mark = 1;
7117 69 : if (list == OMP_LIST_TO || list == OMP_LIST_ENTER)
7118 33 : gfc_add_omp_declare_target (&s->attr, s->name, &n->where);
7119 69 : if (list == OMP_LIST_LINK)
7120 31 : gfc_add_omp_declare_target_link (&s->attr, s->name, &n->where);
7121 69 : if (list == OMP_LIST_LOCAL)
7122 5 : gfc_add_omp_declare_target_local (&s->attr, s->name, &n->where);
7123 69 : s->attr.omp_device_type = c->device_type;
7124 69 : s->attr.omp_declare_target_indirect = c->indirect;
7125 : }
7126 : }
7127 326 : if ((c->device_type || c->indirect)
7128 326 : && !c->lists[OMP_LIST_ENTER]
7129 151 : && !c->lists[OMP_LIST_TO]
7130 47 : && !c->lists[OMP_LIST_LINK]
7131 10 : && !c->lists[OMP_LIST_LOCAL])
7132 2 : gfc_warning_now (OPT_Wopenmp,
7133 : "OMP DECLARE TARGET directive at %L with only "
7134 : "DEVICE_TYPE or INDIRECT clauses is ignored",
7135 : &old_loc);
7136 :
7137 326 : gfc_buffer_error (true);
7138 :
7139 326 : if (c)
7140 326 : gfc_free_omp_clauses (c);
7141 326 : return MATCH_YES;
7142 :
7143 0 : syntax:
7144 0 : gfc_error ("Syntax error in !$OMP DECLARE TARGET list at %C");
7145 :
7146 2 : cleanup:
7147 2 : gfc_current_locus = old_loc;
7148 2 : if (c)
7149 0 : gfc_free_omp_clauses (c);
7150 : return MATCH_ERROR;
7151 : }
7152 :
7153 : /* Skip over and ignore trait-property-extensions.
7154 :
7155 : trait-property-extension :
7156 : trait-property-name
7157 : identifier (trait-property-extension[, trait-property-extension[, ...]])
7158 : constant integer expression
7159 : */
7160 :
7161 : static match gfc_ignore_trait_property_extension_list (void);
7162 :
7163 : static match
7164 7 : gfc_ignore_trait_property_extension (void)
7165 : {
7166 7 : char buf[GFC_MAX_SYMBOL_LEN + 1];
7167 7 : gfc_expr *expr;
7168 :
7169 : /* Identifier form of trait-property name, possibly followed by
7170 : a list of (recursive) trait-property-extensions. */
7171 7 : if (gfc_match_name (buf) == MATCH_YES)
7172 : {
7173 0 : if (gfc_match (" (") == MATCH_YES)
7174 0 : return gfc_ignore_trait_property_extension_list ();
7175 : return MATCH_YES;
7176 : }
7177 :
7178 : /* Literal constant. */
7179 7 : if (gfc_match_literal_constant (&expr, 0) == MATCH_YES)
7180 : return MATCH_YES;
7181 :
7182 : /* FIXME: constant integer expressions. */
7183 0 : gfc_error ("Expected trait-property-extension at %C");
7184 0 : return MATCH_ERROR;
7185 : }
7186 :
7187 : static match
7188 5 : gfc_ignore_trait_property_extension_list (void)
7189 : {
7190 9 : while (1)
7191 : {
7192 7 : if (gfc_ignore_trait_property_extension () != MATCH_YES)
7193 : return MATCH_ERROR;
7194 7 : if (gfc_match (" ,") == MATCH_YES)
7195 2 : continue;
7196 5 : if (gfc_match (" )") == MATCH_YES)
7197 : return MATCH_YES;
7198 0 : gfc_error ("expected %<)%> at %C");
7199 0 : return MATCH_ERROR;
7200 : }
7201 : }
7202 :
7203 :
7204 : match
7205 110 : gfc_match_omp_interop (void)
7206 : {
7207 110 : return match_omp (EXEC_OMP_INTEROP, OMP_INTEROP_CLAUSES);
7208 : }
7209 :
7210 :
7211 : /* OpenMP 5.0:
7212 :
7213 : trait-selector:
7214 : trait-selector-name[([trait-score:]trait-property[,trait-property[,...]])]
7215 :
7216 : trait-score:
7217 : score(score-expression) */
7218 :
7219 : static match
7220 637 : gfc_match_omp_context_selector (gfc_omp_set_selector *oss)
7221 : {
7222 775 : do
7223 : {
7224 775 : char selector[GFC_MAX_SYMBOL_LEN + 1];
7225 :
7226 775 : if (gfc_match_name (selector) != MATCH_YES)
7227 : {
7228 2 : gfc_error ("expected trait selector name at %C");
7229 39 : return MATCH_ERROR;
7230 : }
7231 :
7232 773 : gfc_omp_selector *os = gfc_get_omp_selector ();
7233 773 : if (oss->code == OMP_TRAIT_SET_CONSTRUCT
7234 335 : && !strcmp (selector, "do"))
7235 48 : os->code = OMP_TRAIT_CONSTRUCT_FOR;
7236 725 : else if (oss->code == OMP_TRAIT_SET_CONSTRUCT
7237 287 : && !strcmp (selector, "for"))
7238 1 : os->code = OMP_TRAIT_INVALID;
7239 : else
7240 724 : os->code = omp_lookup_ts_code (oss->code, selector);
7241 773 : os->next = oss->trait_selectors;
7242 773 : oss->trait_selectors = os;
7243 :
7244 773 : if (os->code == OMP_TRAIT_INVALID)
7245 : {
7246 18 : gfc_warning (OPT_Wopenmp,
7247 : "unknown selector %qs for context selector set %qs "
7248 : "at %C",
7249 18 : selector, omp_tss_map[oss->code]);
7250 18 : if (gfc_match (" (") == MATCH_YES
7251 18 : && gfc_ignore_trait_property_extension_list () != MATCH_YES)
7252 : return MATCH_ERROR;
7253 18 : if (gfc_match (" ,") == MATCH_YES)
7254 1 : continue;
7255 598 : break;
7256 : }
7257 :
7258 755 : enum omp_tp_type property_kind = omp_ts_map[os->code].tp_type;
7259 755 : bool allow_score = omp_ts_map[os->code].allow_score;
7260 :
7261 755 : if (gfc_match (" (") == MATCH_YES)
7262 : {
7263 431 : if (property_kind == OMP_TRAIT_PROPERTY_NONE)
7264 : {
7265 6 : gfc_error ("selector %qs does not accept any properties at %C",
7266 : selector);
7267 6 : return MATCH_ERROR;
7268 : }
7269 :
7270 425 : if (gfc_match (" score") == MATCH_YES)
7271 : {
7272 63 : if (!allow_score)
7273 : {
7274 10 : gfc_error ("%<score%> cannot be specified in traits "
7275 : "in the %qs trait-selector-set at %C",
7276 10 : omp_tss_map[oss->code]);
7277 10 : return MATCH_ERROR;
7278 : }
7279 53 : if (gfc_match (" (") != MATCH_YES)
7280 : {
7281 0 : gfc_error ("expected %<(%> at %C");
7282 0 : return MATCH_ERROR;
7283 : }
7284 53 : if (gfc_match_expr (&os->score) != MATCH_YES)
7285 : return MATCH_ERROR;
7286 :
7287 52 : if (gfc_match (" )") != MATCH_YES)
7288 : {
7289 0 : gfc_error ("expected %<)%> at %C");
7290 0 : return MATCH_ERROR;
7291 : }
7292 :
7293 52 : if (gfc_match (" :") != MATCH_YES)
7294 : {
7295 0 : gfc_error ("expected : at %C");
7296 0 : return MATCH_ERROR;
7297 : }
7298 : }
7299 :
7300 414 : gfc_omp_trait_property *otp = gfc_get_omp_trait_property ();
7301 414 : otp->property_kind = property_kind;
7302 414 : otp->next = os->properties;
7303 414 : os->properties = otp;
7304 :
7305 414 : switch (property_kind)
7306 : {
7307 25 : case OMP_TRAIT_PROPERTY_ID:
7308 25 : {
7309 25 : char buf[GFC_MAX_SYMBOL_LEN + 1];
7310 25 : if (gfc_match_name (buf) == MATCH_YES)
7311 : {
7312 24 : otp->name = XNEWVEC (char, strlen (buf) + 1);
7313 24 : strcpy (otp->name, buf);
7314 : }
7315 : else
7316 : {
7317 1 : gfc_error ("expected identifier at %C");
7318 1 : free (otp);
7319 1 : os->properties = nullptr;
7320 1 : return MATCH_ERROR;
7321 : }
7322 : }
7323 24 : break;
7324 290 : case OMP_TRAIT_PROPERTY_NAME_LIST:
7325 343 : do
7326 : {
7327 290 : char buf[GFC_MAX_SYMBOL_LEN + 1];
7328 290 : if (gfc_match_name (buf) == MATCH_YES)
7329 : {
7330 170 : otp->name = XNEWVEC (char, strlen (buf) + 1);
7331 170 : strcpy (otp->name, buf);
7332 170 : otp->is_name = true;
7333 : }
7334 120 : else if (gfc_match_literal_constant (&otp->expr, 0)
7335 : != MATCH_YES
7336 120 : || otp->expr->ts.type != BT_CHARACTER)
7337 : {
7338 5 : gfc_error ("expected identifier or string literal "
7339 : "at %C");
7340 5 : free (otp);
7341 5 : os->properties = nullptr;
7342 5 : return MATCH_ERROR;
7343 : }
7344 :
7345 285 : if (gfc_match (" ,") == MATCH_YES)
7346 : {
7347 53 : otp = gfc_get_omp_trait_property ();
7348 53 : otp->property_kind = property_kind;
7349 53 : otp->next = os->properties;
7350 53 : os->properties = otp;
7351 : }
7352 : else
7353 : break;
7354 53 : }
7355 : while (1);
7356 232 : break;
7357 137 : case OMP_TRAIT_PROPERTY_DEV_NUM_EXPR:
7358 137 : case OMP_TRAIT_PROPERTY_BOOL_EXPR:
7359 137 : if (gfc_match_expr (&otp->expr) != MATCH_YES)
7360 : {
7361 3 : gfc_error ("expected expression at %C");
7362 3 : free (otp);
7363 3 : os->properties = nullptr;
7364 3 : return MATCH_ERROR;
7365 : }
7366 : break;
7367 15 : case OMP_TRAIT_PROPERTY_CLAUSE_LIST:
7368 15 : {
7369 15 : if (os->code == OMP_TRAIT_CONSTRUCT_SIMD)
7370 : {
7371 15 : gfc_matching_omp_context_selector = true;
7372 15 : if (gfc_match_omp_clauses (&otp->clauses,
7373 15 : OMP_DECLARE_SIMD_CLAUSES,
7374 : true, false, false)
7375 : != MATCH_YES)
7376 : {
7377 1 : gfc_matching_omp_context_selector = false;
7378 1 : gfc_error ("expected simd clause at %C");
7379 1 : return MATCH_ERROR;
7380 : }
7381 14 : gfc_matching_omp_context_selector = false;
7382 : }
7383 0 : else if (os->code == OMP_TRAIT_IMPLEMENTATION_REQUIRES)
7384 : {
7385 : /* FIXME: The "requires" selector was added in OpenMP 5.1.
7386 : Currently only the now-deprecated syntax
7387 : from OpenMP 5.0 is supported.
7388 : TODO: When implementing, update modules.cc as well. */
7389 0 : sorry_at (gfc_get_location (&gfc_current_locus),
7390 : "%<requires%> selector is not supported yet");
7391 0 : return MATCH_ERROR;
7392 : }
7393 : else
7394 0 : gcc_unreachable ();
7395 14 : break;
7396 : }
7397 0 : default:
7398 0 : gcc_unreachable ();
7399 : }
7400 :
7401 404 : if (gfc_match (" )") != MATCH_YES)
7402 : {
7403 2 : gfc_error ("expected %<)%> at %C");
7404 2 : return MATCH_ERROR;
7405 : }
7406 : }
7407 324 : else if (property_kind != OMP_TRAIT_PROPERTY_NONE
7408 324 : && property_kind != OMP_TRAIT_PROPERTY_CLAUSE_LIST
7409 8 : && property_kind != OMP_TRAIT_PROPERTY_EXTENSION)
7410 : {
7411 8 : if (gfc_match (" (") != MATCH_YES)
7412 : {
7413 8 : gfc_error ("expected %<(%> at %C");
7414 8 : return MATCH_ERROR;
7415 : }
7416 : }
7417 :
7418 718 : if (gfc_match (" ,") != MATCH_YES)
7419 : break;
7420 : }
7421 : while (1);
7422 :
7423 598 : return MATCH_YES;
7424 : }
7425 :
7426 : /* OpenMP 5.0:
7427 :
7428 : trait-set-selector[,trait-set-selector[,...]]
7429 :
7430 : trait-set-selector:
7431 : trait-set-selector-name = { trait-selector[, trait-selector[, ...]] }
7432 :
7433 : trait-set-selector-name:
7434 : constructor
7435 : device
7436 : implementation
7437 : user */
7438 :
7439 : static match
7440 577 : gfc_match_omp_context_selector_specification (gfc_omp_set_selector **oss_head)
7441 : {
7442 713 : do
7443 : {
7444 645 : match m;
7445 645 : char buf[GFC_MAX_SYMBOL_LEN + 1];
7446 645 : enum omp_tss_code set = OMP_TRAIT_SET_INVALID;
7447 :
7448 645 : m = gfc_match_name (buf);
7449 645 : if (m == MATCH_YES)
7450 643 : set = omp_lookup_tss_code (buf);
7451 :
7452 643 : if (set == OMP_TRAIT_SET_INVALID)
7453 : {
7454 5 : gfc_error ("expected context selector set name at %C");
7455 47 : return MATCH_ERROR;
7456 : }
7457 :
7458 640 : m = gfc_match (" =");
7459 640 : if (m != MATCH_YES)
7460 : {
7461 1 : gfc_error ("expected %<=%> at %C");
7462 1 : return MATCH_ERROR;
7463 : }
7464 :
7465 639 : m = gfc_match (" {");
7466 639 : if (m != MATCH_YES)
7467 : {
7468 2 : gfc_error ("expected %<{%> at %C");
7469 2 : return MATCH_ERROR;
7470 : }
7471 :
7472 637 : gfc_omp_set_selector *oss = gfc_get_omp_set_selector ();
7473 637 : oss->next = *oss_head;
7474 637 : oss->code = set;
7475 637 : *oss_head = oss;
7476 :
7477 637 : if (gfc_match_omp_context_selector (oss) != MATCH_YES)
7478 : return MATCH_ERROR;
7479 :
7480 598 : m = gfc_match (" }");
7481 598 : if (m != MATCH_YES)
7482 : {
7483 0 : gfc_error ("expected %<}%> at %C");
7484 0 : return MATCH_ERROR;
7485 : }
7486 :
7487 598 : m = gfc_match (" ,");
7488 598 : if (m != MATCH_YES)
7489 : break;
7490 68 : }
7491 : while (1);
7492 :
7493 530 : return MATCH_YES;
7494 : }
7495 :
7496 :
7497 : match
7498 419 : gfc_match_omp_declare_variant (void)
7499 : {
7500 419 : char buf[GFC_MAX_SYMBOL_LEN + 1];
7501 :
7502 419 : if (gfc_match (" (") != MATCH_YES)
7503 : {
7504 2 : gfc_error ("expected %<(%> at %C");
7505 2 : return MATCH_ERROR;
7506 : }
7507 :
7508 417 : gfc_symtree *base_proc_st, *variant_proc_st;
7509 417 : if (gfc_match_name (buf) != MATCH_YES)
7510 : {
7511 2 : gfc_error ("expected name at %C");
7512 2 : return MATCH_ERROR;
7513 : }
7514 :
7515 415 : if (gfc_get_ha_sym_tree (buf, &base_proc_st))
7516 : return MATCH_ERROR;
7517 :
7518 415 : if (gfc_match (" :") == MATCH_YES)
7519 : {
7520 16 : if (gfc_match_name (buf) != MATCH_YES)
7521 : {
7522 0 : gfc_error ("expected variant name at %C");
7523 0 : return MATCH_ERROR;
7524 : }
7525 :
7526 16 : if (gfc_get_ha_sym_tree (buf, &variant_proc_st))
7527 : return MATCH_ERROR;
7528 : }
7529 : else
7530 : {
7531 : /* Base procedure not specified. */
7532 399 : variant_proc_st = base_proc_st;
7533 399 : base_proc_st = NULL;
7534 : }
7535 :
7536 415 : gfc_omp_declare_variant *odv;
7537 415 : odv = gfc_get_omp_declare_variant ();
7538 415 : odv->where = gfc_current_locus;
7539 415 : odv->variant_proc_symtree = variant_proc_st;
7540 415 : odv->adjust_args_list = NULL;
7541 415 : odv->base_proc_symtree = base_proc_st;
7542 415 : odv->next = NULL;
7543 415 : odv->error_p = false;
7544 :
7545 : /* Add the new declare variant to the end of the list. */
7546 415 : gfc_omp_declare_variant **prev_next = &gfc_current_ns->omp_declare_variant;
7547 555 : while (*prev_next)
7548 140 : prev_next = &((*prev_next)->next);
7549 415 : *prev_next = odv;
7550 :
7551 415 : if (gfc_match (" )") != MATCH_YES)
7552 : {
7553 1 : gfc_error ("expected %<)%> at %C");
7554 1 : return MATCH_ERROR;
7555 : }
7556 :
7557 414 : bool has_match = false, has_adjust_args = false, has_append_args = false;
7558 414 : bool error_p = false;
7559 414 : locus adjust_args_loc;
7560 414 : locus append_args_loc;
7561 :
7562 414 : gfc_gobble_whitespace ();
7563 414 : gfc_match_char (',');
7564 632 : for (;;)
7565 : {
7566 523 : gfc_gobble_whitespace ();
7567 :
7568 523 : enum clause
7569 : {
7570 : clause_match,
7571 : clause_adjust_args,
7572 : clause_append_args
7573 : } ccode;
7574 :
7575 523 : if (gfc_match ("match") == MATCH_YES)
7576 : ccode = clause_match;
7577 119 : else if (gfc_match ("adjust_args") == MATCH_YES)
7578 : {
7579 517 : ccode = clause_adjust_args;
7580 : adjust_args_loc = gfc_current_locus;
7581 : }
7582 38 : else if (gfc_match ("append_args") == MATCH_YES)
7583 : {
7584 517 : ccode = clause_append_args;
7585 : append_args_loc = gfc_current_locus;
7586 : }
7587 : else
7588 : {
7589 : error_p = true;
7590 : break;
7591 : }
7592 :
7593 517 : if (gfc_match (" ( ") != MATCH_YES)
7594 : {
7595 1 : gfc_error ("expected %<(%> at %C");
7596 1 : return MATCH_ERROR;
7597 : }
7598 :
7599 516 : if (ccode == clause_match)
7600 : {
7601 403 : if (has_match)
7602 : {
7603 1 : gfc_error ("%qs clause at %L specified more than once",
7604 : "match", &gfc_current_locus);
7605 1 : return MATCH_ERROR;
7606 : }
7607 402 : has_match = true;
7608 402 : if (gfc_match_omp_context_selector_specification (&odv->set_selectors)
7609 : != MATCH_YES)
7610 : return MATCH_ERROR;
7611 362 : if (gfc_match (" )") != MATCH_YES)
7612 : {
7613 0 : gfc_error ("expected %<)%> at %C");
7614 0 : return MATCH_ERROR;
7615 : }
7616 : }
7617 113 : else if (ccode == clause_adjust_args)
7618 : {
7619 81 : has_adjust_args = true;
7620 81 : bool need_device_ptr_p = false;
7621 81 : bool need_device_addr_p = false;
7622 81 : if (gfc_match ("nothing ") == MATCH_YES)
7623 : ;
7624 58 : else if (gfc_match ("need_device_ptr ") == MATCH_YES)
7625 : need_device_ptr_p = true;
7626 9 : else if (gfc_match ("need_device_addr ") == MATCH_YES)
7627 : need_device_addr_p = true;
7628 : else
7629 : {
7630 2 : gfc_error ("expected %<nothing%>, %<need_device_ptr%> or "
7631 : "%<need_device_addr%> at %C");
7632 2 : return MATCH_ERROR;
7633 : }
7634 79 : if (gfc_match (": ") != MATCH_YES)
7635 : {
7636 1 : gfc_error ("expected %<:%> at %C");
7637 1 : return MATCH_ERROR;
7638 : }
7639 : gfc_omp_namelist *tail = NULL;
7640 : bool need_range = false, have_range = false;
7641 125 : while (true)
7642 : {
7643 125 : gfc_omp_namelist *p = gfc_get_omp_namelist ();
7644 125 : p->where = gfc_current_locus;
7645 125 : p->u.adj_args.need_ptr = need_device_ptr_p;
7646 125 : p->u.adj_args.need_addr = need_device_addr_p;
7647 125 : if (tail)
7648 : {
7649 47 : tail->next = p;
7650 47 : tail = tail->next;
7651 : }
7652 : else
7653 : {
7654 78 : gfc_omp_namelist **q = &odv->adjust_args_list;
7655 78 : if (*q)
7656 : {
7657 50 : for (; (*q)->next; q = &(*q)->next)
7658 : ;
7659 28 : (*q)->next = p;
7660 : }
7661 : else
7662 50 : *q = p;
7663 : tail = p;
7664 : }
7665 125 : if (gfc_match (": ") == MATCH_YES)
7666 : {
7667 2 : if (have_range)
7668 : {
7669 0 : gfc_error ("unexpected %<:%> at %C");
7670 2 : return MATCH_ERROR;
7671 : }
7672 2 : p->u.adj_args.range_start = have_range = true;
7673 2 : need_range = false;
7674 49 : continue;
7675 : }
7676 123 : if (have_range && gfc_match (", ") == MATCH_YES)
7677 : {
7678 1 : have_range = false;
7679 1 : continue;
7680 : }
7681 122 : if (have_range && gfc_match (") ") == MATCH_YES)
7682 : break;
7683 121 : locus saved_loc = gfc_current_locus;
7684 :
7685 : /* Without ranges, only arg names or integer literals permitted;
7686 : handle literals here as gfc_match_expr simplifies the expr. */
7687 121 : if (gfc_match_literal_constant (&p->expr, true) == MATCH_YES)
7688 : {
7689 17 : gfc_gobble_whitespace ();
7690 17 : char c = gfc_peek_ascii_char ();
7691 17 : if (c != ')' && c != ',' && c != ':')
7692 : {
7693 1 : gfc_free_expr (p->expr);
7694 1 : p->expr = NULL;
7695 1 : gfc_current_locus = saved_loc;
7696 : }
7697 : }
7698 121 : if (!p->expr && gfc_match ("omp_num_args") == MATCH_YES)
7699 : {
7700 6 : if (!have_range)
7701 3 : p->u.adj_args.range_start = need_range = true;
7702 : else
7703 : need_range = false;
7704 :
7705 6 : locus saved_loc2 = gfc_current_locus;
7706 6 : gfc_gobble_whitespace ();
7707 6 : char c = gfc_peek_ascii_char ();
7708 6 : if (c == '+' || c == '-')
7709 : {
7710 5 : if (gfc_match ("+ %e", &p->expr) == MATCH_YES)
7711 1 : p->u.adj_args.omp_num_args_plus = true;
7712 4 : else if (gfc_match ("- %e", &p->expr) == MATCH_YES)
7713 4 : p->u.adj_args.omp_num_args_minus = true;
7714 0 : else if (!gfc_error_check ())
7715 : {
7716 0 : gfc_error ("expected constant integer expression "
7717 : "at %C");
7718 0 : p->u.adj_args.error_p = true;
7719 0 : return MATCH_ERROR;
7720 : }
7721 5 : p->where = gfc_get_location_range (&saved_loc, 1,
7722 : &saved_loc, 1,
7723 : &gfc_current_locus);
7724 : }
7725 : else
7726 : {
7727 1 : p->where = gfc_get_location_range (&saved_loc, 1,
7728 : &saved_loc, 1,
7729 : &saved_loc2);
7730 1 : p->u.adj_args.omp_num_args_plus = true;
7731 : }
7732 : }
7733 115 : else if (!p->expr)
7734 : {
7735 99 : match m = gfc_match_expr (&p->expr);
7736 99 : if (m != MATCH_YES)
7737 : {
7738 1 : gfc_error ("expected dummy parameter name, "
7739 : "%<omp_num_args%> or constant positive integer"
7740 : " at %C");
7741 1 : p->u.adj_args.error_p = true;
7742 1 : return MATCH_ERROR;
7743 : }
7744 98 : if (p->expr->expr_type == EXPR_CONSTANT && !have_range)
7745 98 : need_range = true; /* Constant expr but not literal. */
7746 98 : p->where = p->expr->where;
7747 : }
7748 : else
7749 16 : p->where = p->expr->where;
7750 120 : gfc_gobble_whitespace ();
7751 120 : match m = gfc_match (": ");
7752 120 : if (need_range && m != MATCH_YES)
7753 : {
7754 1 : gfc_error ("expected %<:%> at %C");
7755 1 : return MATCH_ERROR;
7756 : }
7757 119 : if (m == MATCH_YES)
7758 : {
7759 6 : p->u.adj_args.range_start = have_range = true;
7760 6 : need_range = false;
7761 6 : continue;
7762 : }
7763 113 : need_range = have_range = false;
7764 113 : if (gfc_match (", ") == MATCH_YES)
7765 38 : continue;
7766 75 : if (gfc_match (") ") == MATCH_YES)
7767 : break;
7768 : }
7769 : }
7770 32 : else if (ccode == clause_append_args)
7771 : {
7772 32 : if (has_append_args)
7773 : {
7774 1 : gfc_error ("%qs clause at %L specified more than once",
7775 : "append_args", &gfc_current_locus);
7776 1 : return MATCH_ERROR;
7777 : }
7778 56 : has_append_args = true;
7779 : gfc_omp_namelist *append_args_last = NULL;
7780 81 : do
7781 : {
7782 56 : gfc_gobble_whitespace ();
7783 56 : if (gfc_match ("interop ") != MATCH_YES)
7784 : {
7785 0 : gfc_error ("expected %<interop%> at %C");
7786 3 : return MATCH_ERROR;
7787 : }
7788 56 : if (gfc_match ("( ") != MATCH_YES)
7789 : {
7790 0 : gfc_error ("expected %<(%> at %C");
7791 0 : return MATCH_ERROR;
7792 : }
7793 :
7794 56 : bool target, targetsync;
7795 56 : char *type_str = NULL;
7796 56 : int type_str_len;
7797 56 : locus loc = gfc_current_locus;
7798 56 : if (gfc_parser_omp_clause_init_modifiers (target, targetsync,
7799 : &type_str, type_str_len,
7800 : false) == MATCH_ERROR)
7801 : return MATCH_ERROR;
7802 :
7803 54 : gfc_omp_namelist *n = gfc_get_omp_namelist();
7804 54 : n->where = loc;
7805 54 : n->u.init.target = target;
7806 54 : n->u.init.targetsync = targetsync;
7807 54 : n->u.init.len = type_str_len;
7808 54 : n->u2.init_interop = type_str;
7809 54 : if (odv->append_args_list)
7810 : {
7811 25 : append_args_last->next = n;
7812 25 : append_args_last = n;
7813 : }
7814 : else
7815 29 : append_args_last = odv->append_args_list = n;
7816 :
7817 54 : gfc_gobble_whitespace ();
7818 54 : if (gfc_match_char (',') == MATCH_YES)
7819 25 : continue;
7820 29 : if (gfc_match_char (')') == MATCH_YES)
7821 : break;
7822 1 : gfc_error ("Expected %<,%> or %<)%> at %C");
7823 1 : return MATCH_ERROR;
7824 : }
7825 : while (true);
7826 : }
7827 466 : gfc_gobble_whitespace ();
7828 466 : if (gfc_match_omp_eos () == MATCH_YES)
7829 : break;
7830 109 : gfc_match_char (',');
7831 109 : }
7832 :
7833 363 : if (error_p || (!has_match && !has_adjust_args && !has_append_args))
7834 : {
7835 6 : gfc_error ("expected %<match%>, %<adjust_args%> or %<append_args%> at %C");
7836 6 : return MATCH_ERROR;
7837 : }
7838 :
7839 357 : if (!has_match)
7840 : {
7841 3 : gfc_error ("expected %<match%> clause at %C");
7842 3 : return MATCH_ERROR;
7843 : }
7844 :
7845 : return MATCH_YES;
7846 : }
7847 :
7848 :
7849 : static match
7850 160 : match_omp_metadirective (bool begin_p)
7851 : {
7852 160 : locus old_loc = gfc_current_locus;
7853 160 : gfc_omp_variant *variants_head;
7854 160 : gfc_omp_variant **next_variant = &variants_head;
7855 160 : bool default_seen = false;
7856 :
7857 : /* Parse the context selectors. */
7858 656 : for (;;)
7859 : {
7860 408 : bool default_p = false;
7861 408 : gfc_omp_set_selector *selectors = NULL;
7862 :
7863 408 : gfc_gobble_whitespace ();
7864 408 : if (gfc_match_eos () == MATCH_YES)
7865 : break;
7866 266 : gfc_match_char (',');
7867 266 : gfc_gobble_whitespace ();
7868 :
7869 266 : locus variant_locus = gfc_current_locus;
7870 :
7871 266 : if (gfc_match ("default ( ") == MATCH_YES)
7872 : {
7873 82 : default_p = true;
7874 82 : gfc_warning (OPT_Wdeprecated_openmp,
7875 : "%<default%> clause with metadirective at %L "
7876 : "deprecated since OpenMP 5.2", &variant_locus);
7877 : }
7878 184 : else if (gfc_match ("otherwise ( ") == MATCH_YES)
7879 : default_p = true;
7880 177 : else if (gfc_match ("when ( ") != MATCH_YES)
7881 : {
7882 1 : gfc_error ("expected %<when%>, %<otherwise%>, or %<default%> at %C");
7883 1 : gfc_current_locus = old_loc;
7884 18 : return MATCH_ERROR;
7885 : }
7886 89 : if (default_p && default_seen)
7887 : {
7888 3 : gfc_error ("too many %<otherwise%> or %<default%> clauses "
7889 : "in %<metadirective%> at %C");
7890 3 : gfc_current_locus = old_loc;
7891 3 : return MATCH_ERROR;
7892 : }
7893 262 : else if (default_seen)
7894 : {
7895 1 : gfc_error ("%<otherwise%> or %<default%> clause "
7896 : "must appear last in %<metadirective%> at %C");
7897 1 : gfc_current_locus = old_loc;
7898 1 : return MATCH_ERROR;
7899 : }
7900 :
7901 261 : if (!default_p)
7902 : {
7903 175 : if (gfc_match_omp_context_selector_specification (&selectors)
7904 : != MATCH_YES)
7905 : return MATCH_ERROR;
7906 :
7907 168 : if (gfc_match (" : ") != MATCH_YES)
7908 : {
7909 1 : gfc_error ("expected %<:%> at %C");
7910 1 : gfc_current_locus = old_loc;
7911 1 : return MATCH_ERROR;
7912 : }
7913 :
7914 167 : gfc_commit_symbols ();
7915 : }
7916 :
7917 253 : gfc_matching_omp_context_selector = true;
7918 253 : gfc_statement directive = match_omp_directive ();
7919 253 : gfc_matching_omp_context_selector = false;
7920 :
7921 253 : if (is_omp_declarative_stmt (directive))
7922 0 : sorry_at (gfc_get_location (&gfc_current_locus),
7923 : "declarative directive variants are not supported");
7924 :
7925 253 : if (gfc_error_flag_test ())
7926 : {
7927 2 : gfc_current_locus = old_loc;
7928 2 : return MATCH_ERROR;
7929 : }
7930 :
7931 251 : if (gfc_match (" )") != MATCH_YES)
7932 : {
7933 0 : gfc_error ("Expected %<)%> at %C");
7934 0 : gfc_current_locus = old_loc;
7935 0 : return MATCH_ERROR;
7936 : }
7937 :
7938 251 : gfc_commit_symbols ();
7939 :
7940 251 : if (begin_p
7941 251 : && directive != ST_NONE
7942 251 : && gfc_omp_end_stmt (directive) == ST_NONE)
7943 : {
7944 3 : gfc_error ("variant directive used in OMP BEGIN METADIRECTIVE "
7945 : "at %C must have a corresponding end directive");
7946 3 : gfc_current_locus = old_loc;
7947 3 : return MATCH_ERROR;
7948 : }
7949 :
7950 248 : if (default_p)
7951 : default_seen = true;
7952 :
7953 248 : gfc_omp_variant *omv = gfc_get_omp_variant ();
7954 248 : omv->selectors = selectors;
7955 248 : omv->stmt = directive;
7956 248 : omv->where = variant_locus;
7957 :
7958 248 : if (directive == ST_NONE)
7959 : {
7960 : /* The directive was a 'nothing' directive. */
7961 15 : omv->code = gfc_get_code (EXEC_CONTINUE);
7962 15 : omv->code->ext.omp_clauses = NULL;
7963 : }
7964 : else
7965 : {
7966 233 : omv->code = gfc_get_code (new_st.op);
7967 233 : omv->code->ext.omp_clauses = new_st.ext.omp_clauses;
7968 : /* Prevent the OpenMP clauses from being freed via NEW_ST. */
7969 233 : new_st.ext.omp_clauses = NULL;
7970 : }
7971 :
7972 248 : *next_variant = omv;
7973 248 : next_variant = &omv->next;
7974 248 : }
7975 :
7976 142 : if (gfc_match_omp_eos () != MATCH_YES)
7977 : {
7978 0 : gfc_error ("Unexpected junk after OMP METADIRECTIVE at %C");
7979 0 : gfc_current_locus = old_loc;
7980 0 : return MATCH_ERROR;
7981 : }
7982 :
7983 : /* Add a 'default (nothing)' clause if no default is explicitly given. */
7984 142 : if (!default_seen)
7985 : {
7986 65 : gfc_omp_variant *omv = gfc_get_omp_variant ();
7987 65 : omv->stmt = ST_NONE;
7988 65 : omv->code = gfc_get_code (EXEC_CONTINUE);
7989 65 : omv->code->ext.omp_clauses = NULL;
7990 65 : omv->where = old_loc;
7991 65 : omv->selectors = NULL;
7992 :
7993 65 : *next_variant = omv;
7994 65 : next_variant = &omv->next;
7995 : }
7996 :
7997 142 : new_st.op = EXEC_OMP_METADIRECTIVE;
7998 142 : new_st.ext.omp_variants = variants_head;
7999 :
8000 142 : return MATCH_YES;
8001 : }
8002 :
8003 : match
8004 43 : gfc_match_omp_begin_metadirective (void)
8005 : {
8006 43 : return match_omp_metadirective (true);
8007 : }
8008 :
8009 : match
8010 117 : gfc_match_omp_metadirective (void)
8011 : {
8012 117 : return match_omp_metadirective (false);
8013 : }
8014 :
8015 : /* Match 'omp threadprivate' or 'omp groupprivate'. */
8016 : static match
8017 259 : gfc_match_omp_thread_group_private (bool is_groupprivate)
8018 : {
8019 259 : locus old_loc;
8020 259 : char n[GFC_MAX_SYMBOL_LEN+1];
8021 259 : gfc_symbol *sym;
8022 259 : match m;
8023 259 : gfc_symtree *st;
8024 259 : struct sym_loc_t { gfc_symbol *sym; gfc_common_head *com; locus loc; };
8025 259 : auto_vec<sym_loc_t> syms;
8026 :
8027 259 : old_loc = gfc_current_locus;
8028 :
8029 259 : m = gfc_match (" ( ");
8030 259 : if (m != MATCH_YES)
8031 : return m;
8032 :
8033 369 : for (;;)
8034 : {
8035 314 : locus sym_loc = gfc_current_locus;
8036 314 : m = gfc_match_symbol (&sym, 0);
8037 314 : switch (m)
8038 : {
8039 209 : case MATCH_YES:
8040 209 : if (sym->attr.in_common)
8041 0 : gfc_error_now ("%qs variable at %L is an element of a COMMON block",
8042 : is_groupprivate ? "groupprivate" : "threadprivate",
8043 : &sym_loc);
8044 209 : else if (!is_groupprivate
8045 209 : && !gfc_add_threadprivate (&sym->attr, sym->name, &sym_loc))
8046 16 : goto cleanup;
8047 207 : else if (is_groupprivate)
8048 : {
8049 30 : if (!gfc_add_omp_groupprivate (&sym->attr, sym->name, &sym_loc))
8050 4 : goto cleanup;
8051 26 : syms.safe_push ({sym, nullptr, sym_loc});
8052 : }
8053 203 : goto next_item;
8054 : case MATCH_NO:
8055 : break;
8056 0 : case MATCH_ERROR:
8057 0 : goto cleanup;
8058 : }
8059 :
8060 105 : m = gfc_match (" / %n /", n);
8061 105 : if (m == MATCH_ERROR)
8062 0 : goto cleanup;
8063 105 : if (m == MATCH_NO || n[0] == '\0')
8064 0 : goto syntax;
8065 :
8066 105 : st = gfc_find_symtree (gfc_current_ns->common_root, n);
8067 105 : if (st == NULL)
8068 : {
8069 2 : gfc_error ("COMMON block /%s/ not found at %L", n, &sym_loc);
8070 2 : goto cleanup;
8071 : }
8072 103 : syms.safe_push ({nullptr, st->n.common, sym_loc});
8073 103 : if (is_groupprivate)
8074 30 : st->n.common->omp_groupprivate = 1;
8075 : else
8076 73 : st->n.common->threadprivate = 1;
8077 236 : for (sym = st->n.common->head; sym; sym = sym->common_next)
8078 141 : if (!is_groupprivate
8079 141 : && !gfc_add_threadprivate (&sym->attr, sym->name, &sym_loc))
8080 3 : goto cleanup;
8081 138 : else if (is_groupprivate
8082 138 : && !gfc_add_omp_groupprivate (&sym->attr, sym->name, &sym_loc))
8083 5 : goto cleanup;
8084 :
8085 95 : next_item:
8086 298 : if (gfc_match_char (')') == MATCH_YES)
8087 : break;
8088 55 : if (gfc_match_char (',') != MATCH_YES)
8089 0 : goto syntax;
8090 55 : }
8091 :
8092 243 : if (is_groupprivate)
8093 : {
8094 39 : gfc_omp_clauses *c;
8095 39 : m = gfc_match_omp_clauses (&c, omp_mask (OMP_CLAUSE_DEVICE_TYPE));
8096 39 : if (m == MATCH_ERROR)
8097 0 : return MATCH_ERROR;
8098 :
8099 39 : if (c->device_type == OMP_DEVICE_TYPE_UNSET)
8100 19 : c->device_type = OMP_DEVICE_TYPE_ANY;
8101 :
8102 86 : for (size_t i = 0; i < syms.length (); i++)
8103 47 : if (syms[i].sym)
8104 : {
8105 24 : sym_loc_t &n = syms[i];
8106 24 : if (n.sym->attr.in_common)
8107 0 : gfc_error_now ("Variable %qs at %L is an element of a COMMON "
8108 : "block", n.sym->name, &n.loc);
8109 24 : else if (n.sym->attr.omp_declare_target
8110 23 : || n.sym->attr.omp_declare_target_link)
8111 2 : gfc_error_now ("List item %qs at %L implies OMP DECLARE TARGET "
8112 : "with the LOCAL clause, but it has been specified"
8113 : " with a different clause before",
8114 : n.sym->name, &n.loc);
8115 24 : if (n.sym->attr.omp_device_type != OMP_DEVICE_TYPE_UNSET
8116 5 : && n.sym->attr.omp_device_type != c->device_type)
8117 : {
8118 2 : const char *dt = "any";
8119 2 : if (n.sym->attr.omp_device_type == OMP_DEVICE_TYPE_HOST)
8120 : dt = "host";
8121 0 : else if (n.sym->attr.omp_device_type == OMP_DEVICE_TYPE_NOHOST)
8122 0 : dt = "nohost";
8123 2 : gfc_error_now ("List item %qs at %L set in previous OMP DECLARE "
8124 : "TARGET directive to the different DEVICE_TYPE %qs",
8125 : n.sym->name, &n.loc, dt);
8126 : }
8127 24 : gfc_add_omp_declare_target_local (&n.sym->attr, n.sym->name,
8128 : &n.loc);
8129 24 : n.sym->attr.omp_device_type = c->device_type;
8130 : }
8131 : else /* Common block. */
8132 : {
8133 23 : sym_loc_t &n = syms[i];
8134 23 : if (n.com->omp_declare_target
8135 22 : || n.com->omp_declare_target_link)
8136 2 : gfc_error_now ("List item %</%s/%> at %L implies OMP DECLARE "
8137 : "TARGET with the LOCAL clause, but it has been "
8138 : "specified with a different clause before",
8139 2 : n.com->name, &n.loc);
8140 23 : if (n.com->omp_device_type != OMP_DEVICE_TYPE_UNSET
8141 5 : && n.com->omp_device_type != c->device_type)
8142 : {
8143 2 : const char *dt = "any";
8144 2 : if (n.com->omp_device_type == OMP_DEVICE_TYPE_HOST)
8145 : dt = "host";
8146 0 : else if (n.com->omp_device_type == OMP_DEVICE_TYPE_NOHOST)
8147 0 : dt = "nohost";
8148 2 : gfc_error_now ("List item %qs at %L set in previous OMP DECLARE"
8149 : " TARGET directive to the different DEVICE_TYPE "
8150 2 : "%qs", n.com->name, &n.loc, dt);
8151 : }
8152 23 : n.com->omp_declare_target_local = 1;
8153 23 : n.com->omp_device_type = c->device_type;
8154 46 : for (gfc_symbol *s = n.com->head; s; s = s->common_next)
8155 : {
8156 23 : gfc_add_omp_declare_target_local (&s->attr, s->name, &n.loc);
8157 23 : s->attr.omp_device_type = c->device_type;
8158 : }
8159 : }
8160 39 : free (c);
8161 : }
8162 :
8163 243 : if (gfc_match_omp_eos () != MATCH_YES)
8164 : {
8165 0 : gfc_error ("Unexpected junk after OMP %s at %C",
8166 : is_groupprivate ? "GROUPPRIVATE" : "THREADPRIVATE");
8167 0 : goto cleanup;
8168 : }
8169 :
8170 : return MATCH_YES;
8171 :
8172 0 : syntax:
8173 0 : gfc_error ("Syntax error in !$OMP %s list at %C",
8174 : is_groupprivate ? "GROUPPRIVATE" : "THREADPRIVATE");
8175 :
8176 16 : cleanup:
8177 16 : gfc_current_locus = old_loc;
8178 16 : return MATCH_ERROR;
8179 259 : }
8180 :
8181 :
8182 : match
8183 48 : gfc_match_omp_groupprivate (void)
8184 : {
8185 48 : return gfc_match_omp_thread_group_private (true);
8186 : }
8187 :
8188 :
8189 : match
8190 211 : gfc_match_omp_threadprivate (void)
8191 : {
8192 211 : return gfc_match_omp_thread_group_private (false);
8193 : }
8194 :
8195 :
8196 : match
8197 2207 : gfc_match_omp_parallel (void)
8198 : {
8199 2207 : return match_omp (EXEC_OMP_PARALLEL, OMP_PARALLEL_CLAUSES);
8200 : }
8201 :
8202 :
8203 : match
8204 1203 : gfc_match_omp_parallel_do (void)
8205 : {
8206 1203 : return match_omp (EXEC_OMP_PARALLEL_DO,
8207 1203 : (OMP_PARALLEL_CLAUSES | OMP_DO_CLAUSES)
8208 1203 : & ~(omp_mask (OMP_CLAUSE_NOWAIT)));
8209 : }
8210 :
8211 :
8212 : match
8213 298 : gfc_match_omp_parallel_do_simd (void)
8214 : {
8215 298 : return match_omp (EXEC_OMP_PARALLEL_DO_SIMD,
8216 298 : (OMP_PARALLEL_CLAUSES | OMP_DO_CLAUSES | OMP_SIMD_CLAUSES)
8217 298 : & ~(omp_mask (OMP_CLAUSE_NOWAIT)));
8218 : }
8219 :
8220 :
8221 : match
8222 14 : gfc_match_omp_parallel_masked (void)
8223 : {
8224 14 : return match_omp (EXEC_OMP_PARALLEL_MASKED,
8225 14 : OMP_PARALLEL_CLAUSES | OMP_MASKED_CLAUSES);
8226 : }
8227 :
8228 : match
8229 10 : gfc_match_omp_parallel_masked_taskloop (void)
8230 : {
8231 10 : return match_omp (EXEC_OMP_PARALLEL_MASKED_TASKLOOP,
8232 10 : (OMP_PARALLEL_CLAUSES | OMP_MASKED_CLAUSES
8233 10 : | OMP_TASKLOOP_CLAUSES)
8234 10 : & ~(omp_mask (OMP_CLAUSE_IN_REDUCTION)));
8235 : }
8236 :
8237 : match
8238 13 : gfc_match_omp_parallel_masked_taskloop_simd (void)
8239 : {
8240 13 : return match_omp (EXEC_OMP_PARALLEL_MASKED_TASKLOOP_SIMD,
8241 13 : (OMP_PARALLEL_CLAUSES | OMP_MASKED_CLAUSES
8242 13 : | OMP_TASKLOOP_CLAUSES | OMP_SIMD_CLAUSES)
8243 13 : & ~(omp_mask (OMP_CLAUSE_IN_REDUCTION)));
8244 : }
8245 :
8246 : match
8247 14 : gfc_match_omp_parallel_master (void)
8248 : {
8249 14 : gfc_warning (OPT_Wdeprecated_openmp,
8250 : "%<master%> construct at %C deprecated since OpenMP 5.1, use "
8251 : "%<masked%>");
8252 14 : return match_omp (EXEC_OMP_PARALLEL_MASTER, OMP_PARALLEL_CLAUSES);
8253 : }
8254 :
8255 : match
8256 15 : gfc_match_omp_parallel_master_taskloop (void)
8257 : {
8258 15 : gfc_warning (OPT_Wdeprecated_openmp,
8259 : "%<master%> construct at %C deprecated since OpenMP 5.1, "
8260 : "use %<masked%>");
8261 15 : return match_omp (EXEC_OMP_PARALLEL_MASTER_TASKLOOP,
8262 15 : (OMP_PARALLEL_CLAUSES | OMP_TASKLOOP_CLAUSES)
8263 15 : & ~(omp_mask (OMP_CLAUSE_IN_REDUCTION)));
8264 : }
8265 :
8266 : match
8267 21 : gfc_match_omp_parallel_master_taskloop_simd (void)
8268 : {
8269 21 : gfc_warning (OPT_Wdeprecated_openmp,
8270 : "%<master%> construct at %C deprecated since OpenMP 5.1, "
8271 : "use %<masked%>");
8272 21 : return match_omp (EXEC_OMP_PARALLEL_MASTER_TASKLOOP_SIMD,
8273 21 : (OMP_PARALLEL_CLAUSES | OMP_TASKLOOP_CLAUSES
8274 21 : | OMP_SIMD_CLAUSES)
8275 21 : & ~(omp_mask (OMP_CLAUSE_IN_REDUCTION)));
8276 : }
8277 :
8278 : match
8279 59 : gfc_match_omp_parallel_sections (void)
8280 : {
8281 59 : return match_omp (EXEC_OMP_PARALLEL_SECTIONS,
8282 59 : (OMP_PARALLEL_CLAUSES | OMP_SECTIONS_CLAUSES)
8283 59 : & ~(omp_mask (OMP_CLAUSE_NOWAIT)));
8284 : }
8285 :
8286 :
8287 : match
8288 56 : gfc_match_omp_parallel_workshare (void)
8289 : {
8290 56 : return match_omp (EXEC_OMP_PARALLEL_WORKSHARE, OMP_PARALLEL_CLAUSES);
8291 : }
8292 :
8293 : void
8294 49895 : gfc_check_omp_requires (gfc_namespace *ns, int ref_omp_requires)
8295 : {
8296 49895 : const char *msg = G_("Program unit at %L has OpenMP device "
8297 : "constructs/routines but does not set !$OMP REQUIRES %s "
8298 : "but other program units do");
8299 49895 : if (ns->omp_target_seen
8300 1295 : && (ns->omp_requires & OMP_REQ_TARGET_MASK)
8301 1295 : != (ref_omp_requires & OMP_REQ_TARGET_MASK))
8302 : {
8303 6 : gcc_assert (ns->proc_name);
8304 6 : if ((ref_omp_requires & OMP_REQ_REVERSE_OFFLOAD)
8305 5 : && !(ns->omp_requires & OMP_REQ_REVERSE_OFFLOAD))
8306 4 : gfc_error (msg, &ns->proc_name->declared_at, "REVERSE_OFFLOAD");
8307 6 : if ((ref_omp_requires & OMP_REQ_UNIFIED_ADDRESS)
8308 1 : && !(ns->omp_requires & OMP_REQ_UNIFIED_ADDRESS))
8309 1 : gfc_error (msg, &ns->proc_name->declared_at, "UNIFIED_ADDRESS");
8310 6 : if ((ref_omp_requires & OMP_REQ_UNIFIED_SHARED_MEMORY)
8311 4 : && !(ns->omp_requires & OMP_REQ_UNIFIED_SHARED_MEMORY))
8312 2 : gfc_error (msg, &ns->proc_name->declared_at, "UNIFIED_SHARED_MEMORY");
8313 6 : if ((ref_omp_requires & OMP_REQ_SELF_MAPS)
8314 1 : && !(ns->omp_requires & OMP_REQ_UNIFIED_SHARED_MEMORY))
8315 1 : gfc_error (msg, &ns->proc_name->declared_at, "SELF_MAPS");
8316 : }
8317 49895 : }
8318 :
8319 : bool
8320 126 : gfc_omp_requires_add_clause (gfc_omp_requires_kind clause,
8321 : const char *clause_name, locus *loc,
8322 : const char *module_name)
8323 : {
8324 126 : gfc_namespace *prog_unit = gfc_current_ns;
8325 150 : while (prog_unit->parent)
8326 : {
8327 26 : if (gfc_state_stack->previous
8328 26 : && gfc_state_stack->previous->state == COMP_INTERFACE)
8329 : break;
8330 : /* A submodule namespace may have its parent set to the ancestor module
8331 : for host-association purposes. Do not escape the submodule boundary:
8332 : the submodule itself is the program unit for OMP REQUIRES purposes. */
8333 25 : if (prog_unit->proc_name
8334 25 : && prog_unit->proc_name->attr.flavor == FL_MODULE)
8335 : break;
8336 : prog_unit = prog_unit->parent;
8337 : }
8338 :
8339 : /* Requires added after use. */
8340 126 : if (prog_unit->omp_target_seen
8341 24 : && (clause & OMP_REQ_TARGET_MASK)
8342 24 : && !(prog_unit->omp_requires & clause))
8343 : {
8344 0 : if (module_name)
8345 0 : gfc_error ("!$OMP REQUIRES clause %qs specified via module %qs use "
8346 : "at %L comes after using a device construct/routine",
8347 : clause_name, module_name, loc);
8348 : else
8349 0 : gfc_error ("!$OMP REQUIRES clause %qs specified at %L comes after "
8350 : "using a device construct/routine", clause_name, loc);
8351 0 : return false;
8352 : }
8353 :
8354 : /* Overriding atomic_default_mem_order clause value. */
8355 126 : if ((clause & OMP_REQ_ATOMIC_MEM_ORDER_MASK)
8356 34 : && (prog_unit->omp_requires & OMP_REQ_ATOMIC_MEM_ORDER_MASK)
8357 6 : && (prog_unit->omp_requires & OMP_REQ_ATOMIC_MEM_ORDER_MASK)
8358 6 : != (int) clause)
8359 : {
8360 3 : const char *other;
8361 3 : switch (prog_unit->omp_requires & OMP_REQ_ATOMIC_MEM_ORDER_MASK)
8362 : {
8363 : case OMP_REQ_ATOMIC_MEM_ORDER_SEQ_CST: other = "seq_cst"; break;
8364 0 : case OMP_REQ_ATOMIC_MEM_ORDER_ACQ_REL: other = "acq_rel"; break;
8365 1 : case OMP_REQ_ATOMIC_MEM_ORDER_ACQUIRE: other = "acquire"; break;
8366 1 : case OMP_REQ_ATOMIC_MEM_ORDER_RELAXED: other = "relaxed"; break;
8367 0 : case OMP_REQ_ATOMIC_MEM_ORDER_RELEASE: other = "release"; break;
8368 0 : default: gcc_unreachable ();
8369 : }
8370 :
8371 3 : if (module_name)
8372 0 : gfc_error ("!$OMP REQUIRES clause %<atomic_default_mem_order(%s)%> "
8373 : "specified via module %qs use at %L overrides a previous "
8374 : "%<atomic_default_mem_order(%s)%> (which might be through "
8375 : "using a module)", clause_name, module_name, loc, other);
8376 : else
8377 3 : gfc_error ("!$OMP REQUIRES clause %<atomic_default_mem_order(%s)%> "
8378 : "specified at %L overrides a previous "
8379 : "%<atomic_default_mem_order(%s)%> (which might be through "
8380 : "using a module)", clause_name, loc, other);
8381 3 : return false;
8382 : }
8383 :
8384 : /* Requires via module not at program-unit level and not repeating clause. */
8385 123 : if (prog_unit != gfc_current_ns && !(prog_unit->omp_requires & clause))
8386 : {
8387 0 : if (clause & OMP_REQ_ATOMIC_MEM_ORDER_MASK)
8388 0 : gfc_error ("!$OMP REQUIRES clause %<atomic_default_mem_order(%s)%> "
8389 : "specified via module %qs use at %L but same clause is "
8390 : "not specified for the program unit", clause_name,
8391 : module_name, loc);
8392 : else
8393 0 : gfc_error ("!$OMP REQUIRES clause %qs specified via module %qs use at "
8394 : "%L but same clause is not specified for the program unit",
8395 : clause_name, module_name, loc);
8396 0 : return false;
8397 : }
8398 :
8399 123 : if (!gfc_state_stack->previous
8400 115 : || gfc_state_stack->previous->state != COMP_INTERFACE)
8401 122 : prog_unit->omp_requires |= clause;
8402 : return true;
8403 : }
8404 :
8405 : match
8406 98 : gfc_match_omp_requires (void)
8407 : {
8408 98 : static const char *clauses[] = {"reverse_offload",
8409 : "unified_address",
8410 : "unified_shared_memory",
8411 : "self_maps",
8412 : "dynamic_allocators",
8413 : "atomic_default"};
8414 98 : const char *clause = NULL;
8415 98 : int requires_clauses = 0;
8416 98 : bool first = true;
8417 98 : locus old_loc;
8418 :
8419 : /* A submodule's namespace may have its parent pointer set to the ancestor
8420 : module namespace for host-association purposes. The submodule spec part
8421 : is still a valid program-unit spec part for OMP REQUIRES. Only reject
8422 : the directive when we are genuinely nested inside a procedure. */
8423 98 : if (gfc_current_ns->parent
8424 8 : && !(gfc_current_ns->proc_name
8425 8 : && gfc_current_ns->proc_name->attr.flavor == FL_MODULE)
8426 7 : && (!gfc_state_stack->previous
8427 7 : || gfc_state_stack->previous->state != COMP_INTERFACE))
8428 : {
8429 6 : gfc_error ("!$OMP REQUIRES at %C must appear in the specification part "
8430 : "of a program unit");
8431 6 : return MATCH_ERROR;
8432 : }
8433 :
8434 276 : while (true)
8435 : {
8436 184 : old_loc = gfc_current_locus;
8437 184 : gfc_omp_requires_kind requires_clause;
8438 92 : if ((first || gfc_match_char (',') != MATCH_YES)
8439 184 : && (first && gfc_match_space () != MATCH_YES))
8440 0 : goto error;
8441 184 : first = false;
8442 184 : gfc_gobble_whitespace ();
8443 184 : old_loc = gfc_current_locus;
8444 :
8445 184 : if (gfc_match_omp_eos () != MATCH_NO)
8446 : break;
8447 103 : if (gfc_match (clauses[0]) == MATCH_YES)
8448 : {
8449 34 : clause = clauses[0];
8450 34 : requires_clause = OMP_REQ_REVERSE_OFFLOAD;
8451 34 : if (requires_clauses & OMP_REQ_REVERSE_OFFLOAD)
8452 1 : goto duplicate_clause;
8453 : }
8454 69 : else if (gfc_match (clauses[1]) == MATCH_YES)
8455 : {
8456 9 : clause = clauses[1];
8457 9 : requires_clause = OMP_REQ_UNIFIED_ADDRESS;
8458 9 : if (requires_clauses & OMP_REQ_UNIFIED_ADDRESS)
8459 1 : goto duplicate_clause;
8460 : }
8461 60 : else if (gfc_match (clauses[2]) == MATCH_YES)
8462 : {
8463 14 : clause = clauses[2];
8464 14 : requires_clause = OMP_REQ_UNIFIED_SHARED_MEMORY;
8465 14 : if (requires_clauses & OMP_REQ_UNIFIED_SHARED_MEMORY)
8466 1 : goto duplicate_clause;
8467 : }
8468 46 : else if (gfc_match (clauses[3]) == MATCH_YES)
8469 : {
8470 7 : clause = clauses[3];
8471 7 : requires_clause = OMP_REQ_SELF_MAPS;
8472 7 : if (requires_clauses & OMP_REQ_SELF_MAPS)
8473 0 : goto duplicate_clause;
8474 : }
8475 39 : else if (gfc_match (clauses[4]) == MATCH_YES)
8476 : {
8477 7 : clause = clauses[4];
8478 7 : requires_clause = OMP_REQ_DYNAMIC_ALLOCATORS;
8479 7 : if (requires_clauses & OMP_REQ_DYNAMIC_ALLOCATORS)
8480 1 : goto duplicate_clause;
8481 : }
8482 32 : else if (gfc_match ("atomic_default_mem_order (") == MATCH_YES)
8483 : {
8484 31 : clause = clauses[5];
8485 31 : if (requires_clauses & OMP_REQ_ATOMIC_MEM_ORDER_MASK)
8486 1 : goto duplicate_clause;
8487 30 : if (gfc_match (" seq_cst )") == MATCH_YES)
8488 : {
8489 : clause = "seq_cst";
8490 : requires_clause = OMP_REQ_ATOMIC_MEM_ORDER_SEQ_CST;
8491 : }
8492 18 : else if (gfc_match (" acq_rel )") == MATCH_YES)
8493 : {
8494 : clause = "acq_rel";
8495 : requires_clause = OMP_REQ_ATOMIC_MEM_ORDER_ACQ_REL;
8496 : }
8497 12 : else if (gfc_match (" acquire )") == MATCH_YES)
8498 : {
8499 : clause = "acquire";
8500 : requires_clause = OMP_REQ_ATOMIC_MEM_ORDER_ACQUIRE;
8501 : }
8502 9 : else if (gfc_match (" relaxed )") == MATCH_YES)
8503 : {
8504 : clause = "relaxed";
8505 : requires_clause = OMP_REQ_ATOMIC_MEM_ORDER_RELAXED;
8506 : }
8507 5 : else if (gfc_match (" release )") == MATCH_YES)
8508 : {
8509 : clause = "release";
8510 : requires_clause = OMP_REQ_ATOMIC_MEM_ORDER_RELEASE;
8511 : }
8512 : else
8513 : {
8514 2 : gfc_error ("Expected ACQ_REL, ACQUIRE, RELAXED, RELEASE or "
8515 : "SEQ_CST for ATOMIC_DEFAULT_MEM_ORDER clause at %C");
8516 2 : goto error;
8517 : }
8518 : }
8519 : else
8520 1 : goto error;
8521 :
8522 95 : if (!gfc_omp_requires_add_clause (requires_clause, clause, &old_loc, NULL))
8523 3 : goto error;
8524 92 : requires_clauses |= requires_clause;
8525 92 : }
8526 :
8527 81 : if (requires_clauses == 0)
8528 : {
8529 1 : if (!gfc_error_flag_test ())
8530 1 : gfc_error ("Clause expected at %C");
8531 1 : goto error;
8532 : }
8533 : return MATCH_YES;
8534 :
8535 5 : duplicate_clause:
8536 5 : gfc_error ("%qs clause at %L specified more than once", clause, &old_loc);
8537 12 : error:
8538 12 : if (!gfc_error_flag_test ())
8539 1 : gfc_error ("Expected UNIFIED_ADDRESS, UNIFIED_SHARED_MEMORY, SELF_MAPS, "
8540 : "DYNAMIC_ALLOCATORS, REVERSE_OFFLOAD, or "
8541 : "ATOMIC_DEFAULT_MEM_ORDER clause at %L", &old_loc);
8542 : return MATCH_ERROR;
8543 : }
8544 :
8545 :
8546 : match
8547 51 : gfc_match_omp_scan (void)
8548 : {
8549 51 : bool incl;
8550 51 : gfc_omp_clauses *c = gfc_get_omp_clauses ();
8551 51 : gfc_gobble_whitespace ();
8552 51 : if ((incl = (gfc_match ("inclusive") == MATCH_YES))
8553 51 : || gfc_match ("exclusive") == MATCH_YES)
8554 : {
8555 70 : if (gfc_match_omp_variable_list (" (", &c->lists[incl ? OMP_LIST_SCAN_IN
8556 : : OMP_LIST_SCAN_EX],
8557 : false) != MATCH_YES)
8558 : {
8559 0 : gfc_free_omp_clauses (c);
8560 0 : return MATCH_ERROR;
8561 : }
8562 : }
8563 : else
8564 : {
8565 1 : gfc_error ("Expected INCLUSIVE or EXCLUSIVE clause at %C");
8566 1 : gfc_free_omp_clauses (c);
8567 1 : return MATCH_ERROR;
8568 : }
8569 50 : if (gfc_match_omp_eos () != MATCH_YES)
8570 : {
8571 1 : gfc_error ("Unexpected junk after !$OMP SCAN at %C");
8572 1 : gfc_free_omp_clauses (c);
8573 1 : return MATCH_ERROR;
8574 : }
8575 :
8576 49 : new_st.op = EXEC_OMP_SCAN;
8577 49 : new_st.ext.omp_clauses = c;
8578 49 : return MATCH_YES;
8579 : }
8580 :
8581 :
8582 : match
8583 58 : gfc_match_omp_scope (void)
8584 : {
8585 58 : return match_omp (EXEC_OMP_SCOPE, OMP_SCOPE_CLAUSES);
8586 : }
8587 :
8588 :
8589 : match
8590 82 : gfc_match_omp_sections (void)
8591 : {
8592 82 : return match_omp (EXEC_OMP_SECTIONS, OMP_SECTIONS_CLAUSES);
8593 : }
8594 :
8595 :
8596 : match
8597 782 : gfc_match_omp_simd (void)
8598 : {
8599 782 : return match_omp (EXEC_OMP_SIMD, OMP_SIMD_CLAUSES);
8600 : }
8601 :
8602 :
8603 : match
8604 570 : gfc_match_omp_single (void)
8605 : {
8606 570 : return match_omp (EXEC_OMP_SINGLE, OMP_SINGLE_CLAUSES);
8607 : }
8608 :
8609 :
8610 : match
8611 2247 : gfc_match_omp_target (void)
8612 : {
8613 2247 : return match_omp (EXEC_OMP_TARGET, OMP_TARGET_CLAUSES);
8614 : }
8615 :
8616 :
8617 : match
8618 1399 : gfc_match_omp_target_data (void)
8619 : {
8620 1399 : return match_omp (EXEC_OMP_TARGET_DATA, OMP_TARGET_DATA_CLAUSES);
8621 : }
8622 :
8623 :
8624 : match
8625 468 : gfc_match_omp_target_enter_data (void)
8626 : {
8627 468 : return match_omp (EXEC_OMP_TARGET_ENTER_DATA, OMP_TARGET_ENTER_DATA_CLAUSES);
8628 : }
8629 :
8630 :
8631 : match
8632 365 : gfc_match_omp_target_exit_data (void)
8633 : {
8634 365 : return match_omp (EXEC_OMP_TARGET_EXIT_DATA, OMP_TARGET_EXIT_DATA_CLAUSES);
8635 : }
8636 :
8637 :
8638 : match
8639 27 : gfc_match_omp_target_parallel (void)
8640 : {
8641 27 : return match_omp (EXEC_OMP_TARGET_PARALLEL,
8642 27 : (OMP_TARGET_CLAUSES | OMP_PARALLEL_CLAUSES)
8643 27 : & ~(omp_mask (OMP_CLAUSE_COPYIN)));
8644 : }
8645 :
8646 :
8647 : match
8648 81 : gfc_match_omp_target_parallel_do (void)
8649 : {
8650 81 : return match_omp (EXEC_OMP_TARGET_PARALLEL_DO,
8651 81 : (OMP_TARGET_CLAUSES | OMP_PARALLEL_CLAUSES
8652 81 : | OMP_DO_CLAUSES) & ~(omp_mask (OMP_CLAUSE_COPYIN)));
8653 : }
8654 :
8655 :
8656 : match
8657 20 : gfc_match_omp_target_parallel_do_simd (void)
8658 : {
8659 20 : return match_omp (EXEC_OMP_TARGET_PARALLEL_DO_SIMD,
8660 20 : (OMP_TARGET_CLAUSES | OMP_PARALLEL_CLAUSES | OMP_DO_CLAUSES
8661 20 : | OMP_SIMD_CLAUSES) & ~(omp_mask (OMP_CLAUSE_COPYIN)));
8662 : }
8663 :
8664 :
8665 : match
8666 34 : gfc_match_omp_target_simd (void)
8667 : {
8668 34 : return match_omp (EXEC_OMP_TARGET_SIMD,
8669 34 : OMP_TARGET_CLAUSES | OMP_SIMD_CLAUSES);
8670 : }
8671 :
8672 :
8673 : match
8674 76 : gfc_match_omp_target_teams (void)
8675 : {
8676 76 : return match_omp (EXEC_OMP_TARGET_TEAMS,
8677 76 : OMP_TARGET_CLAUSES | OMP_TEAMS_CLAUSES);
8678 : }
8679 :
8680 :
8681 : match
8682 19 : gfc_match_omp_target_teams_distribute (void)
8683 : {
8684 19 : return match_omp (EXEC_OMP_TARGET_TEAMS_DISTRIBUTE,
8685 19 : OMP_TARGET_CLAUSES | OMP_TEAMS_CLAUSES
8686 19 : | OMP_DISTRIBUTE_CLAUSES);
8687 : }
8688 :
8689 :
8690 : match
8691 66 : gfc_match_omp_target_teams_distribute_parallel_do (void)
8692 : {
8693 66 : return match_omp (EXEC_OMP_TARGET_TEAMS_DISTRIBUTE_PARALLEL_DO,
8694 66 : (OMP_TARGET_CLAUSES | OMP_TEAMS_CLAUSES
8695 66 : | OMP_DISTRIBUTE_CLAUSES | OMP_PARALLEL_CLAUSES
8696 66 : | OMP_DO_CLAUSES)
8697 66 : & ~(omp_mask (OMP_CLAUSE_ORDERED))
8698 66 : & ~(omp_mask (OMP_CLAUSE_LINEAR)));
8699 : }
8700 :
8701 :
8702 : match
8703 36 : gfc_match_omp_target_teams_distribute_parallel_do_simd (void)
8704 : {
8705 36 : return match_omp (EXEC_OMP_TARGET_TEAMS_DISTRIBUTE_PARALLEL_DO_SIMD,
8706 36 : (OMP_TARGET_CLAUSES | OMP_TEAMS_CLAUSES
8707 36 : | OMP_DISTRIBUTE_CLAUSES | OMP_PARALLEL_CLAUSES
8708 36 : | OMP_DO_CLAUSES | OMP_SIMD_CLAUSES)
8709 36 : & ~(omp_mask (OMP_CLAUSE_ORDERED)));
8710 : }
8711 :
8712 :
8713 : match
8714 21 : gfc_match_omp_target_teams_distribute_simd (void)
8715 : {
8716 21 : return match_omp (EXEC_OMP_TARGET_TEAMS_DISTRIBUTE_SIMD,
8717 21 : OMP_TARGET_CLAUSES | OMP_TEAMS_CLAUSES
8718 21 : | OMP_DISTRIBUTE_CLAUSES | OMP_SIMD_CLAUSES);
8719 : }
8720 :
8721 :
8722 : match
8723 1725 : gfc_match_omp_target_update (void)
8724 : {
8725 1725 : return match_omp (EXEC_OMP_TARGET_UPDATE, OMP_TARGET_UPDATE_CLAUSES);
8726 : }
8727 :
8728 :
8729 : match
8730 1182 : gfc_match_omp_task (void)
8731 : {
8732 1182 : return match_omp (EXEC_OMP_TASK, OMP_TASK_CLAUSES);
8733 : }
8734 :
8735 :
8736 : match
8737 72 : gfc_match_omp_taskloop (void)
8738 : {
8739 72 : return match_omp (EXEC_OMP_TASKLOOP, OMP_TASKLOOP_CLAUSES);
8740 : }
8741 :
8742 :
8743 : match
8744 40 : gfc_match_omp_taskloop_simd (void)
8745 : {
8746 40 : return match_omp (EXEC_OMP_TASKLOOP_SIMD,
8747 40 : OMP_TASKLOOP_CLAUSES | OMP_SIMD_CLAUSES);
8748 : }
8749 :
8750 :
8751 : match
8752 147 : gfc_match_omp_taskwait (void)
8753 : {
8754 147 : if (gfc_match_omp_eos () == MATCH_YES)
8755 : {
8756 133 : new_st.op = EXEC_OMP_TASKWAIT;
8757 133 : new_st.ext.omp_clauses = NULL;
8758 133 : return MATCH_YES;
8759 : }
8760 14 : return match_omp (EXEC_OMP_TASKWAIT,
8761 14 : omp_mask (OMP_CLAUSE_DEPEND) | OMP_CLAUSE_NOWAIT);
8762 : }
8763 :
8764 :
8765 : match
8766 10 : gfc_match_omp_taskyield (void)
8767 : {
8768 10 : if (gfc_match_omp_eos () != MATCH_YES)
8769 : {
8770 0 : gfc_error ("Unexpected junk after TASKYIELD clause at %C");
8771 0 : return MATCH_ERROR;
8772 : }
8773 10 : new_st.op = EXEC_OMP_TASKYIELD;
8774 10 : new_st.ext.omp_clauses = NULL;
8775 10 : return MATCH_YES;
8776 : }
8777 :
8778 :
8779 : match
8780 218 : gfc_match_omp_teams (void)
8781 : {
8782 218 : return match_omp (EXEC_OMP_TEAMS, OMP_TEAMS_CLAUSES);
8783 : }
8784 :
8785 :
8786 : match
8787 22 : gfc_match_omp_teams_distribute (void)
8788 : {
8789 22 : return match_omp (EXEC_OMP_TEAMS_DISTRIBUTE,
8790 22 : OMP_TEAMS_CLAUSES | OMP_DISTRIBUTE_CLAUSES);
8791 : }
8792 :
8793 :
8794 : match
8795 41 : gfc_match_omp_teams_distribute_parallel_do (void)
8796 : {
8797 41 : return match_omp (EXEC_OMP_TEAMS_DISTRIBUTE_PARALLEL_DO,
8798 41 : (OMP_TEAMS_CLAUSES | OMP_DISTRIBUTE_CLAUSES
8799 41 : | OMP_PARALLEL_CLAUSES | OMP_DO_CLAUSES)
8800 41 : & ~(omp_mask (OMP_CLAUSE_ORDERED)
8801 41 : | OMP_CLAUSE_LINEAR | OMP_CLAUSE_NOWAIT));
8802 : }
8803 :
8804 :
8805 : match
8806 63 : gfc_match_omp_teams_distribute_parallel_do_simd (void)
8807 : {
8808 63 : return match_omp (EXEC_OMP_TEAMS_DISTRIBUTE_PARALLEL_DO_SIMD,
8809 63 : (OMP_TEAMS_CLAUSES | OMP_DISTRIBUTE_CLAUSES
8810 63 : | OMP_PARALLEL_CLAUSES | OMP_DO_CLAUSES
8811 63 : | OMP_SIMD_CLAUSES)
8812 63 : & ~(omp_mask (OMP_CLAUSE_ORDERED) | OMP_CLAUSE_NOWAIT));
8813 : }
8814 :
8815 :
8816 : match
8817 44 : gfc_match_omp_teams_distribute_simd (void)
8818 : {
8819 44 : return match_omp (EXEC_OMP_TEAMS_DISTRIBUTE_SIMD,
8820 44 : OMP_TEAMS_CLAUSES | OMP_DISTRIBUTE_CLAUSES
8821 44 : | OMP_SIMD_CLAUSES);
8822 : }
8823 :
8824 : match
8825 203 : gfc_match_omp_tile (void)
8826 : {
8827 203 : return match_omp (EXEC_OMP_TILE, OMP_TILE_CLAUSES);
8828 : }
8829 :
8830 : match
8831 415 : gfc_match_omp_unroll (void)
8832 : {
8833 415 : return match_omp (EXEC_OMP_UNROLL, OMP_UNROLL_CLAUSES);
8834 : }
8835 :
8836 : match
8837 39 : gfc_match_omp_workshare (void)
8838 : {
8839 39 : return match_omp (EXEC_OMP_WORKSHARE, OMP_WORKSHARE_CLAUSES);
8840 : }
8841 :
8842 :
8843 : match
8844 55 : gfc_match_omp_masked (void)
8845 : {
8846 55 : return match_omp (EXEC_OMP_MASKED, OMP_MASKED_CLAUSES);
8847 : }
8848 :
8849 : match
8850 10 : gfc_match_omp_masked_taskloop (void)
8851 : {
8852 10 : return match_omp (EXEC_OMP_MASKED_TASKLOOP,
8853 10 : OMP_MASKED_CLAUSES | OMP_TASKLOOP_CLAUSES);
8854 : }
8855 :
8856 : match
8857 16 : gfc_match_omp_masked_taskloop_simd (void)
8858 : {
8859 16 : return match_omp (EXEC_OMP_MASKED_TASKLOOP_SIMD,
8860 16 : (OMP_MASKED_CLAUSES | OMP_TASKLOOP_CLAUSES
8861 16 : | OMP_SIMD_CLAUSES));
8862 : }
8863 :
8864 : match
8865 111 : gfc_match_omp_master (void)
8866 : {
8867 111 : gfc_warning (OPT_Wdeprecated_openmp,
8868 : "%<master%> construct at %C deprecated since OpenMP 5.1, "
8869 : "use %<masked%>");
8870 111 : if (gfc_match_omp_eos () != MATCH_YES)
8871 : {
8872 1 : gfc_error ("Unexpected junk after $OMP MASTER statement at %C");
8873 1 : return MATCH_ERROR;
8874 : }
8875 110 : new_st.op = EXEC_OMP_MASTER;
8876 110 : new_st.ext.omp_clauses = NULL;
8877 110 : return MATCH_YES;
8878 : }
8879 :
8880 : match
8881 16 : gfc_match_omp_master_taskloop (void)
8882 : {
8883 16 : gfc_warning (OPT_Wdeprecated_openmp,
8884 : "%<master%> construct at %C deprecated since OpenMP 5.1, "
8885 : "use %<masked%>");
8886 16 : return match_omp (EXEC_OMP_MASTER_TASKLOOP, OMP_TASKLOOP_CLAUSES);
8887 : }
8888 :
8889 : match
8890 21 : gfc_match_omp_master_taskloop_simd (void)
8891 : {
8892 21 : gfc_warning (OPT_Wdeprecated_openmp,
8893 : "%<master%> construct at %C deprecated since OpenMP 5.1, use "
8894 : "%<masked%>");
8895 21 : return match_omp (EXEC_OMP_MASTER_TASKLOOP_SIMD,
8896 21 : OMP_TASKLOOP_CLAUSES | OMP_SIMD_CLAUSES);
8897 : }
8898 :
8899 : match
8900 235 : gfc_match_omp_ordered (void)
8901 : {
8902 235 : return match_omp (EXEC_OMP_ORDERED, OMP_ORDERED_CLAUSES);
8903 : }
8904 :
8905 : match
8906 24 : gfc_match_omp_nothing (void)
8907 : {
8908 24 : if (gfc_match_omp_eos () != MATCH_YES)
8909 : {
8910 1 : gfc_error ("Unexpected junk after $OMP NOTHING statement at %C");
8911 1 : return MATCH_ERROR;
8912 : }
8913 : /* Will use ST_NONE; therefore, no EXEC_OMP_ is needed. */
8914 : return MATCH_YES;
8915 : }
8916 :
8917 : match
8918 317 : gfc_match_omp_ordered_depend (void)
8919 : {
8920 317 : return match_omp (EXEC_OMP_ORDERED, omp_mask (OMP_CLAUSE_DOACROSS));
8921 : }
8922 :
8923 :
8924 : /* omp atomic [clause-list]
8925 : - atomic-clause: read | write | update
8926 : - capture
8927 : - memory-order-clause: seq_cst | acq_rel | release | acquire | relaxed
8928 : - hint(hint-expr)
8929 : - OpenMP 5.1: compare | fail (seq_cst | acquire | relaxed ) | weak
8930 : */
8931 :
8932 : match
8933 2171 : gfc_match_omp_atomic (void)
8934 : {
8935 2171 : gfc_omp_clauses *c;
8936 2171 : locus loc = gfc_current_locus;
8937 :
8938 2171 : if (gfc_match_omp_clauses (&c, OMP_ATOMIC_CLAUSES, true, true) != MATCH_YES)
8939 : return MATCH_ERROR;
8940 :
8941 2153 : if (c->atomic_op == GFC_OMP_ATOMIC_UNSET)
8942 1011 : c->atomic_op = GFC_OMP_ATOMIC_UPDATE;
8943 :
8944 2153 : if (c->capture && c->atomic_op != GFC_OMP_ATOMIC_UPDATE)
8945 3 : gfc_error ("!$OMP ATOMIC at %L with %s clause is incompatible with "
8946 : "READ or WRITE", &loc, "CAPTURE");
8947 2153 : if (c->compare && c->atomic_op != GFC_OMP_ATOMIC_UPDATE)
8948 3 : gfc_error ("!$OMP ATOMIC at %L with %s clause is incompatible with "
8949 : "READ or WRITE", &loc, "COMPARE");
8950 2153 : if (c->fail != OMP_MEMORDER_UNSET && c->atomic_op != GFC_OMP_ATOMIC_UPDATE)
8951 2 : gfc_error ("!$OMP ATOMIC at %L with %s clause is incompatible with "
8952 : "READ or WRITE", &loc, "FAIL");
8953 2153 : if (c->weak && !c->compare)
8954 : {
8955 5 : gfc_error ("!$OMP ATOMIC at %L with %s clause requires %s clause", &loc,
8956 : "WEAK", "COMPARE");
8957 5 : c->weak = false;
8958 : }
8959 :
8960 2153 : if (c->memorder == OMP_MEMORDER_UNSET)
8961 : {
8962 1969 : gfc_namespace *prog_unit = gfc_current_ns;
8963 1969 : while (prog_unit->parent
8964 2525 : && !(prog_unit->proc_name
8965 556 : && prog_unit->proc_name->attr.flavor == FL_MODULE))
8966 : prog_unit = prog_unit->parent;
8967 1969 : switch (prog_unit->omp_requires & OMP_REQ_ATOMIC_MEM_ORDER_MASK)
8968 : {
8969 1936 : case 0:
8970 1936 : case OMP_REQ_ATOMIC_MEM_ORDER_RELAXED:
8971 1936 : c->memorder = OMP_MEMORDER_RELAXED;
8972 1936 : break;
8973 7 : case OMP_REQ_ATOMIC_MEM_ORDER_SEQ_CST:
8974 7 : c->memorder = OMP_MEMORDER_SEQ_CST;
8975 7 : break;
8976 16 : case OMP_REQ_ATOMIC_MEM_ORDER_ACQ_REL:
8977 16 : if (c->capture)
8978 5 : c->memorder = OMP_MEMORDER_ACQ_REL;
8979 11 : else if (c->atomic_op == GFC_OMP_ATOMIC_READ)
8980 3 : c->memorder = OMP_MEMORDER_ACQUIRE;
8981 : else
8982 8 : c->memorder = OMP_MEMORDER_RELEASE;
8983 : break;
8984 5 : case OMP_REQ_ATOMIC_MEM_ORDER_ACQUIRE:
8985 5 : if (c->atomic_op == GFC_OMP_ATOMIC_WRITE)
8986 : {
8987 1 : gfc_error ("!$OMP ATOMIC WRITE at %L incompatible with "
8988 : "ACQUIRES clause implicitly provided by a "
8989 : "REQUIRES directive", &loc);
8990 1 : c->memorder = OMP_MEMORDER_SEQ_CST;
8991 : }
8992 : else
8993 4 : c->memorder = OMP_MEMORDER_ACQUIRE;
8994 : break;
8995 5 : case OMP_REQ_ATOMIC_MEM_ORDER_RELEASE:
8996 5 : if (c->atomic_op == GFC_OMP_ATOMIC_READ)
8997 : {
8998 1 : gfc_error ("!$OMP ATOMIC READ at %L incompatible with "
8999 : "RELEASE clause implicitly provided by a "
9000 : "REQUIRES directive", &loc);
9001 1 : c->memorder = OMP_MEMORDER_SEQ_CST;
9002 : }
9003 : else
9004 4 : c->memorder = OMP_MEMORDER_RELEASE;
9005 : break;
9006 0 : default:
9007 0 : gcc_unreachable ();
9008 : }
9009 : }
9010 : else
9011 184 : switch (c->atomic_op)
9012 : {
9013 29 : case GFC_OMP_ATOMIC_READ:
9014 29 : if (c->memorder == OMP_MEMORDER_RELEASE)
9015 : {
9016 1 : gfc_error ("!$OMP ATOMIC READ at %L incompatible with "
9017 : "RELEASE clause", &loc);
9018 1 : c->memorder = OMP_MEMORDER_SEQ_CST;
9019 : }
9020 28 : else if (c->memorder == OMP_MEMORDER_ACQ_REL)
9021 1 : c->memorder = OMP_MEMORDER_ACQUIRE;
9022 : break;
9023 35 : case GFC_OMP_ATOMIC_WRITE:
9024 35 : if (c->memorder == OMP_MEMORDER_ACQUIRE)
9025 : {
9026 1 : gfc_error ("!$OMP ATOMIC WRITE at %L incompatible with "
9027 : "ACQUIRE clause", &loc);
9028 1 : c->memorder = OMP_MEMORDER_SEQ_CST;
9029 : }
9030 34 : else if (c->memorder == OMP_MEMORDER_ACQ_REL)
9031 1 : c->memorder = OMP_MEMORDER_RELEASE;
9032 : break;
9033 : default:
9034 : break;
9035 : }
9036 2153 : gfc_error_check ();
9037 2153 : new_st.ext.omp_clauses = c;
9038 2153 : new_st.op = EXEC_OMP_ATOMIC;
9039 2153 : return MATCH_YES;
9040 : }
9041 :
9042 :
9043 : /* acc atomic [ read | write | update | capture] */
9044 :
9045 : match
9046 552 : gfc_match_oacc_atomic (void)
9047 : {
9048 552 : gfc_omp_clauses *c = gfc_get_omp_clauses ();
9049 552 : c->atomic_op = GFC_OMP_ATOMIC_UPDATE;
9050 552 : c->memorder = OMP_MEMORDER_RELAXED;
9051 552 : gfc_gobble_whitespace ();
9052 552 : if (gfc_match ("update") == MATCH_YES)
9053 : ;
9054 373 : else if (gfc_match ("read") == MATCH_YES)
9055 17 : c->atomic_op = GFC_OMP_ATOMIC_READ;
9056 356 : else if (gfc_match ("write") == MATCH_YES)
9057 13 : c->atomic_op = GFC_OMP_ATOMIC_WRITE;
9058 343 : else if (gfc_match ("capture") == MATCH_YES)
9059 319 : c->capture = true;
9060 552 : gfc_gobble_whitespace ();
9061 552 : if (gfc_match_omp_eos () != MATCH_YES)
9062 : {
9063 9 : gfc_error ("Unexpected junk after !$ACC ATOMIC statement at %C");
9064 9 : gfc_free_omp_clauses (c);
9065 9 : return MATCH_ERROR;
9066 : }
9067 543 : new_st.ext.omp_clauses = c;
9068 543 : new_st.op = EXEC_OACC_ATOMIC;
9069 543 : return MATCH_YES;
9070 : }
9071 :
9072 :
9073 : match
9074 614 : gfc_match_omp_barrier (void)
9075 : {
9076 614 : if (gfc_match_omp_eos () != MATCH_YES)
9077 : {
9078 0 : gfc_error ("Unexpected junk after $OMP BARRIER statement at %C");
9079 0 : return MATCH_ERROR;
9080 : }
9081 614 : new_st.op = EXEC_OMP_BARRIER;
9082 614 : new_st.ext.omp_clauses = NULL;
9083 614 : return MATCH_YES;
9084 : }
9085 :
9086 :
9087 : match
9088 188 : gfc_match_omp_taskgroup (void)
9089 : {
9090 188 : return match_omp (EXEC_OMP_TASKGROUP, OMP_TASKGROUP_CLAUSES);
9091 : }
9092 :
9093 :
9094 : static enum gfc_omp_cancel_kind
9095 492 : gfc_match_omp_cancel_kind (void)
9096 : {
9097 492 : if (gfc_match_space () != MATCH_YES)
9098 : return OMP_CANCEL_UNKNOWN;
9099 492 : if (gfc_match ("parallel") == MATCH_YES)
9100 : return OMP_CANCEL_PARALLEL;
9101 352 : if (gfc_match ("sections") == MATCH_YES)
9102 : return OMP_CANCEL_SECTIONS;
9103 253 : if (gfc_match ("do") == MATCH_YES)
9104 : return OMP_CANCEL_DO;
9105 123 : if (gfc_match ("taskgroup") == MATCH_YES)
9106 : return OMP_CANCEL_TASKGROUP;
9107 : return OMP_CANCEL_UNKNOWN;
9108 : }
9109 :
9110 :
9111 : match
9112 319 : gfc_match_omp_cancel (void)
9113 : {
9114 319 : gfc_omp_clauses *c;
9115 319 : enum gfc_omp_cancel_kind kind = gfc_match_omp_cancel_kind ();
9116 319 : if (kind == OMP_CANCEL_UNKNOWN)
9117 : return MATCH_ERROR;
9118 319 : if (gfc_match_omp_clauses (&c, omp_mask (OMP_CLAUSE_IF), false) != MATCH_YES)
9119 : return MATCH_ERROR;
9120 316 : c->cancel = kind;
9121 316 : new_st.op = EXEC_OMP_CANCEL;
9122 316 : new_st.ext.omp_clauses = c;
9123 316 : return MATCH_YES;
9124 : }
9125 :
9126 :
9127 : match
9128 173 : gfc_match_omp_cancellation_point (void)
9129 : {
9130 173 : gfc_omp_clauses *c;
9131 173 : enum gfc_omp_cancel_kind kind = gfc_match_omp_cancel_kind ();
9132 173 : if (kind == OMP_CANCEL_UNKNOWN)
9133 : {
9134 2 : gfc_error ("Expected construct-type PARALLEL, SECTIONS, DO or TASKGROUP "
9135 : "in $OMP CANCELLATION POINT statement at %C");
9136 2 : return MATCH_ERROR;
9137 : }
9138 171 : if (gfc_match_omp_eos () != MATCH_YES)
9139 : {
9140 0 : gfc_error ("Unexpected junk after $OMP CANCELLATION POINT statement "
9141 : "at %C");
9142 0 : return MATCH_ERROR;
9143 : }
9144 171 : c = gfc_get_omp_clauses ();
9145 171 : c->cancel = kind;
9146 171 : new_st.op = EXEC_OMP_CANCELLATION_POINT;
9147 171 : new_st.ext.omp_clauses = c;
9148 171 : return MATCH_YES;
9149 : }
9150 :
9151 :
9152 : match
9153 2733 : gfc_match_omp_end_nowait (void)
9154 : {
9155 2733 : bool nowait = false;
9156 2733 : if (gfc_match ("% nowait") == MATCH_YES)
9157 258 : nowait = true;
9158 2733 : if (gfc_match_omp_eos () != MATCH_YES)
9159 : {
9160 4 : if (nowait)
9161 3 : gfc_error ("Unexpected junk after NOWAIT clause at %C");
9162 : else
9163 1 : gfc_error ("Unexpected junk at %C");
9164 4 : return MATCH_ERROR;
9165 : }
9166 2729 : new_st.op = EXEC_OMP_END_NOWAIT;
9167 2729 : new_st.ext.omp_bool = nowait;
9168 2729 : return MATCH_YES;
9169 : }
9170 :
9171 :
9172 : match
9173 566 : gfc_match_omp_end_single (void)
9174 : {
9175 566 : gfc_omp_clauses *c;
9176 566 : if (gfc_match_omp_clauses (&c, omp_mask (OMP_CLAUSE_COPYPRIVATE)
9177 : | OMP_CLAUSE_NOWAIT) != MATCH_YES)
9178 : return MATCH_ERROR;
9179 566 : new_st.op = EXEC_OMP_END_SINGLE;
9180 566 : new_st.ext.omp_clauses = c;
9181 566 : return MATCH_YES;
9182 : }
9183 :
9184 :
9185 : static bool
9186 37142 : oacc_is_loop (gfc_code *code)
9187 : {
9188 37142 : return code->op == EXEC_OACC_PARALLEL_LOOP
9189 : || code->op == EXEC_OACC_KERNELS_LOOP
9190 20087 : || code->op == EXEC_OACC_SERIAL_LOOP
9191 13457 : || code->op == EXEC_OACC_LOOP;
9192 : }
9193 :
9194 : static void
9195 5982 : resolve_scalar_int_expr (gfc_expr *expr, const char *clause)
9196 : {
9197 5982 : if (!gfc_resolve_expr (expr)
9198 5982 : || expr->ts.type != BT_INTEGER
9199 11893 : || expr->rank != 0)
9200 89 : gfc_error ("%s clause at %L requires a scalar INTEGER expression",
9201 : clause, &expr->where);
9202 5982 : }
9203 :
9204 : static void
9205 4090 : resolve_positive_int_expr (gfc_expr *expr, const char *clause)
9206 : {
9207 4090 : resolve_scalar_int_expr (expr, clause);
9208 4090 : if (expr->expr_type == EXPR_CONSTANT
9209 3660 : && expr->ts.type == BT_INTEGER
9210 3627 : && mpz_sgn (expr->value.integer) <= 0)
9211 54 : gfc_warning ((flag_openmp || flag_openmp_simd) ? OPT_Wopenmp : 0,
9212 : "INTEGER expression of %s clause at %L must be positive",
9213 : clause, &expr->where);
9214 4090 : }
9215 :
9216 : static void
9217 86 : resolve_nonnegative_int_expr (gfc_expr *expr, const char *clause)
9218 : {
9219 86 : resolve_scalar_int_expr (expr, clause);
9220 86 : if (expr->expr_type == EXPR_CONSTANT
9221 13 : && expr->ts.type == BT_INTEGER
9222 11 : && mpz_sgn (expr->value.integer) < 0)
9223 6 : gfc_warning ((flag_openmp || flag_openmp_simd) ? OPT_Wopenmp : 0,
9224 : "INTEGER expression of %s clause at %L must be non-negative",
9225 : clause, &expr->where);
9226 86 : }
9227 :
9228 : /* Emits error when symbol is pointer, cray pointer or cray pointee
9229 : of derived of polymorphic type. */
9230 :
9231 : static void
9232 98 : check_symbol_not_pointer (gfc_symbol *sym, locus loc, const char *name)
9233 : {
9234 98 : if (sym->ts.type == BT_DERIVED && sym->attr.cray_pointer)
9235 0 : gfc_error ("Cray pointer object %qs of derived type in %s clause at %L",
9236 : sym->name, name, &loc);
9237 98 : if (sym->ts.type == BT_DERIVED && sym->attr.cray_pointee)
9238 0 : gfc_error ("Cray pointee object %qs of derived type in %s clause at %L",
9239 : sym->name, name, &loc);
9240 :
9241 98 : if ((sym->ts.type == BT_ASSUMED && sym->attr.pointer)
9242 98 : || (sym->ts.type == BT_CLASS && CLASS_DATA (sym)
9243 0 : && CLASS_DATA (sym)->attr.pointer))
9244 0 : gfc_error ("POINTER object %qs of polymorphic type in %s clause at %L",
9245 : sym->name, name, &loc);
9246 98 : if ((sym->ts.type == BT_ASSUMED && sym->attr.cray_pointer)
9247 98 : || (sym->ts.type == BT_CLASS && CLASS_DATA (sym)
9248 0 : && CLASS_DATA (sym)->attr.cray_pointer))
9249 0 : gfc_error ("Cray pointer object %qs of polymorphic type in %s clause at %L",
9250 : sym->name, name, &loc);
9251 98 : if ((sym->ts.type == BT_ASSUMED && sym->attr.cray_pointee)
9252 98 : || (sym->ts.type == BT_CLASS && CLASS_DATA (sym)
9253 0 : && CLASS_DATA (sym)->attr.cray_pointee))
9254 0 : gfc_error ("Cray pointee object %qs of polymorphic type in %s clause at %L",
9255 : sym->name, name, &loc);
9256 98 : }
9257 :
9258 : /* Emits error when symbol represents assumed size/rank array. */
9259 :
9260 : static void
9261 14844 : check_array_not_assumed (gfc_symbol *sym, locus loc, const char *name)
9262 : {
9263 14844 : if (sym->as && sym->as->type == AS_ASSUMED_SIZE)
9264 13 : gfc_error ("Assumed size array %qs in %s clause at %L",
9265 : sym->name, name, &loc);
9266 14844 : if (sym->as && sym->as->type == AS_ASSUMED_RANK)
9267 11 : gfc_error ("Assumed rank array %qs in %s clause at %L",
9268 : sym->name, name, &loc);
9269 14844 : }
9270 :
9271 : static void
9272 5850 : resolve_oacc_data_clauses (gfc_symbol *sym, locus loc, const char *name)
9273 : {
9274 0 : check_array_not_assumed (sym, loc, name);
9275 0 : }
9276 :
9277 : static void
9278 65 : resolve_oacc_deviceptr_clause (gfc_symbol *sym, locus loc, const char *name)
9279 : {
9280 65 : if (sym->attr.pointer
9281 64 : || (sym->ts.type == BT_CLASS && CLASS_DATA (sym)
9282 0 : && CLASS_DATA (sym)->attr.class_pointer))
9283 1 : gfc_error ("POINTER object %qs in %s clause at %L",
9284 : sym->name, name, &loc);
9285 65 : if (sym->attr.cray_pointer
9286 63 : || (sym->ts.type == BT_CLASS && CLASS_DATA (sym)
9287 0 : && CLASS_DATA (sym)->attr.cray_pointer))
9288 2 : gfc_error ("Cray pointer object %qs in %s clause at %L",
9289 : sym->name, name, &loc);
9290 65 : if (sym->attr.cray_pointee
9291 63 : || (sym->ts.type == BT_CLASS && CLASS_DATA (sym)
9292 0 : && CLASS_DATA (sym)->attr.cray_pointee))
9293 2 : gfc_error ("Cray pointee object %qs in %s clause at %L",
9294 : sym->name, name, &loc);
9295 65 : if (sym->attr.allocatable
9296 64 : || (sym->ts.type == BT_CLASS && CLASS_DATA (sym)
9297 0 : && CLASS_DATA (sym)->attr.allocatable))
9298 1 : gfc_error ("ALLOCATABLE object %qs in %s clause at %L",
9299 : sym->name, name, &loc);
9300 65 : if (sym->attr.value)
9301 1 : gfc_error ("VALUE object %qs in %s clause at %L",
9302 : sym->name, name, &loc);
9303 65 : check_array_not_assumed (sym, loc, name);
9304 65 : }
9305 :
9306 :
9307 : struct resolve_omp_udr_callback_data
9308 : {
9309 : gfc_symbol *sym1, *sym2;
9310 : };
9311 :
9312 :
9313 : static int
9314 1413 : resolve_omp_udr_callback (gfc_expr **e, int *, void *data)
9315 : {
9316 1413 : struct resolve_omp_udr_callback_data *rcd
9317 : = (struct resolve_omp_udr_callback_data *) data;
9318 1413 : if ((*e)->expr_type == EXPR_VARIABLE
9319 801 : && ((*e)->symtree->n.sym == rcd->sym1
9320 255 : || (*e)->symtree->n.sym == rcd->sym2))
9321 : {
9322 801 : gfc_ref *ref = gfc_get_ref ();
9323 801 : ref->type = REF_ARRAY;
9324 801 : ref->u.ar.where = (*e)->where;
9325 801 : ref->u.ar.as = (*e)->symtree->n.sym->as;
9326 801 : ref->u.ar.type = AR_FULL;
9327 801 : ref->u.ar.dimen = 0;
9328 801 : ref->next = (*e)->ref;
9329 801 : (*e)->ref = ref;
9330 : }
9331 1413 : return 0;
9332 : }
9333 :
9334 :
9335 : static int
9336 3004 : resolve_omp_udr_callback2 (gfc_expr **e, int *, void *)
9337 : {
9338 3004 : if ((*e)->expr_type == EXPR_FUNCTION
9339 360 : && (*e)->value.function.isym == NULL)
9340 : {
9341 174 : gfc_symbol *sym = (*e)->symtree->n.sym;
9342 174 : if (!sym->attr.intrinsic
9343 174 : && sym->attr.if_source == IFSRC_UNKNOWN)
9344 4 : gfc_error ("Implicitly declared function %s used in "
9345 : "!$OMP DECLARE REDUCTION at %L", sym->name, &(*e)->where);
9346 : }
9347 3004 : return 0;
9348 : }
9349 :
9350 :
9351 : static gfc_code *
9352 801 : resolve_omp_udr_clause (gfc_omp_namelist *n, gfc_namespace *ns,
9353 : gfc_symbol *sym1, gfc_symbol *sym2)
9354 : {
9355 801 : gfc_code *copy;
9356 801 : gfc_symbol sym1_copy, sym2_copy;
9357 :
9358 801 : if (ns->code->op == EXEC_ASSIGN)
9359 : {
9360 629 : copy = gfc_get_code (EXEC_ASSIGN);
9361 629 : copy->expr1 = gfc_copy_expr (ns->code->expr1);
9362 629 : copy->expr2 = gfc_copy_expr (ns->code->expr2);
9363 : }
9364 : else
9365 : {
9366 172 : copy = gfc_get_code (EXEC_CALL);
9367 172 : copy->symtree = ns->code->symtree;
9368 172 : copy->ext.actual = gfc_copy_actual_arglist (ns->code->ext.actual);
9369 : }
9370 801 : copy->loc = ns->code->loc;
9371 801 : sym1_copy = *sym1;
9372 801 : sym2_copy = *sym2;
9373 801 : *sym1 = *n->sym;
9374 801 : *sym2 = *n->sym;
9375 801 : sym1->name = sym1_copy.name;
9376 801 : sym2->name = sym2_copy.name;
9377 801 : ns->proc_name = ns->parent->proc_name;
9378 801 : if (n->sym->attr.dimension)
9379 : {
9380 348 : struct resolve_omp_udr_callback_data rcd;
9381 348 : rcd.sym1 = sym1;
9382 348 : rcd.sym2 = sym2;
9383 348 : gfc_code_walker (©, gfc_dummy_code_callback,
9384 : resolve_omp_udr_callback, &rcd);
9385 : }
9386 801 : gfc_resolve_code (copy, gfc_current_ns);
9387 801 : if (copy->op == EXEC_CALL && copy->resolved_isym == NULL)
9388 : {
9389 172 : gfc_symbol *sym = copy->resolved_sym;
9390 172 : if (sym
9391 170 : && !sym->attr.intrinsic
9392 170 : && sym->attr.if_source == IFSRC_UNKNOWN)
9393 4 : gfc_error ("Implicitly declared subroutine %s used in "
9394 : "!$OMP DECLARE REDUCTION at %L", sym->name,
9395 : ©->loc);
9396 : }
9397 801 : gfc_code_walker (©, gfc_dummy_code_callback,
9398 : resolve_omp_udr_callback2, NULL);
9399 801 : *sym1 = sym1_copy;
9400 801 : *sym2 = sym2_copy;
9401 801 : return copy;
9402 : }
9403 :
9404 : /* Assume that a constant expression in the range 1 (omp_default_mem_alloc)
9405 : to GOMP_OMP_PREDEF_ALLOC_MAX, or GOMP_OMPX_PREDEF_ALLOC_MIN to
9406 : GOMP_OMPX_PREDEF_ALLOC_MAX is fine. The original symbol name is already
9407 : lost during matching via gfc_match_expr. */
9408 : static bool
9409 130 : is_predefined_allocator (gfc_expr *expr)
9410 : {
9411 130 : return (gfc_resolve_expr (expr)
9412 129 : && expr->rank == 0
9413 124 : && expr->ts.type == BT_INTEGER
9414 119 : && expr->ts.kind == gfc_c_intptr_kind
9415 114 : && expr->expr_type == EXPR_CONSTANT
9416 239 : && ((mpz_sgn (expr->value.integer) > 0
9417 107 : && mpz_cmp_si (expr->value.integer,
9418 : GOMP_OMP_PREDEF_ALLOC_MAX) <= 0)
9419 4 : || (mpz_cmp_si (expr->value.integer,
9420 : GOMP_OMPX_PREDEF_ALLOC_MIN) >= 0
9421 1 : && mpz_cmp_si (expr->value.integer,
9422 130 : GOMP_OMPX_PREDEF_ALLOC_MAX) <= 0)));
9423 : }
9424 :
9425 : /* Resolve declarative ALLOCATE statement. Note: Common block vars only appear
9426 : as /block/ not individual, which is ensured during parsing. */
9427 :
9428 : void
9429 62 : gfc_resolve_omp_allocate (gfc_namespace *ns, gfc_omp_namelist *list)
9430 : {
9431 278 : for (gfc_omp_namelist *n = list; n; n = n->next)
9432 : {
9433 216 : if (n->sym->attr.result || n->sym->result == n->sym)
9434 : {
9435 1 : gfc_error ("Unexpected function-result variable %qs at %L in "
9436 : "declarative !$OMP ALLOCATE", n->sym->name, &n->where);
9437 31 : continue;
9438 : }
9439 215 : if (ns->omp_allocate->sym->attr.proc_pointer)
9440 : {
9441 0 : gfc_error ("Procedure pointer %qs not supported with !$OMP "
9442 : "ALLOCATE at %L", n->sym->name, &n->where);
9443 0 : continue;
9444 : }
9445 215 : if (n->sym->attr.flavor != FL_VARIABLE)
9446 : {
9447 3 : gfc_error ("Argument %qs at %L to declarative !$OMP ALLOCATE "
9448 : "directive must be a variable", n->sym->name,
9449 : &n->where);
9450 3 : continue;
9451 : }
9452 212 : if (ns != n->sym->ns || n->sym->attr.use_assoc || n->sym->attr.imported)
9453 : {
9454 8 : gfc_error ("Argument %qs at %L to declarative !$OMP ALLOCATE shall be"
9455 : " in the same scope as the variable declaration",
9456 : n->sym->name, &n->where);
9457 8 : continue;
9458 : }
9459 204 : if (n->sym->attr.dummy)
9460 : {
9461 3 : gfc_error ("Unexpected dummy argument %qs as argument at %L to "
9462 : "declarative !$OMP ALLOCATE", n->sym->name, &n->where);
9463 3 : continue;
9464 : }
9465 201 : if (n->sym->attr.codimension)
9466 : {
9467 0 : gfc_error ("Unexpected coarray argument %qs as argument at %L to "
9468 : "declarative !$OMP ALLOCATE", n->sym->name, &n->where);
9469 0 : continue;
9470 : }
9471 201 : if (n->sym->attr.omp_allocate)
9472 : {
9473 5 : if (n->sym->attr.in_common)
9474 : {
9475 1 : gfc_error ("Duplicated common block %</%s/%> in !$OMP ALLOCATE "
9476 1 : "at %L", n->sym->common_head->name, &n->where);
9477 3 : while (n->next && n->next->sym
9478 3 : && n->sym->common_head == n->next->sym->common_head)
9479 : n = n->next;
9480 : }
9481 : else
9482 4 : gfc_error ("Duplicated variable %qs in !$OMP ALLOCATE at %L",
9483 : n->sym->name, &n->where);
9484 5 : continue;
9485 : }
9486 : /* For 'equivalence(a,b)', a 'union_type {<type> a,b} equiv.0' is created
9487 : with a value expression for 'a' as 'equiv.0.a' (likewise for b); while
9488 : this can be handled, EQUIVALENCE is marked as obsolescent since Fortran
9489 : 2018 and also not widely used. However, it could be supported,
9490 : if needed. */
9491 196 : if (n->sym->attr.in_equivalence)
9492 : {
9493 2 : gfc_error ("Sorry, EQUIVALENCE object %qs not supported with !$OMP "
9494 : "ALLOCATE at %L", n->sym->name, &n->where);
9495 2 : continue;
9496 : }
9497 : /* Similar for Cray pointer/pointee - they could be implemented but as
9498 : common vendor extension but nowadays rarely used and requiring
9499 : -fcray-pointer, there is no need to support them. */
9500 194 : if (n->sym->attr.cray_pointer || n->sym->attr.cray_pointee)
9501 : {
9502 2 : gfc_error ("Sorry, Cray pointers and pointees such as %qs are not "
9503 : "supported with !$OMP ALLOCATE at %L",
9504 : n->sym->name, &n->where);
9505 2 : continue;
9506 : }
9507 192 : n->sym->attr.omp_allocate = 1;
9508 192 : if ((n->sym->ts.type == BT_CLASS && n->sym->attr.class_ok
9509 0 : && CLASS_DATA (n->sym)->attr.allocatable)
9510 192 : || (n->sym->ts.type != BT_CLASS && n->sym->attr.allocatable))
9511 1 : gfc_error ("Unexpected allocatable variable %qs at %L in declarative "
9512 : "!$OMP ALLOCATE directive", n->sym->name, &n->where);
9513 191 : else if ((n->sym->ts.type == BT_CLASS && n->sym->attr.class_ok
9514 0 : && CLASS_DATA (n->sym)->attr.class_pointer)
9515 191 : || (n->sym->ts.type != BT_CLASS && n->sym->attr.pointer))
9516 1 : gfc_error ("Unexpected pointer variable %qs at %L in declarative "
9517 : "!$OMP ALLOCATE directive", n->sym->name, &n->where);
9518 192 : HOST_WIDE_INT alignment = 0;
9519 198 : if (n->u.align
9520 192 : && (!gfc_resolve_expr (n->u.align)
9521 27 : || n->u.align->ts.type != BT_INTEGER
9522 26 : || n->u.align->rank != 0
9523 24 : || n->u.align->expr_type != EXPR_CONSTANT
9524 23 : || gfc_extract_hwi (n->u.align, &alignment)
9525 23 : || !pow2p_hwi (alignment)))
9526 : {
9527 6 : gfc_error ("ALIGN requires a scalar positive constant integer "
9528 : "alignment expression at %L that is a power of two",
9529 6 : &n->u.align->where);
9530 6 : while (n->sym->attr.in_common && n->next && n->next->sym
9531 6 : && n->sym->common_head == n->next->sym->common_head)
9532 : n = n->next;
9533 6 : continue;
9534 : }
9535 186 : if (n->sym->attr.in_common || n->sym->attr.save || n->sym->ns->save_all
9536 63 : || (n->sym->ns->proc_name
9537 63 : && (n->sym->ns->proc_name->attr.flavor == FL_PROGRAM
9538 55 : || n->sym->ns->proc_name->attr.flavor == FL_MODULE
9539 55 : || n->sym->ns->proc_name->attr.flavor == FL_BLOCK_DATA)))
9540 : {
9541 131 : bool com = n->sym->attr.in_common;
9542 131 : if (!n->u2.allocator)
9543 1 : gfc_error ("An ALLOCATOR clause is required as the list item "
9544 : "%<%s%s%s%> at %L has the SAVE attribute", com ? "/" : "",
9545 0 : com ? n->sym->common_head->name : n->sym->name,
9546 : com ? "/" : "", &n->where);
9547 130 : else if (!is_predefined_allocator (n->u2.allocator))
9548 24 : gfc_error ("Predefined allocator required in ALLOCATOR clause at %L"
9549 : " as the list item %<%s%s%s%> at %L has the SAVE attribute",
9550 24 : &n->u2.allocator->where, com ? "/" : "",
9551 24 : com ? n->sym->common_head->name : n->sym->name,
9552 : com ? "/" : "", &n->where);
9553 : /* Static variables may not use omp_cgroup_mem_alloc (6),
9554 : omp_pteam_mem_alloc (7), or omp_thread_mem_alloc (8). */
9555 106 : else if (mpz_cmp_si (n->u2.allocator->value.integer,
9556 : 6 /* cgroup */) >= 0
9557 34 : && mpz_cmp_si (n->u2.allocator->value.integer,
9558 : 8 /* thread */) <= 0)
9559 : {
9560 33 : STATIC_ASSERT (GOMP_OMP_PREDEF_ALLOC_CGROUP == 6);
9561 33 : STATIC_ASSERT (GOMP_OMP_PREDEF_ALLOC_PTEAM == 7);
9562 33 : STATIC_ASSERT (GOMP_OMP_PREDEF_ALLOC_THREAD == 8);
9563 33 : const char *alloc_name[] = {"omp_cgroup_mem_alloc",
9564 : "omp_pteam_mem_alloc",
9565 : "omp_thread_mem_alloc" };
9566 33 : gfc_error ("Predefined allocator %qs in ALLOCATOR clause at %L, "
9567 : "used for list item %<%s%s%s%> at %L, may not be used"
9568 : " for static variables",
9569 33 : alloc_name[mpz_get_ui (n->u2.allocator->value.integer)
9570 33 : - 6 /* cgroup */], &n->u2.allocator->where,
9571 : com ? "/" : "",
9572 33 : com ? n->sym->common_head->name : n->sym->name,
9573 : com ? "/" : "", &n->where);
9574 : }
9575 67 : while (n->sym->attr.in_common && n->next && n->next->sym
9576 186 : && n->sym->common_head == n->next->sym->common_head)
9577 : n = n->next;
9578 : }
9579 55 : else if (n->u2.allocator
9580 55 : && (!gfc_resolve_expr (n->u2.allocator)
9581 20 : || n->u2.allocator->ts.type != BT_INTEGER
9582 19 : || n->u2.allocator->rank != 0
9583 18 : || n->u2.allocator->ts.kind != gfc_c_intptr_kind))
9584 3 : gfc_error ("Expected integer expression of the "
9585 : "%<omp_allocator_handle_kind%> kind at %L",
9586 3 : &n->u2.allocator->where);
9587 : }
9588 62 : }
9589 :
9590 : /* Resolve ASSUME's and ASSUMES' assumption clauses. Note that absent/contains
9591 : is handled during parse time in omp_verify_merge_absent_contains. */
9592 :
9593 : void
9594 29 : gfc_resolve_omp_assumptions (gfc_omp_assumptions *assume)
9595 : {
9596 46 : for (gfc_expr_list *el = assume->holds; el; el = el->next)
9597 17 : if (!gfc_resolve_expr (el->expr)
9598 17 : || el->expr->ts.type != BT_LOGICAL
9599 32 : || el->expr->rank != 0)
9600 4 : gfc_error ("HOLDS expression at %L must be a scalar logical expression",
9601 4 : &el->expr->where);
9602 29 : }
9603 :
9604 :
9605 : /* Resolve the OpenMP ALLOCATE clauses. */
9606 :
9607 : static void
9608 33042 : resolve_omp_allocate_clauses (gfc_code *code, gfc_omp_clauses *omp_clauses,
9609 : gfc_namespace *ns)
9610 : {
9611 33042 : gfc_omp_namelist *n;
9612 33042 : enum gfc_omp_list_type list;
9613 :
9614 33042 : if (!omp_clauses->lists[OMP_LIST_ALLOCATE])
9615 : return;
9616 795 : for (n = omp_clauses->lists[OMP_LIST_ALLOCATE]; n; n = n->next)
9617 : {
9618 515 : if (n->u2.allocator
9619 515 : && (!gfc_resolve_expr (n->u2.allocator)
9620 290 : || n->u2.allocator->ts.type != BT_INTEGER
9621 288 : || n->u2.allocator->rank != 0
9622 287 : || n->u2.allocator->ts.kind != gfc_c_intptr_kind))
9623 : {
9624 8 : gfc_error ("Expected integer expression of the "
9625 : "%<omp_allocator_handle_kind%> kind at %L",
9626 8 : &n->u2.allocator->where);
9627 28 : break;
9628 : }
9629 507 : if (!n->u.align)
9630 399 : continue;
9631 108 : HOST_WIDE_INT alignment = 0;
9632 108 : if (!gfc_resolve_expr (n->u.align)
9633 108 : || n->u.align->ts.type != BT_INTEGER
9634 105 : || n->u.align->rank != 0
9635 102 : || n->u.align->expr_type != EXPR_CONSTANT
9636 99 : || gfc_extract_hwi (n->u.align, &alignment)
9637 99 : || alignment <= 0
9638 207 : || !pow2p_hwi (alignment))
9639 : {
9640 12 : gfc_error ("ALIGN requires a scalar positive constant integer "
9641 : "alignment expression at %L that is a power of two",
9642 12 : &n->u.align->where);
9643 12 : break;
9644 : }
9645 : }
9646 :
9647 : /* Check for 2 things here.
9648 : 1. There is no duplication of variable in allocate clause.
9649 : 2. Variable in allocate clause are also present in some
9650 : privatization clase (non-composite case). */
9651 815 : for (n = omp_clauses->lists[OMP_LIST_ALLOCATE]; n; n = n->next)
9652 515 : if (n->sym)
9653 489 : n->sym->mark = 0;
9654 :
9655 : gfc_omp_namelist *prev = NULL;
9656 815 : for (n = omp_clauses->lists[OMP_LIST_ALLOCATE]; n; )
9657 : {
9658 515 : if (n->sym == NULL)
9659 : {
9660 26 : n = n->next;
9661 26 : continue;
9662 : }
9663 489 : if (n->sym->mark == 1)
9664 : {
9665 3 : gfc_warning (OPT_Wopenmp, "%qs appears more than once in "
9666 : "%<allocate%> at %L" , n->sym->name, &n->where);
9667 : /* We have already seen this variable so it is a duplicate.
9668 : Remove it. */
9669 3 : if (prev != NULL && prev->next == n)
9670 : {
9671 3 : prev->next = n->next;
9672 3 : n->next = NULL;
9673 3 : gfc_free_omp_namelist (n, OMP_LIST_ALLOCATE);
9674 3 : n = prev->next;
9675 : }
9676 3 : continue;
9677 : }
9678 486 : n->sym->mark = 1;
9679 486 : prev = n;
9680 486 : n = n->next;
9681 : }
9682 :
9683 : /* Non-composite constructs. */
9684 300 : if (code && code->op < EXEC_OMP_DO_SIMD)
9685 : {
9686 4760 : for (list = OMP_LIST_FIRST; list < OMP_LIST_NUM;
9687 4641 : list = gfc_omp_list_type (list + 1))
9688 4641 : switch (list)
9689 : {
9690 1071 : case OMP_LIST_PRIVATE:
9691 1071 : case OMP_LIST_FIRSTPRIVATE:
9692 1071 : case OMP_LIST_LASTPRIVATE:
9693 1071 : case OMP_LIST_REDUCTION:
9694 1071 : case OMP_LIST_REDUCTION_INSCAN:
9695 1071 : case OMP_LIST_REDUCTION_TASK:
9696 1071 : case OMP_LIST_IN_REDUCTION:
9697 1071 : case OMP_LIST_TASK_REDUCTION:
9698 1071 : case OMP_LIST_LINEAR:
9699 1370 : for (n = omp_clauses->lists[list]; n; n = n->next)
9700 299 : n->sym->mark = 0;
9701 : break;
9702 : default:
9703 : break;
9704 : }
9705 :
9706 410 : for (n = omp_clauses->lists[OMP_LIST_ALLOCATE]; n; n = n->next)
9707 291 : if (n->sym->mark == 1)
9708 4 : gfc_error ("%qs specified in %<allocate%> clause at %L but not "
9709 : "in an explicit privatization clause",
9710 : n->sym->name, &n->where);
9711 : }
9712 71 : if (!(code
9713 300 : && (code->op == EXEC_OMP_ALLOCATORS || code->op == EXEC_OMP_ALLOCATE)
9714 73 : && code->block
9715 72 : && code->block->next
9716 71 : && code->block->next->op == EXEC_ALLOCATE))
9717 232 : return;
9718 :
9719 68 : if (code->op == EXEC_OMP_ALLOCATE)
9720 49 : gfc_warning (OPT_Wdeprecated_openmp,
9721 : "The use of one or more %<allocate%> directives with "
9722 : "an associated %<allocate%> statement at %L is "
9723 : "deprecated since OpenMP 5.2, use an %<allocators%> "
9724 : "directive", &code->loc);
9725 68 : gfc_alloc *a;
9726 68 : gfc_omp_namelist *n_null = NULL;
9727 68 : bool missing_allocator = false;
9728 68 : gfc_symbol *missing_allocator_sym = NULL;
9729 161 : for (n = omp_clauses->lists[OMP_LIST_ALLOCATE]; n; n = n->next)
9730 : {
9731 93 : if (n->u2.allocator == NULL)
9732 : {
9733 77 : if (!missing_allocator_sym)
9734 59 : missing_allocator_sym = n->sym;
9735 : missing_allocator = true;
9736 : }
9737 93 : if (n->sym == NULL)
9738 : {
9739 26 : n_null = n;
9740 26 : continue;
9741 : }
9742 67 : if (n->sym->attr.codimension)
9743 2 : gfc_error ("Unexpected coarray %qs in %<allocate%> at %L",
9744 : n->sym->name, &n->where);
9745 103 : for (a = code->block->next->ext.alloc.list; a; a = a->next)
9746 101 : if (a->expr->expr_type == EXPR_VARIABLE
9747 101 : && a->expr->symtree->n.sym == n->sym)
9748 : {
9749 65 : gfc_ref *ref;
9750 82 : for (ref = a->expr->ref; ref; ref = ref->next)
9751 17 : if (ref->type == REF_COMPONENT)
9752 : break;
9753 : if (ref == NULL)
9754 : break;
9755 : }
9756 67 : if (a == NULL)
9757 2 : gfc_error ("%qs specified in %<allocate%> at %L but not "
9758 : "in the associated ALLOCATE statement",
9759 2 : n->sym->name, &n->where);
9760 : }
9761 : /* If there is an ALLOCATE directive without list argument, a
9762 : namelist with its allocator/align clauses and n->sym = NULL is
9763 : created during parsing; here, we add all not otherwise specified
9764 : items from the Fortran allocate to that list.
9765 : For an ALLOCATORS directive, not listed items use the normal
9766 : Fortran way.
9767 : The behavior of an ALLOCATE directive that does not list all
9768 : arguments but there is no directive without list argument is not
9769 : well specified. Thus, we reject such code below. In OpenMP 5.2
9770 : the executable ALLOCATE directive is deprecated and in 6.0
9771 : deleted such that no spec clarification is to be expected. */
9772 125 : for (a = code->block->next->ext.alloc.list; a; a = a->next)
9773 89 : if (a->expr->expr_type == EXPR_VARIABLE)
9774 : {
9775 154 : for (n = omp_clauses->lists[OMP_LIST_ALLOCATE]; n; n = n->next)
9776 122 : if (a->expr->symtree->n.sym == n->sym)
9777 : {
9778 57 : gfc_ref *ref;
9779 72 : for (ref = a->expr->ref; ref; ref = ref->next)
9780 15 : if (ref->type == REF_COMPONENT)
9781 : break;
9782 : if (ref == NULL)
9783 : break;
9784 : }
9785 89 : if (n == NULL && n_null == NULL)
9786 : {
9787 : /* OK for ALLOCATORS but for ALLOCATE: Unspecified whether
9788 : that should use the default allocator of OpenMP or the
9789 : Fortran allocator. Thus, just reject it. */
9790 7 : if (code->op == EXEC_OMP_ALLOCATE)
9791 1 : gfc_error ("%qs listed in %<allocate%> statement at %L "
9792 : "but it is neither explicitly in listed in "
9793 : "the %<!$OMP ALLOCATE%> directive nor exists"
9794 : " a directive without argument list",
9795 1 : a->expr->symtree->n.sym->name,
9796 : &a->expr->where);
9797 : break;
9798 : }
9799 82 : if (n == NULL)
9800 : {
9801 25 : if (a->expr->symtree->n.sym->attr.codimension)
9802 1 : gfc_error ("Unexpected coarray %qs in %<allocate%> at "
9803 : "%L, implicitly listed in %<!$OMP ALLOCATE%>"
9804 : " at %L", a->expr->symtree->n.sym->name,
9805 : &a->expr->where, &n_null->where);
9806 : break;
9807 : }
9808 : }
9809 68 : gfc_namespace *prog_unit = ns;
9810 87 : while (prog_unit->parent)
9811 : prog_unit = prog_unit->parent;
9812 : gfc_namespace *fn_ns = ns;
9813 72 : while (fn_ns)
9814 : {
9815 70 : if (ns->proc_name
9816 70 : && (ns->proc_name->attr.subroutine
9817 6 : || ns->proc_name->attr.function))
9818 : break;
9819 4 : fn_ns = fn_ns->parent;
9820 : }
9821 68 : if (missing_allocator
9822 58 : && !(prog_unit->omp_requires & OMP_REQ_DYNAMIC_ALLOCATORS)
9823 58 : && ((fn_ns && fn_ns->proc_name->attr.omp_declare_target)
9824 55 : || omp_clauses->contained_in_target_construct))
9825 : {
9826 6 : if (code->op == EXEC_OMP_ALLOCATORS)
9827 2 : gfc_error ("ALLOCATORS directive at %L inside a target region "
9828 : "must specify an ALLOCATOR modifier for %qs",
9829 : &code->loc, missing_allocator_sym->name);
9830 4 : else if (missing_allocator_sym)
9831 2 : gfc_error ("ALLOCATE directive at %L inside a target region "
9832 : "must specify an ALLOCATOR clause for %qs",
9833 : &code->loc, missing_allocator_sym->name);
9834 : else
9835 2 : gfc_error ("ALLOCATE directive at %L inside a target region "
9836 : "must specify an ALLOCATOR clause", &code->loc);
9837 : }
9838 : }
9839 :
9840 :
9841 : /* Diagnose list items that appear multiple times in OpenMP or OpenACC clauses,
9842 : unless permitted by the specification. */
9843 :
9844 : static void
9845 33042 : check_omp_clauses_dupl_syms (gfc_code *code, gfc_omp_clauses *omp_clauses,
9846 : bool openacc)
9847 : {
9848 33042 : gfc_omp_namelist *n;
9849 33042 : enum gfc_omp_list_type list;
9850 :
9851 : /* Check that no symbol appears on multiple clauses, except that
9852 : a symbol can appear on both firstprivate and lastprivate. */
9853 1321680 : for (list = OMP_LIST_FIRST; list < OMP_LIST_NUM;
9854 1288638 : list = gfc_omp_list_type (list + 1))
9855 1334473 : for (n = omp_clauses->lists[list]; n; n = n->next)
9856 : {
9857 45835 : if (!n->sym) /* omp_all_memory. */
9858 47 : continue;
9859 45788 : n->sym->mark = 0;
9860 45788 : n->sym->comp_mark = 0;
9861 45788 : n->sym->data_mark = 0;
9862 45788 : n->sym->dev_mark = 0;
9863 45788 : n->sym->gen_mark = 0;
9864 45788 : n->sym->reduc_mark = 0;
9865 : }
9866 1321680 : for (list = OMP_LIST_FIRST; list < OMP_LIST_NUM;
9867 1288638 : list = gfc_omp_list_type (list + 1))
9868 1288638 : if (list != OMP_LIST_FIRSTPRIVATE
9869 1288638 : && list != OMP_LIST_LASTPRIVATE
9870 1288638 : && list != OMP_LIST_ALIGNED
9871 1189512 : && list != OMP_LIST_DEPEND
9872 1189512 : && list != OMP_LIST_FROM
9873 1123428 : && list != OMP_LIST_TO
9874 1123428 : && list != OMP_LIST_INTEROP
9875 1057344 : && (list != OMP_LIST_REDUCTION || !openacc)
9876 1044349 : && list != OMP_LIST_ALLOCATE)
9877 1046234 : for (n = omp_clauses->lists[list]; n; n = n->next)
9878 : {
9879 34927 : bool component_ref_p = false;
9880 :
9881 : /* Allow multiple components of the same (e.g. derived-type)
9882 : variable here. Duplicate components are detected elsewhere. */
9883 34927 : if (n->expr && n->expr->expr_type == EXPR_VARIABLE)
9884 16007 : for (gfc_ref *ref = n->expr->ref; ref; ref = ref->next)
9885 9737 : if (ref->type == REF_COMPONENT)
9886 3190 : component_ref_p = true;
9887 34927 : if ((list == OMP_LIST_IS_DEVICE_PTR
9888 34927 : || list == OMP_LIST_HAS_DEVICE_ADDR)
9889 313 : && !component_ref_p)
9890 : {
9891 313 : if (n->sym->gen_mark
9892 311 : || n->sym->dev_mark
9893 310 : || n->sym->reduc_mark
9894 310 : || n->sym->mark)
9895 5 : gfc_error ("Symbol %qs present on multiple clauses at %L",
9896 : n->sym->name, &n->where);
9897 : else
9898 308 : n->sym->dev_mark = 1;
9899 : }
9900 34614 : else if ((list == OMP_LIST_USE_DEVICE_PTR
9901 34614 : || list == OMP_LIST_USE_DEVICE_ADDR
9902 34614 : || list == OMP_LIST_PRIVATE
9903 : || list == OMP_LIST_SHARED)
9904 12855 : && !component_ref_p)
9905 : {
9906 12855 : if (n->sym->gen_mark || n->sym->dev_mark || n->sym->reduc_mark)
9907 13 : gfc_error ("Symbol %qs present on multiple clauses at %L",
9908 : n->sym->name, &n->where);
9909 : else
9910 : {
9911 12842 : n->sym->gen_mark = 1;
9912 : /* Set both generic and device bits if we have
9913 : use_device_*(x) or shared(x). This allows us to diagnose
9914 : "map(x) private(x)" below. */
9915 12842 : if (list != OMP_LIST_PRIVATE)
9916 3456 : n->sym->dev_mark = 1;
9917 : }
9918 : }
9919 21759 : else if ((list == OMP_LIST_REDUCTION
9920 21759 : || list == OMP_LIST_REDUCTION_TASK
9921 19299 : || list == OMP_LIST_REDUCTION_INSCAN
9922 19299 : || list == OMP_LIST_IN_REDUCTION
9923 19086 : || list == OMP_LIST_TASK_REDUCTION)
9924 2673 : && !component_ref_p)
9925 : {
9926 : /* Attempts to mix reduction types are diagnosed below. */
9927 2673 : if (n->sym->gen_mark || n->sym->dev_mark)
9928 2 : gfc_error ("Symbol %qs present on multiple clauses at %L",
9929 : n->sym->name, &n->where);
9930 2673 : n->sym->reduc_mark = 1;
9931 : }
9932 19086 : else if ((!component_ref_p && n->sym->comp_mark)
9933 19085 : || (component_ref_p && n->sym->mark))
9934 : {
9935 42 : if (openacc)
9936 3 : gfc_error ("Symbol %qs has mixed component and non-component "
9937 3 : "accesses at %L", n->sym->name, &n->where);
9938 : }
9939 19044 : else if ((openacc || list != OMP_LIST_MAP) && n->sym->mark)
9940 88 : gfc_error ("Symbol %qs present on multiple clauses at %L",
9941 : n->sym->name, &n->where);
9942 : else
9943 : {
9944 18956 : if (component_ref_p)
9945 2466 : n->sym->comp_mark = 1;
9946 : else
9947 16490 : n->sym->mark = 1;
9948 : }
9949 : }
9950 :
9951 : /* Detect specifically the case where we have "map(x) private(x)" and raise
9952 : an error. If we have "...simd" combined directives though, the "private"
9953 : applies to the simd part, so this is permitted though. */
9954 42436 : for (n = omp_clauses->lists[OMP_LIST_PRIVATE]; n; n = n->next)
9955 9394 : if (n->sym->mark
9956 6 : && n->sym->gen_mark
9957 6 : && !n->sym->dev_mark
9958 6 : && !n->sym->reduc_mark
9959 5 : && code->op != EXEC_OMP_TARGET_SIMD
9960 : && code->op != EXEC_OMP_TARGET_PARALLEL_DO_SIMD
9961 : && code->op != EXEC_OMP_TARGET_TEAMS_DISTRIBUTE_SIMD
9962 : && code->op != EXEC_OMP_TARGET_TEAMS_DISTRIBUTE_PARALLEL_DO_SIMD)
9963 1 : gfc_error ("Symbol %qs present on multiple clauses at %L",
9964 : n->sym->name, &n->where);
9965 :
9966 : gcc_assert (OMP_LIST_LASTPRIVATE == OMP_LIST_FIRSTPRIVATE + 1);
9967 99126 : for (list = OMP_LIST_FIRSTPRIVATE; list <= OMP_LIST_LASTPRIVATE;
9968 66084 : list = gfc_omp_list_type (list + 1))
9969 70307 : for (n = omp_clauses->lists[list]; n; n = n->next)
9970 4223 : if (n->sym->data_mark || n->sym->gen_mark || n->sym->dev_mark)
9971 : {
9972 9 : gfc_error ("Symbol %qs present on multiple clauses at %L",
9973 : n->sym->name, &n->where);
9974 9 : n->sym->data_mark = n->sym->gen_mark = n->sym->dev_mark = 0;
9975 : }
9976 4214 : else if (n->sym->mark
9977 18 : && code->op != EXEC_OMP_TARGET_TEAMS
9978 : && code->op != EXEC_OMP_TARGET_TEAMS_DISTRIBUTE
9979 : && code->op != EXEC_OMP_TARGET_TEAMS_LOOP
9980 : && code->op != EXEC_OMP_TARGET_TEAMS_DISTRIBUTE_SIMD
9981 : && code->op != EXEC_OMP_TARGET_TEAMS_DISTRIBUTE_PARALLEL_DO
9982 : && code->op != EXEC_OMP_TARGET_PARALLEL
9983 : && code->op != EXEC_OMP_TARGET_PARALLEL_DO
9984 : && code->op != EXEC_OMP_TARGET_PARALLEL_LOOP
9985 : && code->op != EXEC_OMP_TARGET_PARALLEL_DO_SIMD
9986 : && code->op != EXEC_OMP_TARGET_TEAMS_DISTRIBUTE_PARALLEL_DO_SIMD)
9987 7 : gfc_error ("Symbol %qs present on both data and map clauses "
9988 : "at %L", n->sym->name, &n->where);
9989 :
9990 34957 : for (n = omp_clauses->lists[OMP_LIST_FIRSTPRIVATE]; n; n = n->next)
9991 : {
9992 1915 : if (n->sym->data_mark || n->sym->gen_mark || n->sym->dev_mark)
9993 7 : gfc_error ("Symbol %qs present on multiple clauses at %L",
9994 : n->sym->name, &n->where);
9995 : else
9996 1908 : n->sym->data_mark = 1;
9997 : }
9998 :
9999 : /* LASTPRIVATE clauses. */
10000 35350 : for (n = omp_clauses->lists[OMP_LIST_LASTPRIVATE]; n; n = n->next)
10001 2308 : n->sym->data_mark = 0;
10002 35350 : for (n = omp_clauses->lists[OMP_LIST_LASTPRIVATE]; n; n = n->next)
10003 : {
10004 2308 : if (n->sym->data_mark || n->sym->gen_mark || n->sym->dev_mark)
10005 0 : gfc_error ("Symbol %qs present on multiple clauses at %L",
10006 : n->sym->name, &n->where);
10007 : else
10008 2308 : n->sym->data_mark = 1;
10009 : }
10010 :
10011 : /* ALIGNED clauses. */
10012 33192 : for (n = omp_clauses->lists[OMP_LIST_ALIGNED]; n; n = n->next)
10013 150 : n->sym->mark = 0;
10014 :
10015 33192 : for (n = omp_clauses->lists[OMP_LIST_ALIGNED]; n; n = n->next)
10016 : {
10017 150 : if (n->sym->mark)
10018 0 : gfc_error ("Symbol %qs present on multiple clauses at %L",
10019 : n->sym->name, &n->where);
10020 : else
10021 150 : n->sym->mark = 1;
10022 : }
10023 :
10024 : /* FROM and TO clauses. */
10025 33812 : for (n = omp_clauses->lists[OMP_LIST_TO]; n; n = n->next)
10026 770 : n->sym->mark = 0;
10027 34075 : for (n = omp_clauses->lists[OMP_LIST_FROM]; n; n = n->next)
10028 1033 : if (n->expr == NULL)
10029 1015 : n->sym->mark = 1;
10030 33812 : for (n = omp_clauses->lists[OMP_LIST_TO]; n; n = n->next)
10031 : {
10032 770 : if (n->expr == NULL && n->sym->mark)
10033 0 : gfc_error ("Symbol %qs present on both FROM and TO clauses at %L",
10034 : n->sym->name, &n->where);
10035 : else
10036 770 : n->sym->mark = 1;
10037 : }
10038 :
10039 : /* OpenACC reductions. */
10040 33042 : if (openacc)
10041 : {
10042 15131 : for (n = omp_clauses->lists[OMP_LIST_REDUCTION]; n; n = n->next)
10043 2136 : n->sym->mark = 0;
10044 15131 : for (n = omp_clauses->lists[OMP_LIST_REDUCTION]; n; n = n->next)
10045 : {
10046 2136 : if (n->sym->mark)
10047 0 : gfc_error ("Symbol %qs present on multiple clauses at %L",
10048 : n->sym->name, &n->where);
10049 : else
10050 2136 : n->sym->mark = 1;
10051 :
10052 : /* OpenACC does not support reductions on arrays. */
10053 2136 : if (n->sym->as)
10054 71 : gfc_error ("Array %qs is not permitted in reduction at %L",
10055 : n->sym->name, &n->where);
10056 : }
10057 : }
10058 33042 : }
10059 :
10060 : /* OpenMP/OpenACC: Resolve the list item of a MAP, TO, FROM, CACHE, AFFINITY
10061 : or DEPEND clause. */
10062 :
10063 : static void
10064 20943 : resolve_omp_clauses_aff_dep_map_cache (gfc_code *code,
10065 : gfc_omp_namelist *n,
10066 : const char *name,
10067 : enum gfc_omp_list_type list,
10068 : gfc_omp_clauses *omp_clauses,
10069 : bool openacc)
10070 : {
10071 20943 : gcc_checking_assert (list == OMP_LIST_AFFINITY || list == OMP_LIST_DEPEND
10072 : || list == OMP_LIST_MAP || list == OMP_LIST_TO
10073 : || list == OMP_LIST_FROM || list == OMP_LIST_CACHE);
10074 :
10075 20943 : if (list != OMP_LIST_CACHE && n->u2.ns && !n->u2.ns->resolved)
10076 : {
10077 109 : n->u2.ns->resolved = 1;
10078 109 : for (gfc_symbol *sym = n->u2.ns->omp_affinity_iterators;
10079 235 : sym; sym = sym->tlink)
10080 : {
10081 126 : gfc_constructor *c;
10082 126 : c = gfc_constructor_first (sym->value->value.constructor);
10083 126 : if (!gfc_resolve_expr (c->expr)
10084 126 : || c->expr->ts.type != BT_INTEGER
10085 250 : || c->expr->rank != 0)
10086 2 : gfc_error ("Scalar integer expression for range begin expected "
10087 2 : "at %L", &c->expr->where);
10088 126 : c = gfc_constructor_next (c);
10089 126 : if (!gfc_resolve_expr (c->expr)
10090 126 : || c->expr->ts.type != BT_INTEGER
10091 250 : || c->expr->rank != 0)
10092 2 : gfc_error ("Scalar integer expression for range end expected at %L",
10093 2 : &c->expr->where);
10094 126 : c = gfc_constructor_next (c);
10095 126 : if (c && (!gfc_resolve_expr (c->expr)
10096 16 : || c->expr->ts.type != BT_INTEGER
10097 14 : || c->expr->rank != 0))
10098 2 : gfc_error ("Scalar integer expression for range step expected "
10099 2 : "at %L", &c->expr->where);
10100 124 : else if (c
10101 14 : && c->expr->expr_type == EXPR_CONSTANT
10102 12 : && mpz_cmp_si (c->expr->value.integer, 0) == 0)
10103 2 : gfc_error ("Nonzero range step expected at %L", &c->expr->where);
10104 : }
10105 : }
10106 20842 : if (list == OMP_LIST_DEPEND)
10107 : {
10108 1963 : if (n->u.depend_doacross_op == OMP_DEPEND_SINK_FIRST
10109 : || n->u.depend_doacross_op == OMP_DOACROSS_SINK_FIRST
10110 1963 : || n->u.depend_doacross_op == OMP_DOACROSS_SINK)
10111 : {
10112 1233 : if (omp_clauses->doacross_source)
10113 : {
10114 0 : gfc_error ("Dependence-type SINK used together with SOURCE on "
10115 : "the same construct at %L", &n->where);
10116 0 : omp_clauses->doacross_source = false;
10117 : }
10118 1233 : else if (n->expr)
10119 : {
10120 571 : if (!gfc_resolve_expr (n->expr)
10121 571 : || n->expr->ts.type != BT_INTEGER
10122 1142 : || n->expr->rank != 0)
10123 0 : gfc_error ("SINK addend not a constant integer at %L",
10124 : &n->where);
10125 : }
10126 1233 : if (n->sym == NULL
10127 4 : && (n->expr == NULL
10128 3 : || mpz_cmp_si (n->expr->value.integer, -1) != 0))
10129 2 : gfc_error ("omp_cur_iteration at %L requires %<-1%> as "
10130 : "logical offset", &n->where);
10131 1233 : return;
10132 : }
10133 730 : if (n->u.depend_doacross_op == OMP_DEPEND_DEPOBJ
10134 38 : && !n->expr
10135 22 : && (n->sym->ts.type != BT_INTEGER
10136 22 : || n->sym->ts.kind != 2 * gfc_index_integer_kind
10137 22 : || n->sym->attr.dimension))
10138 0 : gfc_error ("Locator %qs at %L in DEPEND clause of depobj type shall be "
10139 : "a scalar integer of OMP_DEPEND_KIND kind",
10140 : n->sym->name, &n->where);
10141 730 : else if (n->u.depend_doacross_op == OMP_DEPEND_DEPOBJ
10142 38 : && n->expr
10143 746 : && (!gfc_resolve_expr (n->expr)
10144 16 : || n->expr->ts.type != BT_INTEGER
10145 16 : || n->expr->ts.kind != 2 * gfc_index_integer_kind
10146 16 : || n->expr->rank != 0))
10147 0 : gfc_error ("Locator at %L in DEPEND clause of depobj type shall be a "
10148 0 : "scalar integer of OMP_DEPEND_KIND kind", &n->expr->where);
10149 : }
10150 19710 : gfc_ref *lastref = NULL, *lastslice = NULL;
10151 19710 : bool resolved = false;
10152 19710 : if (n->expr)
10153 : {
10154 6539 : lastref = n->expr->ref;
10155 6539 : resolved = gfc_resolve_expr (n->expr);
10156 :
10157 : /* Look through component refs to find last array reference. */
10158 6539 : if (resolved)
10159 : {
10160 16571 : for (gfc_ref *ref = n->expr->ref; ref; ref = ref->next)
10161 10050 : if (ref->type == REF_COMPONENT
10162 : || ref->type == REF_SUBSTRING
10163 10050 : || ref->type == REF_INQUIRY)
10164 : lastref = ref;
10165 6799 : else if (ref->type == REF_ARRAY)
10166 : {
10167 14290 : for (int i = 0; i < ref->u.ar.dimen; i++)
10168 7491 : if (ref->u.ar.dimen_type[i] == DIMEN_RANGE)
10169 6277 : lastslice = ref;
10170 : lastref = ref;
10171 : }
10172 :
10173 : /* The "!$acc cache" directive allows rectangular subarrays to be
10174 : specified, with some restrictions on the form of bounds (not
10175 : implemented). Only raise an error here if we're really sure the
10176 : array isn't contiguous. An expression such as arr(-n:n,-n:n)
10177 : could be contiguous even if it looks like it may not be. */
10178 6521 : if (code
10179 6502 : && code->op != EXEC_OACC_UPDATE
10180 5720 : && list != OMP_LIST_CACHE
10181 5720 : && list != OMP_LIST_DEPEND
10182 5398 : && !gfc_is_simply_contiguous (n->expr, false, true)
10183 1517 : && gfc_is_not_contiguous (n->expr)
10184 6534 : && !(lastslice && (lastslice->next
10185 3 : || lastslice->type != REF_ARRAY)))
10186 3 : gfc_error ("Array is not contiguous at %L", &n->where);
10187 : }
10188 : }
10189 19710 : if (list == OMP_LIST_MAP
10190 17041 : && (n->sym->attr.omp_groupprivate
10191 17040 : || n->sym->attr.omp_declare_target_local))
10192 2 : gfc_error ("%qs argument to MAP clause at %L must not be a device-local "
10193 : "variable, including GROUPPRIVATE", n->sym->name, &n->where);
10194 19710 : if (openacc
10195 19710 : && list == OMP_LIST_MAP
10196 9571 : && (n->u.map.op == OMP_MAP_ATTACH || n->u.map.op == OMP_MAP_DETACH))
10197 : {
10198 117 : symbol_attribute attr;
10199 117 : if (n->expr)
10200 99 : attr = gfc_expr_attr (n->expr);
10201 : else
10202 18 : attr = n->sym->attr;
10203 117 : if (!attr.pointer && !attr.allocatable)
10204 7 : gfc_error ("%qs clause argument must be ALLOCATABLE or a POINTER at %L",
10205 7 : (n->u.map.op == OMP_MAP_ATTACH) ? "attach" : "detach",
10206 : &n->where);
10207 : }
10208 19710 : if (lastref
10209 13183 : || (n->expr && (!resolved || n->expr->expr_type != EXPR_VARIABLE)))
10210 : {
10211 6539 : if (!lastslice && lastref && lastref->type == REF_SUBSTRING)
10212 11 : gfc_error ("Unexpected substring reference in %s clause at %L",
10213 : name, &n->where);
10214 6528 : else if (!lastslice && lastref && lastref->type == REF_INQUIRY)
10215 : {
10216 12 : gcc_assert (lastref->u.i == INQUIRY_RE || lastref->u.i == INQUIRY_IM);
10217 12 : gfc_error ("Unexpected complex-parts designator reference in %s "
10218 : "clause at %L", name, &n->where);
10219 : }
10220 6516 : else if (!resolved
10221 6498 : || n->expr->expr_type != EXPR_VARIABLE
10222 6486 : || (lastslice
10223 5615 : && (lastslice->next || lastslice->type != REF_ARRAY)))
10224 46 : gfc_error ("%qs in %s clause at %L is not a proper array section",
10225 46 : n->sym->name, name, &n->where);
10226 : else if (lastslice)
10227 : {
10228 : int i;
10229 : gfc_array_ref *ar = &lastslice->u.ar;
10230 11873 : for (i = 0; i < ar->dimen; i++)
10231 6275 : if (ar->stride[i] && code && code->op != EXEC_OACC_UPDATE)
10232 : {
10233 1 : gfc_error ("Stride should not be specified for array section "
10234 : "in %s clause at %L", name, &n->where);
10235 1 : break;
10236 : }
10237 6274 : else if (ar->dimen_type[i] != DIMEN_ELEMENT
10238 6274 : && ar->dimen_type[i] != DIMEN_RANGE)
10239 : {
10240 0 : gfc_error ("%qs in %s clause at %L is not a proper array "
10241 0 : "section", n->sym->name, name, &n->where);
10242 0 : break;
10243 : }
10244 6274 : else if ((list == OMP_LIST_DEPEND || list == OMP_LIST_AFFINITY)
10245 161 : && ar->start[i]
10246 133 : && ar->start[i]->expr_type == EXPR_CONSTANT
10247 97 : && ar->end[i]
10248 72 : && ar->end[i]->expr_type == EXPR_CONSTANT
10249 72 : && mpz_cmp (ar->start[i]->value.integer,
10250 72 : ar->end[i]->value.integer) > 0)
10251 : {
10252 0 : gfc_error ("%qs in %s clause at %L is a zero size array "
10253 0 : "section", n->sym->name,
10254 : list == OMP_LIST_DEPEND ? "DEPEND" : "AFFINITY",
10255 : &n->where);
10256 0 : break;
10257 : }
10258 : }
10259 : }
10260 13171 : else if (openacc)
10261 : {
10262 5915 : if (list == OMP_LIST_MAP && n->u.map.op == OMP_MAP_FORCE_DEVICEPTR)
10263 65 : resolve_oacc_deviceptr_clause (n->sym, n->where, name);
10264 : else
10265 5850 : resolve_oacc_data_clauses (n->sym, n->where, name);
10266 : }
10267 7256 : else if (list != OMP_LIST_DEPEND
10268 6763 : && n->sym->as
10269 3339 : && n->sym->as->type == AS_ASSUMED_SIZE)
10270 5 : gfc_error ("Assumed size array %qs in %s clause at %L",
10271 : n->sym->name, name, &n->where);
10272 19710 : if (code && list == OMP_LIST_MAP && !openacc)
10273 7432 : switch (code->op)
10274 : {
10275 6157 : case EXEC_OMP_TARGET:
10276 6157 : case EXEC_OMP_TARGET_PARALLEL:
10277 6157 : case EXEC_OMP_TARGET_PARALLEL_DO:
10278 6157 : case EXEC_OMP_TARGET_PARALLEL_DO_SIMD:
10279 6157 : case EXEC_OMP_TARGET_PARALLEL_LOOP:
10280 6157 : case EXEC_OMP_TARGET_SIMD:
10281 6157 : case EXEC_OMP_TARGET_TEAMS:
10282 6157 : case EXEC_OMP_TARGET_TEAMS_DISTRIBUTE:
10283 6157 : case EXEC_OMP_TARGET_TEAMS_DISTRIBUTE_PARALLEL_DO:
10284 6157 : case EXEC_OMP_TARGET_TEAMS_DISTRIBUTE_PARALLEL_DO_SIMD:
10285 6157 : case EXEC_OMP_TARGET_TEAMS_DISTRIBUTE_SIMD:
10286 6157 : case EXEC_OMP_TARGET_TEAMS_LOOP:
10287 6157 : case EXEC_OMP_TARGET_DATA:
10288 6157 : 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_FROM:
10295 : case OMP_MAP_ALWAYS_FROM:
10296 : case OMP_MAP_PRESENT_FROM:
10297 : case OMP_MAP_ALWAYS_PRESENT_FROM:
10298 : case OMP_MAP_TOFROM:
10299 : case OMP_MAP_ALWAYS_TOFROM:
10300 : case OMP_MAP_PRESENT_TOFROM:
10301 : case OMP_MAP_ALWAYS_PRESENT_TOFROM:
10302 : case OMP_MAP_ALLOC:
10303 : case OMP_MAP_PRESENT_ALLOC:
10304 : break;
10305 2 : default:
10306 2 : gfc_error ("TARGET%s with map-type other than TO, "
10307 : "FROM, TOFROM, or ALLOC on MAP clause "
10308 : "at %L",
10309 : code->op == EXEC_OMP_TARGET_DATA
10310 : ? " DATA" : "", &n->where);
10311 2 : break;
10312 : }
10313 : break;
10314 697 : case EXEC_OMP_TARGET_ENTER_DATA:
10315 697 : switch (n->u.map.op)
10316 : {
10317 : case OMP_MAP_TO:
10318 : case OMP_MAP_ALWAYS_TO:
10319 : case OMP_MAP_PRESENT_TO:
10320 : case OMP_MAP_ALWAYS_PRESENT_TO:
10321 : case OMP_MAP_ALLOC:
10322 : case OMP_MAP_PRESENT_ALLOC:
10323 : break;
10324 178 : case OMP_MAP_TOFROM:
10325 178 : n->u.map.op = OMP_MAP_TO;
10326 178 : break;
10327 3 : case OMP_MAP_ALWAYS_TOFROM:
10328 3 : n->u.map.op = OMP_MAP_ALWAYS_TO;
10329 3 : break;
10330 2 : case OMP_MAP_PRESENT_TOFROM:
10331 2 : n->u.map.op = OMP_MAP_PRESENT_TO;
10332 2 : break;
10333 2 : case OMP_MAP_ALWAYS_PRESENT_TOFROM:
10334 2 : n->u.map.op = OMP_MAP_ALWAYS_PRESENT_TO;
10335 2 : break;
10336 2 : default:
10337 2 : gfc_error ("TARGET ENTER DATA with map-type other "
10338 : "than TO, TOFROM or ALLOC on MAP clause "
10339 : "at %L", &n->where);
10340 2 : break;
10341 : }
10342 : break;
10343 578 : case EXEC_OMP_TARGET_EXIT_DATA:
10344 578 : switch (n->u.map.op)
10345 : {
10346 : case OMP_MAP_FROM:
10347 : case OMP_MAP_ALWAYS_FROM:
10348 : case OMP_MAP_PRESENT_FROM:
10349 : case OMP_MAP_ALWAYS_PRESENT_FROM:
10350 : case OMP_MAP_RELEASE:
10351 : case OMP_MAP_DELETE:
10352 : break;
10353 132 : case OMP_MAP_TOFROM:
10354 132 : n->u.map.op = OMP_MAP_FROM;
10355 132 : break;
10356 1 : case OMP_MAP_ALWAYS_TOFROM:
10357 1 : n->u.map.op = OMP_MAP_ALWAYS_FROM;
10358 1 : break;
10359 0 : case OMP_MAP_PRESENT_TOFROM:
10360 0 : n->u.map.op = OMP_MAP_PRESENT_FROM;
10361 0 : break;
10362 0 : case OMP_MAP_ALWAYS_PRESENT_TOFROM:
10363 0 : n->u.map.op = OMP_MAP_ALWAYS_PRESENT_FROM;
10364 0 : break;
10365 2 : default:
10366 2 : gfc_error ("TARGET EXIT DATA with map-type other "
10367 : "than FROM, TOFROM, RELEASE, or DELETE on "
10368 : "MAP clause at %L", &n->where);
10369 2 : break;
10370 : }
10371 : break;
10372 : default:
10373 : break;
10374 : }
10375 19710 : if (list == OMP_LIST_MAP || list == OMP_LIST_TO || list == OMP_LIST_FROM)
10376 : {
10377 18844 : gfc_typespec *ts = n->expr ? &n->expr->ts : &n->sym->ts;
10378 :
10379 18844 : if (ts->type == BT_DERIVED || ts->type == BT_CLASS)
10380 : {
10381 9 : const char *mapper_id = (n->u3.udm
10382 999 : ? n->u3.udm->requested_mapper_id : "");
10383 999 : gfc_omp_udm *udm = gfc_find_omp_udm (gfc_current_ns, mapper_id, ts);
10384 999 : if (mapper_id[0] != '\0' && !udm)
10385 1 : gfc_error ("User-defined mapper %qs not found at %L",
10386 : mapper_id, &n->where);
10387 995 : else if (udm)
10388 : {
10389 26 : if (!n->u3.udm)
10390 : {
10391 18 : gcc_assert (mapper_id[0] == '\0');
10392 18 : n->u3.udm = gfc_get_omp_namelist_udm ();
10393 18 : n->u3.udm->requested_mapper_id = mapper_id;
10394 : }
10395 26 : n->u3.udm->resolved_udm = udm;
10396 : }
10397 : }
10398 : }
10399 :
10400 19710 : if (list != OMP_LIST_DEPEND)
10401 : {
10402 18980 : n->sym->attr.referenced = 1;
10403 18980 : if (n->sym->attr.threadprivate)
10404 1 : gfc_error ("THREADPRIVATE object %qs in %s clause at %L",
10405 : n->sym->name, name, &n->where);
10406 18980 : if (n->sym->attr.cray_pointee)
10407 14 : gfc_error ("Cray pointee %qs in %s clause at %L",
10408 : n->sym->name, name, &n->where);
10409 : }
10410 : }
10411 :
10412 : /* OpenMP directive resolving routines. */
10413 :
10414 : static void
10415 33042 : resolve_omp_clauses (gfc_code *code, gfc_omp_clauses *omp_clauses,
10416 : gfc_namespace *ns, bool openacc = false)
10417 : {
10418 33042 : gfc_omp_namelist *n, *last;
10419 33042 : gfc_expr_list *el;
10420 33042 : enum gfc_omp_list_type list;
10421 33042 : int ifc;
10422 33042 : bool if_without_mod = false;
10423 33042 : gfc_omp_linear_op linear_op = OMP_LINEAR_DEFAULT;
10424 33042 : static const char *clause_names[]
10425 : = { "PRIVATE", "FIRSTPRIVATE", "LASTPRIVATE", "COPYPRIVATE", "SHARED",
10426 : "COPYIN", "UNIFORM", "AFFINITY", "ALIGNED", "LINEAR", "DEPEND", "MAP",
10427 : "TO", "FROM", "INCLUSIVE", "EXCLUSIVE",
10428 : "REDUCTION", "REDUCTION" /*inscan*/, "REDUCTION" /*task*/,
10429 : "IN_REDUCTION", "TASK_REDUCTION",
10430 : "DEVICE_RESIDENT", "LINK", "LOCAL", "USE_DEVICE",
10431 : "CACHE", "IS_DEVICE_PTR", "USE_DEVICE_PTR", "USE_DEVICE_ADDR",
10432 : "NONTEMPORAL", "ALLOCATE", "HAS_DEVICE_ADDR", "ENTER",
10433 : "USES_ALLOCATORS", "INIT", "USE", "DESTROY", "INTEROP", "ADJUST_ARGS" };
10434 33042 : STATIC_ASSERT (ARRAY_SIZE (clause_names) == OMP_LIST_NUM);
10435 :
10436 33042 : if (omp_clauses == NULL)
10437 : return;
10438 :
10439 33042 : if (ns == NULL)
10440 32598 : ns = gfc_current_ns;
10441 :
10442 33042 : check_omp_clauses_dupl_syms (code, omp_clauses, openacc);
10443 :
10444 33042 : if (omp_clauses->orderedc && omp_clauses->orderedc < omp_clauses->collapse)
10445 0 : gfc_error ("ORDERED clause parameter is less than COLLAPSE at %L",
10446 : &code->loc);
10447 33042 : if (omp_clauses->order_concurrent && omp_clauses->ordered)
10448 4 : gfc_error ("ORDER clause must not be used together with ORDERED at %L",
10449 : &code->loc);
10450 33042 : if (omp_clauses->if_expr)
10451 : {
10452 1299 : gfc_expr *expr = omp_clauses->if_expr;
10453 1299 : if (!gfc_resolve_expr (expr)
10454 1299 : || expr->ts.type != BT_LOGICAL || expr->rank != 0)
10455 16 : gfc_error ("IF clause at %L requires a scalar LOGICAL expression",
10456 : &expr->where);
10457 : if_without_mod = true;
10458 : }
10459 363462 : for (ifc = 0; ifc < OMP_IF_LAST; ifc++)
10460 330420 : if (omp_clauses->if_exprs[ifc])
10461 : {
10462 137 : gfc_expr *expr = omp_clauses->if_exprs[ifc];
10463 137 : bool ok = true;
10464 137 : if (!gfc_resolve_expr (expr)
10465 137 : || expr->ts.type != BT_LOGICAL || expr->rank != 0)
10466 0 : gfc_error ("IF clause at %L requires a scalar LOGICAL expression",
10467 : &expr->where);
10468 137 : else if (if_without_mod)
10469 : {
10470 1 : gfc_error ("IF clause without modifier at %L used together with "
10471 : "IF clauses with modifiers",
10472 1 : &omp_clauses->if_expr->where);
10473 1 : if_without_mod = false;
10474 : }
10475 : else
10476 136 : switch (code->op)
10477 : {
10478 13 : case EXEC_OMP_CANCEL:
10479 13 : ok = ifc == OMP_IF_CANCEL;
10480 13 : break;
10481 :
10482 16 : case EXEC_OMP_PARALLEL:
10483 16 : case EXEC_OMP_PARALLEL_DO:
10484 16 : case EXEC_OMP_PARALLEL_LOOP:
10485 16 : case EXEC_OMP_PARALLEL_MASKED:
10486 16 : case EXEC_OMP_PARALLEL_MASTER:
10487 16 : case EXEC_OMP_PARALLEL_SECTIONS:
10488 16 : case EXEC_OMP_PARALLEL_WORKSHARE:
10489 16 : case EXEC_OMP_DISTRIBUTE_PARALLEL_DO:
10490 16 : case EXEC_OMP_TEAMS_DISTRIBUTE_PARALLEL_DO:
10491 16 : ok = ifc == OMP_IF_PARALLEL;
10492 16 : break;
10493 :
10494 28 : case EXEC_OMP_PARALLEL_DO_SIMD:
10495 28 : case EXEC_OMP_DISTRIBUTE_PARALLEL_DO_SIMD:
10496 28 : case EXEC_OMP_TEAMS_DISTRIBUTE_PARALLEL_DO_SIMD:
10497 28 : ok = ifc == OMP_IF_PARALLEL || ifc == OMP_IF_SIMD;
10498 28 : break;
10499 :
10500 8 : case EXEC_OMP_PARALLEL_MASKED_TASKLOOP:
10501 8 : case EXEC_OMP_PARALLEL_MASTER_TASKLOOP:
10502 8 : ok = ifc == OMP_IF_PARALLEL || ifc == OMP_IF_TASKLOOP;
10503 8 : break;
10504 :
10505 12 : case EXEC_OMP_PARALLEL_MASKED_TASKLOOP_SIMD:
10506 12 : case EXEC_OMP_PARALLEL_MASTER_TASKLOOP_SIMD:
10507 12 : ok = (ifc == OMP_IF_PARALLEL
10508 12 : || ifc == OMP_IF_TASKLOOP
10509 : || ifc == OMP_IF_SIMD);
10510 : break;
10511 :
10512 0 : case EXEC_OMP_SIMD:
10513 0 : case EXEC_OMP_DO_SIMD:
10514 0 : case EXEC_OMP_DISTRIBUTE_SIMD:
10515 0 : case EXEC_OMP_TEAMS_DISTRIBUTE_SIMD:
10516 0 : ok = ifc == OMP_IF_SIMD;
10517 0 : break;
10518 :
10519 1 : case EXEC_OMP_TASK:
10520 1 : ok = ifc == OMP_IF_TASK;
10521 1 : break;
10522 :
10523 5 : case EXEC_OMP_TASKLOOP:
10524 5 : case EXEC_OMP_MASKED_TASKLOOP:
10525 5 : case EXEC_OMP_MASTER_TASKLOOP:
10526 5 : ok = ifc == OMP_IF_TASKLOOP;
10527 5 : break;
10528 :
10529 20 : case EXEC_OMP_TASKLOOP_SIMD:
10530 20 : case EXEC_OMP_MASKED_TASKLOOP_SIMD:
10531 20 : case EXEC_OMP_MASTER_TASKLOOP_SIMD:
10532 20 : ok = ifc == OMP_IF_TASKLOOP || ifc == OMP_IF_SIMD;
10533 20 : break;
10534 :
10535 5 : case EXEC_OMP_TARGET:
10536 5 : case EXEC_OMP_TARGET_TEAMS:
10537 5 : case EXEC_OMP_TARGET_TEAMS_DISTRIBUTE:
10538 5 : case EXEC_OMP_TARGET_TEAMS_LOOP:
10539 5 : ok = ifc == OMP_IF_TARGET;
10540 5 : break;
10541 :
10542 4 : case EXEC_OMP_TARGET_TEAMS_DISTRIBUTE_SIMD:
10543 4 : case EXEC_OMP_TARGET_SIMD:
10544 4 : ok = ifc == OMP_IF_TARGET || ifc == OMP_IF_SIMD;
10545 4 : break;
10546 :
10547 1 : case EXEC_OMP_TARGET_DATA:
10548 1 : ok = ifc == OMP_IF_TARGET_DATA;
10549 1 : break;
10550 :
10551 1 : case EXEC_OMP_TARGET_UPDATE:
10552 1 : ok = ifc == OMP_IF_TARGET_UPDATE;
10553 1 : break;
10554 :
10555 1 : case EXEC_OMP_TARGET_ENTER_DATA:
10556 1 : ok = ifc == OMP_IF_TARGET_ENTER_DATA;
10557 1 : break;
10558 :
10559 1 : case EXEC_OMP_TARGET_EXIT_DATA:
10560 1 : ok = ifc == OMP_IF_TARGET_EXIT_DATA;
10561 1 : break;
10562 :
10563 10 : case EXEC_OMP_TARGET_TEAMS_DISTRIBUTE_PARALLEL_DO:
10564 10 : case EXEC_OMP_TARGET_PARALLEL:
10565 10 : case EXEC_OMP_TARGET_PARALLEL_DO:
10566 10 : case EXEC_OMP_TARGET_PARALLEL_LOOP:
10567 10 : ok = ifc == OMP_IF_TARGET || ifc == OMP_IF_PARALLEL;
10568 10 : break;
10569 :
10570 10 : case EXEC_OMP_TARGET_PARALLEL_DO_SIMD:
10571 10 : case EXEC_OMP_TARGET_TEAMS_DISTRIBUTE_PARALLEL_DO_SIMD:
10572 10 : ok = (ifc == OMP_IF_TARGET
10573 10 : || ifc == OMP_IF_PARALLEL
10574 : || ifc == OMP_IF_SIMD);
10575 : break;
10576 :
10577 : default:
10578 : ok = false;
10579 : break;
10580 : }
10581 115 : if (!ok)
10582 : {
10583 2 : static const char *ifs[] = {
10584 : "CANCEL",
10585 : "PARALLEL",
10586 : "SIMD",
10587 : "TASK",
10588 : "TASKLOOP",
10589 : "TARGET",
10590 : "TARGET DATA",
10591 : "TARGET UPDATE",
10592 : "TARGET ENTER DATA",
10593 : "TARGET EXIT DATA"
10594 : };
10595 2 : gfc_error ("IF clause modifier %s at %L not appropriate for "
10596 : "the current OpenMP construct", ifs[ifc], &expr->where);
10597 : }
10598 : }
10599 :
10600 33042 : if (omp_clauses->self_expr)
10601 : {
10602 177 : gfc_expr *expr = omp_clauses->self_expr;
10603 177 : if (!gfc_resolve_expr (expr)
10604 177 : || expr->ts.type != BT_LOGICAL || expr->rank != 0)
10605 6 : gfc_error ("SELF clause at %L requires a scalar LOGICAL expression",
10606 : &expr->where);
10607 : }
10608 :
10609 33042 : if (omp_clauses->final_expr)
10610 : {
10611 64 : gfc_expr *expr = omp_clauses->final_expr;
10612 64 : if (!gfc_resolve_expr (expr)
10613 64 : || expr->ts.type != BT_LOGICAL || expr->rank != 0)
10614 0 : gfc_error ("FINAL clause at %L requires a scalar LOGICAL expression",
10615 : &expr->where);
10616 : }
10617 33042 : if (omp_clauses->novariants)
10618 : {
10619 9 : gfc_expr *expr = omp_clauses->novariants;
10620 18 : if (!gfc_resolve_expr (expr) || expr->ts.type != BT_LOGICAL
10621 17 : || expr->rank != 0)
10622 1 : gfc_error (
10623 : "NOVARIANTS clause at %L requires a scalar LOGICAL expression",
10624 : &expr->where);
10625 33042 : if_without_mod = true;
10626 : }
10627 33042 : if (omp_clauses->nocontext)
10628 : {
10629 12 : gfc_expr *expr = omp_clauses->nocontext;
10630 24 : if (!gfc_resolve_expr (expr) || expr->ts.type != BT_LOGICAL
10631 23 : || expr->rank != 0)
10632 1 : gfc_error (
10633 : "NOCONTEXT clause at %L requires a scalar LOGICAL expression",
10634 : &expr->where);
10635 33042 : if_without_mod = true;
10636 : }
10637 :
10638 34058 : for (el = omp_clauses->num_threads_list; el; el = el->next)
10639 1016 : resolve_positive_int_expr (el->expr, "NUM_THREADS");
10640 :
10641 33042 : if (omp_clauses->dyn_groupprivate)
10642 10 : resolve_nonnegative_int_expr (omp_clauses->dyn_groupprivate,
10643 : "DYN_GROUPPRIVATE");
10644 33042 : if (omp_clauses->chunk_size)
10645 : {
10646 510 : gfc_expr *expr = omp_clauses->chunk_size;
10647 510 : if (!gfc_resolve_expr (expr)
10648 510 : || expr->ts.type != BT_INTEGER || expr->rank != 0)
10649 0 : gfc_error ("SCHEDULE clause's chunk_size at %L requires "
10650 : "a scalar INTEGER expression", &expr->where);
10651 510 : else if (expr->expr_type == EXPR_CONSTANT
10652 : && expr->ts.type == BT_INTEGER
10653 485 : && mpz_sgn (expr->value.integer) <= 0)
10654 2 : gfc_warning (OPT_Wopenmp, "INTEGER expression of SCHEDULE clause's "
10655 : "chunk_size at %L must be positive", &expr->where);
10656 : }
10657 33042 : if (omp_clauses->sched_kind != OMP_SCHED_NONE
10658 891 : && omp_clauses->sched_nonmonotonic)
10659 : {
10660 34 : if (omp_clauses->sched_monotonic)
10661 2 : gfc_error ("Both MONOTONIC and NONMONOTONIC schedule modifiers "
10662 : "specified at %L", &code->loc);
10663 32 : else if (omp_clauses->ordered)
10664 4 : gfc_error ("NONMONOTONIC schedule modifier specified with ORDERED "
10665 : "clause at %L", &code->loc);
10666 : }
10667 :
10668 33042 : if (omp_clauses->depobj
10669 33042 : && (!gfc_resolve_expr (omp_clauses->depobj)
10670 115 : || omp_clauses->depobj->ts.type != BT_INTEGER
10671 114 : || omp_clauses->depobj->ts.kind != 2 * gfc_index_integer_kind
10672 113 : || omp_clauses->depobj->rank != 0))
10673 4 : gfc_error ("DEPOBJ in DEPOBJ construct at %L shall be a scalar integer "
10674 4 : "of OMP_DEPEND_KIND kind", &omp_clauses->depobj->where);
10675 :
10676 : /* Check that list items are variables. */
10677 1321680 : for (list = OMP_LIST_FIRST; list < OMP_LIST_NUM;
10678 1288638 : list = gfc_omp_list_type (list + 1))
10679 1334473 : for (n = omp_clauses->lists[list]; n; n = n->next)
10680 : {
10681 45835 : if (!n->sym) /* omp_all_memory. */
10682 47 : continue;
10683 45788 : if (n->sym->attr.flavor == FL_VARIABLE
10684 277 : || n->sym->attr.proc_pointer
10685 236 : || (!code
10686 0 : && !ns->omp_udm_ns
10687 0 : && (!n->sym->attr.dummy || n->sym->ns != ns)))
10688 : {
10689 45552 : if (!code
10690 302 : && !ns->omp_udm_ns
10691 264 : && (!n->sym->attr.dummy || n->sym->ns != ns))
10692 0 : gfc_error ("Variable %qs is not a dummy argument at %L",
10693 : n->sym->name, &n->where);
10694 45552 : continue;
10695 : }
10696 236 : if (n->sym->attr.flavor == FL_PROCEDURE
10697 153 : && n->sym->result == n->sym
10698 138 : && n->sym->attr.function)
10699 : {
10700 138 : if (ns->proc_name == n->sym
10701 44 : || (ns->parent && ns->parent->proc_name == n->sym))
10702 101 : continue;
10703 37 : if (ns->proc_name->attr.entry_master)
10704 : {
10705 32 : gfc_entry_list *el = ns->entries;
10706 51 : for (; el; el = el->next)
10707 51 : if (el->sym == n->sym)
10708 : break;
10709 32 : if (el)
10710 32 : continue;
10711 : }
10712 5 : if (ns->parent
10713 3 : && ns->parent->proc_name->attr.entry_master)
10714 : {
10715 2 : gfc_entry_list *el = ns->parent->entries;
10716 3 : for (; el; el = el->next)
10717 3 : if (el->sym == n->sym)
10718 : break;
10719 2 : if (el)
10720 2 : continue;
10721 : }
10722 : }
10723 101 : if (list == OMP_LIST_MAP
10724 18 : && n->sym->attr.flavor == FL_PARAMETER)
10725 : {
10726 : /* OpenACC since 3.4 permits for Fortran named constants, but
10727 : permits removing then as optimization is not needed and such
10728 : ignore them. Likewise below for FIRSTPRIVATE. */
10729 12 : if (openacc)
10730 10 : gfc_warning (OPT_Wsurprising, "Clause for object %qs at %L is "
10731 : "ignored as parameters need not be copied",
10732 : n->sym->name, &n->where);
10733 : else
10734 2 : gfc_error ("Object %qs is not a variable at %L; parameters"
10735 : " cannot be and need not be mapped", n->sym->name,
10736 : &n->where);
10737 : }
10738 89 : else if (openacc && n->sym->attr.flavor == FL_PARAMETER)
10739 9 : gfc_warning (OPT_Wsurprising, "Clause for object %qs at %L is ignored"
10740 : " as it is a parameter", n->sym->name, &n->where);
10741 80 : else if (list != OMP_LIST_USES_ALLOCATORS)
10742 30 : gfc_error ("Object %qs is not a variable at %L", n->sym->name,
10743 : &n->where);
10744 : }
10745 :
10746 33042 : if (omp_clauses->lists[OMP_LIST_REDUCTION_INSCAN])
10747 : {
10748 69 : locus *loc = &omp_clauses->lists[OMP_LIST_REDUCTION_INSCAN]->where;
10749 69 : if (code->op != EXEC_OMP_DO
10750 : && code->op != EXEC_OMP_SIMD
10751 : && code->op != EXEC_OMP_DO_SIMD
10752 : && code->op != EXEC_OMP_PARALLEL_DO
10753 : && code->op != EXEC_OMP_PARALLEL_DO_SIMD)
10754 23 : gfc_error ("%<inscan%> REDUCTION clause on construct other than DO, "
10755 : "SIMD, DO SIMD, PARALLEL DO, PARALLEL DO SIMD at %L",
10756 : loc);
10757 69 : if (omp_clauses->ordered)
10758 2 : gfc_error ("ORDERED clause specified together with %<inscan%> "
10759 : "REDUCTION clause at %L", loc);
10760 69 : if (omp_clauses->sched_kind != OMP_SCHED_NONE)
10761 3 : gfc_error ("SCHEDULE clause specified together with %<inscan%> "
10762 : "REDUCTION clause at %L", loc);
10763 : }
10764 :
10765 33042 : if (code
10766 32801 : && code->op == EXEC_OMP_INTEROP
10767 63 : && omp_clauses->lists[OMP_LIST_DEPEND])
10768 : {
10769 12 : if (!omp_clauses->lists[OMP_LIST_INIT]
10770 5 : && !omp_clauses->lists[OMP_LIST_USE]
10771 1 : && !omp_clauses->lists[OMP_LIST_DESTROY])
10772 : {
10773 1 : gfc_error ("DEPEND clause at %L requires action clause with "
10774 : "%<targetsync%> interop-type",
10775 : &omp_clauses->lists[OMP_LIST_DEPEND]->where);
10776 : }
10777 22 : for (n = omp_clauses->lists[OMP_LIST_INIT]; n; n = n->next)
10778 12 : if (!n->u.init.targetsync)
10779 : {
10780 2 : gfc_error ("DEPEND clause at %L requires %<targetsync%> "
10781 : "interop-type, lacking it for %qs at %L",
10782 2 : &omp_clauses->lists[OMP_LIST_DEPEND]->where,
10783 2 : n->sym->name, &n->where);
10784 2 : break;
10785 : }
10786 : }
10787 32801 : if (code && (code->op == EXEC_OMP_INTEROP || code->op == EXEC_OMP_DISPATCH))
10788 1085 : for (list = OMP_LIST_INIT; list <= OMP_LIST_INTEROP;
10789 868 : list = gfc_omp_list_type (list + 1))
10790 1123 : for (n = omp_clauses->lists[list]; n; n = n->next)
10791 : {
10792 255 : if (n->sym->ts.type != BT_INTEGER
10793 252 : || n->sym->ts.kind != gfc_index_integer_kind
10794 248 : || n->sym->attr.dimension
10795 243 : || n->sym->attr.flavor != FL_VARIABLE)
10796 16 : gfc_error ("%qs at %L in %qs clause must be a scalar integer "
10797 : "variable of %<omp_interop_kind%> kind", n->sym->name,
10798 : &n->where, clause_names[list]);
10799 255 : if (list != OMP_LIST_USE && list != OMP_LIST_INTEROP
10800 109 : && n->sym->attr.intent == INTENT_IN)
10801 2 : gfc_error ("%qs at %L in %qs clause must be definable",
10802 : n->sym->name, &n->where, clause_names[list]);
10803 : }
10804 :
10805 33042 : resolve_omp_allocate_clauses (code, omp_clauses, ns);
10806 :
10807 33042 : bool has_inscan = false, has_notinscan = false;
10808 1321680 : for (enum gfc_omp_list_type list = OMP_LIST_FIRST; list < OMP_LIST_NUM;
10809 1288638 : list = gfc_omp_list_type (list + 1))
10810 1288638 : if ((n = omp_clauses->lists[list]) != NULL)
10811 : {
10812 29299 : const char *name = clause_names[list];
10813 :
10814 29299 : switch (list)
10815 : {
10816 : case OMP_LIST_COPYIN:
10817 267 : for (; n != NULL; n = n->next)
10818 : {
10819 170 : if (!n->sym->attr.threadprivate)
10820 0 : gfc_error ("Non-THREADPRIVATE object %qs in COPYIN clause"
10821 : " at %L", n->sym->name, &n->where);
10822 : }
10823 : break;
10824 83 : case OMP_LIST_COPYPRIVATE:
10825 83 : if (omp_clauses->nowait)
10826 6 : gfc_error ("NOWAIT clause must not be used with COPYPRIVATE "
10827 : "clause at %L", &n->where);
10828 376 : for (; n != NULL; n = n->next)
10829 : {
10830 293 : if (n->sym->as && n->sym->as->type == AS_ASSUMED_SIZE)
10831 0 : gfc_error ("Assumed size array %qs in COPYPRIVATE clause "
10832 : "at %L", n->sym->name, &n->where);
10833 293 : if (n->sym->attr.pointer && n->sym->attr.intent == INTENT_IN)
10834 1 : gfc_error ("INTENT(IN) POINTER %qs in COPYPRIVATE clause "
10835 : "at %L", n->sym->name, &n->where);
10836 : }
10837 : break;
10838 : case OMP_LIST_SHARED:
10839 2604 : for (; n != NULL; n = n->next)
10840 : {
10841 1642 : if (n->sym->attr.threadprivate)
10842 0 : gfc_error ("THREADPRIVATE object %qs in SHARED clause at "
10843 : "%L", n->sym->name, &n->where);
10844 1642 : if (n->sym->attr.cray_pointee)
10845 1 : gfc_error ("Cray pointee %qs in SHARED clause at %L",
10846 : n->sym->name, &n->where);
10847 1642 : if (n->sym->attr.associate_var)
10848 8 : gfc_error ("Associate name %qs in SHARED clause at %L",
10849 8 : n->sym->attr.select_type_temporary
10850 4 : ? n->sym->assoc->target->symtree->n.sym->name
10851 : : n->sym->name, &n->where);
10852 1642 : if (omp_clauses->detach
10853 1 : && n->sym == omp_clauses->detach->symtree->n.sym)
10854 1 : gfc_error ("DETACH event handle %qs in SHARED clause at %L",
10855 : n->sym->name, &n->where);
10856 : }
10857 : break;
10858 : case OMP_LIST_ALIGNED:
10859 256 : for (; n != NULL; n = n->next)
10860 : {
10861 150 : if (!n->sym->attr.pointer
10862 45 : && !n->sym->attr.allocatable
10863 30 : && !n->sym->attr.cray_pointer
10864 18 : && (n->sym->ts.type != BT_DERIVED
10865 18 : || (n->sym->ts.u.derived->from_intmod
10866 : != INTMOD_ISO_C_BINDING)
10867 18 : || (n->sym->ts.u.derived->intmod_sym_id
10868 : != ISOCBINDING_PTR)))
10869 0 : gfc_error ("%qs in ALIGNED clause must be POINTER, "
10870 : "ALLOCATABLE, Cray pointer or C_PTR at %L",
10871 : n->sym->name, &n->where);
10872 150 : else if (n->expr)
10873 : {
10874 147 : if (!gfc_resolve_expr (n->expr)
10875 147 : || n->expr->ts.type != BT_INTEGER
10876 146 : || n->expr->rank != 0
10877 146 : || n->expr->expr_type != EXPR_CONSTANT
10878 292 : || mpz_sgn (n->expr->value.integer) <= 0)
10879 4 : gfc_error ("%qs in ALIGNED clause at %L requires a scalar"
10880 : " positive constant integer alignment "
10881 4 : "expression", n->sym->name, &n->where);
10882 : }
10883 : }
10884 : break;
10885 : case OMP_LIST_AFFINITY:
10886 : case OMP_LIST_DEPEND:
10887 : case OMP_LIST_MAP:
10888 : case OMP_LIST_TO:
10889 : case OMP_LIST_FROM:
10890 : case OMP_LIST_CACHE:
10891 33196 : for (; n != NULL; n = n->next)
10892 20943 : resolve_omp_clauses_aff_dep_map_cache (code, n, name, list,
10893 : omp_clauses, openacc);
10894 : break;
10895 : case OMP_LIST_IS_DEVICE_PTR:
10896 : last = NULL;
10897 377 : for (n = omp_clauses->lists[list]; n != NULL; )
10898 : {
10899 257 : if ((n->sym->ts.type != BT_DERIVED
10900 71 : || !n->sym->ts.u.derived->ts.is_iso_c
10901 71 : || (n->sym->ts.u.derived->intmod_sym_id
10902 : != ISOCBINDING_PTR))
10903 187 : && code->op == EXEC_OMP_DISPATCH)
10904 : /* Non-TARGET (i.e. DISPATCH) requires a C_PTR. */
10905 3 : gfc_error ("List item %qs in %s clause at %L must be of "
10906 : "TYPE(C_PTR)", n->sym->name, name, &n->where);
10907 254 : else if (n->sym->ts.type != BT_DERIVED
10908 70 : || !n->sym->ts.u.derived->ts.is_iso_c
10909 70 : || (n->sym->ts.u.derived->intmod_sym_id
10910 : != ISOCBINDING_PTR))
10911 : {
10912 : /* For TARGET, non-C_PTR are deprecated and handled as
10913 : has_device_addr. */
10914 184 : gfc_warning (OPT_Wdeprecated_openmp,
10915 : "Non-C_PTR type argument at %L is deprecated, "
10916 : "use HAS_DEVICE_ADDR", &n->where);
10917 184 : gfc_omp_namelist *n2 = n;
10918 184 : n = n->next;
10919 184 : if (last)
10920 0 : last->next = n;
10921 : else
10922 184 : omp_clauses->lists[list] = n;
10923 184 : n2->next = omp_clauses->lists[OMP_LIST_HAS_DEVICE_ADDR];
10924 184 : omp_clauses->lists[OMP_LIST_HAS_DEVICE_ADDR] = n2;
10925 184 : continue;
10926 184 : }
10927 73 : last = n;
10928 73 : n = n->next;
10929 : }
10930 : break;
10931 : case OMP_LIST_HAS_DEVICE_ADDR:
10932 : case OMP_LIST_USE_DEVICE_ADDR:
10933 : break;
10934 : case OMP_LIST_USE_DEVICE_PTR:
10935 : /* Non-C_PTR are deprecated and handled as use_device_ADDR. */
10936 : last = NULL;
10937 475 : for (n = omp_clauses->lists[list]; n != NULL; )
10938 : {
10939 312 : gfc_omp_namelist *n2 = n;
10940 312 : if (n->sym->ts.type != BT_DERIVED
10941 18 : || !n->sym->ts.u.derived->ts.is_iso_c)
10942 : {
10943 294 : gfc_warning (OPT_Wdeprecated_openmp,
10944 : "Non-C_PTR type argument at %L is "
10945 : "deprecated, use USE_DEVICE_ADDR", &n->where);
10946 294 : n = n->next;
10947 294 : if (last)
10948 0 : last->next = n;
10949 : else
10950 294 : omp_clauses->lists[list] = n;
10951 294 : n2->next = omp_clauses->lists[OMP_LIST_USE_DEVICE_ADDR];
10952 294 : omp_clauses->lists[OMP_LIST_USE_DEVICE_ADDR] = n2;
10953 294 : continue;
10954 : }
10955 18 : last = n;
10956 18 : n = n->next;
10957 : }
10958 : break;
10959 65 : case OMP_LIST_USES_ALLOCATORS:
10960 65 : {
10961 65 : if (n != NULL
10962 65 : && n->u.memspace_sym
10963 20 : && (n->u.memspace_sym->attr.flavor != FL_PARAMETER
10964 18 : || n->u.memspace_sym->ts.type != BT_INTEGER
10965 18 : || n->u.memspace_sym->ts.kind != gfc_c_intptr_kind
10966 18 : || n->u.memspace_sym->attr.dimension
10967 18 : || (!startswith (n->u.memspace_sym->name, "omp_")
10968 0 : && !startswith (n->u.memspace_sym->name, "ompx_"))
10969 18 : || !endswith (n->u.memspace_sym->name, "_mem_space")))
10970 3 : gfc_error ("Memspace %qs at %L in USES_ALLOCATORS must be "
10971 : "a predefined memory space",
10972 : n->u.memspace_sym->name, &n->where);
10973 180 : for (; n != NULL; n = n->next)
10974 : {
10975 122 : if (n->sym->ts.type != BT_INTEGER
10976 121 : || n->sym->ts.kind != gfc_c_intptr_kind
10977 120 : || n->sym->attr.dimension)
10978 3 : gfc_error ("Allocator %qs at %L in USES_ALLOCATORS must "
10979 : "be a scalar integer of kind "
10980 : "%<omp_allocator_handle_kind%>", n->sym->name,
10981 : &n->where);
10982 119 : else if (n->sym->attr.flavor != FL_VARIABLE
10983 50 : && strcmp (n->sym->name, "omp_null_allocator") != 0
10984 165 : && ((!startswith (n->sym->name, "omp_")
10985 1 : && !startswith (n->sym->name, "ompx_"))
10986 45 : || !endswith (n->sym->name, "_mem_alloc")))
10987 2 : gfc_error ("Allocator %qs at %L in USES_ALLOCATORS must "
10988 : "either a variable or a predefined allocator",
10989 : n->sym->name, &n->where);
10990 117 : else if ((n->u.memspace_sym || n->u2.traits_sym)
10991 61 : && n->sym->attr.flavor != FL_VARIABLE)
10992 3 : gfc_error ("A memory space or traits array may not be "
10993 : "specified for predefined allocator %qs at %L",
10994 : n->sym->name, &n->where);
10995 122 : if (n->u2.traits_sym
10996 50 : && (n->u2.traits_sym->attr.flavor != FL_PARAMETER
10997 47 : || !n->u2.traits_sym->attr.dimension
10998 45 : || n->u2.traits_sym->as->rank != 1
10999 45 : || n->u2.traits_sym->ts.type != BT_DERIVED
11000 43 : || strcmp (n->u2.traits_sym->ts.u.derived->name,
11001 : "omp_alloctrait") != 0))
11002 : {
11003 7 : gfc_error ("Traits array %qs in USES_ALLOCATORS %L must "
11004 : "be a one-dimensional named constant array of "
11005 : "type %<omp_alloctrait%>",
11006 : n->u2.traits_sym->name, &n->where);
11007 7 : break;
11008 : }
11009 : }
11010 : break;
11011 : }
11012 : default:
11013 34776 : for (; n != NULL; n = n->next)
11014 : {
11015 20380 : if (n->sym == NULL)
11016 : {
11017 26 : gcc_assert (code->op == EXEC_OMP_ALLOCATORS
11018 : || code->op == EXEC_OMP_ALLOCATE);
11019 26 : continue;
11020 : }
11021 20354 : bool bad = false;
11022 20354 : bool is_reduction = (list == OMP_LIST_REDUCTION
11023 : || list == OMP_LIST_REDUCTION_INSCAN
11024 : || list == OMP_LIST_REDUCTION_TASK
11025 : || list == OMP_LIST_IN_REDUCTION
11026 20354 : || list == OMP_LIST_TASK_REDUCTION);
11027 20354 : if (list == OMP_LIST_REDUCTION_INSCAN)
11028 : has_inscan = true;
11029 20282 : else if (is_reduction)
11030 4737 : has_notinscan = true;
11031 20354 : if (has_inscan && has_notinscan && is_reduction)
11032 : {
11033 3 : gfc_error ("%<inscan%> and non-%<inscan%> %<reduction%> "
11034 : "clauses on the same construct at %L",
11035 : &n->where);
11036 3 : break;
11037 : }
11038 20351 : if (n->sym->attr.threadprivate)
11039 1 : gfc_error ("THREADPRIVATE object %qs in %s clause at %L",
11040 : n->sym->name, name, &n->where);
11041 20351 : if (n->sym->attr.cray_pointee)
11042 14 : gfc_error ("Cray pointee %qs in %s clause at %L",
11043 : n->sym->name, name, &n->where);
11044 20351 : if (n->sym->attr.associate_var)
11045 22 : gfc_error ("Associate name %qs in %s clause at %L",
11046 22 : n->sym->attr.select_type_temporary
11047 4 : ? n->sym->assoc->target->symtree->n.sym->name
11048 : : n->sym->name, name, &n->where);
11049 20351 : if (list != OMP_LIST_PRIVATE && is_reduction)
11050 : {
11051 4806 : if (n->sym->attr.proc_pointer)
11052 1 : gfc_error ("Procedure pointer %qs in %s clause at %L",
11053 : n->sym->name, name, &n->where);
11054 4806 : if (n->sym->attr.pointer)
11055 3 : gfc_error ("POINTER object %qs in %s clause at %L",
11056 : n->sym->name, name, &n->where);
11057 4806 : if (n->sym->attr.cray_pointer)
11058 5 : gfc_error ("Cray pointer %qs in %s clause at %L",
11059 : n->sym->name, name, &n->where);
11060 : }
11061 20351 : if (code
11062 20351 : && (oacc_is_loop (code)
11063 : || code->op == EXEC_OACC_PARALLEL
11064 : || code->op == EXEC_OACC_SERIAL))
11065 8741 : check_array_not_assumed (n->sym, n->where, name);
11066 11610 : else if (list != OMP_LIST_UNIFORM
11067 11493 : && n->sym->as && n->sym->as->type == AS_ASSUMED_SIZE)
11068 2 : gfc_error ("Assumed size array %qs in %s clause at %L",
11069 : n->sym->name, name, &n->where);
11070 20351 : if (n->sym->attr.in_namelist && !is_reduction)
11071 0 : gfc_error ("Variable %qs in %s clause is used in "
11072 : "NAMELIST statement at %L",
11073 : n->sym->name, name, &n->where);
11074 20351 : if (n->sym->attr.pointer && n->sym->attr.intent == INTENT_IN)
11075 3 : switch (list)
11076 : {
11077 3 : case OMP_LIST_PRIVATE:
11078 3 : case OMP_LIST_LASTPRIVATE:
11079 3 : case OMP_LIST_LINEAR:
11080 : /* case OMP_LIST_REDUCTION: */
11081 3 : gfc_error ("INTENT(IN) POINTER %qs in %s clause at %L",
11082 : n->sym->name, name, &n->where);
11083 3 : break;
11084 : default:
11085 : break;
11086 : }
11087 20351 : if (omp_clauses->detach
11088 3 : && (list == OMP_LIST_PRIVATE
11089 : || list == OMP_LIST_FIRSTPRIVATE
11090 : || list == OMP_LIST_LASTPRIVATE)
11091 3 : && n->sym == omp_clauses->detach->symtree->n.sym)
11092 1 : gfc_error ("DETACH event handle %qs in %s clause at %L",
11093 : n->sym->name, name, &n->where);
11094 :
11095 20351 : if (!openacc
11096 20351 : && (list == OMP_LIST_PRIVATE
11097 20351 : || list == OMP_LIST_FIRSTPRIVATE)
11098 4704 : && ((n->sym->ts.type == BT_DERIVED
11099 158 : && n->sym->ts.u.derived->attr.alloc_comp)
11100 4594 : || n->sym->ts.type == BT_CLASS))
11101 170 : switch (code->op)
11102 : {
11103 8 : case EXEC_OMP_TARGET:
11104 8 : case EXEC_OMP_TARGET_PARALLEL:
11105 8 : case EXEC_OMP_TARGET_PARALLEL_DO:
11106 8 : case EXEC_OMP_TARGET_PARALLEL_DO_SIMD:
11107 8 : case EXEC_OMP_TARGET_PARALLEL_LOOP:
11108 8 : case EXEC_OMP_TARGET_SIMD:
11109 8 : case EXEC_OMP_TARGET_TEAMS:
11110 8 : case EXEC_OMP_TARGET_TEAMS_DISTRIBUTE:
11111 8 : case EXEC_OMP_TARGET_TEAMS_DISTRIBUTE_PARALLEL_DO:
11112 8 : case EXEC_OMP_TARGET_TEAMS_DISTRIBUTE_PARALLEL_DO_SIMD:
11113 8 : case EXEC_OMP_TARGET_TEAMS_DISTRIBUTE_SIMD:
11114 8 : case EXEC_OMP_TARGET_TEAMS_LOOP:
11115 8 : if (n->sym->ts.type == BT_DERIVED
11116 2 : && n->sym->ts.u.derived->attr.alloc_comp)
11117 3 : gfc_error ("Sorry, list item %qs at %L with allocatable"
11118 : " components is not yet supported in %s "
11119 : "clause", n->sym->name, &n->where,
11120 : list == OMP_LIST_PRIVATE ? "PRIVATE"
11121 : : "FIRSTPRIVATE");
11122 : else
11123 9 : gfc_error ("Polymorphic list item %qs at %L in %s "
11124 : "clause has unspecified behavior and "
11125 : "unsupported", n->sym->name, &n->where,
11126 : list == OMP_LIST_PRIVATE ? "PRIVATE"
11127 : : "FIRSTPRIVATE");
11128 : break;
11129 : default:
11130 : break;
11131 : }
11132 :
11133 20351 : switch (list)
11134 : {
11135 104 : case OMP_LIST_REDUCTION_TASK:
11136 104 : if (code
11137 104 : && (code->op == EXEC_OMP_LOOP
11138 : || code->op == EXEC_OMP_TASKLOOP
11139 : || code->op == EXEC_OMP_TASKLOOP_SIMD
11140 : || code->op == EXEC_OMP_MASKED_TASKLOOP
11141 : || code->op == EXEC_OMP_MASKED_TASKLOOP_SIMD
11142 : || code->op == EXEC_OMP_MASTER_TASKLOOP
11143 : || code->op == EXEC_OMP_MASTER_TASKLOOP_SIMD
11144 : || code->op == EXEC_OMP_PARALLEL_LOOP
11145 : || code->op == EXEC_OMP_PARALLEL_MASKED_TASKLOOP
11146 : || code->op == EXEC_OMP_PARALLEL_MASKED_TASKLOOP_SIMD
11147 : || code->op == EXEC_OMP_PARALLEL_MASTER_TASKLOOP
11148 : || code->op == EXEC_OMP_PARALLEL_MASTER_TASKLOOP_SIMD
11149 : || code->op == EXEC_OMP_TARGET_PARALLEL_LOOP
11150 : || code->op == EXEC_OMP_TARGET_TEAMS_LOOP
11151 : || code->op == EXEC_OMP_TEAMS
11152 : || code->op == EXEC_OMP_TEAMS_DISTRIBUTE
11153 : || code->op == EXEC_OMP_TEAMS_LOOP))
11154 : {
11155 17 : gfc_error ("Only DEFAULT permitted as reduction-"
11156 : "modifier in REDUCTION clause at %L",
11157 : &n->where);
11158 17 : break;
11159 : }
11160 4789 : gcc_fallthrough ();
11161 4789 : case OMP_LIST_REDUCTION:
11162 4789 : case OMP_LIST_IN_REDUCTION:
11163 4789 : case OMP_LIST_TASK_REDUCTION:
11164 4789 : case OMP_LIST_REDUCTION_INSCAN:
11165 4789 : switch (n->u.reduction_op)
11166 : {
11167 2655 : case OMP_REDUCTION_PLUS:
11168 2655 : case OMP_REDUCTION_TIMES:
11169 2655 : case OMP_REDUCTION_MINUS:
11170 2655 : if (!gfc_numeric_ts (&n->sym->ts))
11171 : bad = true;
11172 : break;
11173 1112 : case OMP_REDUCTION_AND:
11174 1112 : case OMP_REDUCTION_OR:
11175 1112 : case OMP_REDUCTION_EQV:
11176 1112 : case OMP_REDUCTION_NEQV:
11177 1112 : if (n->sym->ts.type != BT_LOGICAL)
11178 : bad = true;
11179 : break;
11180 480 : case OMP_REDUCTION_MAX:
11181 480 : case OMP_REDUCTION_MIN:
11182 480 : if (n->sym->ts.type != BT_INTEGER
11183 212 : && n->sym->ts.type != BT_REAL)
11184 : bad = true;
11185 : break;
11186 192 : case OMP_REDUCTION_IAND:
11187 192 : case OMP_REDUCTION_IOR:
11188 192 : case OMP_REDUCTION_IEOR:
11189 192 : if (n->sym->ts.type != BT_INTEGER)
11190 : bad = true;
11191 : break;
11192 : case OMP_REDUCTION_USER:
11193 : bad = true;
11194 : break;
11195 : default:
11196 : break;
11197 : }
11198 : if (!bad)
11199 4215 : n->u2.udr = NULL;
11200 : else
11201 : {
11202 574 : const char *udr_name = NULL;
11203 574 : if (n->u2.udr)
11204 : {
11205 470 : udr_name = n->u2.udr->udr->name;
11206 470 : n->u2.udr->udr
11207 940 : = gfc_find_omp_udr (NULL, udr_name,
11208 470 : &n->sym->ts);
11209 470 : if (n->u2.udr->udr == NULL)
11210 : {
11211 0 : free (n->u2.udr);
11212 0 : n->u2.udr = NULL;
11213 : }
11214 : }
11215 574 : if (n->u2.udr == NULL)
11216 : {
11217 104 : if (udr_name == NULL)
11218 104 : switch (n->u.reduction_op)
11219 : {
11220 50 : case OMP_REDUCTION_PLUS:
11221 50 : case OMP_REDUCTION_TIMES:
11222 50 : case OMP_REDUCTION_MINUS:
11223 50 : case OMP_REDUCTION_AND:
11224 50 : case OMP_REDUCTION_OR:
11225 50 : case OMP_REDUCTION_EQV:
11226 50 : case OMP_REDUCTION_NEQV:
11227 50 : udr_name = gfc_op2string ((gfc_intrinsic_op)
11228 : n->u.reduction_op);
11229 50 : break;
11230 : case OMP_REDUCTION_MAX:
11231 : udr_name = "max";
11232 : break;
11233 9 : case OMP_REDUCTION_MIN:
11234 9 : udr_name = "min";
11235 9 : break;
11236 12 : case OMP_REDUCTION_IAND:
11237 12 : udr_name = "iand";
11238 12 : break;
11239 12 : case OMP_REDUCTION_IOR:
11240 12 : udr_name = "ior";
11241 12 : break;
11242 9 : case OMP_REDUCTION_IEOR:
11243 9 : udr_name = "ieor";
11244 9 : break;
11245 0 : default:
11246 0 : gcc_unreachable ();
11247 : }
11248 104 : gfc_error ("!$OMP DECLARE REDUCTION %s not found "
11249 : "for type %s at %L", udr_name,
11250 104 : gfc_typename (&n->sym->ts), &n->where);
11251 : }
11252 : else
11253 : {
11254 470 : gfc_omp_udr *udr = n->u2.udr->udr;
11255 470 : n->u.reduction_op = OMP_REDUCTION_USER;
11256 470 : n->u2.udr->combiner
11257 940 : = resolve_omp_udr_clause (n, udr->combiner_ns,
11258 470 : udr->omp_out,
11259 470 : udr->omp_in);
11260 470 : if (udr->initializer_ns)
11261 331 : n->u2.udr->initializer
11262 331 : = resolve_omp_udr_clause (n,
11263 : udr->initializer_ns,
11264 331 : udr->omp_priv,
11265 331 : udr->omp_orig);
11266 : }
11267 : }
11268 : break;
11269 874 : case OMP_LIST_LINEAR:
11270 874 : if (code)
11271 : {
11272 727 : bool is_worksharing_for = false;
11273 727 : switch (code->op)
11274 : {
11275 54 : case EXEC_OMP_DO:
11276 54 : case EXEC_OMP_PARALLEL_DO:
11277 54 : case EXEC_OMP_DISTRIBUTE_PARALLEL_DO:
11278 54 : case EXEC_OMP_TARGET_PARALLEL_DO:
11279 54 : case EXEC_OMP_TEAMS_DISTRIBUTE_PARALLEL_DO:
11280 54 : case EXEC_OMP_TARGET_TEAMS_DISTRIBUTE_PARALLEL_DO:
11281 54 : is_worksharing_for = true;
11282 54 : break;
11283 : default:
11284 : break;
11285 : }
11286 :
11287 54 : if (is_worksharing_for
11288 54 : && (n->sym->attr.dimension
11289 53 : || n->sym->attr.allocatable))
11290 : {
11291 1 : if (n->sym->attr.allocatable)
11292 0 : gfc_error ("Sorry, ALLOCATABLE object %qs in "
11293 : "LINEAR clause on worksharing-loop "
11294 : "construct at %L is not yet supported",
11295 : n->sym->name, &n->where);
11296 : else
11297 1 : gfc_error ("Sorry, array %qs in LINEAR clause "
11298 : "on worksharing-loop construct at %L "
11299 : "is not yet supported",
11300 : n->sym->name, &n->where);
11301 : break;
11302 : }
11303 : }
11304 :
11305 726 : if (code
11306 726 : && n->u.linear.op != OMP_LINEAR_DEFAULT
11307 23 : && n->u.linear.op != linear_op)
11308 : {
11309 23 : if (n->u.linear.old_modifier)
11310 : {
11311 9 : gfc_error ("LINEAR clause modifier used on DO or "
11312 : "SIMD construct at %L", &n->where);
11313 9 : linear_op = n->u.linear.op;
11314 : }
11315 14 : else if (n->u.linear.op != OMP_LINEAR_VAL)
11316 : {
11317 6 : gfc_error ("LINEAR clause modifier other than VAL "
11318 : "used on DO or SIMD construct at %L",
11319 : &n->where);
11320 6 : linear_op = n->u.linear.op;
11321 : }
11322 : }
11323 850 : else if (n->u.linear.op != OMP_LINEAR_REF
11324 800 : && n->sym->ts.type != BT_INTEGER)
11325 1 : gfc_error ("LINEAR variable %qs must be INTEGER "
11326 : "at %L", n->sym->name, &n->where);
11327 849 : else if ((n->u.linear.op == OMP_LINEAR_REF
11328 799 : || n->u.linear.op == OMP_LINEAR_UVAL)
11329 61 : && n->sym->attr.value)
11330 0 : gfc_error ("LINEAR dummy argument %qs with VALUE "
11331 : "attribute with %s modifier at %L",
11332 : n->sym->name,
11333 : n->u.linear.op == OMP_LINEAR_REF
11334 : ? "REF" : "UVAL", &n->where);
11335 849 : else if (n->expr)
11336 : {
11337 830 : gfc_expr *expr = n->expr;
11338 830 : if (!gfc_resolve_expr (expr)
11339 830 : || expr->ts.type != BT_INTEGER
11340 1660 : || expr->rank != 0)
11341 0 : gfc_error ("%qs in LINEAR clause at %L requires "
11342 : "a scalar integer linear-step expression",
11343 0 : n->sym->name, &n->where);
11344 830 : else if (!code && expr->expr_type != EXPR_CONSTANT)
11345 : {
11346 11 : if (expr->expr_type == EXPR_VARIABLE
11347 7 : && expr->symtree->n.sym->attr.dummy
11348 6 : && expr->symtree->n.sym->ns == ns)
11349 : {
11350 6 : gfc_omp_namelist *n2;
11351 6 : for (n2 = omp_clauses->lists[OMP_LIST_UNIFORM];
11352 6 : n2; n2 = n2->next)
11353 6 : if (n2->sym == expr->symtree->n.sym)
11354 : break;
11355 6 : if (n2)
11356 : break;
11357 : }
11358 5 : gfc_error ("%qs in LINEAR clause at %L requires "
11359 : "a constant integer linear-step "
11360 : "expression or dummy argument "
11361 : "specified in UNIFORM clause",
11362 5 : n->sym->name, &n->where);
11363 : }
11364 : }
11365 : break;
11366 : /* Workaround for PR middle-end/26316, nothing really needs
11367 : to be done here for OMP_LIST_PRIVATE. */
11368 9394 : case OMP_LIST_PRIVATE:
11369 9394 : gcc_assert (code && code->op != EXEC_NOP);
11370 : break;
11371 98 : case OMP_LIST_USE_DEVICE:
11372 98 : if (n->sym->attr.allocatable
11373 98 : || (n->sym->ts.type == BT_CLASS && CLASS_DATA (n->sym)
11374 0 : && CLASS_DATA (n->sym)->attr.allocatable))
11375 0 : gfc_error ("ALLOCATABLE object %qs in %s clause at %L",
11376 : n->sym->name, name, &n->where);
11377 98 : if (n->sym->ts.type == BT_CLASS
11378 0 : && CLASS_DATA (n->sym)
11379 0 : && CLASS_DATA (n->sym)->attr.class_pointer)
11380 0 : gfc_error ("POINTER object %qs of polymorphic type in "
11381 : "%s clause at %L", n->sym->name, name,
11382 : &n->where);
11383 98 : if (n->sym->attr.cray_pointer)
11384 2 : gfc_error ("Cray pointer object %qs in %s clause at %L",
11385 : n->sym->name, name, &n->where);
11386 96 : else if (n->sym->attr.cray_pointee)
11387 2 : gfc_error ("Cray pointee object %qs in %s clause at %L",
11388 : n->sym->name, name, &n->where);
11389 94 : else if (n->sym->attr.flavor == FL_VARIABLE
11390 93 : && !n->sym->as
11391 54 : && !n->sym->attr.pointer)
11392 13 : gfc_error ("%s clause variable %qs at %L is neither "
11393 : "a POINTER nor an array", name,
11394 : n->sym->name, &n->where);
11395 : /* FALLTHRU */
11396 98 : case OMP_LIST_DEVICE_RESIDENT:
11397 98 : check_symbol_not_pointer (n->sym, n->where, name);
11398 98 : check_array_not_assumed (n->sym, n->where, name);
11399 98 : break;
11400 : default:
11401 : break;
11402 : }
11403 : }
11404 : break;
11405 : }
11406 : }
11407 : /* OpenMP 5.1: use_device_ptr acts like use_device_addr, except for
11408 : type(c_ptr). */
11409 33042 : if (omp_clauses->lists[OMP_LIST_USE_DEVICE_PTR])
11410 : {
11411 9 : gfc_omp_namelist *n_prev, *n_next, *n_addr;
11412 9 : n_addr = omp_clauses->lists[OMP_LIST_USE_DEVICE_ADDR];
11413 28 : for (; n_addr && n_addr->next; n_addr = n_addr->next)
11414 : ;
11415 : n_prev = NULL;
11416 : n = omp_clauses->lists[OMP_LIST_USE_DEVICE_PTR];
11417 27 : while (n)
11418 : {
11419 18 : n_next = n->next;
11420 18 : if (n->sym->ts.type != BT_DERIVED
11421 18 : || n->sym->ts.u.derived->ts.f90_type != BT_VOID)
11422 : {
11423 0 : n->next = NULL;
11424 0 : if (n_addr)
11425 0 : n_addr->next = n;
11426 : else
11427 0 : omp_clauses->lists[OMP_LIST_USE_DEVICE_ADDR] = n;
11428 0 : n_addr = n;
11429 0 : if (n_prev)
11430 0 : n_prev->next = n_next;
11431 : else
11432 0 : omp_clauses->lists[OMP_LIST_USE_DEVICE_PTR] = n_next;
11433 : }
11434 : else
11435 : n_prev = n;
11436 : n = n_next;
11437 : }
11438 : }
11439 33042 : if (omp_clauses->safelen_expr)
11440 93 : resolve_positive_int_expr (omp_clauses->safelen_expr, "SAFELEN");
11441 33042 : if (omp_clauses->simdlen_expr)
11442 123 : resolve_positive_int_expr (omp_clauses->simdlen_expr, "SIMDLEN");
11443 33236 : for (el = omp_clauses->num_teams_list; el; el = el->next)
11444 194 : resolve_positive_int_expr (el->expr, "NUM_TEAMS");
11445 33042 : if (omp_clauses->num_teams_list
11446 153 : && omp_clauses->num_teams_list->next
11447 34 : && !omp_clauses->num_teams_dims
11448 27 : && omp_clauses->num_teams_list->expr->expr_type == EXPR_CONSTANT
11449 13 : && omp_clauses->num_teams_list->next->expr->expr_type == EXPR_CONSTANT
11450 13 : && mpz_cmp (omp_clauses->num_teams_list->expr->value.integer,
11451 13 : omp_clauses->num_teams_list->next->expr->value.integer) > 0)
11452 2 : gfc_warning (OPT_Wopenmp, "NUM_TEAMS lower bound at %L larger than upper "
11453 : "bound at %L", &omp_clauses->num_teams_list->expr->where,
11454 : &omp_clauses->num_teams_list->next->expr->where);
11455 33042 : if (omp_clauses->device)
11456 333 : resolve_scalar_int_expr (omp_clauses->device, "DEVICE");
11457 33042 : if (omp_clauses->filter)
11458 42 : resolve_nonnegative_int_expr (omp_clauses->filter, "FILTER");
11459 33042 : if (omp_clauses->hint)
11460 : {
11461 42 : resolve_scalar_int_expr (omp_clauses->hint, "HINT");
11462 42 : if (omp_clauses->hint->ts.type != BT_INTEGER
11463 40 : || omp_clauses->hint->expr_type != EXPR_CONSTANT
11464 38 : || mpz_sgn (omp_clauses->hint->value.integer) < 0)
11465 5 : gfc_error ("Value of HINT clause at %L shall be a valid "
11466 : "constant hint expression", &omp_clauses->hint->where);
11467 : }
11468 33042 : if (omp_clauses->priority)
11469 34 : resolve_nonnegative_int_expr (omp_clauses->priority, "PRIORITY");
11470 33042 : if (omp_clauses->dist_chunk_size)
11471 : {
11472 83 : gfc_expr *expr = omp_clauses->dist_chunk_size;
11473 83 : if (!gfc_resolve_expr (expr)
11474 83 : || expr->ts.type != BT_INTEGER || expr->rank != 0)
11475 0 : gfc_error ("DIST_SCHEDULE clause's chunk_size at %L requires "
11476 : "a scalar INTEGER expression", &expr->where);
11477 : }
11478 33164 : for (el = omp_clauses->thread_limit_list; el; el = el->next)
11479 122 : resolve_positive_int_expr (el->expr, "THREAD_LIMIT");
11480 33042 : if (omp_clauses->grainsize)
11481 34 : resolve_positive_int_expr (omp_clauses->grainsize, "GRAINSIZE");
11482 33042 : if (omp_clauses->num_tasks)
11483 26 : resolve_positive_int_expr (omp_clauses->num_tasks, "NUM_TASKS");
11484 33042 : if (omp_clauses->grainsize && omp_clauses->num_tasks)
11485 1 : gfc_error ("%<GRAINSIZE%> clause at %L must not be used together with "
11486 : "%<NUM_TASKS%> clause", &omp_clauses->grainsize->where);
11487 33042 : if (omp_clauses->lists[OMP_LIST_REDUCTION] && omp_clauses->nogroup)
11488 1 : gfc_error ("%<REDUCTION%> clause at %L must not be used together with "
11489 : "%<NOGROUP%> clause",
11490 : &omp_clauses->lists[OMP_LIST_REDUCTION]->where);
11491 33042 : if (omp_clauses->full && omp_clauses->partial)
11492 0 : gfc_error ("%<FULL%> clause at %C must not be used together with "
11493 : "%<PARTIAL%> clause");
11494 33042 : if (omp_clauses->async)
11495 610 : if (omp_clauses->async_expr)
11496 610 : resolve_scalar_int_expr (omp_clauses->async_expr, "ASYNC");
11497 33042 : if (omp_clauses->device_num_expr)
11498 105 : resolve_scalar_int_expr (omp_clauses->device_num_expr, "DEVICE_NUM");
11499 33042 : if (code && code->op == EXEC_OACC_SET
11500 121 : && !omp_clauses->device_num_expr
11501 52 : && !omp_clauses->oacc_device_type_present)
11502 2 : gfc_error ("At least one of the clauses %<DEVICE_TYPE%> and %<DEVICE_NUM%> "
11503 : "should be present in %<SET%> directive at %L", &code->loc);
11504 33042 : if (omp_clauses->num_gangs_expr)
11505 682 : resolve_positive_int_expr (omp_clauses->num_gangs_expr, "NUM_GANGS");
11506 33042 : if (omp_clauses->num_workers_expr)
11507 599 : resolve_positive_int_expr (omp_clauses->num_workers_expr, "NUM_WORKERS");
11508 33042 : if (omp_clauses->vector_length_expr)
11509 569 : resolve_positive_int_expr (omp_clauses->vector_length_expr,
11510 : "VECTOR_LENGTH");
11511 33042 : if (omp_clauses->gang_num_expr)
11512 114 : resolve_positive_int_expr (omp_clauses->gang_num_expr, "GANG");
11513 33042 : if (omp_clauses->gang_static_expr)
11514 94 : resolve_positive_int_expr (omp_clauses->gang_static_expr, "GANG");
11515 33042 : if (omp_clauses->worker_expr)
11516 101 : resolve_positive_int_expr (omp_clauses->worker_expr, "WORKER");
11517 33042 : if (omp_clauses->vector_expr)
11518 132 : resolve_positive_int_expr (omp_clauses->vector_expr, "VECTOR");
11519 33381 : for (el = omp_clauses->wait_list; el; el = el->next)
11520 339 : resolve_scalar_int_expr (el->expr, "WAIT");
11521 33042 : if (omp_clauses->collapse && omp_clauses->tile_list)
11522 4 : gfc_error ("Incompatible use of TILE and COLLAPSE at %L", &code->loc);
11523 33042 : if (omp_clauses->message)
11524 : {
11525 56 : gfc_expr *expr = omp_clauses->message;
11526 56 : if (!gfc_resolve_expr (expr)
11527 56 : || expr->ts.kind != gfc_default_character_kind
11528 109 : || expr->ts.type != BT_CHARACTER || expr->rank != 0)
11529 4 : gfc_error ("MESSAGE clause at %L requires a scalar default-kind "
11530 : "CHARACTER expression", &expr->where);
11531 : }
11532 33042 : if (!openacc
11533 33042 : && code
11534 19806 : && omp_clauses->lists[OMP_LIST_MAP] == NULL
11535 16019 : && omp_clauses->lists[OMP_LIST_USE_DEVICE_PTR] == NULL
11536 16016 : && omp_clauses->lists[OMP_LIST_USE_DEVICE_ADDR] == NULL)
11537 : {
11538 15993 : const char *p = NULL;
11539 15993 : switch (code->op)
11540 : {
11541 1 : case EXEC_OMP_TARGET_ENTER_DATA: p = "TARGET ENTER DATA"; break;
11542 1 : case EXEC_OMP_TARGET_EXIT_DATA: p = "TARGET EXIT DATA"; break;
11543 : default: break;
11544 : }
11545 15993 : if (code->op == EXEC_OMP_TARGET_DATA)
11546 1 : gfc_error ("TARGET DATA must contain at least one MAP, USE_DEVICE_PTR, "
11547 : "or USE_DEVICE_ADDR clause at %L", &code->loc);
11548 15992 : else if (p)
11549 2 : gfc_error ("%s must contain at least one MAP clause at %L",
11550 : p, &code->loc);
11551 : }
11552 33042 : if (omp_clauses->sizes_list)
11553 : {
11554 : gfc_expr_list *el;
11555 572 : for (el = omp_clauses->sizes_list; el; el = el->next)
11556 : {
11557 377 : resolve_scalar_int_expr (el->expr, "SIZES");
11558 377 : if (el->expr->expr_type != EXPR_CONSTANT)
11559 1 : gfc_error ("SIZES requires constant expression at %L",
11560 : &el->expr->where);
11561 376 : else if (el->expr->expr_type == EXPR_CONSTANT
11562 376 : && el->expr->ts.type == BT_INTEGER
11563 376 : && mpz_sgn (el->expr->value.integer) <= 0)
11564 2 : gfc_error ("INTEGER expression of %s clause at %L must be "
11565 : "positive", "SIZES", &el->expr->where);
11566 : }
11567 : }
11568 :
11569 33042 : if (!openacc && omp_clauses->detach)
11570 : {
11571 125 : if (!gfc_resolve_expr (omp_clauses->detach)
11572 125 : || omp_clauses->detach->ts.type != BT_INTEGER
11573 124 : || omp_clauses->detach->ts.kind != gfc_c_intptr_kind
11574 248 : || omp_clauses->detach->rank != 0)
11575 3 : gfc_error ("%qs at %L should be a scalar of type "
11576 : "integer(kind=omp_event_handle_kind)",
11577 3 : omp_clauses->detach->symtree->n.sym->name,
11578 3 : &omp_clauses->detach->where);
11579 122 : else if (omp_clauses->detach->symtree->n.sym->attr.dimension > 0)
11580 1 : gfc_error ("The event handle at %L must not be an array element",
11581 : &omp_clauses->detach->where);
11582 121 : else if (omp_clauses->detach->symtree->n.sym->ts.type == BT_DERIVED
11583 120 : || omp_clauses->detach->symtree->n.sym->ts.type == BT_CLASS)
11584 1 : gfc_error ("The event handle at %L must not be part of "
11585 : "a derived type or class", &omp_clauses->detach->where);
11586 :
11587 125 : if (omp_clauses->mergeable)
11588 2 : gfc_error ("%<DETACH%> clause at %L must not be used together with "
11589 2 : "%<MERGEABLE%> clause", &omp_clauses->detach->where);
11590 : }
11591 :
11592 12995 : if (openacc
11593 12995 : && code->op == EXEC_OACC_HOST_DATA
11594 60 : && omp_clauses->lists[OMP_LIST_USE_DEVICE] == NULL)
11595 1 : gfc_error ("%<host_data%> construct at %L requires %<use_device%> clause",
11596 : &code->loc);
11597 :
11598 33042 : if (omp_clauses->assume)
11599 16 : gfc_resolve_omp_assumptions (omp_clauses->assume);
11600 : }
11601 :
11602 :
11603 : /* Return true if SYM is ever referenced in EXPR except in the SE node. */
11604 :
11605 : static bool
11606 4991 : expr_references_sym (gfc_expr *e, gfc_symbol *s, gfc_expr *se)
11607 : {
11608 6617 : gfc_actual_arglist *arg;
11609 6617 : if (e == NULL || e == se)
11610 : return false;
11611 5366 : switch (e->expr_type)
11612 : {
11613 3120 : case EXPR_CONSTANT:
11614 3120 : case EXPR_NULL:
11615 3120 : case EXPR_VARIABLE:
11616 3120 : case EXPR_STRUCTURE:
11617 3120 : case EXPR_ARRAY:
11618 3120 : if (e->symtree != NULL
11619 1152 : && e->symtree->n.sym == s)
11620 : return true;
11621 : return false;
11622 0 : case EXPR_SUBSTRING:
11623 0 : if (e->ref != NULL
11624 0 : && (expr_references_sym (e->ref->u.ss.start, s, se)
11625 0 : || expr_references_sym (e->ref->u.ss.end, s, se)))
11626 0 : return true;
11627 : return false;
11628 1735 : case EXPR_OP:
11629 1735 : if (expr_references_sym (e->value.op.op2, s, se))
11630 : return true;
11631 1626 : return expr_references_sym (e->value.op.op1, s, se);
11632 511 : case EXPR_FUNCTION:
11633 896 : for (arg = e->value.function.actual; arg; arg = arg->next)
11634 586 : if (expr_references_sym (arg->expr, s, se))
11635 : return true;
11636 : return false;
11637 0 : default:
11638 0 : gcc_unreachable ();
11639 : }
11640 : }
11641 :
11642 :
11643 : /* If EXPR is a conversion function that widens the type
11644 : if WIDENING is true or narrows the type if NARROW is true,
11645 : return the inner expression, otherwise return NULL. */
11646 :
11647 : static gfc_expr *
11648 5911 : is_conversion (gfc_expr *expr, bool narrowing, bool widening)
11649 : {
11650 5911 : gfc_typespec *ts1, *ts2;
11651 :
11652 5911 : if (expr->expr_type != EXPR_FUNCTION
11653 917 : || expr->value.function.isym == NULL
11654 894 : || expr->value.function.esym != NULL
11655 894 : || expr->value.function.isym->id != GFC_ISYM_CONVERSION
11656 388 : || (!narrowing && !widening))
11657 : return NULL;
11658 :
11659 388 : if (narrowing && widening)
11660 267 : return expr->value.function.actual->expr;
11661 :
11662 121 : if (widening)
11663 : {
11664 121 : ts1 = &expr->ts;
11665 121 : ts2 = &expr->value.function.actual->expr->ts;
11666 : }
11667 : else
11668 : {
11669 0 : ts1 = &expr->value.function.actual->expr->ts;
11670 0 : ts2 = &expr->ts;
11671 : }
11672 :
11673 121 : if (ts1->type > ts2->type
11674 49 : || (ts1->type == ts2->type && ts1->kind > ts2->kind))
11675 121 : return expr->value.function.actual->expr;
11676 :
11677 : return NULL;
11678 : }
11679 :
11680 : static bool
11681 6855 : is_scalar_intrinsic_expr (gfc_expr *expr, bool must_be_var, bool conv_ok)
11682 : {
11683 6855 : if (must_be_var
11684 4020 : && (expr->expr_type != EXPR_VARIABLE || !expr->symtree))
11685 : {
11686 37 : if (!conv_ok)
11687 : return false;
11688 37 : gfc_expr *conv = is_conversion (expr, true, true);
11689 37 : if (!conv)
11690 : return false;
11691 36 : if (conv->expr_type != EXPR_VARIABLE || !conv->symtree)
11692 : return false;
11693 : }
11694 6852 : return (expr->rank == 0
11695 6848 : && !gfc_is_coindexed (expr)
11696 13700 : && (expr->ts.type == BT_INTEGER
11697 : || expr->ts.type == BT_REAL
11698 : || expr->ts.type == BT_COMPLEX
11699 : || expr->ts.type == BT_LOGICAL));
11700 : }
11701 :
11702 : static void
11703 2697 : resolve_omp_atomic (gfc_code *code)
11704 : {
11705 2697 : gfc_code *atomic_code = code->block;
11706 2697 : gfc_symbol *var;
11707 2697 : gfc_expr *stmt_expr2, *capt_expr2;
11708 2697 : gfc_omp_atomic_op aop
11709 2697 : = (gfc_omp_atomic_op) (atomic_code->ext.omp_clauses->atomic_op
11710 : & GFC_OMP_ATOMIC_MASK);
11711 2697 : gfc_code *stmt = NULL, *capture_stmt = NULL, *tailing_stmt = NULL;
11712 2697 : gfc_expr *comp_cond = NULL;
11713 2697 : locus *loc = NULL;
11714 :
11715 2697 : code = code->block->next;
11716 : /* resolve_blocks asserts this is initially EXEC_ASSIGN or EXEC_IF
11717 : If it changed to EXEC_NOP, assume an error has been emitted already. */
11718 2697 : if (code->op == EXEC_NOP)
11719 : return;
11720 :
11721 2696 : if (atomic_code->ext.omp_clauses->compare
11722 156 : && atomic_code->ext.omp_clauses->capture)
11723 : {
11724 : /* Must be either "if (x == e) then; x = d; else; v = x; end if"
11725 : or "v = expr" followed/preceded by
11726 : "if (x == e) then; x = d; end if" or "if (x == e) x = d". */
11727 103 : gfc_code *next = code;
11728 103 : if (code->op == EXEC_ASSIGN)
11729 : {
11730 19 : capture_stmt = code;
11731 19 : next = code->next;
11732 : }
11733 103 : if (next->op == EXEC_IF
11734 103 : && next->block
11735 103 : && next->block->op == EXEC_IF
11736 103 : && next->block->next
11737 102 : && next->block->next->op == EXEC_ASSIGN)
11738 : {
11739 102 : comp_cond = next->block->expr1;
11740 102 : stmt = next->block->next;
11741 102 : if (stmt->next)
11742 : {
11743 0 : loc = &stmt->loc;
11744 0 : goto unexpected;
11745 : }
11746 : }
11747 1 : else if (capture_stmt)
11748 : {
11749 0 : gfc_error ("Expected IF at %L in atomic compare capture",
11750 : &next->loc);
11751 0 : return;
11752 : }
11753 103 : if (stmt && !capture_stmt && next->block->block)
11754 : {
11755 64 : if (next->block->block->expr1)
11756 : {
11757 0 : gfc_error ("Expected ELSE at %L in atomic compare capture",
11758 : &next->block->block->expr1->where);
11759 0 : return;
11760 : }
11761 64 : if (!code->block->block->next
11762 64 : || code->block->block->next->op != EXEC_ASSIGN)
11763 : {
11764 0 : loc = (code->block->block->next ? &code->block->block->next->loc
11765 : : &code->block->block->loc);
11766 0 : goto unexpected;
11767 : }
11768 64 : capture_stmt = code->block->block->next;
11769 64 : if (capture_stmt->next)
11770 : {
11771 0 : loc = &capture_stmt->next->loc;
11772 0 : goto unexpected;
11773 : }
11774 : }
11775 103 : if (stmt && !capture_stmt && next->next->op == EXEC_ASSIGN)
11776 : capture_stmt = next->next;
11777 84 : else if (!capture_stmt)
11778 : {
11779 1 : loc = &code->loc;
11780 1 : goto unexpected;
11781 : }
11782 : }
11783 2593 : else if (atomic_code->ext.omp_clauses->compare)
11784 : {
11785 : /* Must be: "if (x == e) then; x = d; end if" or "if (x == e) x = d". */
11786 53 : if (code->op == EXEC_IF
11787 53 : && code->block
11788 53 : && code->block->op == EXEC_IF
11789 53 : && code->block->next
11790 51 : && code->block->next->op == EXEC_ASSIGN)
11791 : {
11792 51 : comp_cond = code->block->expr1;
11793 51 : stmt = code->block->next;
11794 51 : if (stmt->next || code->block->block)
11795 : {
11796 0 : loc = stmt->next ? &stmt->next->loc : &code->block->block->loc;
11797 0 : goto unexpected;
11798 : }
11799 : }
11800 : else
11801 : {
11802 2 : loc = &code->loc;
11803 2 : goto unexpected;
11804 : }
11805 : }
11806 2540 : else if (atomic_code->ext.omp_clauses->capture)
11807 : {
11808 : /* Must be: "v = x" followed/preceded by "x = ...". */
11809 489 : if (code->op != EXEC_ASSIGN)
11810 0 : goto unexpected;
11811 489 : if (code->next->op != EXEC_ASSIGN)
11812 : {
11813 0 : loc = &code->next->loc;
11814 0 : goto unexpected;
11815 : }
11816 489 : gfc_expr *expr2, *expr2_next;
11817 489 : expr2 = is_conversion (code->expr2, true, true);
11818 489 : if (expr2 == NULL)
11819 447 : expr2 = code->expr2;
11820 489 : expr2_next = is_conversion (code->next->expr2, true, true);
11821 489 : if (expr2_next == NULL)
11822 478 : expr2_next = code->next->expr2;
11823 489 : if (code->expr1->expr_type == EXPR_VARIABLE
11824 489 : && code->next->expr1->expr_type == EXPR_VARIABLE
11825 489 : && expr2->expr_type == EXPR_VARIABLE
11826 243 : && expr2_next->expr_type == EXPR_VARIABLE)
11827 : {
11828 1 : if (code->expr1->symtree->n.sym == expr2_next->symtree->n.sym)
11829 : {
11830 : stmt = code;
11831 : capture_stmt = code->next;
11832 : }
11833 : else
11834 : {
11835 489 : capture_stmt = code;
11836 489 : stmt = code->next;
11837 : }
11838 : }
11839 488 : else if (expr2->expr_type == EXPR_VARIABLE)
11840 : {
11841 : capture_stmt = code;
11842 : stmt = code->next;
11843 : }
11844 : else
11845 : {
11846 247 : stmt = code;
11847 247 : capture_stmt = code->next;
11848 : }
11849 : /* Shall be NULL but can happen for invalid code. */
11850 489 : tailing_stmt = code->next->next;
11851 : }
11852 : else
11853 : {
11854 : /* x = ... */
11855 2051 : stmt = code;
11856 2051 : if (!atomic_code->ext.omp_clauses->compare && stmt->op != EXEC_ASSIGN)
11857 1 : goto unexpected;
11858 : /* Shall be NULL but can happen for invalid code. */
11859 2050 : tailing_stmt = code->next;
11860 : }
11861 :
11862 2692 : if (comp_cond)
11863 : {
11864 153 : if (comp_cond->expr_type != EXPR_OP
11865 153 : || (comp_cond->value.op.op != INTRINSIC_EQ
11866 : && comp_cond->value.op.op != INTRINSIC_EQ_OS
11867 : && comp_cond->value.op.op != INTRINSIC_EQV))
11868 : {
11869 0 : gfc_error ("Expected %<==%>, %<.EQ.%> or %<.EQV.%> atomic comparison "
11870 : "expression at %L", &comp_cond->where);
11871 0 : return;
11872 : }
11873 153 : if (!is_scalar_intrinsic_expr (comp_cond->value.op.op1, true, true))
11874 : {
11875 1 : gfc_error ("Expected scalar intrinsic variable at %L in atomic "
11876 1 : "comparison", &comp_cond->value.op.op1->where);
11877 1 : return;
11878 : }
11879 152 : if (!gfc_resolve_expr (comp_cond->value.op.op2))
11880 : return;
11881 152 : if (!is_scalar_intrinsic_expr (comp_cond->value.op.op2, false, false))
11882 : {
11883 0 : gfc_error ("Expected scalar intrinsic expression at %L in atomic "
11884 0 : "comparison", &comp_cond->value.op.op1->where);
11885 0 : return;
11886 : }
11887 : }
11888 :
11889 2691 : if (!is_scalar_intrinsic_expr (stmt->expr1, true, false))
11890 : {
11891 4 : gfc_error ("!$OMP ATOMIC statement must set a scalar variable of "
11892 4 : "intrinsic type at %L", &stmt->expr1->where);
11893 4 : return;
11894 : }
11895 :
11896 2687 : if (!gfc_resolve_expr (stmt->expr2))
11897 : return;
11898 2683 : if (!is_scalar_intrinsic_expr (stmt->expr2, false, false))
11899 : {
11900 0 : gfc_error ("!$OMP ATOMIC statement must assign an expression of "
11901 0 : "intrinsic type at %L", &stmt->expr2->where);
11902 0 : return;
11903 : }
11904 :
11905 2683 : if (gfc_expr_attr (stmt->expr1).allocatable)
11906 : {
11907 0 : gfc_error ("!$OMP ATOMIC with ALLOCATABLE variable at %L",
11908 0 : &stmt->expr1->where);
11909 0 : return;
11910 : }
11911 :
11912 : /* Should be diagnosed above already. */
11913 2683 : gcc_assert (tailing_stmt == NULL);
11914 :
11915 2683 : var = stmt->expr1->symtree->n.sym;
11916 2683 : stmt_expr2 = is_conversion (stmt->expr2, true, true);
11917 2683 : if (stmt_expr2 == NULL)
11918 2527 : stmt_expr2 = stmt->expr2;
11919 :
11920 2683 : switch (aop)
11921 : {
11922 503 : case GFC_OMP_ATOMIC_READ:
11923 503 : if (stmt_expr2->expr_type != EXPR_VARIABLE)
11924 0 : gfc_error ("!$OMP ATOMIC READ statement must read from a scalar "
11925 : "variable of intrinsic type at %L", &stmt_expr2->where);
11926 : return;
11927 421 : case GFC_OMP_ATOMIC_WRITE:
11928 421 : if (expr_references_sym (stmt_expr2, var, NULL))
11929 0 : gfc_error ("expr in !$OMP ATOMIC WRITE assignment var = expr "
11930 : "must be scalar and cannot reference var at %L",
11931 : &stmt_expr2->where);
11932 : return;
11933 1759 : default:
11934 1759 : break;
11935 : }
11936 :
11937 1759 : if (atomic_code->ext.omp_clauses->capture)
11938 : {
11939 588 : if (!is_scalar_intrinsic_expr (capture_stmt->expr1, true, false))
11940 : {
11941 0 : gfc_error ("!$OMP ATOMIC capture-statement must set a scalar "
11942 : "variable of intrinsic type at %L",
11943 0 : &capture_stmt->expr1->where);
11944 0 : return;
11945 : }
11946 :
11947 588 : if (!is_scalar_intrinsic_expr (capture_stmt->expr2, true, true))
11948 : {
11949 2 : gfc_error ("!$OMP ATOMIC capture-statement requires a scalar variable"
11950 2 : " of intrinsic type at %L", &capture_stmt->expr2->where);
11951 2 : return;
11952 : }
11953 586 : capt_expr2 = is_conversion (capture_stmt->expr2, true, true);
11954 586 : if (capt_expr2 == NULL)
11955 564 : capt_expr2 = capture_stmt->expr2;
11956 :
11957 586 : if (capt_expr2->symtree->n.sym != var)
11958 : {
11959 1 : gfc_error ("!$OMP ATOMIC CAPTURE capture statement reads from "
11960 : "different variable than update statement writes "
11961 : "into at %L", &capture_stmt->expr2->where);
11962 1 : return;
11963 : }
11964 : }
11965 :
11966 1756 : if (atomic_code->ext.omp_clauses->compare)
11967 : {
11968 149 : gfc_expr *var_expr;
11969 149 : if (comp_cond->value.op.op1->expr_type == EXPR_VARIABLE)
11970 : var_expr = comp_cond->value.op.op1;
11971 : else
11972 12 : var_expr = comp_cond->value.op.op1->value.function.actual->expr;
11973 149 : if (var_expr->symtree->n.sym != var)
11974 : {
11975 2 : gfc_error ("For !$OMP ATOMIC COMPARE, the first operand in comparison"
11976 : " at %L must be the variable %qs that the update statement"
11977 : " writes into at %L", &var_expr->where, var->name,
11978 2 : &stmt->expr1->where);
11979 2 : return;
11980 : }
11981 147 : if (stmt_expr2->rank != 0 || expr_references_sym (stmt_expr2, var, NULL))
11982 : {
11983 1 : gfc_error ("expr in !$OMP ATOMIC COMPARE assignment var = expr "
11984 : "must be scalar and cannot reference var at %L",
11985 : &stmt_expr2->where);
11986 1 : return;
11987 : }
11988 : }
11989 1607 : else if (atomic_code->ext.omp_clauses->capture
11990 1607 : && !expr_references_sym (stmt_expr2, var, NULL))
11991 22 : atomic_code->ext.omp_clauses->atomic_op
11992 22 : = (gfc_omp_atomic_op) (atomic_code->ext.omp_clauses->atomic_op
11993 : | GFC_OMP_ATOMIC_SWAP);
11994 1585 : else if (stmt_expr2->expr_type == EXPR_OP)
11995 : {
11996 1229 : gfc_expr *v = NULL, *e, *c;
11997 1229 : gfc_intrinsic_op op = stmt_expr2->value.op.op;
11998 1229 : gfc_intrinsic_op alt_op = INTRINSIC_NONE;
11999 :
12000 1229 : if (atomic_code->ext.omp_clauses->fail != OMP_MEMORDER_UNSET)
12001 3 : gfc_error ("!$OMP ATOMIC UPDATE at %L with FAIL clause requires either"
12002 : " the COMPARE clause or using the intrinsic MIN/MAX "
12003 : "procedure", &atomic_code->loc);
12004 1229 : switch (op)
12005 : {
12006 742 : case INTRINSIC_PLUS:
12007 742 : alt_op = INTRINSIC_MINUS;
12008 742 : break;
12009 94 : case INTRINSIC_TIMES:
12010 94 : alt_op = INTRINSIC_DIVIDE;
12011 94 : break;
12012 120 : case INTRINSIC_MINUS:
12013 120 : alt_op = INTRINSIC_PLUS;
12014 120 : break;
12015 94 : case INTRINSIC_DIVIDE:
12016 94 : alt_op = INTRINSIC_TIMES;
12017 94 : break;
12018 : case INTRINSIC_AND:
12019 : case INTRINSIC_OR:
12020 : break;
12021 43 : case INTRINSIC_EQV:
12022 43 : alt_op = INTRINSIC_NEQV;
12023 43 : break;
12024 43 : case INTRINSIC_NEQV:
12025 43 : alt_op = INTRINSIC_EQV;
12026 43 : break;
12027 1 : default:
12028 1 : gfc_error ("!$OMP ATOMIC assignment operator must be binary "
12029 : "+, *, -, /, .AND., .OR., .EQV. or .NEQV. at %L",
12030 : &stmt_expr2->where);
12031 1 : return;
12032 : }
12033 :
12034 : /* Check for var = var op expr resp. var = expr op var where
12035 : expr doesn't reference var and var op expr is mathematically
12036 : equivalent to var op (expr) resp. expr op var equivalent to
12037 : (expr) op var. We rely here on the fact that the matcher
12038 : for x op1 y op2 z where op1 and op2 have equal precedence
12039 : returns (x op1 y) op2 z. */
12040 1228 : e = stmt_expr2->value.op.op2;
12041 1228 : if (e->expr_type == EXPR_VARIABLE
12042 288 : && e->symtree != NULL
12043 288 : && e->symtree->n.sym == var)
12044 : v = e;
12045 999 : else if ((c = is_conversion (e, false, true)) != NULL
12046 48 : && c->expr_type == EXPR_VARIABLE
12047 48 : && c->symtree != NULL
12048 1047 : && c->symtree->n.sym == var)
12049 : v = c;
12050 : else
12051 : {
12052 951 : gfc_expr **p = NULL, **q;
12053 1049 : for (q = &stmt_expr2->value.op.op1; (e = *q) != NULL; )
12054 1049 : if (e->expr_type == EXPR_VARIABLE
12055 948 : && e->symtree != NULL
12056 948 : && e->symtree->n.sym == var)
12057 : {
12058 : v = e;
12059 : break;
12060 : }
12061 101 : else if ((c = is_conversion (e, false, true)) != NULL)
12062 60 : q = &e->value.function.actual->expr;
12063 41 : else if (e->expr_type != EXPR_OP
12064 41 : || (e->value.op.op != op
12065 15 : && e->value.op.op != alt_op)
12066 38 : || e->rank != 0)
12067 : break;
12068 : else
12069 : {
12070 38 : p = q;
12071 38 : q = &e->value.op.op1;
12072 : }
12073 :
12074 951 : if (v == NULL)
12075 : {
12076 3 : gfc_error ("!$OMP ATOMIC assignment must be var = var op expr "
12077 : "or var = expr op var at %L", &stmt_expr2->where);
12078 3 : return;
12079 : }
12080 :
12081 948 : if (p != NULL)
12082 : {
12083 38 : e = *p;
12084 38 : switch (e->value.op.op)
12085 : {
12086 8 : case INTRINSIC_MINUS:
12087 8 : case INTRINSIC_DIVIDE:
12088 8 : case INTRINSIC_EQV:
12089 8 : case INTRINSIC_NEQV:
12090 8 : gfc_error ("!$OMP ATOMIC var = var op expr not "
12091 : "mathematically equivalent to var = var op "
12092 : "(expr) at %L", &stmt_expr2->where);
12093 8 : break;
12094 : default:
12095 : break;
12096 : }
12097 :
12098 : /* Canonicalize into var = var op (expr). */
12099 38 : *p = e->value.op.op2;
12100 38 : e->value.op.op2 = stmt_expr2;
12101 38 : e->ts = stmt_expr2->ts;
12102 38 : if (stmt->expr2 == stmt_expr2)
12103 26 : stmt->expr2 = stmt_expr2 = e;
12104 : else
12105 12 : stmt->expr2->value.function.actual->expr = stmt_expr2 = e;
12106 :
12107 38 : if (!gfc_compare_types (&stmt_expr2->value.op.op1->ts,
12108 : &stmt_expr2->ts))
12109 : {
12110 24 : for (p = &stmt_expr2->value.op.op1; *p != v;
12111 12 : p = &(*p)->value.function.actual->expr)
12112 : ;
12113 12 : *p = NULL;
12114 12 : gfc_free_expr (stmt_expr2->value.op.op1);
12115 12 : stmt_expr2->value.op.op1 = v;
12116 12 : gfc_convert_type (v, &stmt_expr2->ts, 2);
12117 : }
12118 : }
12119 : }
12120 :
12121 1225 : if (e->rank != 0 || expr_references_sym (stmt->expr2, var, v))
12122 : {
12123 1 : gfc_error ("expr in !$OMP ATOMIC assignment var = var op expr "
12124 : "must be scalar and cannot reference var at %L",
12125 : &stmt_expr2->where);
12126 1 : return;
12127 : }
12128 : }
12129 356 : else if (stmt_expr2->expr_type == EXPR_FUNCTION
12130 355 : && stmt_expr2->value.function.isym != NULL
12131 355 : && stmt_expr2->value.function.esym == NULL
12132 355 : && stmt_expr2->value.function.actual != NULL
12133 355 : && stmt_expr2->value.function.actual->next != NULL)
12134 : {
12135 355 : gfc_actual_arglist *arg, *var_arg;
12136 :
12137 355 : switch (stmt_expr2->value.function.isym->id)
12138 : {
12139 : case GFC_ISYM_MIN:
12140 : case GFC_ISYM_MAX:
12141 : break;
12142 147 : case GFC_ISYM_IAND:
12143 147 : case GFC_ISYM_IOR:
12144 147 : case GFC_ISYM_IEOR:
12145 147 : if (stmt_expr2->value.function.actual->next->next != NULL)
12146 : {
12147 0 : gfc_error ("!$OMP ATOMIC assignment intrinsic IAND, IOR "
12148 : "or IEOR must have two arguments at %L",
12149 : &stmt_expr2->where);
12150 0 : return;
12151 : }
12152 : break;
12153 1 : default:
12154 1 : gfc_error ("!$OMP ATOMIC assignment intrinsic must be "
12155 : "MIN, MAX, IAND, IOR or IEOR at %L",
12156 : &stmt_expr2->where);
12157 1 : return;
12158 : }
12159 :
12160 : var_arg = NULL;
12161 1088 : for (arg = stmt_expr2->value.function.actual; arg; arg = arg->next)
12162 : {
12163 741 : gfc_expr *e = NULL;
12164 741 : if (arg == stmt_expr2->value.function.actual
12165 387 : || (var_arg == NULL && arg->next == NULL))
12166 : {
12167 527 : e = is_conversion (arg->expr, false, true);
12168 527 : if (!e)
12169 514 : e = arg->expr;
12170 527 : if (e->expr_type == EXPR_VARIABLE
12171 453 : && e->symtree != NULL
12172 453 : && e->symtree->n.sym == var)
12173 741 : var_arg = arg;
12174 : }
12175 741 : if ((!var_arg || !e) && expr_references_sym (arg->expr, var, NULL))
12176 : {
12177 7 : gfc_error ("!$OMP ATOMIC intrinsic arguments except one must "
12178 : "not reference %qs at %L",
12179 : var->name, &arg->expr->where);
12180 7 : return;
12181 : }
12182 734 : if (arg->expr->rank != 0)
12183 : {
12184 0 : gfc_error ("!$OMP ATOMIC intrinsic arguments must be scalar "
12185 : "at %L", &arg->expr->where);
12186 0 : return;
12187 : }
12188 : }
12189 :
12190 347 : if (var_arg == NULL)
12191 : {
12192 1 : gfc_error ("First or last !$OMP ATOMIC intrinsic argument must "
12193 : "be %qs at %L", var->name, &stmt_expr2->where);
12194 1 : return;
12195 : }
12196 :
12197 346 : if (var_arg != stmt_expr2->value.function.actual)
12198 : {
12199 : /* Canonicalize, so that var comes first. */
12200 172 : gcc_assert (var_arg->next == NULL);
12201 : for (arg = stmt_expr2->value.function.actual;
12202 185 : arg->next != var_arg; arg = arg->next)
12203 : ;
12204 172 : var_arg->next = stmt_expr2->value.function.actual;
12205 172 : stmt_expr2->value.function.actual = var_arg;
12206 172 : arg->next = NULL;
12207 : }
12208 : }
12209 : else
12210 1 : gfc_error ("!$OMP ATOMIC assignment must have an operator or "
12211 : "intrinsic on right hand side at %L", &stmt_expr2->where);
12212 : return;
12213 :
12214 4 : unexpected:
12215 4 : gfc_error ("unexpected !$OMP ATOMIC expression at %L",
12216 : loc ? loc : &code->loc);
12217 4 : return;
12218 : }
12219 :
12220 :
12221 : static struct fortran_omp_context
12222 : {
12223 : gfc_code *code;
12224 : hash_set<gfc_symbol *> *sharing_clauses;
12225 : hash_set<gfc_symbol *> *private_iterators;
12226 : struct fortran_omp_context *previous;
12227 : bool is_openmp;
12228 : } *omp_current_ctx;
12229 : static gfc_code *omp_current_do_code;
12230 : static int omp_current_do_collapse;
12231 :
12232 : /* Forward declaration for mutually recursive functions. */
12233 : static gfc_code *
12234 : find_nested_loop_in_block (gfc_code *block);
12235 :
12236 : /* Return the first nested DO loop in CHAIN, or NULL if there
12237 : isn't one. Does no error checking on intervening code. */
12238 :
12239 : static gfc_code *
12240 27482 : find_nested_loop_in_chain (gfc_code *chain)
12241 : {
12242 27482 : gfc_code *code;
12243 :
12244 27482 : if (!chain)
12245 : return NULL;
12246 :
12247 31643 : for (code = chain; code; code = code->next)
12248 31222 : switch (code->op)
12249 : {
12250 : case EXEC_DO:
12251 : case EXEC_OMP_TILE:
12252 : case EXEC_OMP_UNROLL:
12253 : return code;
12254 621 : case EXEC_BLOCK:
12255 621 : if (gfc_code *c = find_nested_loop_in_block (code))
12256 : return c;
12257 : break;
12258 : default:
12259 : break;
12260 : }
12261 : return NULL;
12262 : }
12263 :
12264 : /* Return the first nested DO loop in BLOCK, or NULL if there
12265 : isn't one. Does no error checking on intervening code. */
12266 : static gfc_code *
12267 939 : find_nested_loop_in_block (gfc_code *block)
12268 : {
12269 939 : gfc_namespace *ns;
12270 939 : gcc_assert (block->op == EXEC_BLOCK);
12271 939 : ns = block->ext.block.ns;
12272 939 : gcc_assert (ns);
12273 939 : return find_nested_loop_in_chain (ns->code);
12274 : }
12275 :
12276 : void
12277 5432 : gfc_resolve_omp_do_blocks (gfc_code *code, gfc_namespace *ns)
12278 : {
12279 5432 : if (code->block->next && code->block->next->op == EXEC_DO)
12280 : {
12281 5079 : int i;
12282 :
12283 5079 : omp_current_do_code = code->block->next;
12284 5079 : if (code->ext.omp_clauses->orderedc)
12285 142 : omp_current_do_collapse = code->ext.omp_clauses->orderedc;
12286 4937 : else if (code->ext.omp_clauses->collapse)
12287 1121 : omp_current_do_collapse = code->ext.omp_clauses->collapse;
12288 3816 : else if (code->ext.omp_clauses->sizes_list)
12289 175 : omp_current_do_collapse
12290 175 : = gfc_expr_list_len (code->ext.omp_clauses->sizes_list);
12291 : else
12292 3641 : omp_current_do_collapse = 1;
12293 5079 : if (code->ext.omp_clauses->lists[OMP_LIST_REDUCTION_INSCAN])
12294 : {
12295 : /* Checking that there is a matching EXEC_OMP_SCAN in the
12296 : innermost body cannot be deferred to resolve_omp_do because
12297 : we process directives nested in the loop before we get
12298 : there. */
12299 60 : locus *loc
12300 : = &code->ext.omp_clauses->lists[OMP_LIST_REDUCTION_INSCAN]->where;
12301 60 : gfc_code *c;
12302 :
12303 80 : for (i = 1, c = omp_current_do_code;
12304 80 : i < omp_current_do_collapse; i++)
12305 : {
12306 22 : c = find_nested_loop_in_chain (c->block->next);
12307 22 : if (!c || c->op != EXEC_DO || c->block == NULL)
12308 : break;
12309 : }
12310 :
12311 : /* Skip this if we don't have enough nested loops. That
12312 : problem will be diagnosed elsewhere. */
12313 60 : if (c && c->op == EXEC_DO)
12314 : {
12315 58 : gfc_code *block = c->block ? c->block->next : NULL;
12316 58 : if (block && block->op != EXEC_OMP_SCAN)
12317 54 : while (block && block->next
12318 54 : && block->next->op != EXEC_OMP_SCAN)
12319 : block = block->next;
12320 43 : if (!block
12321 46 : || (block->op != EXEC_OMP_SCAN
12322 43 : && (!block->next || block->next->op != EXEC_OMP_SCAN)))
12323 19 : gfc_error ("With INSCAN at %L, expected loop body with "
12324 : "!$OMP SCAN between two "
12325 : "structured block sequences", loc);
12326 : else
12327 : {
12328 39 : if (block->op == EXEC_OMP_SCAN)
12329 3 : gfc_warning (OPT_Wopenmp,
12330 : "!$OMP SCAN at %L with zero executable "
12331 : "statements in preceding structured block "
12332 : "sequence", &block->loc);
12333 39 : if ((block->op == EXEC_OMP_SCAN && !block->next)
12334 38 : || (block->next && block->next->op == EXEC_OMP_SCAN
12335 36 : && !block->next->next))
12336 3 : gfc_warning (OPT_Wopenmp,
12337 : "!$OMP SCAN at %L with zero executable "
12338 : "statements in succeeding structured block "
12339 : "sequence", block->op == EXEC_OMP_SCAN
12340 1 : ? &block->loc : &block->next->loc);
12341 : }
12342 58 : if (block && block->op != EXEC_OMP_SCAN)
12343 43 : block = block->next;
12344 46 : if (block && block->op == EXEC_OMP_SCAN)
12345 : /* Mark 'omp scan' as checked; flag will be unset later. */
12346 39 : block->ext.omp_clauses->if_present = true;
12347 : }
12348 : }
12349 : }
12350 5432 : gfc_resolve_blocks (code->block, ns);
12351 5432 : omp_current_do_collapse = 0;
12352 5432 : omp_current_do_code = NULL;
12353 5432 : }
12354 :
12355 :
12356 : void
12357 6103 : gfc_resolve_omp_parallel_blocks (gfc_code *code, gfc_namespace *ns)
12358 : {
12359 6103 : struct fortran_omp_context ctx;
12360 6103 : gfc_omp_clauses *omp_clauses = code->ext.omp_clauses;
12361 6103 : gfc_omp_namelist *n;
12362 :
12363 6103 : ctx.code = code;
12364 6103 : ctx.sharing_clauses = new hash_set<gfc_symbol *>;
12365 6103 : ctx.private_iterators = new hash_set<gfc_symbol *>;
12366 6103 : ctx.previous = omp_current_ctx;
12367 6103 : ctx.is_openmp = true;
12368 6103 : omp_current_ctx = &ctx;
12369 :
12370 244120 : for (enum gfc_omp_list_type list = OMP_LIST_FIRST; list < OMP_LIST_NUM;
12371 238017 : list = gfc_omp_list_type (list + 1))
12372 238017 : switch (list)
12373 : {
12374 61030 : case OMP_LIST_SHARED:
12375 61030 : case OMP_LIST_PRIVATE:
12376 61030 : case OMP_LIST_FIRSTPRIVATE:
12377 61030 : case OMP_LIST_LASTPRIVATE:
12378 61030 : case OMP_LIST_REDUCTION:
12379 61030 : case OMP_LIST_REDUCTION_INSCAN:
12380 61030 : case OMP_LIST_REDUCTION_TASK:
12381 61030 : case OMP_LIST_IN_REDUCTION:
12382 61030 : case OMP_LIST_TASK_REDUCTION:
12383 61030 : case OMP_LIST_LINEAR:
12384 70021 : for (n = omp_clauses->lists[list]; n; n = n->next)
12385 8991 : ctx.sharing_clauses->add (n->sym);
12386 : break;
12387 : default:
12388 : break;
12389 : }
12390 :
12391 6103 : switch (code->op)
12392 : {
12393 2368 : case EXEC_OMP_DISTRIBUTE_PARALLEL_DO:
12394 2368 : case EXEC_OMP_DISTRIBUTE_PARALLEL_DO_SIMD:
12395 2368 : case EXEC_OMP_MASKED_TASKLOOP:
12396 2368 : case EXEC_OMP_MASKED_TASKLOOP_SIMD:
12397 2368 : case EXEC_OMP_MASTER_TASKLOOP:
12398 2368 : case EXEC_OMP_MASTER_TASKLOOP_SIMD:
12399 2368 : case EXEC_OMP_PARALLEL_DO:
12400 2368 : case EXEC_OMP_PARALLEL_DO_SIMD:
12401 2368 : case EXEC_OMP_PARALLEL_LOOP:
12402 2368 : case EXEC_OMP_PARALLEL_MASKED_TASKLOOP:
12403 2368 : case EXEC_OMP_PARALLEL_MASKED_TASKLOOP_SIMD:
12404 2368 : case EXEC_OMP_PARALLEL_MASTER_TASKLOOP:
12405 2368 : case EXEC_OMP_PARALLEL_MASTER_TASKLOOP_SIMD:
12406 2368 : case EXEC_OMP_TARGET_PARALLEL_DO:
12407 2368 : case EXEC_OMP_TARGET_PARALLEL_DO_SIMD:
12408 2368 : case EXEC_OMP_TARGET_PARALLEL_LOOP:
12409 2368 : case EXEC_OMP_TARGET_TEAMS_DISTRIBUTE:
12410 2368 : case EXEC_OMP_TARGET_TEAMS_DISTRIBUTE_PARALLEL_DO:
12411 2368 : case EXEC_OMP_TARGET_TEAMS_DISTRIBUTE_PARALLEL_DO_SIMD:
12412 2368 : case EXEC_OMP_TARGET_TEAMS_DISTRIBUTE_SIMD:
12413 2368 : case EXEC_OMP_TARGET_TEAMS_LOOP:
12414 2368 : case EXEC_OMP_TASKLOOP:
12415 2368 : case EXEC_OMP_TASKLOOP_SIMD:
12416 2368 : case EXEC_OMP_TEAMS_DISTRIBUTE:
12417 2368 : case EXEC_OMP_TEAMS_DISTRIBUTE_PARALLEL_DO:
12418 2368 : case EXEC_OMP_TEAMS_DISTRIBUTE_PARALLEL_DO_SIMD:
12419 2368 : case EXEC_OMP_TEAMS_DISTRIBUTE_SIMD:
12420 2368 : case EXEC_OMP_TEAMS_LOOP:
12421 2368 : gfc_resolve_omp_do_blocks (code, ns);
12422 2368 : break;
12423 3735 : default:
12424 3735 : gfc_resolve_blocks (code->block, ns);
12425 : }
12426 :
12427 6103 : omp_current_ctx = ctx.previous;
12428 12206 : delete ctx.sharing_clauses;
12429 12206 : delete ctx.private_iterators;
12430 6103 : }
12431 :
12432 :
12433 : /* Save and clear openmp.cc private state. */
12434 :
12435 : void
12436 301727 : gfc_omp_save_and_clear_state (struct gfc_omp_saved_state *state)
12437 : {
12438 301727 : state->ptrs[0] = omp_current_ctx;
12439 301727 : state->ptrs[1] = omp_current_do_code;
12440 301727 : state->ints[0] = omp_current_do_collapse;
12441 301727 : omp_current_ctx = NULL;
12442 301727 : omp_current_do_code = NULL;
12443 301727 : omp_current_do_collapse = 0;
12444 301727 : }
12445 :
12446 :
12447 : /* Restore openmp.cc private state from the saved state. */
12448 :
12449 : void
12450 301726 : gfc_omp_restore_state (struct gfc_omp_saved_state *state)
12451 : {
12452 301726 : omp_current_ctx = (struct fortran_omp_context *) state->ptrs[0];
12453 301726 : omp_current_do_code = (gfc_code *) state->ptrs[1];
12454 301726 : omp_current_do_collapse = state->ints[0];
12455 301726 : }
12456 :
12457 :
12458 : /* Note a DO iterator variable. This is special in !$omp parallel
12459 : construct, where they are predetermined private. */
12460 :
12461 : void
12462 33170 : gfc_resolve_do_iterator (gfc_code *code, gfc_symbol *sym, bool add_clause)
12463 : {
12464 33170 : if (omp_current_ctx == NULL)
12465 : return;
12466 :
12467 13113 : int i = omp_current_do_collapse;
12468 13113 : gfc_code *c = omp_current_do_code;
12469 :
12470 13113 : if (sym->attr.threadprivate)
12471 : return;
12472 :
12473 : /* !$omp do and !$omp parallel do iteration variable is predetermined
12474 : private just in the !$omp do resp. !$omp parallel do construct,
12475 : with no implications for the outer parallel constructs. */
12476 :
12477 17948 : while (i-- >= 1 && c)
12478 : {
12479 9502 : if (code == c)
12480 : return;
12481 4835 : c = find_nested_loop_in_chain (c->block->next);
12482 4835 : if (c && (c->op == EXEC_OMP_TILE || c->op == EXEC_OMP_UNROLL))
12483 : return;
12484 : }
12485 :
12486 : /* An openacc context may represent a data clause. Abort if so. */
12487 8446 : if (!omp_current_ctx->is_openmp && !oacc_is_loop (omp_current_ctx->code))
12488 : return;
12489 :
12490 7468 : if (omp_current_ctx->sharing_clauses->contains (sym))
12491 : return;
12492 :
12493 6466 : if (! omp_current_ctx->private_iterators->add (sym) && add_clause)
12494 : {
12495 6276 : gfc_omp_clauses *omp_clauses = omp_current_ctx->code->ext.omp_clauses;
12496 6276 : gfc_omp_namelist *p;
12497 :
12498 6276 : p = gfc_get_omp_namelist ();
12499 6276 : p->sym = sym;
12500 6276 : p->where = omp_current_ctx->code->loc;
12501 6276 : p->next = omp_clauses->lists[OMP_LIST_PRIVATE];
12502 6276 : omp_clauses->lists[OMP_LIST_PRIVATE] = p;
12503 : }
12504 : }
12505 :
12506 : static void
12507 775 : handle_local_var (gfc_symbol *sym)
12508 : {
12509 775 : if (sym->attr.flavor != FL_VARIABLE
12510 180 : || sym->as != NULL
12511 139 : || (sym->ts.type != BT_INTEGER && sym->ts.type != BT_REAL))
12512 : return;
12513 72 : gfc_resolve_do_iterator (sym->ns->code, sym, false);
12514 : }
12515 :
12516 : void
12517 348691 : gfc_resolve_omp_local_vars (gfc_namespace *ns)
12518 : {
12519 348691 : if (omp_current_ctx)
12520 469 : gfc_traverse_ns (ns, handle_local_var);
12521 348691 : }
12522 :
12523 :
12524 : /* Error checking on intervening code uses a code walker. */
12525 :
12526 : struct icode_error_state
12527 : {
12528 : const char *name;
12529 : bool errorp;
12530 : gfc_code *nested;
12531 : gfc_code *next;
12532 : };
12533 :
12534 : static int
12535 944 : icode_code_error_callback (gfc_code **codep,
12536 : int *walk_subtrees ATTRIBUTE_UNUSED, void *opaque)
12537 : {
12538 944 : gfc_code *code = *codep;
12539 944 : icode_error_state *state = (icode_error_state *)opaque;
12540 :
12541 : /* gfc_code_walker walks down CODE's next chain as well as
12542 : walking things that are actually nested in CODE. We need to
12543 : special-case traversal of outer blocks, so stop immediately if we
12544 : are heading down such a next chain. */
12545 944 : if (code == state->next)
12546 : return 1;
12547 :
12548 647 : switch (code->op)
12549 : {
12550 1 : case EXEC_DO:
12551 1 : case EXEC_DO_WHILE:
12552 1 : case EXEC_DO_CONCURRENT:
12553 1 : gfc_error ("%s cannot contain loop in intervening code at %L",
12554 : state->name, &code->loc);
12555 1 : state->errorp = true;
12556 1 : break;
12557 0 : case EXEC_CYCLE:
12558 0 : case EXEC_EXIT:
12559 : /* Errors have already been diagnosed in match_exit_cycle. */
12560 0 : state->errorp = true;
12561 0 : break;
12562 : case EXEC_OMP_ASSUME:
12563 : case EXEC_OMP_METADIRECTIVE:
12564 : /* Per OpenMP 6.0, some non-executable directives are allowed in
12565 : intervening code. */
12566 : break;
12567 477 : case EXEC_CALL:
12568 : /* Per OpenMP 5.2, the "omp_" prefix is reserved, so we don't have to
12569 : consider the possibility that some locally-bound definition
12570 : overrides the runtime routine. */
12571 477 : if (code->resolved_sym
12572 477 : && omp_runtime_api_procname (code->resolved_sym->name))
12573 : {
12574 1 : gfc_error ("%s cannot contain OpenMP API call in intervening code "
12575 : "at %L",
12576 : state->name, &code->loc);
12577 1 : state->errorp = true;
12578 : }
12579 : break;
12580 168 : default:
12581 168 : if (code->op >= EXEC_OMP_FIRST_OPENMP_EXEC
12582 168 : && code->op <= EXEC_OMP_LAST_OPENMP_EXEC)
12583 : {
12584 2 : gfc_error ("%s cannot contain OpenMP directive in intervening code "
12585 : "at %L",
12586 : state->name, &code->loc);
12587 2 : state->errorp = true;
12588 : }
12589 : }
12590 : return 0;
12591 : }
12592 :
12593 : static int
12594 1081 : icode_expr_error_callback (gfc_expr **expr,
12595 : int *walk_subtrees ATTRIBUTE_UNUSED, void *opaque)
12596 : {
12597 1081 : icode_error_state *state = (icode_error_state *)opaque;
12598 :
12599 1081 : switch ((*expr)->expr_type)
12600 : {
12601 : /* As for EXPR_CALL with "omp_"-prefixed symbols. */
12602 2 : case EXPR_FUNCTION:
12603 2 : {
12604 2 : gfc_symbol *sym = (*expr)->value.function.esym;
12605 2 : if (sym && omp_runtime_api_procname (sym->name))
12606 : {
12607 1 : gfc_error ("%s cannot contain OpenMP API call in intervening code "
12608 : "at %L",
12609 1 : state->name, &((*expr)->where));
12610 1 : state->errorp = true;
12611 : }
12612 : }
12613 :
12614 : break;
12615 : default:
12616 : break;
12617 : }
12618 :
12619 : /* FIXME: The description of canonical loop form in the OpenMP standard
12620 : also says "array expressions" are not permitted in intervening code.
12621 : That term is not defined in either the OpenMP spec or the Fortran
12622 : standard, although the latter uses it informally to refer to any
12623 : expression that is not scalar-valued. It is also apparently not the
12624 : thing GCC internally calls EXPR_ARRAY. It seems the intent of the
12625 : OpenMP restriction is to disallow elemental operations/intrinsics
12626 : (including things that are not expressions, like assignment
12627 : statements) that generate implicit loops over array operands
12628 : (even if the result is a scalar), but even if the spec said
12629 : that there is no list of all the cases that would be forbidden.
12630 : This is OpenMP issue 3326. */
12631 :
12632 1081 : return 0;
12633 : }
12634 :
12635 : static void
12636 267 : diagnose_intervening_code_errors_1 (gfc_code *chain,
12637 : struct icode_error_state *state)
12638 : {
12639 267 : gfc_code *code;
12640 1080 : for (code = chain; code; code = code->next)
12641 : {
12642 813 : if (code == state->nested)
12643 : /* Do not walk the nested loop or its body, we are only
12644 : interested in intervening code. */
12645 : ;
12646 636 : else if (code->op == EXEC_BLOCK
12647 636 : && find_nested_loop_in_block (code) == state->nested)
12648 : /* This block contains the nested loop, recurse on its
12649 : statements. */
12650 : {
12651 90 : gfc_namespace* ns = code->ext.block.ns;
12652 90 : diagnose_intervening_code_errors_1 (ns->code, state);
12653 : }
12654 : else
12655 : /* Treat the whole statement as a unit. */
12656 : {
12657 546 : gfc_code *temp = state->next;
12658 546 : state->next = code->next;
12659 546 : gfc_code_walker (&code, icode_code_error_callback,
12660 : icode_expr_error_callback, state);
12661 546 : state->next = temp;
12662 : }
12663 : }
12664 267 : }
12665 :
12666 : /* Diagnose intervening code errors in BLOCK with nested loop NESTED.
12667 : NAME is the user-friendly name of the OMP directive, used for error
12668 : messages. Returns true if any error was found. */
12669 : static bool
12670 177 : diagnose_intervening_code_errors (gfc_code *chain, const char *name,
12671 : gfc_code *nested)
12672 : {
12673 177 : struct icode_error_state state;
12674 177 : state.name = name;
12675 177 : state.errorp = false;
12676 177 : state.nested = nested;
12677 177 : state.next = NULL;
12678 0 : diagnose_intervening_code_errors_1 (chain, &state);
12679 177 : return state.errorp;
12680 : }
12681 :
12682 : /* Helper function for restructure_intervening_code: wrap CHAIN in
12683 : a marker to indicate that it is a structured block sequence. That
12684 : information will be used later on (in omp-low.cc) for error checking. */
12685 : static gfc_code *
12686 461 : make_structured_block (gfc_code *chain)
12687 : {
12688 461 : gcc_assert (chain);
12689 461 : gfc_namespace *ns = gfc_build_block_ns (gfc_current_ns);
12690 461 : gfc_code *result = gfc_get_code (EXEC_BLOCK);
12691 461 : result->op = EXEC_BLOCK;
12692 461 : result->ext.block.ns = ns;
12693 461 : result->ext.block.assoc = NULL;
12694 461 : result->loc = chain->loc;
12695 461 : ns->omp_structured_block = 1;
12696 461 : ns->code = chain;
12697 461 : return result;
12698 : }
12699 :
12700 : /* Push intervening code surrounding a loop, including nested scopes,
12701 : into the body of the loop. CHAINP is the pointer to the head of
12702 : the next-chain to scan, OUTER_LOOP is the EXEC_DO for the next outer
12703 : loop level, and COLLAPSE is the number of nested loops we need to
12704 : process.
12705 : Note that CHAINP may point at outer_loop->block->next when we
12706 : are scanning the body of a loop, but if there is an intervening block
12707 : CHAINP points into the block's chain rather than its enclosing outer
12708 : loop. This is why OUTER_LOOP is passed separately. */
12709 : static gfc_code *
12710 7182 : restructure_intervening_code (gfc_code **chainp, gfc_code *outer_loop,
12711 : int count)
12712 : {
12713 7182 : gfc_code *code;
12714 7182 : gfc_code *head = *chainp;
12715 7182 : gfc_code *tail = NULL;
12716 7182 : gfc_code *innermost_loop = NULL;
12717 :
12718 7446 : for (code = *chainp; code; code = code->next, chainp = &(*chainp)->next)
12719 : {
12720 7446 : if (code->op == EXEC_DO)
12721 : {
12722 : /* Cut CODE free from its chain, leaving the ends dangling. */
12723 7098 : *chainp = NULL;
12724 7098 : tail = code->next;
12725 7098 : code->next = NULL;
12726 :
12727 7098 : if (count == 1)
12728 : innermost_loop = code;
12729 : else
12730 2090 : innermost_loop
12731 2090 : = restructure_intervening_code (&code->block->next,
12732 : code, count - 1);
12733 : break;
12734 : }
12735 348 : else if (code->op == EXEC_BLOCK
12736 348 : && find_nested_loop_in_block (code))
12737 : {
12738 84 : gfc_namespace *ns = code->ext.block.ns;
12739 :
12740 : /* Cut CODE free from its chain, leaving the ends dangling. */
12741 84 : *chainp = NULL;
12742 84 : tail = code->next;
12743 84 : code->next = NULL;
12744 :
12745 84 : innermost_loop
12746 84 : = restructure_intervening_code (&ns->code, outer_loop,
12747 : count);
12748 :
12749 : /* At this point we have already pulled out the nested loop and
12750 : pointed outer_loop at it, and moved the intervening code that
12751 : was previously in the block into the body of innermost_loop.
12752 : Now we want to move the BLOCK itself so it wraps the entire
12753 : current body of innermost_loop. */
12754 84 : ns->code = innermost_loop->block->next;
12755 84 : innermost_loop->block->next = code;
12756 84 : break;
12757 : }
12758 : }
12759 :
12760 2174 : gcc_assert (innermost_loop);
12761 :
12762 : /* Now we have split the intervening code into two parts:
12763 : head is the start of the part before the loop/block, terminating
12764 : at *chainp, and tail is the part after it. Mark each part as
12765 : a structured block sequence, and splice the two parts around the
12766 : existing body of the innermost loop. */
12767 7182 : if (head != code)
12768 : {
12769 222 : gfc_code *block = make_structured_block (head);
12770 222 : if (innermost_loop->block->next)
12771 221 : gfc_append_code (block, innermost_loop->block->next);
12772 222 : innermost_loop->block->next = block;
12773 : }
12774 7182 : if (tail)
12775 : {
12776 239 : gfc_code *block = make_structured_block (tail);
12777 239 : if (innermost_loop->block->next)
12778 237 : gfc_append_code (innermost_loop->block->next, block);
12779 : else
12780 2 : innermost_loop->block->next = block;
12781 : }
12782 :
12783 : /* For loops, finally splice CODE into OUTER_LOOP. We already handled
12784 : relinking EXEC_BLOCK above. */
12785 7182 : if (code->op == EXEC_DO && outer_loop)
12786 7098 : outer_loop->block->next = code;
12787 :
12788 7182 : return innermost_loop;
12789 : }
12790 :
12791 : /* CODE is an OMP loop construct. Return true if VAR matches an iteration
12792 : variable outer to level DEPTH. */
12793 : static bool
12794 8095 : is_outer_iteration_variable (gfc_code *code, int depth, gfc_symbol *var)
12795 : {
12796 8095 : int i;
12797 8095 : gfc_code *do_code = code;
12798 :
12799 12622 : for (i = 1; i < depth; i++)
12800 : {
12801 5028 : do_code = find_nested_loop_in_chain (do_code->block->next);
12802 5028 : gcc_assert (do_code);
12803 5028 : if (do_code->op == EXEC_OMP_TILE || do_code->op == EXEC_OMP_UNROLL)
12804 : {
12805 51 : --i;
12806 51 : continue;
12807 : }
12808 4977 : gfc_symbol *ivar = do_code->ext.iterator->var->symtree->n.sym;
12809 4977 : if (var == ivar)
12810 : return true;
12811 : }
12812 : return false;
12813 : }
12814 :
12815 : /* Forward declaration for recursive functions. */
12816 : static gfc_code *
12817 : check_nested_loop_in_block (gfc_code *block, gfc_expr *expr, gfc_symbol *sym,
12818 : bool *bad);
12819 :
12820 : /* Like find_nested_loop_in_chain, but additionally check that EXPR
12821 : does not reference any variables bound in intervening EXEC_BLOCKs
12822 : and that SYM is not bound in such intervening blocks. Either EXPR or SYM
12823 : may be null. Sets *BAD to true if either test fails. */
12824 : static gfc_code *
12825 48213 : check_nested_loop_in_chain (gfc_code *chain, gfc_expr *expr, gfc_symbol *sym,
12826 : bool *bad)
12827 : {
12828 51817 : for (gfc_code *code = chain; code; code = code->next)
12829 : {
12830 51529 : if (code->op == EXEC_DO)
12831 : return code;
12832 4123 : else if (code->op == EXEC_OMP_TILE || code->op == EXEC_OMP_UNROLL)
12833 1682 : return check_nested_loop_in_chain (code->block->next, expr, sym, bad);
12834 2441 : else if (code->op == EXEC_BLOCK)
12835 : {
12836 807 : gfc_code *c = check_nested_loop_in_block (code, expr, sym, bad);
12837 807 : if (c)
12838 : return c;
12839 : }
12840 : }
12841 : return NULL;
12842 : }
12843 :
12844 : /* Code walker for block symtrees. It doesn't take any kind of state
12845 : argument, so use a static variable. */
12846 : static struct check_nested_loop_in_block_state_t {
12847 : gfc_expr *expr;
12848 : gfc_symbol *sym;
12849 : bool *bad;
12850 : } check_nested_loop_in_block_state;
12851 :
12852 : static void
12853 766 : check_nested_loop_in_block_symbol (gfc_symbol *sym)
12854 : {
12855 766 : if (sym == check_nested_loop_in_block_state.sym
12856 766 : || (check_nested_loop_in_block_state.expr
12857 567 : && gfc_find_sym_in_expr (sym,
12858 : check_nested_loop_in_block_state.expr)))
12859 5 : *check_nested_loop_in_block_state.bad = true;
12860 766 : }
12861 :
12862 : /* Return the first nested DO loop in BLOCK, or NULL if there
12863 : isn't one. Set *BAD to true if EXPR references any variables in BLOCK, or
12864 : SYM is bound in BLOCK. Either EXPR or SYM may be null. */
12865 : static gfc_code *
12866 807 : check_nested_loop_in_block (gfc_code *block, gfc_expr *expr,
12867 : gfc_symbol *sym, bool *bad)
12868 : {
12869 807 : gfc_namespace *ns;
12870 807 : gcc_assert (block->op == EXEC_BLOCK);
12871 807 : ns = block->ext.block.ns;
12872 807 : gcc_assert (ns);
12873 :
12874 : /* Skip the check if this block doesn't contain the nested loop, or
12875 : if we already know it's bad. */
12876 807 : gfc_code *result = check_nested_loop_in_chain (ns->code, expr, sym, bad);
12877 807 : if (result && !*bad)
12878 : {
12879 519 : check_nested_loop_in_block_state.expr = expr;
12880 519 : check_nested_loop_in_block_state.sym = sym;
12881 519 : check_nested_loop_in_block_state.bad = bad;
12882 519 : gfc_traverse_ns (ns, check_nested_loop_in_block_symbol);
12883 519 : check_nested_loop_in_block_state.expr = NULL;
12884 519 : check_nested_loop_in_block_state.sym = NULL;
12885 519 : check_nested_loop_in_block_state.bad = NULL;
12886 : }
12887 807 : return result;
12888 : }
12889 :
12890 : /* CODE is an OMP loop construct. Return true if EXPR references
12891 : any variables bound in intervening code, to level DEPTH. */
12892 : static bool
12893 22753 : expr_uses_intervening_var (gfc_code *code, int depth, gfc_expr *expr)
12894 : {
12895 22753 : int i;
12896 22753 : gfc_code *do_code = code;
12897 :
12898 58285 : for (i = 0; i < depth; i++)
12899 : {
12900 35535 : bool bad = false;
12901 35535 : do_code = check_nested_loop_in_chain (do_code->block->next,
12902 : expr, NULL, &bad);
12903 35535 : if (bad)
12904 3 : return true;
12905 : }
12906 : return false;
12907 : }
12908 :
12909 : /* CODE is an OMP loop construct. Return true if SYM is bound in
12910 : intervening code, to level DEPTH. */
12911 : static bool
12912 7594 : is_intervening_var (gfc_code *code, int depth, gfc_symbol *sym)
12913 : {
12914 7594 : int i;
12915 7594 : gfc_code *do_code = code;
12916 :
12917 19463 : for (i = 0; i < depth; i++)
12918 : {
12919 11871 : bool bad = false;
12920 11871 : do_code = check_nested_loop_in_chain (do_code->block->next,
12921 : NULL, sym, &bad);
12922 11871 : if (bad)
12923 2 : return true;
12924 : }
12925 : return false;
12926 : }
12927 :
12928 : /* CODE is an OMP loop construct. Return true if EXPR does not reference
12929 : any iteration variables outer to level DEPTH. */
12930 : static bool
12931 23832 : expr_is_invariant (gfc_code *code, int depth, gfc_expr *expr)
12932 : {
12933 23832 : int i;
12934 23832 : gfc_code *do_code = code;
12935 :
12936 37154 : for (i = 1; i < depth; i++)
12937 : {
12938 14388 : do_code = find_nested_loop_in_chain (do_code->block->next);
12939 14388 : gcc_assert (do_code);
12940 14388 : if (do_code->op == EXEC_OMP_TILE || do_code->op == EXEC_OMP_UNROLL)
12941 : {
12942 136 : --i;
12943 136 : continue;
12944 : }
12945 14252 : gfc_symbol *ivar = do_code->ext.iterator->var->symtree->n.sym;
12946 14252 : if (gfc_find_sym_in_expr (ivar, expr))
12947 : return false;
12948 : }
12949 : return true;
12950 : }
12951 :
12952 : /* CODE is an OMP loop construct. Return true if EXPR matches one of the
12953 : canonical forms for a bound expression. It may include references to
12954 : an iteration variable outer to level DEPTH; set OUTER_VARP if so. */
12955 : static bool
12956 15179 : bound_expr_is_canonical (gfc_code *code, int depth, gfc_expr *expr,
12957 : gfc_symbol **outer_varp)
12958 : {
12959 15179 : gfc_expr *expr2 = NULL;
12960 :
12961 : /* Rectangular case. */
12962 15179 : if (depth == 0 || expr_is_invariant (code, depth, expr))
12963 14611 : return true;
12964 :
12965 : /* Any simple variable that didn't pass expr_is_invariant must be
12966 : an outer_var. */
12967 568 : if (expr->expr_type == EXPR_VARIABLE && expr->rank == 0)
12968 : {
12969 63 : *outer_varp = expr->symtree->n.sym;
12970 63 : return true;
12971 : }
12972 :
12973 : /* All other permitted forms are binary operators. */
12974 505 : if (expr->expr_type != EXPR_OP)
12975 : return false;
12976 :
12977 : /* Check for plus/minus a loop invariant expr. */
12978 503 : if (expr->value.op.op == INTRINSIC_PLUS
12979 503 : || expr->value.op.op == INTRINSIC_MINUS)
12980 : {
12981 483 : if (expr_is_invariant (code, depth, expr->value.op.op1))
12982 48 : expr2 = expr->value.op.op2;
12983 435 : else if (expr_is_invariant (code, depth, expr->value.op.op2))
12984 434 : expr2 = expr->value.op.op1;
12985 : else
12986 : return false;
12987 : }
12988 : else
12989 : expr2 = expr;
12990 :
12991 : /* Check for a product with a loop-invariant expr. */
12992 502 : if (expr2->expr_type == EXPR_OP
12993 96 : && expr2->value.op.op == INTRINSIC_TIMES)
12994 : {
12995 96 : if (expr_is_invariant (code, depth, expr2->value.op.op1))
12996 40 : expr2 = expr2->value.op.op2;
12997 56 : else if (expr_is_invariant (code, depth, expr2->value.op.op2))
12998 53 : expr2 = expr2->value.op.op1;
12999 : else
13000 : return false;
13001 : }
13002 :
13003 : /* What's left must be a reference to an outer loop variable. */
13004 499 : if (expr2->expr_type == EXPR_VARIABLE
13005 499 : && expr2->rank == 0
13006 998 : && is_outer_iteration_variable (code, depth, expr2->symtree->n.sym))
13007 : {
13008 499 : *outer_varp = expr2->symtree->n.sym;
13009 499 : return true;
13010 : }
13011 :
13012 : return false;
13013 : }
13014 :
13015 : static void
13016 5432 : resolve_omp_do (gfc_code *code)
13017 : {
13018 5432 : gfc_code *do_code, *next;
13019 5432 : int i, count, non_generated_count;
13020 5432 : gfc_omp_namelist *n;
13021 5432 : gfc_symbol *dovar;
13022 5432 : const char *name;
13023 5432 : bool is_simd = false;
13024 5432 : bool errorp = false;
13025 5432 : bool perfect_nesting_errorp = false;
13026 5432 : bool imperfect = false;
13027 :
13028 5432 : switch (code->op)
13029 : {
13030 : case EXEC_OMP_DISTRIBUTE: name = "!$OMP DISTRIBUTE"; break;
13031 49 : case EXEC_OMP_DISTRIBUTE_PARALLEL_DO:
13032 49 : name = "!$OMP DISTRIBUTE PARALLEL DO";
13033 49 : break;
13034 32 : case EXEC_OMP_DISTRIBUTE_PARALLEL_DO_SIMD:
13035 32 : name = "!$OMP DISTRIBUTE PARALLEL DO SIMD";
13036 32 : is_simd = true;
13037 32 : break;
13038 50 : case EXEC_OMP_DISTRIBUTE_SIMD:
13039 50 : name = "!$OMP DISTRIBUTE SIMD";
13040 50 : is_simd = true;
13041 50 : break;
13042 1336 : case EXEC_OMP_DO: name = "!$OMP DO"; break;
13043 134 : case EXEC_OMP_DO_SIMD: name = "!$OMP DO SIMD"; is_simd = true; break;
13044 64 : case EXEC_OMP_LOOP: name = "!$OMP LOOP"; break;
13045 1220 : case EXEC_OMP_PARALLEL_DO: name = "!$OMP PARALLEL DO"; break;
13046 304 : case EXEC_OMP_PARALLEL_DO_SIMD:
13047 304 : name = "!$OMP PARALLEL DO SIMD";
13048 304 : is_simd = true;
13049 304 : break;
13050 46 : case EXEC_OMP_PARALLEL_LOOP: name = "!$OMP PARALLEL LOOP"; break;
13051 7 : case EXEC_OMP_PARALLEL_MASKED_TASKLOOP:
13052 7 : name = "!$OMP PARALLEL MASKED TASKLOOP";
13053 7 : break;
13054 10 : case EXEC_OMP_PARALLEL_MASKED_TASKLOOP_SIMD:
13055 10 : name = "!$OMP PARALLEL MASKED TASKLOOP SIMD";
13056 10 : is_simd = true;
13057 10 : break;
13058 12 : case EXEC_OMP_PARALLEL_MASTER_TASKLOOP:
13059 12 : name = "!$OMP PARALLEL MASTER TASKLOOP";
13060 12 : break;
13061 18 : case EXEC_OMP_PARALLEL_MASTER_TASKLOOP_SIMD:
13062 18 : name = "!$OMP PARALLEL MASTER TASKLOOP SIMD";
13063 18 : is_simd = true;
13064 18 : break;
13065 8 : case EXEC_OMP_MASKED_TASKLOOP: name = "!$OMP MASKED TASKLOOP"; break;
13066 14 : case EXEC_OMP_MASKED_TASKLOOP_SIMD:
13067 14 : name = "!$OMP MASKED TASKLOOP SIMD";
13068 14 : is_simd = true;
13069 14 : break;
13070 14 : case EXEC_OMP_MASTER_TASKLOOP: name = "!$OMP MASTER TASKLOOP"; break;
13071 19 : case EXEC_OMP_MASTER_TASKLOOP_SIMD:
13072 19 : name = "!$OMP MASTER TASKLOOP SIMD";
13073 19 : is_simd = true;
13074 19 : break;
13075 783 : case EXEC_OMP_SIMD: name = "!$OMP SIMD"; is_simd = true; break;
13076 88 : case EXEC_OMP_TARGET_PARALLEL_DO: name = "!$OMP TARGET PARALLEL DO"; break;
13077 20 : case EXEC_OMP_TARGET_PARALLEL_DO_SIMD:
13078 20 : name = "!$OMP TARGET PARALLEL DO SIMD";
13079 20 : is_simd = true;
13080 20 : break;
13081 16 : case EXEC_OMP_TARGET_PARALLEL_LOOP:
13082 16 : name = "!$OMP TARGET PARALLEL LOOP";
13083 16 : break;
13084 33 : case EXEC_OMP_TARGET_SIMD:
13085 33 : name = "!$OMP TARGET SIMD";
13086 33 : is_simd = true;
13087 33 : break;
13088 20 : case EXEC_OMP_TARGET_TEAMS_DISTRIBUTE:
13089 20 : name = "!$OMP TARGET TEAMS DISTRIBUTE";
13090 20 : break;
13091 77 : case EXEC_OMP_TARGET_TEAMS_DISTRIBUTE_PARALLEL_DO:
13092 77 : name = "!$OMP TARGET TEAMS DISTRIBUTE PARALLEL DO";
13093 77 : break;
13094 38 : case EXEC_OMP_TARGET_TEAMS_DISTRIBUTE_PARALLEL_DO_SIMD:
13095 38 : name = "!$OMP TARGET TEAMS DISTRIBUTE PARALLEL DO SIMD";
13096 38 : is_simd = true;
13097 38 : break;
13098 20 : case EXEC_OMP_TARGET_TEAMS_DISTRIBUTE_SIMD:
13099 20 : name = "!$OMP TARGET TEAMS DISTRIBUTE SIMD";
13100 20 : is_simd = true;
13101 20 : break;
13102 19 : case EXEC_OMP_TARGET_TEAMS_LOOP: name = "!$OMP TARGET TEAMS LOOP"; break;
13103 69 : case EXEC_OMP_TASKLOOP: name = "!$OMP TASKLOOP"; break;
13104 38 : case EXEC_OMP_TASKLOOP_SIMD:
13105 38 : name = "!$OMP TASKLOOP SIMD";
13106 38 : is_simd = true;
13107 38 : break;
13108 20 : case EXEC_OMP_TEAMS_DISTRIBUTE: name = "!$OMP TEAMS DISTRIBUTE"; break;
13109 39 : case EXEC_OMP_TEAMS_DISTRIBUTE_PARALLEL_DO:
13110 39 : name = "!$OMP TEAMS DISTRIBUTE PARALLEL DO";
13111 39 : break;
13112 61 : case EXEC_OMP_TEAMS_DISTRIBUTE_PARALLEL_DO_SIMD:
13113 61 : name = "!$OMP TEAMS DISTRIBUTE PARALLEL DO SIMD";
13114 61 : is_simd = true;
13115 61 : break;
13116 42 : case EXEC_OMP_TEAMS_DISTRIBUTE_SIMD:
13117 42 : name = "!$OMP TEAMS DISTRIBUTE SIMD";
13118 42 : is_simd = true;
13119 42 : break;
13120 48 : case EXEC_OMP_TEAMS_LOOP: name = "!$OMP TEAMS LOOP"; break;
13121 195 : case EXEC_OMP_TILE: name = "!$OMP TILE"; break;
13122 415 : case EXEC_OMP_UNROLL: name = "!$OMP UNROLL"; break;
13123 0 : default: gcc_unreachable ();
13124 : }
13125 :
13126 5432 : if (code->ext.omp_clauses)
13127 5432 : resolve_omp_clauses (code, code->ext.omp_clauses, NULL);
13128 :
13129 5432 : if (code->op == EXEC_OMP_TILE && code->ext.omp_clauses->sizes_list == NULL)
13130 0 : gfc_error ("SIZES clause is required on !$OMP TILE construct at %L",
13131 : &code->loc);
13132 :
13133 5432 : do_code = code->block->next;
13134 5432 : if (code->ext.omp_clauses->orderedc)
13135 : count = code->ext.omp_clauses->orderedc;
13136 5288 : else if (code->ext.omp_clauses->sizes_list)
13137 195 : count = gfc_expr_list_len (code->ext.omp_clauses->sizes_list);
13138 : else
13139 : {
13140 5093 : count = code->ext.omp_clauses->collapse;
13141 5093 : if (count <= 0)
13142 : count = 1;
13143 : }
13144 :
13145 5432 : non_generated_count = count;
13146 : /* While the spec defines the loop nest depth independently of the COLLAPSE
13147 : clause, in practice the middle end only pays attention to the COLLAPSE
13148 : depth and treats any further inner loops as the final-loop-body. So
13149 : here we also check canonical loop nest form only for the number of
13150 : outer loops specified by the COLLAPSE clause too. */
13151 8072 : for (i = 1; i <= count; i++)
13152 : {
13153 8072 : gfc_symbol *start_var = NULL, *end_var = NULL;
13154 : /* Parse errors are not recoverable. */
13155 8072 : if (do_code->op == EXEC_DO_WHILE)
13156 : {
13157 6 : gfc_error ("%s cannot be a DO WHILE or DO without loop control "
13158 : "at %L", name, &do_code->loc);
13159 106 : goto fail;
13160 : }
13161 8066 : if (do_code->op == EXEC_DO_CONCURRENT)
13162 : {
13163 4 : gfc_error ("%s cannot be a DO CONCURRENT loop at %L", name,
13164 : &do_code->loc);
13165 4 : goto fail;
13166 : }
13167 8062 : if (do_code->op == EXEC_OMP_TILE || do_code->op == EXEC_OMP_UNROLL)
13168 : {
13169 466 : if (do_code->op == EXEC_OMP_UNROLL)
13170 : {
13171 308 : if (!do_code->ext.omp_clauses->partial)
13172 : {
13173 53 : gfc_error ("Generated loop of UNROLL construct at %L "
13174 : "without PARTIAL clause does not have "
13175 : "canonical form", &do_code->loc);
13176 53 : goto fail;
13177 : }
13178 255 : else if (i != count)
13179 : {
13180 5 : gfc_error ("UNROLL construct at %L with PARTIAL clause "
13181 : "generates just one loop with canonical form "
13182 : "but %d loops are needed",
13183 5 : &do_code->loc, count - i + 1);
13184 5 : goto fail;
13185 : }
13186 : }
13187 158 : else if (do_code->op == EXEC_OMP_TILE)
13188 : {
13189 158 : if (do_code->ext.omp_clauses->sizes_list == NULL)
13190 : /* This should have been diagnosed earlier already. */
13191 0 : return;
13192 158 : int l = gfc_expr_list_len (do_code->ext.omp_clauses->sizes_list);
13193 158 : if (count - i + 1 > l)
13194 : {
13195 14 : gfc_error ("TILE construct at %L generates %d loops "
13196 : "with canonical form but %d loops are needed",
13197 : &do_code->loc, l, count - i + 1);
13198 14 : goto fail;
13199 : }
13200 : }
13201 394 : if (do_code->ext.omp_clauses && do_code->ext.omp_clauses->erroneous)
13202 17 : goto fail;
13203 377 : if (imperfect && !perfect_nesting_errorp)
13204 : {
13205 4 : sorry_at (gfc_get_location (&do_code->loc),
13206 : "Imperfectly nested loop using generated loops");
13207 4 : errorp = true;
13208 : }
13209 377 : if (non_generated_count == count)
13210 329 : non_generated_count = i - 1;
13211 377 : --i;
13212 377 : do_code = do_code->block->next;
13213 377 : continue;
13214 377 : }
13215 7596 : gcc_assert (do_code->op == EXEC_DO);
13216 7596 : if (do_code->ext.iterator->var->ts.type != BT_INTEGER)
13217 : {
13218 3 : gfc_error ("%s iteration variable must be of type integer at %L",
13219 : name, &do_code->loc);
13220 3 : errorp = true;
13221 : }
13222 7596 : dovar = do_code->ext.iterator->var->symtree->n.sym;
13223 7596 : if (dovar->attr.threadprivate)
13224 : {
13225 0 : gfc_error ("%s iteration variable must not be THREADPRIVATE "
13226 : "at %L", name, &do_code->loc);
13227 0 : errorp = true;
13228 : }
13229 7596 : if (code->ext.omp_clauses)
13230 303840 : for (enum gfc_omp_list_type list = OMP_LIST_FIRST; list < OMP_LIST_NUM;
13231 296244 : list = gfc_omp_list_type (list + 1))
13232 97578 : if (!is_simd || code->ext.omp_clauses->collapse > 1
13233 296244 : ? (list != OMP_LIST_PRIVATE && list != OMP_LIST_LASTPRIVATE
13234 255021 : && list != OMP_LIST_ALLOCATE)
13235 41223 : : (list != OMP_LIST_PRIVATE && list != OMP_LIST_LASTPRIVATE
13236 41223 : && list != OMP_LIST_ALLOCATE && list != OMP_LIST_LINEAR))
13237 276784 : for (n = code->ext.omp_clauses->lists[list]; n; n = n->next)
13238 4385 : if (dovar == n->sym)
13239 : {
13240 5 : if (!is_simd || code->ext.omp_clauses->collapse > 1)
13241 4 : gfc_error ("%s iteration variable present on clause "
13242 : "other than PRIVATE, LASTPRIVATE or "
13243 : "ALLOCATE at %L", name, &do_code->loc);
13244 : else
13245 1 : gfc_error ("%s iteration variable present on clause "
13246 : "other than PRIVATE, LASTPRIVATE, ALLOCATE or "
13247 : "LINEAR at %L", name, &do_code->loc);
13248 : errorp = true;
13249 : }
13250 7596 : if (is_outer_iteration_variable (code, i, dovar))
13251 : {
13252 2 : gfc_error ("%s iteration variable used in more than one loop at %L",
13253 : name, &do_code->loc);
13254 2 : errorp = true;
13255 : }
13256 7594 : else if (is_intervening_var (code, i, dovar))
13257 : {
13258 2 : gfc_error ("%s iteration variable at %L is bound in "
13259 : "intervening code",
13260 : name, &do_code->loc);
13261 2 : errorp = true;
13262 : }
13263 7592 : else if (!bound_expr_is_canonical (code, i,
13264 7592 : do_code->ext.iterator->start,
13265 : &start_var))
13266 : {
13267 4 : gfc_error ("%s loop start expression not in canonical form at %L",
13268 : name, &do_code->loc);
13269 4 : errorp = true;
13270 : }
13271 7588 : else if (expr_uses_intervening_var (code, i,
13272 7588 : do_code->ext.iterator->start))
13273 : {
13274 1 : gfc_error ("%s loop start expression at %L uses variable bound in "
13275 : "intervening code",
13276 : name, &do_code->loc);
13277 1 : errorp = true;
13278 : }
13279 7587 : else if (!bound_expr_is_canonical (code, i,
13280 7587 : do_code->ext.iterator->end,
13281 : &end_var))
13282 : {
13283 2 : gfc_error ("%s loop end expression not in canonical form at %L",
13284 : name, &do_code->loc);
13285 2 : errorp = true;
13286 : }
13287 7585 : else if (expr_uses_intervening_var (code, i,
13288 7585 : do_code->ext.iterator->end))
13289 : {
13290 1 : gfc_error ("%s loop end expression at %L uses variable bound in "
13291 : "intervening code",
13292 : name, &do_code->loc);
13293 1 : errorp = true;
13294 : }
13295 7584 : else if (start_var && end_var && start_var != end_var)
13296 : {
13297 1 : gfc_error ("%s loop bounds reference different "
13298 : "iteration variables at %L", name, &do_code->loc);
13299 1 : errorp = true;
13300 : }
13301 7583 : else if (!expr_is_invariant (code, i, do_code->ext.iterator->step))
13302 : {
13303 3 : gfc_error ("%s loop increment not in canonical form at %L",
13304 : name, &do_code->loc);
13305 3 : errorp = true;
13306 : }
13307 7580 : else if (expr_uses_intervening_var (code, i,
13308 7580 : do_code->ext.iterator->step))
13309 : {
13310 1 : gfc_error ("%s loop increment expression at %L uses variable "
13311 : "bound in intervening code",
13312 : name, &do_code->loc);
13313 1 : errorp = true;
13314 : }
13315 7596 : if (start_var || end_var)
13316 : {
13317 528 : code->ext.omp_clauses->non_rectangular = 1;
13318 528 : if (i > non_generated_count)
13319 : {
13320 3 : sorry_at (gfc_get_location (&do_code->loc),
13321 : "Non-rectangular loops from generated loops "
13322 : "unsupported");
13323 3 : errorp = true;
13324 : }
13325 : }
13326 :
13327 : /* Only parse loop body into nested loop and intervening code if
13328 : there are supposed to be more loops in the nest to collapse. */
13329 7596 : if (i == count)
13330 : break;
13331 :
13332 2270 : next = find_nested_loop_in_chain (do_code->block->next);
13333 :
13334 2270 : if (!next)
13335 : {
13336 : /* Parse error, can't recover from this. */
13337 7 : gfc_error ("not enough DO loops for collapsed %s (level %d) at %L",
13338 : name, i, &code->loc);
13339 7 : goto fail;
13340 : }
13341 2263 : else if (next != do_code->block->next
13342 2103 : || (next->next && next->next->op != EXEC_CONTINUE))
13343 : /* Imperfectly nested loop found. */
13344 : {
13345 : /* Only diagnose violation of imperfect nesting constraints once. */
13346 177 : if (!perfect_nesting_errorp)
13347 : {
13348 176 : if (code->ext.omp_clauses->orderedc)
13349 : {
13350 3 : gfc_error ("%s inner loops must be perfectly nested with "
13351 : "ORDERED clause at %L",
13352 : name, &code->loc);
13353 3 : perfect_nesting_errorp = true;
13354 : }
13355 173 : else if (code->ext.omp_clauses->lists[OMP_LIST_REDUCTION_INSCAN])
13356 : {
13357 2 : gfc_error ("%s inner loops must be perfectly nested with "
13358 : "REDUCTION INSCAN clause at %L",
13359 : name, &code->loc);
13360 2 : perfect_nesting_errorp = true;
13361 : }
13362 171 : else if (code->op == EXEC_OMP_TILE)
13363 : {
13364 8 : gfc_error ("%s inner loops must be perfectly nested at %L",
13365 : name, &code->loc);
13366 8 : perfect_nesting_errorp = true;
13367 : }
13368 13 : if (perfect_nesting_errorp)
13369 : errorp = true;
13370 : }
13371 177 : if (diagnose_intervening_code_errors (do_code->block->next,
13372 : name, next))
13373 5 : errorp = true;
13374 : imperfect = true;
13375 : }
13376 2263 : do_code = next;
13377 : }
13378 :
13379 : /* Give up now if we found any constraint violations. */
13380 5326 : if (errorp)
13381 : {
13382 48 : fail:
13383 154 : if (code->ext.omp_clauses)
13384 154 : code->ext.omp_clauses->erroneous = 1;
13385 154 : return;
13386 : }
13387 :
13388 5278 : if (non_generated_count)
13389 5008 : restructure_intervening_code (&code->block->next, code,
13390 : non_generated_count);
13391 : }
13392 :
13393 : /* Resolve the context selector. In particular, SKIP_P is set to true,
13394 : the context can never be matched. */
13395 :
13396 : static void
13397 764 : gfc_resolve_omp_context_selector (gfc_omp_set_selector *oss,
13398 : bool is_metadirective, bool *skip_p)
13399 : {
13400 764 : if (skip_p)
13401 310 : *skip_p = false;
13402 1453 : for (gfc_omp_set_selector *set_selector = oss; set_selector;
13403 689 : set_selector = set_selector->next)
13404 1485 : for (gfc_omp_selector *os = set_selector->trait_selectors; os; os = os->next)
13405 : {
13406 814 : if (os->score)
13407 : {
13408 52 : if (!gfc_resolve_expr (os->score)
13409 52 : || os->score->ts.type != BT_INTEGER
13410 104 : || os->score->rank != 0)
13411 : {
13412 0 : gfc_error ("%<score%> argument must be constant integer "
13413 0 : "expression at %L", &os->score->where);
13414 0 : gfc_free_expr (os->score);
13415 0 : os->score = nullptr;
13416 : }
13417 52 : else if (os->score->expr_type == EXPR_CONSTANT
13418 52 : && mpz_sgn (os->score->value.integer) < 0)
13419 : {
13420 1 : gfc_error ("%<score%> argument must be non-negative at %L",
13421 : &os->score->where);
13422 1 : gfc_free_expr (os->score);
13423 1 : os->score = nullptr;
13424 : }
13425 : }
13426 :
13427 814 : if (os->code == OMP_TRAIT_INVALID)
13428 : break;
13429 796 : enum omp_tp_type property_kind = omp_ts_map[os->code].tp_type;
13430 796 : gfc_omp_trait_property *otp = os->properties;
13431 :
13432 796 : if (!otp)
13433 409 : continue;
13434 387 : switch (property_kind)
13435 : {
13436 139 : case OMP_TRAIT_PROPERTY_DEV_NUM_EXPR:
13437 139 : case OMP_TRAIT_PROPERTY_BOOL_EXPR:
13438 139 : if (!gfc_resolve_expr (otp->expr)
13439 138 : || (property_kind == OMP_TRAIT_PROPERTY_BOOL_EXPR
13440 124 : && otp->expr->ts.type != BT_LOGICAL)
13441 137 : || (property_kind == OMP_TRAIT_PROPERTY_DEV_NUM_EXPR
13442 14 : && otp->expr->ts.type != BT_INTEGER)
13443 137 : || otp->expr->rank != 0
13444 276 : || (!is_metadirective && otp->expr->expr_type != EXPR_CONSTANT))
13445 : {
13446 3 : if (is_metadirective)
13447 : {
13448 0 : if (property_kind == OMP_TRAIT_PROPERTY_BOOL_EXPR)
13449 0 : gfc_error ("property must be a "
13450 : "logical expression at %L",
13451 0 : &otp->expr->where);
13452 : else
13453 0 : gfc_error ("property must be an "
13454 : "integer expression at %L",
13455 0 : &otp->expr->where);
13456 : }
13457 : else
13458 : {
13459 3 : if (property_kind == OMP_TRAIT_PROPERTY_BOOL_EXPR)
13460 2 : gfc_error ("property must be a constant "
13461 : "logical expression at %L",
13462 2 : &otp->expr->where);
13463 : else
13464 1 : gfc_error ("property must be a constant "
13465 : "integer expression at %L",
13466 1 : &otp->expr->where);
13467 : }
13468 : /* Prevent later ICEs. */
13469 3 : gfc_expr *e;
13470 3 : if (property_kind == OMP_TRAIT_PROPERTY_BOOL_EXPR)
13471 2 : e = gfc_get_logical_expr (gfc_default_logical_kind,
13472 2 : &otp->expr->where, true);
13473 : else
13474 1 : e = gfc_get_int_expr (gfc_default_integer_kind,
13475 1 : &otp->expr->where, 0);
13476 3 : gfc_free_expr (otp->expr);
13477 3 : otp->expr = e;
13478 3 : continue;
13479 3 : }
13480 : /* Device number must be conforming, which includes
13481 : omp_initial_device (-1), omp_invalid_device (-4),
13482 : and omp_default_device (-5). */
13483 136 : if (property_kind == OMP_TRAIT_PROPERTY_DEV_NUM_EXPR
13484 14 : && otp->expr->expr_type == EXPR_CONSTANT
13485 5 : && mpz_sgn (otp->expr->value.integer) < 0
13486 3 : && mpz_cmp_si (otp->expr->value.integer, -1) != 0
13487 2 : && mpz_cmp_si (otp->expr->value.integer, -4) != 0
13488 1 : && mpz_cmp_si (otp->expr->value.integer, -5) != 0)
13489 1 : gfc_error ("property must be a conforming device number at %L",
13490 : &otp->expr->where);
13491 : break;
13492 : default:
13493 : break;
13494 : }
13495 : /* This only handles one specific case: User condition.
13496 : FIXME: Handle more cases by calling omp_context_selector_matches;
13497 : unfortunately, we cannot generate the tree here as, e.g., PARM_DECL
13498 : backend decl are not available at this stage - but might be used in,
13499 : e.g. user conditions. See PR122361. */
13500 384 : if (skip_p && otp
13501 138 : && os->code == OMP_TRAIT_USER_CONDITION
13502 81 : && otp->expr->expr_type == EXPR_CONSTANT
13503 14 : && otp->expr->value.logical == false)
13504 12 : *skip_p = true;
13505 : }
13506 764 : }
13507 :
13508 :
13509 : static void
13510 138 : resolve_omp_metadirective (gfc_code *code, gfc_namespace *ns)
13511 : {
13512 138 : gfc_omp_variant *variant = code->ext.omp_variants;
13513 138 : gfc_omp_variant *prev_variant = variant;
13514 :
13515 448 : while (variant)
13516 : {
13517 310 : bool skip;
13518 310 : gfc_resolve_omp_context_selector (variant->selectors, true, &skip);
13519 310 : gfc_code *variant_code = variant->code;
13520 310 : gfc_resolve_code (variant_code, ns);
13521 310 : if (skip)
13522 : {
13523 : /* The following should only be true if an error occurred
13524 : as the 'otherwise' clause should always match. */
13525 12 : if (variant == code->ext.omp_variants && !variant->next)
13526 : break;
13527 12 : gfc_omp_variant *tmp = variant;
13528 12 : if (variant == code->ext.omp_variants)
13529 11 : variant = prev_variant = code->ext.omp_variants = variant->next;
13530 : else
13531 1 : variant = prev_variant->next = variant->next;
13532 12 : gfc_free_omp_set_selector_list (tmp->selectors);
13533 12 : free (tmp);
13534 : }
13535 : else
13536 : {
13537 298 : prev_variant = variant;
13538 298 : variant = variant->next;
13539 : }
13540 : }
13541 : /* Replace metadirective by its body if only 'nothing' remains. */
13542 138 : if (!code->ext.omp_variants->next && code->ext.omp_variants->stmt == ST_NONE)
13543 : {
13544 11 : gfc_code *next = code->next;
13545 11 : gfc_code *inner = code->ext.omp_variants->code;
13546 11 : gfc_free_omp_set_selector_list (code->ext.omp_variants->selectors);
13547 11 : free (code->ext.omp_variants);
13548 11 : *code = *inner;
13549 11 : free (inner);
13550 11 : while (code->next)
13551 : code = code->next;
13552 11 : code->next = next;
13553 : }
13554 138 : }
13555 :
13556 :
13557 : static gfc_statement
13558 63 : omp_code_to_statement (gfc_code *code)
13559 : {
13560 63 : switch (code->op)
13561 : {
13562 : case EXEC_OMP_PARALLEL:
13563 : return ST_OMP_PARALLEL;
13564 0 : case EXEC_OMP_PARALLEL_MASKED:
13565 0 : return ST_OMP_PARALLEL_MASKED;
13566 0 : case EXEC_OMP_PARALLEL_MASKED_TASKLOOP:
13567 0 : return ST_OMP_PARALLEL_MASKED_TASKLOOP;
13568 0 : case EXEC_OMP_PARALLEL_MASKED_TASKLOOP_SIMD:
13569 0 : return ST_OMP_PARALLEL_MASKED_TASKLOOP_SIMD;
13570 0 : case EXEC_OMP_PARALLEL_MASTER:
13571 0 : return ST_OMP_PARALLEL_MASTER;
13572 0 : case EXEC_OMP_PARALLEL_MASTER_TASKLOOP:
13573 0 : return ST_OMP_PARALLEL_MASTER_TASKLOOP;
13574 0 : case EXEC_OMP_PARALLEL_MASTER_TASKLOOP_SIMD:
13575 0 : return ST_OMP_PARALLEL_MASTER_TASKLOOP_SIMD;
13576 1 : case EXEC_OMP_PARALLEL_SECTIONS:
13577 1 : return ST_OMP_PARALLEL_SECTIONS;
13578 1 : case EXEC_OMP_SECTIONS:
13579 1 : return ST_OMP_SECTIONS;
13580 1 : case EXEC_OMP_ORDERED:
13581 1 : return ST_OMP_ORDERED;
13582 1 : case EXEC_OMP_CRITICAL:
13583 1 : return ST_OMP_CRITICAL;
13584 0 : case EXEC_OMP_MASKED:
13585 0 : return ST_OMP_MASKED;
13586 0 : case EXEC_OMP_MASKED_TASKLOOP:
13587 0 : return ST_OMP_MASKED_TASKLOOP;
13588 0 : case EXEC_OMP_MASKED_TASKLOOP_SIMD:
13589 0 : return ST_OMP_MASKED_TASKLOOP_SIMD;
13590 1 : case EXEC_OMP_MASTER:
13591 1 : return ST_OMP_MASTER;
13592 0 : case EXEC_OMP_MASTER_TASKLOOP:
13593 0 : return ST_OMP_MASTER_TASKLOOP;
13594 0 : case EXEC_OMP_MASTER_TASKLOOP_SIMD:
13595 0 : return ST_OMP_MASTER_TASKLOOP_SIMD;
13596 1 : case EXEC_OMP_SINGLE:
13597 1 : return ST_OMP_SINGLE;
13598 1 : case EXEC_OMP_TASK:
13599 1 : return ST_OMP_TASK;
13600 1 : case EXEC_OMP_WORKSHARE:
13601 1 : return ST_OMP_WORKSHARE;
13602 1 : case EXEC_OMP_PARALLEL_WORKSHARE:
13603 1 : return ST_OMP_PARALLEL_WORKSHARE;
13604 3 : case EXEC_OMP_DO:
13605 3 : return ST_OMP_DO;
13606 0 : case EXEC_OMP_LOOP:
13607 0 : return ST_OMP_LOOP;
13608 0 : case EXEC_OMP_ALLOCATE:
13609 0 : return ST_OMP_ALLOCATE_EXEC;
13610 0 : case EXEC_OMP_ALLOCATORS:
13611 0 : return ST_OMP_ALLOCATORS;
13612 0 : case EXEC_OMP_ASSUME:
13613 0 : return ST_OMP_ASSUME;
13614 1 : case EXEC_OMP_ATOMIC:
13615 1 : return ST_OMP_ATOMIC;
13616 1 : case EXEC_OMP_BARRIER:
13617 1 : return ST_OMP_BARRIER;
13618 1 : case EXEC_OMP_CANCEL:
13619 1 : return ST_OMP_CANCEL;
13620 1 : case EXEC_OMP_CANCELLATION_POINT:
13621 1 : return ST_OMP_CANCELLATION_POINT;
13622 0 : case EXEC_OMP_ERROR:
13623 0 : return ST_OMP_ERROR;
13624 1 : case EXEC_OMP_FLUSH:
13625 1 : return ST_OMP_FLUSH;
13626 0 : case EXEC_OMP_INTEROP:
13627 0 : return ST_OMP_INTEROP;
13628 1 : case EXEC_OMP_DISTRIBUTE:
13629 1 : return ST_OMP_DISTRIBUTE;
13630 1 : case EXEC_OMP_DISTRIBUTE_PARALLEL_DO:
13631 1 : return ST_OMP_DISTRIBUTE_PARALLEL_DO;
13632 1 : case EXEC_OMP_DISTRIBUTE_PARALLEL_DO_SIMD:
13633 1 : return ST_OMP_DISTRIBUTE_PARALLEL_DO_SIMD;
13634 1 : case EXEC_OMP_DISTRIBUTE_SIMD:
13635 1 : return ST_OMP_DISTRIBUTE_SIMD;
13636 1 : case EXEC_OMP_DO_SIMD:
13637 1 : return ST_OMP_DO_SIMD;
13638 0 : case EXEC_OMP_SCAN:
13639 0 : return ST_OMP_SCAN;
13640 0 : case EXEC_OMP_SCOPE:
13641 0 : return ST_OMP_SCOPE;
13642 1 : case EXEC_OMP_SIMD:
13643 1 : return ST_OMP_SIMD;
13644 1 : case EXEC_OMP_TARGET:
13645 1 : return ST_OMP_TARGET;
13646 1 : case EXEC_OMP_TARGET_DATA:
13647 1 : return ST_OMP_TARGET_DATA;
13648 1 : case EXEC_OMP_TARGET_ENTER_DATA:
13649 1 : return ST_OMP_TARGET_ENTER_DATA;
13650 1 : case EXEC_OMP_TARGET_EXIT_DATA:
13651 1 : return ST_OMP_TARGET_EXIT_DATA;
13652 1 : case EXEC_OMP_TARGET_PARALLEL:
13653 1 : return ST_OMP_TARGET_PARALLEL;
13654 1 : case EXEC_OMP_TARGET_PARALLEL_DO:
13655 1 : return ST_OMP_TARGET_PARALLEL_DO;
13656 1 : case EXEC_OMP_TARGET_PARALLEL_DO_SIMD:
13657 1 : return ST_OMP_TARGET_PARALLEL_DO_SIMD;
13658 0 : case EXEC_OMP_TARGET_PARALLEL_LOOP:
13659 0 : return ST_OMP_TARGET_PARALLEL_LOOP;
13660 1 : case EXEC_OMP_TARGET_SIMD:
13661 1 : return ST_OMP_TARGET_SIMD;
13662 1 : case EXEC_OMP_TARGET_TEAMS:
13663 1 : return ST_OMP_TARGET_TEAMS;
13664 1 : case EXEC_OMP_TARGET_TEAMS_DISTRIBUTE:
13665 1 : return ST_OMP_TARGET_TEAMS_DISTRIBUTE;
13666 1 : case EXEC_OMP_TARGET_TEAMS_DISTRIBUTE_PARALLEL_DO:
13667 1 : return ST_OMP_TARGET_TEAMS_DISTRIBUTE_PARALLEL_DO;
13668 1 : case EXEC_OMP_TARGET_TEAMS_DISTRIBUTE_PARALLEL_DO_SIMD:
13669 1 : return ST_OMP_TARGET_TEAMS_DISTRIBUTE_PARALLEL_DO_SIMD;
13670 1 : case EXEC_OMP_TARGET_TEAMS_DISTRIBUTE_SIMD:
13671 1 : return ST_OMP_TARGET_TEAMS_DISTRIBUTE_SIMD;
13672 0 : case EXEC_OMP_TARGET_TEAMS_LOOP:
13673 0 : return ST_OMP_TARGET_TEAMS_LOOP;
13674 1 : case EXEC_OMP_TARGET_UPDATE:
13675 1 : return ST_OMP_TARGET_UPDATE;
13676 1 : case EXEC_OMP_TASKGROUP:
13677 1 : return ST_OMP_TASKGROUP;
13678 1 : case EXEC_OMP_TASKLOOP:
13679 1 : return ST_OMP_TASKLOOP;
13680 1 : case EXEC_OMP_TASKLOOP_SIMD:
13681 1 : return ST_OMP_TASKLOOP_SIMD;
13682 1 : case EXEC_OMP_TASKWAIT:
13683 1 : return ST_OMP_TASKWAIT;
13684 1 : case EXEC_OMP_TASKYIELD:
13685 1 : return ST_OMP_TASKYIELD;
13686 1 : case EXEC_OMP_TEAMS:
13687 1 : return ST_OMP_TEAMS;
13688 1 : case EXEC_OMP_TEAMS_DISTRIBUTE:
13689 1 : return ST_OMP_TEAMS_DISTRIBUTE;
13690 1 : case EXEC_OMP_TEAMS_DISTRIBUTE_PARALLEL_DO:
13691 1 : return ST_OMP_TEAMS_DISTRIBUTE_PARALLEL_DO;
13692 1 : case EXEC_OMP_TEAMS_DISTRIBUTE_PARALLEL_DO_SIMD:
13693 1 : return ST_OMP_TEAMS_DISTRIBUTE_PARALLEL_DO_SIMD;
13694 1 : case EXEC_OMP_TEAMS_DISTRIBUTE_SIMD:
13695 1 : return ST_OMP_TEAMS_DISTRIBUTE_SIMD;
13696 0 : case EXEC_OMP_TEAMS_LOOP:
13697 0 : return ST_OMP_TEAMS_LOOP;
13698 6 : case EXEC_OMP_PARALLEL_DO:
13699 6 : return ST_OMP_PARALLEL_DO;
13700 1 : case EXEC_OMP_PARALLEL_DO_SIMD:
13701 1 : return ST_OMP_PARALLEL_DO_SIMD;
13702 0 : case EXEC_OMP_PARALLEL_LOOP:
13703 0 : return ST_OMP_PARALLEL_LOOP;
13704 1 : case EXEC_OMP_DEPOBJ:
13705 1 : return ST_OMP_DEPOBJ;
13706 0 : case EXEC_OMP_TILE:
13707 0 : return ST_OMP_TILE;
13708 0 : case EXEC_OMP_UNROLL:
13709 0 : return ST_OMP_UNROLL;
13710 0 : case EXEC_OMP_DISPATCH:
13711 0 : return ST_OMP_DISPATCH;
13712 0 : default:
13713 0 : gcc_unreachable ();
13714 : }
13715 : }
13716 :
13717 : static gfc_statement
13718 63 : oacc_code_to_statement (gfc_code *code)
13719 : {
13720 63 : switch (code->op)
13721 : {
13722 : case EXEC_OACC_PARALLEL:
13723 : return ST_OACC_PARALLEL;
13724 : case EXEC_OACC_KERNELS:
13725 : return ST_OACC_KERNELS;
13726 : case EXEC_OACC_SERIAL:
13727 : return ST_OACC_SERIAL;
13728 : case EXEC_OACC_DATA:
13729 : return ST_OACC_DATA;
13730 : case EXEC_OACC_HOST_DATA:
13731 : return ST_OACC_HOST_DATA;
13732 : case EXEC_OACC_PARALLEL_LOOP:
13733 : return ST_OACC_PARALLEL_LOOP;
13734 : case EXEC_OACC_KERNELS_LOOP:
13735 : return ST_OACC_KERNELS_LOOP;
13736 : case EXEC_OACC_SERIAL_LOOP:
13737 : return ST_OACC_SERIAL_LOOP;
13738 : case EXEC_OACC_LOOP:
13739 : return ST_OACC_LOOP;
13740 : case EXEC_OACC_ATOMIC:
13741 : return ST_OACC_ATOMIC;
13742 : case EXEC_OACC_ROUTINE:
13743 : return ST_OACC_ROUTINE;
13744 : case EXEC_OACC_UPDATE:
13745 : return ST_OACC_UPDATE;
13746 : case EXEC_OACC_WAIT:
13747 : return ST_OACC_WAIT;
13748 : case EXEC_OACC_CACHE:
13749 : return ST_OACC_CACHE;
13750 : case EXEC_OACC_ENTER_DATA:
13751 : return ST_OACC_ENTER_DATA;
13752 : case EXEC_OACC_EXIT_DATA:
13753 : return ST_OACC_EXIT_DATA;
13754 : case EXEC_OACC_DECLARE:
13755 : return ST_OACC_DECLARE;
13756 : case EXEC_OACC_INIT:
13757 : return ST_OACC_INIT;
13758 : case EXEC_OACC_SHUTDOWN:
13759 : return ST_OACC_SHUTDOWN;
13760 : case EXEC_OACC_SET:
13761 : return ST_OACC_SET;
13762 0 : default:
13763 0 : gcc_unreachable ();
13764 : }
13765 : }
13766 :
13767 : static void
13768 13538 : resolve_oacc_directive_inside_omp_region (gfc_code *code)
13769 : {
13770 13538 : if (omp_current_ctx != NULL && omp_current_ctx->is_openmp)
13771 : {
13772 11 : gfc_statement st = omp_code_to_statement (omp_current_ctx->code);
13773 11 : gfc_statement oacc_st = oacc_code_to_statement (code);
13774 11 : gfc_error ("The %s directive cannot be specified within "
13775 : "a %s region at %L", gfc_ascii_statement (oacc_st),
13776 : gfc_ascii_statement (st), &code->loc);
13777 : }
13778 13538 : }
13779 :
13780 : static void
13781 21246 : resolve_omp_directive_inside_oacc_region (gfc_code *code)
13782 : {
13783 21246 : if (omp_current_ctx != NULL && !omp_current_ctx->is_openmp)
13784 : {
13785 52 : gfc_statement st = oacc_code_to_statement (omp_current_ctx->code);
13786 52 : gfc_statement omp_st = omp_code_to_statement (code);
13787 52 : gfc_error ("The %s directive cannot be specified within "
13788 : "a %s region at %L", gfc_ascii_statement (omp_st),
13789 : gfc_ascii_statement (st), &code->loc);
13790 : }
13791 21246 : }
13792 :
13793 :
13794 : static void
13795 5272 : resolve_oacc_nested_loops (gfc_code *code, gfc_code* do_code, int collapse,
13796 : const char *clause)
13797 : {
13798 5272 : gfc_symbol *dovar;
13799 5272 : gfc_code *c;
13800 5272 : int i;
13801 :
13802 5792 : for (i = 1; i <= collapse; i++)
13803 : {
13804 5792 : if (do_code->op == EXEC_DO_WHILE)
13805 : {
13806 10 : gfc_error ("!$ACC LOOP cannot be a DO WHILE or DO without loop control "
13807 : "at %L", &do_code->loc);
13808 10 : break;
13809 : }
13810 5782 : if (do_code->op == EXEC_DO_CONCURRENT)
13811 : {
13812 3 : gfc_error ("!$ACC LOOP cannot be a DO CONCURRENT loop at %L",
13813 : &do_code->loc);
13814 3 : break;
13815 : }
13816 5779 : gcc_assert (do_code->op == EXEC_DO);
13817 5779 : if (do_code->ext.iterator->var->ts.type != BT_INTEGER)
13818 6 : gfc_error ("!$ACC LOOP iteration variable must be of type integer at %L",
13819 : &do_code->loc);
13820 5779 : dovar = do_code->ext.iterator->var->symtree->n.sym;
13821 5779 : if (i > 1)
13822 : {
13823 518 : gfc_code *do_code2 = code->block->next;
13824 518 : int j;
13825 :
13826 1218 : for (j = 1; j < i; j++)
13827 : {
13828 710 : gfc_symbol *ivar = do_code2->ext.iterator->var->symtree->n.sym;
13829 710 : if (dovar == ivar
13830 710 : || gfc_find_sym_in_expr (ivar, do_code->ext.iterator->start)
13831 701 : || gfc_find_sym_in_expr (ivar, do_code->ext.iterator->end)
13832 1410 : || gfc_find_sym_in_expr (ivar, do_code->ext.iterator->step))
13833 : {
13834 10 : gfc_error ("!$ACC LOOP %s loops don't form rectangular "
13835 : "iteration space at %L", clause, &do_code->loc);
13836 10 : break;
13837 : }
13838 700 : do_code2 = do_code2->block->next;
13839 : }
13840 : }
13841 5779 : if (i == collapse)
13842 : break;
13843 577 : for (c = do_code->next; c; c = c->next)
13844 48 : if (c->op != EXEC_NOP && c->op != EXEC_CONTINUE)
13845 : {
13846 0 : gfc_error ("%s !$ACC LOOP loops not perfectly nested at %L",
13847 : clause, &c->loc);
13848 0 : break;
13849 : }
13850 529 : if (c)
13851 : break;
13852 529 : do_code = do_code->block;
13853 529 : if (do_code->op != EXEC_DO && do_code->op != EXEC_DO_WHILE
13854 0 : && do_code->op != EXEC_DO_CONCURRENT)
13855 : {
13856 0 : gfc_error ("not enough DO loops for %s !$ACC LOOP at %L",
13857 : clause, &code->loc);
13858 0 : break;
13859 : }
13860 529 : do_code = do_code->next;
13861 529 : if (do_code == NULL
13862 522 : || (do_code->op != EXEC_DO && do_code->op != EXEC_DO_WHILE
13863 2 : && do_code->op != EXEC_DO_CONCURRENT))
13864 : {
13865 9 : gfc_error ("not enough DO loops for %s !$ACC LOOP at %L",
13866 : clause, &code->loc);
13867 9 : break;
13868 : }
13869 : }
13870 5272 : }
13871 :
13872 :
13873 : static void
13874 10119 : resolve_oacc_loop_blocks (gfc_code *code)
13875 : {
13876 10119 : if (!oacc_is_loop (code))
13877 : return;
13878 :
13879 5272 : if (code->ext.omp_clauses->tile_list && code->ext.omp_clauses->gang
13880 24 : && code->ext.omp_clauses->worker && code->ext.omp_clauses->vector)
13881 0 : gfc_error ("Tiled loop cannot be parallelized across gangs, workers and "
13882 : "vectors at the same time at %L", &code->loc);
13883 :
13884 5272 : if (code->ext.omp_clauses->tile_list)
13885 : {
13886 : gfc_expr_list *el;
13887 501 : for (el = code->ext.omp_clauses->tile_list; el; el = el->next)
13888 : {
13889 304 : if (el->expr == NULL)
13890 : {
13891 : /* NULL expressions are used to represent '*' arguments.
13892 : Convert those to a 0 expressions. */
13893 113 : el->expr = gfc_get_constant_expr (BT_INTEGER,
13894 : gfc_default_integer_kind,
13895 : &code->loc);
13896 113 : mpz_set_si (el->expr->value.integer, 0);
13897 : }
13898 : else
13899 : {
13900 191 : resolve_positive_int_expr (el->expr, "TILE");
13901 191 : if (el->expr->expr_type != EXPR_CONSTANT)
13902 14 : gfc_error ("TILE requires constant expression at %L",
13903 : &code->loc);
13904 : }
13905 : }
13906 : }
13907 : }
13908 :
13909 :
13910 : void
13911 10119 : gfc_resolve_oacc_blocks (gfc_code *code, gfc_namespace *ns)
13912 : {
13913 10119 : fortran_omp_context ctx;
13914 10119 : gfc_omp_clauses *omp_clauses = code->ext.omp_clauses;
13915 10119 : gfc_omp_namelist *n;
13916 :
13917 10119 : resolve_oacc_loop_blocks (code);
13918 :
13919 10119 : ctx.code = code;
13920 10119 : ctx.sharing_clauses = new hash_set<gfc_symbol *>;
13921 10119 : ctx.private_iterators = new hash_set<gfc_symbol *>;
13922 10119 : ctx.previous = omp_current_ctx;
13923 10119 : ctx.is_openmp = false;
13924 10119 : omp_current_ctx = &ctx;
13925 :
13926 404760 : for (enum gfc_omp_list_type list = OMP_LIST_FIRST; list < OMP_LIST_NUM;
13927 394641 : list = gfc_omp_list_type (list + 1))
13928 394641 : switch (list)
13929 : {
13930 10119 : case OMP_LIST_PRIVATE:
13931 10710 : for (n = omp_clauses->lists[list]; n; n = n->next)
13932 591 : ctx.sharing_clauses->add (n->sym);
13933 : break;
13934 : default:
13935 : break;
13936 : }
13937 :
13938 10119 : gfc_resolve_blocks (code->block, ns);
13939 :
13940 10119 : omp_current_ctx = ctx.previous;
13941 20238 : delete ctx.sharing_clauses;
13942 20238 : delete ctx.private_iterators;
13943 10119 : }
13944 :
13945 :
13946 : static void
13947 5272 : resolve_oacc_loop (gfc_code *code)
13948 : {
13949 5272 : gfc_code *do_code;
13950 5272 : int collapse;
13951 :
13952 5272 : if (code->ext.omp_clauses)
13953 5272 : resolve_omp_clauses (code, code->ext.omp_clauses, NULL, true);
13954 :
13955 5272 : do_code = code->block->next;
13956 5272 : collapse = code->ext.omp_clauses->collapse;
13957 :
13958 : /* Both collapsed and tiled loops are lowered the same way, but are not
13959 : compatible. In gfc_trans_omp_do, the tile is prioritized. */
13960 5272 : if (code->ext.omp_clauses->tile_list)
13961 : {
13962 : int num = 0;
13963 : gfc_expr_list *el;
13964 501 : for (el = code->ext.omp_clauses->tile_list; el; el = el->next)
13965 304 : ++num;
13966 197 : resolve_oacc_nested_loops (code, code->block->next, num, "tiled");
13967 197 : return;
13968 : }
13969 :
13970 5075 : if (collapse <= 0)
13971 : collapse = 1;
13972 5075 : resolve_oacc_nested_loops (code, do_code, collapse, "collapsed");
13973 : }
13974 :
13975 : void
13976 348691 : gfc_resolve_oacc_declare (gfc_namespace *ns)
13977 : {
13978 348691 : enum gfc_omp_list_type list;
13979 348691 : gfc_omp_namelist *n;
13980 348691 : gfc_oacc_declare *oc;
13981 :
13982 348691 : if (ns->oacc_declare == NULL)
13983 : return;
13984 :
13985 290 : for (oc = ns->oacc_declare; oc; oc = oc->next)
13986 : {
13987 6480 : for (list = OMP_LIST_FIRST; list < OMP_LIST_NUM;
13988 6318 : list = gfc_omp_list_type (list + 1))
13989 6574 : for (n = oc->clauses->lists[list]; n; n = n->next)
13990 : {
13991 256 : n->sym->mark = 0;
13992 256 : if (n->sym->attr.flavor != FL_VARIABLE
13993 16 : && (n->sym->attr.flavor != FL_PROCEDURE
13994 8 : || n->sym->result != n->sym))
13995 : {
13996 14 : if (n->sym->attr.flavor != FL_PARAMETER)
13997 : {
13998 8 : gfc_error ("Object %qs is not a variable at %L",
13999 : n->sym->name, &oc->loc);
14000 8 : continue;
14001 : }
14002 : /* Note that OpenACC 3.4 permits name constants, but the
14003 : implementation is permitted to ignore the clause;
14004 : as semantically, device_resident kind of makes sense
14005 : (and the wording with it is a bit odd), the warning
14006 : is suppressed. */
14007 6 : if (list != OMP_LIST_DEVICE_RESIDENT)
14008 5 : gfc_warning (OPT_Wsurprising, "Object %qs at %L is ignored as"
14009 : " parameters need not be copied", n->sym->name,
14010 : &oc->loc);
14011 : }
14012 :
14013 248 : if (n->expr && n->expr->ref->type == REF_ARRAY)
14014 : {
14015 1 : gfc_error ("Array sections: %qs not allowed in"
14016 1 : " !$ACC DECLARE at %L", n->sym->name, &oc->loc);
14017 1 : continue;
14018 : }
14019 : }
14020 :
14021 252 : for (n = oc->clauses->lists[OMP_LIST_DEVICE_RESIDENT]; n; n = n->next)
14022 90 : check_array_not_assumed (n->sym, oc->loc, "DEVICE_RESIDENT");
14023 : }
14024 :
14025 290 : for (oc = ns->oacc_declare; oc; oc = oc->next)
14026 : {
14027 6480 : for (list = OMP_LIST_FIRST; list < OMP_LIST_NUM;
14028 6318 : list = gfc_omp_list_type (list + 1))
14029 6574 : for (n = oc->clauses->lists[list]; n; n = n->next)
14030 : {
14031 256 : if (n->sym->mark)
14032 : {
14033 9 : gfc_error ("Symbol %qs present on multiple clauses at %L",
14034 : n->sym->name, &oc->loc);
14035 9 : continue;
14036 : }
14037 : else
14038 247 : n->sym->mark = 1;
14039 : }
14040 : }
14041 :
14042 290 : for (oc = ns->oacc_declare; oc; oc = oc->next)
14043 : {
14044 6480 : for (list = OMP_LIST_FIRST; list < OMP_LIST_NUM;
14045 6318 : list = gfc_omp_list_type (list + 1))
14046 6574 : for (n = oc->clauses->lists[list]; n; n = n->next)
14047 256 : n->sym->mark = 0;
14048 : }
14049 : }
14050 :
14051 :
14052 : void
14053 348691 : gfc_resolve_oacc_routines (gfc_namespace *ns)
14054 : {
14055 348691 : for (gfc_oacc_routine_name *orn = ns->oacc_routine_names;
14056 348791 : orn;
14057 100 : orn = orn->next)
14058 : {
14059 100 : gfc_symbol *sym = orn->sym;
14060 100 : if (!sym->attr.external
14061 29 : && !sym->attr.function
14062 27 : && !sym->attr.subroutine)
14063 : {
14064 7 : gfc_error ("NAME %qs does not refer to a subroutine or function"
14065 : " in !$ACC ROUTINE ( NAME ) at %L", sym->name, &orn->loc);
14066 7 : continue;
14067 : }
14068 93 : if (!gfc_add_omp_declare_target (&sym->attr, sym->name, &orn->loc))
14069 : {
14070 20 : gfc_error ("NAME %qs invalid"
14071 : " in !$ACC ROUTINE ( NAME ) at %L", sym->name, &orn->loc);
14072 20 : continue;
14073 : }
14074 : }
14075 348691 : }
14076 :
14077 :
14078 : void
14079 13538 : gfc_resolve_oacc_directive (gfc_code *code, gfc_namespace *ns ATTRIBUTE_UNUSED)
14080 : {
14081 13538 : resolve_oacc_directive_inside_omp_region (code);
14082 :
14083 13538 : switch (code->op)
14084 : {
14085 7723 : case EXEC_OACC_PARALLEL:
14086 7723 : case EXEC_OACC_KERNELS:
14087 7723 : case EXEC_OACC_SERIAL:
14088 7723 : case EXEC_OACC_DATA:
14089 7723 : case EXEC_OACC_HOST_DATA:
14090 7723 : case EXEC_OACC_UPDATE:
14091 7723 : case EXEC_OACC_ENTER_DATA:
14092 7723 : case EXEC_OACC_EXIT_DATA:
14093 7723 : case EXEC_OACC_WAIT:
14094 7723 : case EXEC_OACC_CACHE:
14095 7723 : case EXEC_OACC_INIT:
14096 7723 : case EXEC_OACC_SHUTDOWN:
14097 7723 : case EXEC_OACC_SET:
14098 7723 : resolve_omp_clauses (code, code->ext.omp_clauses, NULL, true);
14099 7723 : break;
14100 5272 : case EXEC_OACC_PARALLEL_LOOP:
14101 5272 : case EXEC_OACC_KERNELS_LOOP:
14102 5272 : case EXEC_OACC_SERIAL_LOOP:
14103 5272 : case EXEC_OACC_LOOP:
14104 5272 : resolve_oacc_loop (code);
14105 5272 : break;
14106 543 : case EXEC_OACC_ATOMIC:
14107 543 : resolve_omp_atomic (code);
14108 543 : break;
14109 : default:
14110 : break;
14111 : }
14112 13538 : }
14113 :
14114 :
14115 : static void
14116 2182 : resolve_omp_target (gfc_code *code)
14117 : {
14118 : #define GFC_IS_TEAMS_CONSTRUCT(op) \
14119 : (op == EXEC_OMP_TEAMS \
14120 : || op == EXEC_OMP_TEAMS_DISTRIBUTE \
14121 : || op == EXEC_OMP_TEAMS_DISTRIBUTE_SIMD \
14122 : || op == EXEC_OMP_TEAMS_DISTRIBUTE_PARALLEL_DO \
14123 : || op == EXEC_OMP_TEAMS_DISTRIBUTE_PARALLEL_DO_SIMD \
14124 : || op == EXEC_OMP_TEAMS_LOOP)
14125 :
14126 2182 : if (!code->ext.omp_clauses->contains_teams_construct)
14127 : return;
14128 203 : gfc_code *c = code->block->next;
14129 203 : if (c->op == EXEC_BLOCK)
14130 30 : c = c->ext.block.ns->code;
14131 203 : if (code->ext.omp_clauses->target_first_st_is_teams_or_meta)
14132 : {
14133 192 : if (c->op == EXEC_OMP_METADIRECTIVE)
14134 : {
14135 15 : struct gfc_omp_variant *mc
14136 : = c->ext.omp_variants;
14137 : /* All mc->(next...->)code should be identical with regards
14138 : to the diagnostic below. */
14139 16 : do
14140 : {
14141 16 : if (mc->stmt != ST_NONE
14142 15 : && GFC_IS_TEAMS_CONSTRUCT (mc->code->op))
14143 : {
14144 14 : if (c->next == NULL && mc->code->next == NULL)
14145 : return;
14146 : c = mc->code;
14147 : break;
14148 : }
14149 2 : mc = mc->next;
14150 : }
14151 2 : while (mc);
14152 : }
14153 177 : else if (GFC_IS_TEAMS_CONSTRUCT (c->op) && c->next == NULL)
14154 : return;
14155 : }
14156 :
14157 31 : while (c && !GFC_IS_TEAMS_CONSTRUCT (c->op))
14158 8 : c = c->next;
14159 23 : if (c)
14160 19 : gfc_error ("!$OMP TARGET region at %L with a nested TEAMS at %L may not "
14161 : "contain any other statement, declaration or directive outside "
14162 : "of the single TEAMS construct", &c->loc, &code->loc);
14163 : else
14164 4 : gfc_error ("!$OMP TARGET region at %L with a nested TEAMS may not "
14165 : "contain any other statement, declaration or directive outside "
14166 : "of the single TEAMS construct", &code->loc);
14167 : #undef GFC_IS_TEAMS_CONSTRUCT
14168 : }
14169 :
14170 : static void
14171 154 : resolve_omp_dispatch (gfc_code *code)
14172 : {
14173 154 : gfc_code *next = code->block->next;
14174 154 : if (next == NULL)
14175 : return;
14176 :
14177 151 : gfc_exec_op op = next->op;
14178 151 : gcc_assert (op == EXEC_CALL || op == EXEC_ASSIGN);
14179 151 : if (op != EXEC_CALL
14180 74 : && (op != EXEC_ASSIGN || next->expr2->expr_type != EXPR_FUNCTION))
14181 3 : gfc_error (
14182 : "%<OMP DISPATCH%> directive at %L must be followed by a procedure "
14183 : "call with optional assignment",
14184 : &code->loc);
14185 :
14186 77 : if ((op == EXEC_CALL && next->resolved_sym != NULL
14187 76 : && next->resolved_sym->attr.proc_pointer)
14188 150 : || (op == EXEC_ASSIGN && gfc_expr_attr (next->expr2).proc_pointer))
14189 1 : gfc_error ("%<OMP DISPATCH%> directive at %L cannot be followed by a "
14190 : "procedure pointer",
14191 : &code->loc);
14192 : }
14193 :
14194 : /* Resolve OpenMP directive clauses and check various requirements
14195 : of each directive. */
14196 :
14197 : void
14198 21246 : gfc_resolve_omp_directive (gfc_code *code, gfc_namespace *ns)
14199 : {
14200 21246 : resolve_omp_directive_inside_oacc_region (code);
14201 :
14202 21246 : if (code->op != EXEC_OMP_ATOMIC)
14203 19092 : gfc_maybe_initialize_eh ();
14204 :
14205 21246 : switch (code->op)
14206 : {
14207 5432 : case EXEC_OMP_DISTRIBUTE:
14208 5432 : case EXEC_OMP_DISTRIBUTE_PARALLEL_DO:
14209 5432 : case EXEC_OMP_DISTRIBUTE_PARALLEL_DO_SIMD:
14210 5432 : case EXEC_OMP_DISTRIBUTE_SIMD:
14211 5432 : case EXEC_OMP_DO:
14212 5432 : case EXEC_OMP_DO_SIMD:
14213 5432 : case EXEC_OMP_LOOP:
14214 5432 : case EXEC_OMP_PARALLEL_DO:
14215 5432 : case EXEC_OMP_PARALLEL_DO_SIMD:
14216 5432 : case EXEC_OMP_PARALLEL_LOOP:
14217 5432 : case EXEC_OMP_PARALLEL_MASKED_TASKLOOP:
14218 5432 : case EXEC_OMP_PARALLEL_MASKED_TASKLOOP_SIMD:
14219 5432 : case EXEC_OMP_PARALLEL_MASTER_TASKLOOP:
14220 5432 : case EXEC_OMP_PARALLEL_MASTER_TASKLOOP_SIMD:
14221 5432 : case EXEC_OMP_MASKED_TASKLOOP:
14222 5432 : case EXEC_OMP_MASKED_TASKLOOP_SIMD:
14223 5432 : case EXEC_OMP_MASTER_TASKLOOP:
14224 5432 : case EXEC_OMP_MASTER_TASKLOOP_SIMD:
14225 5432 : case EXEC_OMP_SIMD:
14226 5432 : case EXEC_OMP_TARGET_PARALLEL_DO:
14227 5432 : case EXEC_OMP_TARGET_PARALLEL_DO_SIMD:
14228 5432 : case EXEC_OMP_TARGET_PARALLEL_LOOP:
14229 5432 : case EXEC_OMP_TARGET_SIMD:
14230 5432 : case EXEC_OMP_TARGET_TEAMS_DISTRIBUTE:
14231 5432 : case EXEC_OMP_TARGET_TEAMS_DISTRIBUTE_PARALLEL_DO:
14232 5432 : case EXEC_OMP_TARGET_TEAMS_DISTRIBUTE_PARALLEL_DO_SIMD:
14233 5432 : case EXEC_OMP_TARGET_TEAMS_DISTRIBUTE_SIMD:
14234 5432 : case EXEC_OMP_TARGET_TEAMS_LOOP:
14235 5432 : case EXEC_OMP_TASKLOOP:
14236 5432 : case EXEC_OMP_TASKLOOP_SIMD:
14237 5432 : case EXEC_OMP_TEAMS_DISTRIBUTE:
14238 5432 : case EXEC_OMP_TEAMS_DISTRIBUTE_PARALLEL_DO:
14239 5432 : case EXEC_OMP_TEAMS_DISTRIBUTE_PARALLEL_DO_SIMD:
14240 5432 : case EXEC_OMP_TEAMS_DISTRIBUTE_SIMD:
14241 5432 : case EXEC_OMP_TEAMS_LOOP:
14242 5432 : case EXEC_OMP_TILE:
14243 5432 : case EXEC_OMP_UNROLL:
14244 5432 : resolve_omp_do (code);
14245 5432 : break;
14246 2182 : case EXEC_OMP_TARGET:
14247 2182 : resolve_omp_target (code);
14248 10273 : gcc_fallthrough ();
14249 10273 : case EXEC_OMP_ALLOCATE:
14250 10273 : case EXEC_OMP_ALLOCATORS:
14251 10273 : case EXEC_OMP_ASSUME:
14252 10273 : case EXEC_OMP_CANCEL:
14253 10273 : case EXEC_OMP_ERROR:
14254 10273 : case EXEC_OMP_INTEROP:
14255 10273 : case EXEC_OMP_MASKED:
14256 10273 : case EXEC_OMP_ORDERED:
14257 10273 : case EXEC_OMP_PARALLEL_WORKSHARE:
14258 10273 : case EXEC_OMP_PARALLEL:
14259 10273 : case EXEC_OMP_PARALLEL_MASKED:
14260 10273 : case EXEC_OMP_PARALLEL_MASTER:
14261 10273 : case EXEC_OMP_PARALLEL_SECTIONS:
14262 10273 : case EXEC_OMP_SCOPE:
14263 10273 : case EXEC_OMP_SECTIONS:
14264 10273 : case EXEC_OMP_SINGLE:
14265 10273 : case EXEC_OMP_TARGET_DATA:
14266 10273 : case EXEC_OMP_TARGET_ENTER_DATA:
14267 10273 : case EXEC_OMP_TARGET_EXIT_DATA:
14268 10273 : case EXEC_OMP_TARGET_PARALLEL:
14269 10273 : case EXEC_OMP_TARGET_TEAMS:
14270 10273 : case EXEC_OMP_TASK:
14271 10273 : case EXEC_OMP_TASKWAIT:
14272 10273 : case EXEC_OMP_TEAMS:
14273 10273 : case EXEC_OMP_WORKSHARE:
14274 10273 : case EXEC_OMP_DEPOBJ:
14275 10273 : if (code->ext.omp_clauses)
14276 10140 : resolve_omp_clauses (code, code->ext.omp_clauses, NULL);
14277 : break;
14278 1718 : case EXEC_OMP_TARGET_UPDATE:
14279 1718 : if (code->ext.omp_clauses)
14280 1718 : resolve_omp_clauses (code, code->ext.omp_clauses, NULL);
14281 1718 : if (code->ext.omp_clauses == NULL
14282 1718 : || (code->ext.omp_clauses->lists[OMP_LIST_TO] == NULL
14283 994 : && code->ext.omp_clauses->lists[OMP_LIST_FROM] == NULL))
14284 0 : gfc_error ("OMP TARGET UPDATE at %L requires at least one TO or "
14285 : "FROM clause", &code->loc);
14286 : break;
14287 2154 : case EXEC_OMP_ATOMIC:
14288 2154 : resolve_omp_clauses (code, code->block->ext.omp_clauses, NULL);
14289 2154 : resolve_omp_atomic (code);
14290 2154 : break;
14291 159 : case EXEC_OMP_CRITICAL:
14292 159 : resolve_omp_clauses (code, code->ext.omp_clauses, NULL);
14293 159 : if (!code->ext.omp_clauses->critical_name
14294 112 : && code->ext.omp_clauses->hint
14295 3 : && code->ext.omp_clauses->hint->ts.type == BT_INTEGER
14296 3 : && code->ext.omp_clauses->hint->expr_type == EXPR_CONSTANT
14297 3 : && mpz_sgn (code->ext.omp_clauses->hint->value.integer) != 0)
14298 1 : gfc_error ("OMP CRITICAL at %L with HINT clause requires a NAME, "
14299 : "except when omp_sync_hint_none is used", &code->loc);
14300 : break;
14301 49 : case EXEC_OMP_SCAN:
14302 : /* Flag is only used to checking, hence, it is unset afterwards. */
14303 49 : if (!code->ext.omp_clauses->if_present)
14304 10 : gfc_error ("Unexpected !$OMP SCAN at %L outside loop construct with "
14305 : "%<inscan%> REDUCTION clause", &code->loc);
14306 49 : code->ext.omp_clauses->if_present = false;
14307 49 : resolve_omp_clauses (code, code->ext.omp_clauses, ns);
14308 49 : break;
14309 154 : case EXEC_OMP_DISPATCH:
14310 154 : if (code->ext.omp_clauses)
14311 154 : resolve_omp_clauses (code, code->ext.omp_clauses, ns);
14312 154 : resolve_omp_dispatch (code);
14313 154 : break;
14314 138 : case EXEC_OMP_METADIRECTIVE:
14315 138 : resolve_omp_metadirective (code, ns);
14316 138 : break;
14317 : default:
14318 : break;
14319 : }
14320 21246 : }
14321 :
14322 : /* Resolve !$omp declare {variant|simd} constructs in NS.
14323 : Note that !$omp declare target is resolved in resolve_symbol. */
14324 :
14325 : void
14326 360463 : gfc_resolve_omp_declare (gfc_namespace *ns)
14327 : {
14328 360463 : gfc_omp_declare_simd *ods;
14329 360699 : for (ods = ns->omp_declare_simd; ods; ods = ods->next)
14330 : {
14331 236 : if (ods->proc_name != NULL
14332 196 : && ods->proc_name != ns->proc_name)
14333 6 : gfc_error ("!$OMP DECLARE SIMD should refer to containing procedure "
14334 : "%qs at %L", ns->proc_name->name, &ods->where);
14335 236 : if (ods->clauses)
14336 218 : resolve_omp_clauses (NULL, ods->clauses, ns);
14337 : }
14338 :
14339 360463 : gfc_omp_declare_variant *odv;
14340 360463 : gfc_omp_namelist *range_begin = NULL;
14341 :
14342 360917 : for (odv = ns->omp_declare_variant; odv; odv = odv->next)
14343 454 : gfc_resolve_omp_context_selector (odv->set_selectors, false, nullptr);
14344 360917 : for (odv = ns->omp_declare_variant; odv; odv = odv->next)
14345 657 : for (gfc_omp_namelist *n = odv->adjust_args_list; n != NULL; n = n->next)
14346 : {
14347 203 : if ((n->expr == NULL
14348 6 : && (range_begin
14349 4 : || n->u.adj_args.range_start
14350 1 : || n->u.adj_args.omp_num_args_plus
14351 1 : || n->u.adj_args.omp_num_args_minus))
14352 198 : || n->u.adj_args.error_p)
14353 : {
14354 : }
14355 197 : else if (range_begin
14356 191 : || n->u.adj_args.range_start
14357 186 : || n->u.adj_args.omp_num_args_plus
14358 186 : || n->u.adj_args.omp_num_args_minus)
14359 : {
14360 11 : if (!n->expr
14361 11 : || !gfc_resolve_expr (n->expr)
14362 11 : || n->expr->expr_type != EXPR_CONSTANT
14363 10 : || n->expr->ts.type != BT_INTEGER
14364 10 : || n->expr->rank != 0
14365 10 : || mpz_sgn (n->expr->value.integer) < 0
14366 20 : || ((n->u.adj_args.omp_num_args_plus
14367 8 : || n->u.adj_args.omp_num_args_minus)
14368 5 : && mpz_sgn (n->expr->value.integer) == 0))
14369 : {
14370 2 : if (n->u.adj_args.omp_num_args_plus
14371 2 : || n->u.adj_args.omp_num_args_minus)
14372 0 : gfc_error ("Expected constant non-negative scalar integer "
14373 : "offset expression at %L", &n->where);
14374 : else
14375 2 : gfc_error ("For range-based %<adjust_args%>, a constant "
14376 : "positive scalar integer expression is required "
14377 : "at %L", &n->where);
14378 : }
14379 : }
14380 186 : else if (n->expr
14381 186 : && n->expr->expr_type == EXPR_CONSTANT
14382 21 : && n->expr->ts.type == BT_INTEGER
14383 20 : && mpz_sgn (n->expr->value.integer) > 0)
14384 : {
14385 : }
14386 166 : else if (!n->expr
14387 166 : || !gfc_resolve_expr (n->expr)
14388 331 : || n->expr->expr_type != EXPR_VARIABLE)
14389 2 : gfc_error ("Expected dummy parameter name or a positive integer "
14390 : "at %L", &n->where);
14391 164 : else if (n->expr->expr_type == EXPR_VARIABLE)
14392 164 : n->sym = n->expr->symtree->n.sym;
14393 :
14394 203 : range_begin = n->u.adj_args.range_start ? n : NULL;
14395 : }
14396 360463 : }
14397 :
14398 : struct omp_udr_callback_data
14399 : {
14400 : gfc_omp_udr *omp_udr;
14401 : bool is_initializer;
14402 : };
14403 :
14404 : static int
14405 3706 : omp_udr_callback (gfc_expr **e, int *walk_subtrees ATTRIBUTE_UNUSED,
14406 : void *data)
14407 : {
14408 3706 : struct omp_udr_callback_data *cd = (struct omp_udr_callback_data *) data;
14409 3706 : if ((*e)->expr_type == EXPR_VARIABLE)
14410 : {
14411 2276 : if (cd->is_initializer)
14412 : {
14413 539 : if ((*e)->symtree->n.sym != cd->omp_udr->omp_priv
14414 140 : && (*e)->symtree->n.sym != cd->omp_udr->omp_orig)
14415 4 : gfc_error ("Variable other than OMP_PRIV or OMP_ORIG used in "
14416 : "INITIALIZER clause of !$OMP DECLARE REDUCTION at %L",
14417 : &(*e)->where);
14418 : }
14419 : else
14420 : {
14421 1737 : if ((*e)->symtree->n.sym != cd->omp_udr->omp_out
14422 619 : && (*e)->symtree->n.sym != cd->omp_udr->omp_in)
14423 6 : gfc_error ("Variable other than OMP_OUT or OMP_IN used in "
14424 : "combiner of !$OMP DECLARE REDUCTION at %L",
14425 : &(*e)->where);
14426 : }
14427 : }
14428 3706 : return 0;
14429 : }
14430 :
14431 : /* Resolve !$omp declare reduction constructs. */
14432 :
14433 : static void
14434 626 : gfc_resolve_omp_udr (gfc_omp_udr *omp_udr)
14435 : {
14436 626 : gfc_actual_arglist *a;
14437 626 : const char *predef_name = NULL;
14438 :
14439 626 : switch (omp_udr->rop)
14440 : {
14441 625 : case OMP_REDUCTION_PLUS:
14442 625 : case OMP_REDUCTION_TIMES:
14443 625 : case OMP_REDUCTION_MINUS:
14444 625 : case OMP_REDUCTION_AND:
14445 625 : case OMP_REDUCTION_OR:
14446 625 : case OMP_REDUCTION_EQV:
14447 625 : case OMP_REDUCTION_NEQV:
14448 625 : case OMP_REDUCTION_MAX:
14449 625 : case OMP_REDUCTION_USER:
14450 625 : break;
14451 1 : default:
14452 1 : gfc_error ("Invalid operator for !$OMP DECLARE REDUCTION %s at %L",
14453 : omp_udr->name, &omp_udr->where);
14454 26 : return;
14455 : }
14456 :
14457 625 : if (gfc_omp_udr_predef (omp_udr->rop, omp_udr->name,
14458 : &omp_udr->ts, &predef_name))
14459 : {
14460 19 : if (predef_name)
14461 19 : gfc_error ("Redefinition of predefined %qs in "
14462 : "!$OMP DECLARE REDUCTION at %L",
14463 : predef_name, &omp_udr->where);
14464 : else
14465 0 : gfc_error ("Redefinition of predefined %qs in "
14466 : "!$OMP DECLARE REDUCTION at %L", omp_udr->name,
14467 : &omp_udr->where);
14468 19 : return;
14469 : }
14470 :
14471 606 : if (omp_udr->ts.type == BT_CHARACTER
14472 62 : && omp_udr->ts.u.cl->length
14473 32 : && omp_udr->ts.u.cl->length->expr_type != EXPR_CONSTANT)
14474 : {
14475 1 : gfc_error ("CHARACTER length in !$OMP DECLARE REDUCTION %qs not "
14476 : "constant at %L", omp_udr->name, &omp_udr->where);
14477 1 : return;
14478 : }
14479 :
14480 605 : struct omp_udr_callback_data cd;
14481 605 : cd.omp_udr = omp_udr;
14482 605 : cd.is_initializer = false;
14483 605 : gfc_code_walker (&omp_udr->combiner_ns->code, gfc_dummy_code_callback,
14484 : omp_udr_callback, &cd);
14485 605 : if (omp_udr->combiner_ns->code->op == EXEC_CALL)
14486 : {
14487 346 : for (a = omp_udr->combiner_ns->code->ext.actual; a; a = a->next)
14488 237 : if (a->expr == NULL)
14489 : break;
14490 110 : if (a)
14491 1 : gfc_error ("Subroutine call with alternate returns in combiner "
14492 : "of !$OMP DECLARE REDUCTION at %L",
14493 : &omp_udr->combiner_ns->code->loc);
14494 : }
14495 605 : if (omp_udr->initializer_ns)
14496 : {
14497 377 : cd.is_initializer = true;
14498 377 : gfc_code_walker (&omp_udr->initializer_ns->code, gfc_dummy_code_callback,
14499 : omp_udr_callback, &cd);
14500 377 : if (omp_udr->initializer_ns->code->op == EXEC_CALL)
14501 : {
14502 377 : for (a = omp_udr->initializer_ns->code->ext.actual; a; a = a->next)
14503 243 : if (a->expr == NULL)
14504 : break;
14505 135 : if (a)
14506 1 : gfc_error ("Subroutine call with alternate returns in "
14507 : "INITIALIZER clause of !$OMP DECLARE REDUCTION "
14508 : "at %L", &omp_udr->initializer_ns->code->loc);
14509 136 : for (a = omp_udr->initializer_ns->code->ext.actual; a; a = a->next)
14510 135 : if (a->expr
14511 135 : && a->expr->expr_type == EXPR_VARIABLE
14512 135 : && a->expr->symtree->n.sym == omp_udr->omp_priv
14513 134 : && a->expr->ref == NULL)
14514 : break;
14515 135 : if (a == NULL)
14516 1 : gfc_error ("One of actual subroutine arguments in INITIALIZER "
14517 : "clause of !$OMP DECLARE REDUCTION must be OMP_PRIV "
14518 : "at %L", &omp_udr->initializer_ns->code->loc);
14519 : }
14520 : }
14521 228 : else if (omp_udr->ts.type == BT_DERIVED
14522 228 : && !gfc_has_default_initializer (omp_udr->ts.u.derived))
14523 : {
14524 4 : gfc_error ("Missing INITIALIZER clause for !$OMP DECLARE REDUCTION "
14525 : "of derived type without default initializer at %L",
14526 : &omp_udr->where);
14527 4 : return;
14528 : }
14529 : }
14530 :
14531 : void
14532 361517 : gfc_resolve_omp_udrs (gfc_symtree *st)
14533 : {
14534 361517 : gfc_omp_udr *omp_udr;
14535 :
14536 361517 : if (st == NULL)
14537 : return;
14538 527 : gfc_resolve_omp_udrs (st->left);
14539 527 : gfc_resolve_omp_udrs (st->right);
14540 1153 : for (omp_udr = st->n.omp_udr; omp_udr; omp_udr = omp_udr->next)
14541 626 : gfc_resolve_omp_udr (omp_udr);
14542 : }
14543 :
14544 : /* Resolve !$omp declare mapper constructs. */
14545 :
14546 : static void
14547 23 : gfc_resolve_omp_udm (gfc_omp_udm *omp_udm)
14548 : {
14549 23 : resolve_omp_clauses (NULL, omp_udm->clauses, omp_udm->mapper_ns);
14550 :
14551 23 : gfc_omp_namelist *n;
14552 25 : for (n = omp_udm->clauses->lists[OMP_LIST_MAP]; n; n = n->next)
14553 23 : if (n->sym == omp_udm->var_sym)
14554 : break;
14555 23 : if (!n)
14556 2 : gfc_error ("At least one %<map%> clause in !$OMP DECLARE MAPPER at %L must "
14557 : "map %qs or an element of it",
14558 2 : &omp_udm->where, omp_udm->var_sym->name);
14559 23 : }
14560 :
14561 : void
14562 360507 : gfc_resolve_omp_udms (gfc_symtree *st)
14563 : {
14564 360507 : gfc_omp_udm *omp_udm;
14565 :
14566 360507 : if (st == NULL)
14567 : return;
14568 22 : gfc_resolve_omp_udms (st->left);
14569 22 : gfc_resolve_omp_udms (st->right);
14570 45 : for (omp_udm = st->n.omp_udm; omp_udm; omp_udm = omp_udm->next)
14571 23 : gfc_resolve_omp_udm (omp_udm);
14572 : }
|
