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 : {"cancellation_point", GFC_OMP_DIR_EXECUTABLE, ST_OMP_CANCELLATION_POINT},
71 : {"cancel", GFC_OMP_DIR_EXECUTABLE, ST_OMP_CANCEL},
72 : {"critical", GFC_OMP_DIR_EXECUTABLE, ST_OMP_CRITICAL},
73 : /* {"declare induction", GFC_OMP_DIR_DECLARATIVE, ST_OMP_DECLARE_INDUCTION}, */
74 : /* {"declare_induction", GFC_OMP_DIR_DECLARATIVE, ST_OMP_DECLARE_INDUCTION}, */
75 : {"declare mapper", GFC_OMP_DIR_DECLARATIVE, ST_OMP_DECLARE_MAPPER},
76 : {"declare_mapper", GFC_OMP_DIR_DECLARATIVE, ST_OMP_DECLARE_MAPPER},
77 : {"declare reduction", GFC_OMP_DIR_DECLARATIVE, ST_OMP_DECLARE_REDUCTION},
78 : {"declare_reduction", GFC_OMP_DIR_DECLARATIVE, ST_OMP_DECLARE_REDUCTION},
79 : {"declare simd", GFC_OMP_DIR_DECLARATIVE, ST_OMP_DECLARE_SIMD},
80 : {"declare_simd", GFC_OMP_DIR_DECLARATIVE, ST_OMP_DECLARE_SIMD},
81 : {"declare target", GFC_OMP_DIR_DECLARATIVE, ST_OMP_DECLARE_TARGET},
82 : {"declare_target", GFC_OMP_DIR_DECLARATIVE, ST_OMP_DECLARE_TARGET},
83 : {"declare variant", GFC_OMP_DIR_DECLARATIVE, ST_OMP_DECLARE_VARIANT},
84 : {"declare_variant", GFC_OMP_DIR_DECLARATIVE, ST_OMP_DECLARE_VARIANT},
85 : {"depobj", GFC_OMP_DIR_EXECUTABLE, ST_OMP_DEPOBJ},
86 : {"dispatch", GFC_OMP_DIR_EXECUTABLE, ST_OMP_DISPATCH},
87 : {"distribute", GFC_OMP_DIR_EXECUTABLE, ST_OMP_DISTRIBUTE},
88 : {"do", GFC_OMP_DIR_EXECUTABLE, ST_OMP_DO},
89 : /* "error" becomes GFC_OMP_DIR_EXECUTABLE with at(execution) */
90 : {"error", GFC_OMP_DIR_UTILITY, ST_OMP_ERROR},
91 : /* {"flatten", GFC_OMP_DIR_EXECUTABLE, ST_OMP_FLATTEN}, */
92 : {"flush", GFC_OMP_DIR_EXECUTABLE, ST_OMP_FLUSH},
93 : /* {"fuse", GFC_OMP_DIR_EXECUTABLE, ST_OMP_FLUSE}, */
94 : {"groupprivate", GFC_OMP_DIR_DECLARATIVE, ST_OMP_GROUPPRIVATE},
95 : /* {"interchange", GFC_OMP_DIR_EXECUTABLE, ST_OMP_INTERCHANGE}, */
96 : {"interop", GFC_OMP_DIR_EXECUTABLE, ST_OMP_INTEROP},
97 : {"loop", GFC_OMP_DIR_EXECUTABLE, ST_OMP_LOOP},
98 : {"masked", GFC_OMP_DIR_EXECUTABLE, ST_OMP_MASKED},
99 : {"metadirective", GFC_OMP_DIR_META, ST_OMP_METADIRECTIVE},
100 : /* Note: gfc_match_omp_nothing returns ST_NONE. */
101 : {"nothing", GFC_OMP_DIR_UTILITY, ST_OMP_NOTHING},
102 : /* Special case; for now map to the first one.
103 : ordered-blockassoc = ST_OMP_ORDERED
104 : ordered-standalone = ST_OMP_ORDERED_DEPEND + depend/doacross. */
105 : {"ordered", GFC_OMP_DIR_EXECUTABLE, ST_OMP_ORDERED},
106 : {"parallel", GFC_OMP_DIR_EXECUTABLE, ST_OMP_PARALLEL},
107 : {"requires", GFC_OMP_DIR_INFORMATIONAL, ST_OMP_REQUIRES},
108 : {"scan", GFC_OMP_DIR_SUBSIDIARY, ST_OMP_SCAN},
109 : {"scope", GFC_OMP_DIR_EXECUTABLE, ST_OMP_SCOPE},
110 : {"sections", GFC_OMP_DIR_EXECUTABLE, ST_OMP_SECTIONS},
111 : {"section", GFC_OMP_DIR_SUBSIDIARY, ST_OMP_SECTION},
112 : {"simd", GFC_OMP_DIR_EXECUTABLE, ST_OMP_SIMD},
113 : {"single", GFC_OMP_DIR_EXECUTABLE, ST_OMP_SINGLE},
114 : /* {"split", GFC_OMP_DIR_EXECUTABLE, ST_OMP_SPLIT}, */
115 : /* {"strip", GFC_OMP_DIR_EXECUTABLE, ST_OMP_STRIP}, */
116 : {"target data", GFC_OMP_DIR_EXECUTABLE, ST_OMP_TARGET_DATA},
117 : {"target_data", GFC_OMP_DIR_EXECUTABLE, ST_OMP_TARGET_DATA},
118 : {"target enter data", GFC_OMP_DIR_EXECUTABLE, ST_OMP_TARGET_ENTER_DATA},
119 : {"target_enter_data", GFC_OMP_DIR_EXECUTABLE, ST_OMP_TARGET_ENTER_DATA},
120 : {"target exit data", GFC_OMP_DIR_EXECUTABLE, ST_OMP_TARGET_EXIT_DATA},
121 : {"target_exit_data", GFC_OMP_DIR_EXECUTABLE, ST_OMP_TARGET_EXIT_DATA},
122 : {"target update", GFC_OMP_DIR_EXECUTABLE, ST_OMP_TARGET_UPDATE},
123 : {"target_update", GFC_OMP_DIR_EXECUTABLE, ST_OMP_TARGET_UPDATE},
124 : {"target", GFC_OMP_DIR_EXECUTABLE, ST_OMP_TARGET},
125 : /* {"taskgraph", GFC_OMP_DIR_EXECUTABLE, ST_OMP_TASKGRAPH}, */
126 : /* {"task iteration", GFC_OMP_DIR_EXECUTABLE, ST_OMP_TASK_ITERATION}, */
127 : {"taskloop", GFC_OMP_DIR_EXECUTABLE, ST_OMP_TASKLOOP},
128 : {"taskwait", GFC_OMP_DIR_EXECUTABLE, ST_OMP_TASKWAIT},
129 : {"taskyield", GFC_OMP_DIR_EXECUTABLE, ST_OMP_TASKYIELD},
130 : {"task", GFC_OMP_DIR_EXECUTABLE, ST_OMP_TASK},
131 : {"teams", GFC_OMP_DIR_EXECUTABLE, ST_OMP_TEAMS},
132 : {"threadprivate", GFC_OMP_DIR_DECLARATIVE, ST_OMP_THREADPRIVATE},
133 : {"tile", GFC_OMP_DIR_EXECUTABLE, ST_OMP_TILE},
134 : {"unroll", GFC_OMP_DIR_EXECUTABLE, ST_OMP_UNROLL},
135 : /* {"workdistribute", GFC_OMP_DIR_EXECUTABLE, ST_OMP_WORKDISTRIBUTE}, */
136 : {"workshare", GFC_OMP_DIR_EXECUTABLE, ST_OMP_WORKSHARE},
137 : };
138 :
139 :
140 : /* Match an end of OpenMP directive. End of OpenMP directive is optional
141 : whitespace, followed by '\n' or comment '!'. In the special case where a
142 : context selector is being matched, match against ')' instead. */
143 :
144 : static match
145 56281 : gfc_match_omp_eos (void)
146 : {
147 56281 : locus old_loc;
148 56281 : char c;
149 :
150 56281 : old_loc = gfc_current_locus;
151 56281 : gfc_gobble_whitespace ();
152 :
153 56281 : if (gfc_matching_omp_context_selector)
154 : {
155 276 : if (gfc_peek_ascii_char () == ')')
156 : return MATCH_YES;
157 : }
158 : else
159 : {
160 56005 : c = gfc_next_ascii_char ();
161 56005 : switch (c)
162 : {
163 0 : case '!':
164 0 : do
165 0 : c = gfc_next_ascii_char ();
166 0 : while (c != '\n');
167 : /* Fall through */
168 :
169 : case '\n':
170 : return MATCH_YES;
171 : }
172 : }
173 :
174 1791 : gfc_current_locus = old_loc;
175 1791 : return MATCH_NO;
176 : }
177 :
178 : match
179 13225 : gfc_match_omp_eos_error (void)
180 : {
181 13225 : if (gfc_match_omp_eos() == MATCH_YES)
182 : return MATCH_YES;
183 :
184 35 : gfc_error ("Unexpected junk at %C");
185 35 : return MATCH_ERROR;
186 : }
187 :
188 :
189 : /* Free an omp_clauses structure. */
190 :
191 : void
192 83730 : gfc_free_omp_clauses (gfc_omp_clauses *c)
193 : {
194 83730 : if (c == NULL)
195 : return;
196 :
197 56698 : gfc_free_expr (c->if_expr);
198 680376 : for (int i = 0; i < OMP_IF_LAST; i++)
199 566980 : gfc_free_expr (c->if_exprs[i]);
200 56698 : gfc_free_expr (c->self_expr);
201 56698 : gfc_free_expr (c->final_expr);
202 56698 : gfc_free_expr (c->chunk_size);
203 56698 : gfc_free_expr (c->safelen_expr);
204 56698 : gfc_free_expr (c->simdlen_expr);
205 56698 : gfc_free_expr (c->device);
206 56698 : gfc_free_expr (c->dyn_groupprivate);
207 56698 : gfc_free_expr (c->dist_chunk_size);
208 56698 : gfc_free_expr (c->grainsize);
209 56698 : gfc_free_expr (c->hint);
210 56698 : gfc_free_expr (c->num_tasks);
211 56698 : gfc_free_expr (c->priority);
212 56698 : gfc_free_expr (c->detach);
213 56698 : gfc_free_expr (c->novariants);
214 56698 : gfc_free_expr (c->nocontext);
215 56698 : gfc_free_expr (c->async_expr);
216 56698 : gfc_free_expr (c->gang_num_expr);
217 56698 : gfc_free_expr (c->gang_static_expr);
218 56698 : gfc_free_expr (c->worker_expr);
219 56698 : gfc_free_expr (c->vector_expr);
220 56698 : gfc_free_expr (c->num_gangs_expr);
221 56698 : gfc_free_expr (c->num_workers_expr);
222 56698 : gfc_free_expr (c->vector_length_expr);
223 56698 : gfc_free_expr (c->device_num_expr);
224 2324618 : for (enum gfc_omp_list_type t = OMP_LIST_FIRST; t < OMP_LIST_NUM;
225 2211222 : t = gfc_omp_list_type (t + 1))
226 2211222 : gfc_free_omp_namelist (c->lists[t], t);
227 56698 : gfc_free_expr_list (c->num_teams_list);
228 56698 : gfc_free_expr_list (c->thread_limit_list);
229 56698 : gfc_free_expr_list (c->num_threads_list);
230 56698 : gfc_free_expr_list (c->wait_list);
231 56698 : gfc_free_expr_list (c->tile_list);
232 56698 : gfc_free_expr_list (c->sizes_list);
233 56698 : free (const_cast<char *> (c->critical_name));
234 56698 : if (c->assume)
235 : {
236 33 : free (c->assume->absent);
237 33 : free (c->assume->contains);
238 33 : gfc_free_expr_list (c->assume->holds);
239 33 : free (c->assume);
240 : }
241 56698 : free (c);
242 : }
243 :
244 : /* Free oacc_declare structures. */
245 :
246 : void
247 76 : gfc_free_oacc_declare_clauses (struct gfc_oacc_declare *oc)
248 : {
249 76 : struct gfc_oacc_declare *decl = oc;
250 :
251 76 : do
252 : {
253 76 : struct gfc_oacc_declare *next;
254 :
255 76 : next = decl->next;
256 76 : gfc_free_omp_clauses (decl->clauses);
257 76 : free (decl);
258 76 : decl = next;
259 : }
260 76 : while (decl);
261 76 : }
262 :
263 : /* Free expression list. */
264 : void
265 341435 : gfc_free_expr_list (gfc_expr_list *list)
266 : {
267 341435 : gfc_expr_list *n;
268 :
269 344226 : for (; list; list = n)
270 : {
271 2791 : n = list->next;
272 2791 : free (list);
273 : }
274 341435 : }
275 :
276 : /* Free an !$omp declare simd construct list. */
277 :
278 : void
279 247 : gfc_free_omp_declare_simd (gfc_omp_declare_simd *ods)
280 : {
281 247 : if (ods)
282 : {
283 247 : gfc_free_omp_clauses (ods->clauses);
284 247 : free (ods);
285 : }
286 247 : }
287 :
288 : void
289 548089 : gfc_free_omp_declare_simd_list (gfc_omp_declare_simd *list)
290 : {
291 548336 : while (list)
292 : {
293 247 : gfc_omp_declare_simd *current = list;
294 247 : list = list->next;
295 247 : gfc_free_omp_declare_simd (current);
296 : }
297 548089 : }
298 :
299 : static void
300 738 : gfc_free_omp_trait_property_list (gfc_omp_trait_property *list)
301 : {
302 1150 : while (list)
303 : {
304 412 : gfc_omp_trait_property *current = list;
305 412 : list = list->next;
306 412 : switch (current->property_kind)
307 : {
308 24 : case OMP_TRAIT_PROPERTY_ID:
309 24 : free (current->name);
310 24 : break;
311 261 : case OMP_TRAIT_PROPERTY_NAME_LIST:
312 261 : if (current->is_name)
313 168 : free (current->name);
314 : break;
315 15 : case OMP_TRAIT_PROPERTY_CLAUSE_LIST:
316 15 : gfc_free_omp_clauses (current->clauses);
317 15 : break;
318 : default:
319 : break;
320 : }
321 412 : free (current);
322 : }
323 738 : }
324 :
325 : static void
326 609 : gfc_free_omp_selector_list (gfc_omp_selector *list)
327 : {
328 1347 : while (list)
329 : {
330 738 : gfc_omp_selector *current = list;
331 738 : list = list->next;
332 738 : gfc_free_omp_trait_property_list (current->properties);
333 738 : free (current);
334 : }
335 609 : }
336 :
337 : static void
338 681 : gfc_free_omp_set_selector_list (gfc_omp_set_selector *list)
339 : {
340 1290 : while (list)
341 : {
342 609 : gfc_omp_set_selector *current = list;
343 609 : list = list->next;
344 609 : gfc_free_omp_selector_list (current->trait_selectors);
345 609 : free (current);
346 : }
347 681 : }
348 :
349 : /* Free an !$omp declare variant construct list. */
350 :
351 : void
352 548089 : gfc_free_omp_declare_variant_list (gfc_omp_declare_variant *list)
353 : {
354 548550 : while (list)
355 : {
356 461 : gfc_omp_declare_variant *current = list;
357 461 : list = list->next;
358 461 : gfc_free_omp_set_selector_list (current->set_selectors);
359 461 : gfc_free_omp_namelist (current->adjust_args_list, OMP_LIST_NONE);
360 461 : free (current);
361 : }
362 548089 : }
363 :
364 : /* Free an !$omp declare reduction. */
365 :
366 : void
367 1285 : gfc_free_omp_udr (gfc_omp_udr *omp_udr)
368 : {
369 1285 : if (omp_udr)
370 : {
371 692 : gfc_free_omp_udr (omp_udr->next);
372 692 : gfc_free_namespace (omp_udr->combiner_ns);
373 692 : if (omp_udr->initializer_ns)
374 392 : gfc_free_namespace (omp_udr->initializer_ns);
375 692 : free (omp_udr);
376 : }
377 1285 : }
378 :
379 : /* Free variants of an !$omp metadirective construct. */
380 :
381 : void
382 96 : gfc_free_omp_variants (gfc_omp_variant *variant)
383 : {
384 293 : while (variant)
385 : {
386 197 : gfc_omp_variant *next_variant = variant->next;
387 197 : gfc_free_omp_set_selector_list (variant->selectors);
388 197 : free (variant);
389 197 : variant = next_variant;
390 : }
391 96 : }
392 :
393 : /* Free an !$omp declare mapper. */
394 :
395 : void
396 60 : gfc_free_omp_udm (gfc_omp_udm *omp_udm)
397 : {
398 60 : if (omp_udm)
399 : {
400 30 : gfc_free_omp_udm (omp_udm->next);
401 30 : gfc_free_namespace (omp_udm->mapper_ns);
402 30 : free (omp_udm);
403 : }
404 60 : }
405 :
406 : static gfc_omp_udr *
407 4718 : gfc_find_omp_udr (gfc_namespace *ns, const char *name, gfc_typespec *ts)
408 : {
409 4718 : gfc_symtree *st;
410 :
411 4718 : if (ns == NULL)
412 471 : ns = gfc_current_ns;
413 5668 : do
414 : {
415 5668 : gfc_omp_udr *omp_udr;
416 :
417 5668 : st = gfc_find_symtree (ns->omp_udr_root, name);
418 5668 : if (st != NULL)
419 : {
420 943 : for (omp_udr = st->n.omp_udr; omp_udr; omp_udr = omp_udr->next)
421 943 : if (ts == NULL)
422 : return omp_udr;
423 572 : else if (gfc_compare_types (&omp_udr->ts, ts))
424 : {
425 483 : if (ts->type == BT_CHARACTER)
426 : {
427 60 : if (omp_udr->ts.u.cl->length == NULL)
428 : return omp_udr;
429 36 : if (ts->u.cl->length == NULL)
430 0 : continue;
431 36 : if (gfc_compare_expr (omp_udr->ts.u.cl->length,
432 : ts->u.cl->length,
433 : INTRINSIC_EQ) != 0)
434 12 : continue;
435 : }
436 : return omp_udr;
437 : }
438 : }
439 :
440 : /* Don't escape an interface block. */
441 4826 : if (ns && !ns->has_import_set
442 4826 : && ns->proc_name && ns->proc_name->attr.if_source == IFSRC_IFBODY)
443 : break;
444 :
445 4826 : ns = ns->parent;
446 : }
447 4826 : while (ns != NULL);
448 :
449 : return NULL;
450 : }
451 :
452 :
453 : /* Match a variable/common block list and construct a namelist from it;
454 : if has_all_memory != NULL, *has_all_memory is set and omp_all_memory
455 : yields a list->sym NULL entry. */
456 :
457 : static match
458 31851 : gfc_match_omp_variable_list (const char *str, gfc_omp_namelist **list,
459 : bool allow_common, bool *end_colon = NULL,
460 : gfc_omp_namelist ***headp = NULL,
461 : bool allow_sections = false,
462 : bool allow_derived = false,
463 : bool *has_all_memory = NULL,
464 : bool reject_common_vars = false,
465 : bool reverse_order = false)
466 : {
467 31851 : gfc_omp_namelist *head, *tail, *p;
468 31851 : locus old_loc, cur_loc;
469 31851 : char n[GFC_MAX_SYMBOL_LEN+1];
470 31851 : gfc_symbol *sym;
471 31851 : match m;
472 31851 : gfc_symtree *st;
473 :
474 31851 : head = tail = NULL;
475 :
476 31851 : old_loc = gfc_current_locus;
477 31851 : if (has_all_memory)
478 709 : *has_all_memory = false;
479 31851 : m = gfc_match (str);
480 31851 : if (m != MATCH_YES)
481 : return m;
482 :
483 38531 : for (;;)
484 : {
485 38531 : gfc_gobble_whitespace ();
486 38531 : cur_loc = gfc_current_locus;
487 :
488 38531 : m = gfc_match_name (n);
489 38531 : if (m == MATCH_YES && strcmp (n, "omp_all_memory") == 0)
490 : {
491 23 : locus loc = gfc_get_location_range (NULL, 0, &cur_loc, 1,
492 : &gfc_current_locus);
493 23 : if (!has_all_memory)
494 : {
495 2 : gfc_error ("%<omp_all_memory%> at %L not permitted in this "
496 : "clause", &loc);
497 2 : goto cleanup;
498 : }
499 21 : *has_all_memory = true;
500 21 : p = gfc_get_omp_namelist ();
501 21 : if (head == NULL)
502 : head = tail = p;
503 : else
504 : {
505 3 : tail->next = p;
506 3 : tail = tail->next;
507 : }
508 21 : tail->where = loc;
509 21 : goto next_item;
510 : }
511 38252 : if (m == MATCH_YES)
512 : {
513 38252 : gfc_symtree *st;
514 38252 : if ((m = gfc_get_ha_sym_tree (n, &st) ? MATCH_ERROR : MATCH_YES)
515 : == MATCH_YES)
516 38252 : sym = st->n.sym;
517 : }
518 38508 : switch (m)
519 : {
520 38252 : case MATCH_YES:
521 38252 : gfc_expr *expr;
522 38252 : expr = NULL;
523 38252 : gfc_gobble_whitespace ();
524 23548 : if ((allow_sections && gfc_peek_ascii_char () == '(')
525 57438 : || (allow_derived && gfc_peek_ascii_char () == '%'))
526 : {
527 6609 : gfc_current_locus = cur_loc;
528 6609 : m = gfc_match_variable (&expr, 0);
529 6609 : switch (m)
530 : {
531 4 : case MATCH_ERROR:
532 12 : goto cleanup;
533 0 : case MATCH_NO:
534 0 : goto syntax;
535 6605 : default:
536 6605 : break;
537 : }
538 6605 : if (gfc_is_coindexed (expr))
539 : {
540 5 : gfc_error ("List item shall not be coindexed at %L",
541 5 : &expr->where);
542 5 : goto cleanup;
543 : }
544 : }
545 38243 : gfc_set_sym_referenced (sym);
546 38243 : p = gfc_get_omp_namelist ();
547 38243 : if (head == NULL)
548 : head = tail = p;
549 10161 : else if (reverse_order)
550 : {
551 57 : p->next = head;
552 57 : head = p;
553 : }
554 : else
555 : {
556 10104 : tail->next = p;
557 10104 : tail = tail->next;
558 : }
559 38243 : p->sym = sym;
560 38243 : p->expr = expr;
561 38243 : p->where = gfc_get_location_range (NULL, 0, &cur_loc, 1,
562 : &gfc_current_locus);
563 38243 : if (reject_common_vars && sym->attr.in_common)
564 : {
565 3 : gcc_assert (allow_common);
566 3 : gfc_error ("%qs at %L is part of the common block %</%s/%> and "
567 : "may only be specified implicitly via the named "
568 : "common block", sym->name, &cur_loc,
569 3 : sym->common_head->name);
570 3 : goto cleanup;
571 : }
572 38240 : goto next_item;
573 256 : case MATCH_NO:
574 256 : break;
575 0 : case MATCH_ERROR:
576 0 : goto cleanup;
577 : }
578 :
579 256 : if (!allow_common)
580 12 : goto syntax;
581 :
582 244 : m = gfc_match ("/ %n /", n);
583 244 : if (m == MATCH_ERROR)
584 0 : goto cleanup;
585 244 : if (m == MATCH_NO)
586 19 : goto syntax;
587 :
588 225 : cur_loc = gfc_get_location_range (NULL, 0, &cur_loc, 1,
589 : &gfc_current_locus);
590 225 : st = gfc_find_symtree (gfc_current_ns->common_root, n);
591 225 : if (st == NULL)
592 : {
593 2 : gfc_error ("COMMON block %</%s/%> not found at %L", n, &cur_loc);
594 2 : goto cleanup;
595 : }
596 724 : for (sym = st->n.common->head; sym; sym = sym->common_next)
597 : {
598 501 : gfc_set_sym_referenced (sym);
599 501 : p = gfc_get_omp_namelist ();
600 501 : if (head == NULL)
601 : head = tail = p;
602 325 : else if (reverse_order)
603 : {
604 0 : p->next = head;
605 0 : head = p;
606 : }
607 : else
608 : {
609 325 : tail->next = p;
610 325 : tail = tail->next;
611 : }
612 501 : p->sym = sym;
613 501 : p->where = cur_loc;
614 : }
615 :
616 223 : next_item:
617 38484 : if (end_colon && gfc_match_char (':') == MATCH_YES)
618 : {
619 806 : *end_colon = true;
620 806 : break;
621 : }
622 37678 : if (gfc_match_char (')') == MATCH_YES)
623 : break;
624 10232 : if (gfc_match_char (',') != MATCH_YES)
625 21 : goto syntax;
626 : }
627 :
628 38296 : while (*list)
629 10044 : list = &(*list)->next;
630 :
631 28252 : *list = head;
632 28252 : if (headp)
633 22351 : *headp = list;
634 : return MATCH_YES;
635 :
636 52 : syntax:
637 52 : gfc_error ("Syntax error in OpenMP variable list at %C");
638 :
639 68 : cleanup:
640 68 : gfc_free_omp_namelist (head, OMP_LIST_NONE);
641 68 : gfc_current_locus = old_loc;
642 68 : return MATCH_ERROR;
643 : }
644 :
645 : /* Match a variable/procedure/common block list and construct a namelist
646 : from it. */
647 :
648 : static match
649 392 : gfc_match_omp_to_link (const char *str, gfc_omp_namelist **list)
650 : {
651 392 : gfc_omp_namelist *head, *tail, *p;
652 392 : locus old_loc, cur_loc;
653 392 : char n[GFC_MAX_SYMBOL_LEN+1];
654 392 : gfc_symbol *sym;
655 392 : match m;
656 392 : gfc_symtree *st;
657 :
658 392 : head = tail = NULL;
659 :
660 392 : old_loc = gfc_current_locus;
661 :
662 392 : m = gfc_match (str);
663 392 : if (m != MATCH_YES)
664 : return m;
665 :
666 569 : for (;;)
667 : {
668 569 : cur_loc = gfc_current_locus;
669 569 : m = gfc_match_symbol (&sym, 1);
670 569 : switch (m)
671 : {
672 527 : case MATCH_YES:
673 527 : p = gfc_get_omp_namelist ();
674 527 : if (head == NULL)
675 : head = tail = p;
676 : else
677 : {
678 194 : tail->next = p;
679 194 : tail = tail->next;
680 : }
681 527 : tail->sym = sym;
682 527 : tail->where = cur_loc;
683 527 : goto next_item;
684 : case MATCH_NO:
685 : break;
686 0 : case MATCH_ERROR:
687 0 : goto cleanup;
688 : }
689 :
690 42 : m = gfc_match (" / %n /", n);
691 42 : if (m == MATCH_ERROR)
692 0 : goto cleanup;
693 42 : if (m == MATCH_NO)
694 0 : goto syntax;
695 :
696 42 : st = gfc_find_symtree (gfc_current_ns->common_root, n);
697 42 : if (st == NULL)
698 : {
699 0 : gfc_error ("COMMON block /%s/ not found at %C", n);
700 0 : goto cleanup;
701 : }
702 42 : p = gfc_get_omp_namelist ();
703 42 : if (head == NULL)
704 : head = tail = p;
705 : else
706 : {
707 4 : tail->next = p;
708 4 : tail = tail->next;
709 : }
710 42 : tail->u.common = st->n.common;
711 42 : tail->where = cur_loc;
712 :
713 569 : next_item:
714 569 : if (gfc_match_char (')') == MATCH_YES)
715 : break;
716 198 : if (gfc_match_char (',') != MATCH_YES)
717 0 : goto syntax;
718 : }
719 :
720 383 : while (*list)
721 12 : list = &(*list)->next;
722 :
723 371 : *list = head;
724 371 : return MATCH_YES;
725 :
726 0 : syntax:
727 0 : gfc_error ("Syntax error in OpenMP variable list at %C");
728 :
729 0 : cleanup:
730 0 : gfc_free_omp_namelist (head, OMP_LIST_NONE);
731 0 : gfc_current_locus = old_loc;
732 0 : return MATCH_ERROR;
733 : }
734 :
735 : /* Match detach(event-handle). */
736 :
737 : static match
738 126 : gfc_match_omp_detach (gfc_expr **expr)
739 : {
740 126 : locus old_loc = gfc_current_locus;
741 :
742 126 : if (gfc_match ("detach ( ") != MATCH_YES)
743 0 : goto syntax_error;
744 :
745 126 : if (gfc_match_variable (expr, 0) != MATCH_YES)
746 0 : goto syntax_error;
747 :
748 126 : if (gfc_match_char (')') != MATCH_YES)
749 0 : goto syntax_error;
750 :
751 : return MATCH_YES;
752 :
753 0 : syntax_error:
754 0 : gfc_error ("Syntax error in OpenMP detach clause at %C");
755 0 : gfc_current_locus = old_loc;
756 0 : return MATCH_ERROR;
757 :
758 : }
759 :
760 : /* Match doacross(sink : ...) construct a namelist from it;
761 : if depend is true, match legacy 'depend(sink : ...)'. */
762 :
763 : static match
764 241 : gfc_match_omp_doacross_sink (gfc_omp_namelist **list, bool depend)
765 : {
766 241 : char n[GFC_MAX_SYMBOL_LEN+1];
767 241 : gfc_omp_namelist *head, *tail, *p;
768 241 : locus old_loc, cur_loc;
769 241 : gfc_symbol *sym;
770 :
771 241 : head = tail = NULL;
772 :
773 241 : old_loc = gfc_current_locus;
774 :
775 2231 : for (;;)
776 : {
777 1236 : gfc_gobble_whitespace ();
778 1236 : cur_loc = gfc_current_locus;
779 :
780 1236 : if (gfc_match_name (n) != MATCH_YES)
781 1 : goto syntax;
782 1235 : locus loc = gfc_get_location_range (NULL, 0, &cur_loc, 1,
783 : &gfc_current_locus);
784 1235 : if (UNLIKELY (strcmp (n, "omp_all_memory") == 0))
785 : {
786 1 : gfc_error ("%<omp_all_memory%> used with dependence-type "
787 : "other than OUT or INOUT at %L", &loc);
788 1 : goto cleanup;
789 : }
790 1234 : sym = NULL;
791 1234 : if (!(strcmp (n, "omp_cur_iteration") == 0))
792 : {
793 1229 : gfc_symtree *st;
794 1229 : if (gfc_get_ha_sym_tree (n, &st))
795 0 : goto syntax;
796 1229 : sym = st->n.sym;
797 1229 : gfc_set_sym_referenced (sym);
798 : }
799 1234 : p = gfc_get_omp_namelist ();
800 1234 : if (head == NULL)
801 : {
802 239 : head = tail = p;
803 253 : head->u.depend_doacross_op = (depend ? OMP_DEPEND_SINK_FIRST
804 : : OMP_DOACROSS_SINK_FIRST);
805 : }
806 : else
807 : {
808 995 : tail->next = p;
809 995 : tail = tail->next;
810 995 : tail->u.depend_doacross_op = OMP_DOACROSS_SINK;
811 : }
812 1234 : tail->sym = sym;
813 1234 : tail->expr = NULL;
814 1234 : tail->where = loc;
815 1234 : if (gfc_match_char ('+') == MATCH_YES)
816 : {
817 154 : if (gfc_match_literal_constant (&tail->expr, 0) != MATCH_YES)
818 0 : goto syntax;
819 : }
820 1080 : else if (gfc_match_char ('-') == MATCH_YES)
821 : {
822 418 : if (gfc_match_literal_constant (&tail->expr, 0) != MATCH_YES)
823 1 : goto syntax;
824 417 : tail->expr = gfc_uminus (tail->expr);
825 : }
826 1233 : if (gfc_match_char (')') == MATCH_YES)
827 : break;
828 995 : if (gfc_match_char (',') != MATCH_YES)
829 0 : goto syntax;
830 995 : }
831 :
832 1030 : while (*list)
833 792 : list = &(*list)->next;
834 :
835 238 : *list = head;
836 238 : return MATCH_YES;
837 :
838 2 : syntax:
839 2 : gfc_error ("Syntax error in OpenMP SINK dependence-type list at %C");
840 :
841 3 : cleanup:
842 3 : gfc_free_omp_namelist (head, OMP_LIST_DEPEND);
843 3 : gfc_current_locus = old_loc;
844 3 : return MATCH_ERROR;
845 : }
846 :
847 : static int
848 332 : match_oacc_device_type_kind (void)
849 : {
850 332 : char name[GFC_MAX_SYMBOL_LEN + 1];
851 :
852 : /* Since device_type arg accept * as all,
853 : we need to check first the case when
854 : the user inputs * as the parameter. */
855 332 : gfc_gobble_whitespace ();
856 332 : name[0] = (char) gfc_next_char ();
857 :
858 332 : if (name[0] == '*')
859 : return GOMP_DEVICE_NONE;
860 :
861 : /* If is not *, we try to match the
862 : pre-defined names. */
863 :
864 332 : match m = gfc_match (" %n ", name + 1);
865 :
866 332 : if (m != MATCH_YES)
867 : return -1;
868 :
869 332 : if (strcmp (name ,"host") == 0)
870 : return GOMP_DEVICE_HOST;
871 144 : if (strcmp (name, "nvidia") == 0)
872 : return GOMP_DEVICE_NVIDIA_PTX;
873 72 : if (strcmp (name, "radeon") == 0)
874 69 : return GOMP_DEVICE_GCN;
875 :
876 : return -1;
877 : }
878 :
879 : static match
880 332 : match_oacc_device_type (gfc_omp_clauses *c)
881 : {
882 332 : locus old_loc = gfc_current_locus;
883 :
884 332 : int result = match_oacc_device_type_kind ();
885 332 : match m;
886 :
887 332 : if (result == -1)
888 3 : goto syntax;
889 :
890 329 : m = gfc_match_char (')', true);
891 :
892 329 : if (m != MATCH_YES)
893 3 : goto single_argument;
894 :
895 326 : c->oacc_device_type = (unsigned) result;
896 326 : c->oacc_device_type_present = 1;
897 :
898 326 : return MATCH_YES;
899 :
900 3 : single_argument:
901 3 : gfc_error ("OpenACC %<DEVICE_TYPE%> clause only accepts one argument, "
902 : "unexpected char at %C");
903 3 : goto cleanup;
904 :
905 3 : syntax:
906 3 : gfc_error ("Syntax error in OpenACC %<DEVICE_TYPE%> argument at %C. Expected "
907 : "host, radeon, nvidia or * as argument.");
908 :
909 6 : cleanup:
910 6 : gfc_current_locus = old_loc;
911 6 : return MATCH_ERROR;
912 : }
913 :
914 : static match
915 1960 : match_omp_oacc_expr_list (const char *str, gfc_expr_list **list,
916 : bool allow_asterisk, bool is_omp)
917 : {
918 1960 : gfc_expr_list *head, *tail, *p;
919 1960 : locus old_loc;
920 1960 : gfc_expr *expr;
921 1960 : match m;
922 :
923 1960 : head = tail = NULL;
924 :
925 1960 : old_loc = gfc_current_locus;
926 :
927 1960 : if (str && (m = gfc_match (str)) != MATCH_YES)
928 : return m;
929 :
930 2237 : for (;;)
931 : {
932 2237 : m = gfc_match_expr (&expr);
933 2237 : if (m == MATCH_YES || allow_asterisk)
934 : {
935 2220 : p = gfc_get_expr_list ();
936 2220 : if (head == NULL)
937 : head = tail = p;
938 : else
939 : {
940 400 : tail->next = p;
941 400 : tail = tail->next;
942 : }
943 2220 : if (m == MATCH_YES)
944 2087 : tail->expr = expr;
945 133 : else if (gfc_match (" *") != MATCH_YES)
946 18 : goto syntax;
947 2202 : goto next_item;
948 : }
949 17 : if (m == MATCH_ERROR)
950 0 : goto cleanup;
951 17 : goto syntax;
952 :
953 2202 : next_item:
954 2202 : if (gfc_match_char (')') == MATCH_YES)
955 : break;
956 422 : if (gfc_match_char (',') != MATCH_YES)
957 17 : goto syntax;
958 : }
959 :
960 1786 : while (*list)
961 6 : list = &(*list)->next;
962 :
963 1780 : *list = head;
964 1780 : return MATCH_YES;
965 :
966 52 : syntax:
967 52 : if (is_omp)
968 23 : gfc_error ("Syntax error in OpenMP expression list at %C");
969 : else
970 29 : gfc_error ("Syntax error in OpenACC expression list at %C");
971 :
972 52 : cleanup:
973 52 : gfc_free_expr_list (head);
974 52 : gfc_current_locus = old_loc;
975 52 : return MATCH_ERROR;
976 : }
977 :
978 : static match
979 3056 : match_oacc_clause_gwv (gfc_omp_clauses *cp, unsigned gwv)
980 : {
981 3056 : match ret = MATCH_YES;
982 :
983 3056 : if (gfc_match (" ( ") != MATCH_YES)
984 : return MATCH_NO;
985 :
986 470 : if (gwv == GOMP_DIM_GANG)
987 : {
988 : /* The gang clause accepts two optional arguments, num and static.
989 : The num argument may either be explicit (num: <val>) or
990 : implicit without (<val> without num:). */
991 :
992 457 : while (ret == MATCH_YES)
993 : {
994 236 : if (gfc_match (" static :") == MATCH_YES)
995 : {
996 114 : if (cp->gang_static)
997 : return MATCH_ERROR;
998 : else
999 113 : cp->gang_static = true;
1000 113 : if (gfc_match_char ('*') == MATCH_YES)
1001 18 : cp->gang_static_expr = NULL;
1002 95 : else if (gfc_match (" %e ", &cp->gang_static_expr) != MATCH_YES)
1003 : return MATCH_ERROR;
1004 : }
1005 : else
1006 : {
1007 122 : if (cp->gang_num_expr)
1008 : return MATCH_ERROR;
1009 :
1010 : /* The 'num' argument is optional. */
1011 121 : gfc_match (" num :");
1012 :
1013 121 : if (gfc_match (" %e ", &cp->gang_num_expr) != MATCH_YES)
1014 : return MATCH_ERROR;
1015 : }
1016 :
1017 231 : ret = gfc_match (" , ");
1018 : }
1019 : }
1020 244 : else if (gwv == GOMP_DIM_WORKER)
1021 : {
1022 : /* The 'num' argument is optional. */
1023 107 : gfc_match (" num :");
1024 :
1025 107 : if (gfc_match (" %e ", &cp->worker_expr) != MATCH_YES)
1026 : return MATCH_ERROR;
1027 : }
1028 137 : else if (gwv == GOMP_DIM_VECTOR)
1029 : {
1030 : /* The 'length' argument is optional. */
1031 137 : gfc_match (" length :");
1032 :
1033 137 : if (gfc_match (" %e ", &cp->vector_expr) != MATCH_YES)
1034 : return MATCH_ERROR;
1035 : }
1036 : else
1037 0 : gfc_fatal_error ("Unexpected OpenACC parallelism.");
1038 :
1039 459 : return gfc_match (" )");
1040 : }
1041 :
1042 : static match
1043 8 : gfc_match_oacc_clause_link (const char *str, gfc_omp_namelist **list)
1044 : {
1045 8 : gfc_omp_namelist *head = NULL;
1046 8 : gfc_omp_namelist *tail, *p;
1047 8 : locus old_loc;
1048 8 : char n[GFC_MAX_SYMBOL_LEN+1];
1049 8 : gfc_symbol *sym;
1050 8 : match m;
1051 8 : gfc_symtree *st;
1052 :
1053 8 : old_loc = gfc_current_locus;
1054 :
1055 8 : m = gfc_match (str);
1056 8 : if (m != MATCH_YES)
1057 : return m;
1058 :
1059 8 : m = gfc_match (" (");
1060 :
1061 14 : for (;;)
1062 : {
1063 14 : m = gfc_match_symbol (&sym, 0);
1064 14 : switch (m)
1065 : {
1066 8 : case MATCH_YES:
1067 8 : if (sym->attr.in_common)
1068 : {
1069 2 : gfc_error_now ("Variable at %C is an element of a COMMON block");
1070 2 : goto cleanup;
1071 : }
1072 6 : gfc_set_sym_referenced (sym);
1073 6 : p = gfc_get_omp_namelist ();
1074 6 : if (head == NULL)
1075 : head = tail = p;
1076 : else
1077 : {
1078 4 : tail->next = p;
1079 4 : tail = tail->next;
1080 : }
1081 6 : tail->sym = sym;
1082 6 : tail->expr = NULL;
1083 6 : tail->where = gfc_current_locus;
1084 6 : goto next_item;
1085 : case MATCH_NO:
1086 : break;
1087 :
1088 0 : case MATCH_ERROR:
1089 0 : goto cleanup;
1090 : }
1091 :
1092 6 : m = gfc_match (" / %n /", n);
1093 6 : if (m == MATCH_ERROR)
1094 0 : goto cleanup;
1095 6 : if (m == MATCH_NO || n[0] == '\0')
1096 0 : goto syntax;
1097 :
1098 6 : st = gfc_find_symtree (gfc_current_ns->common_root, n);
1099 6 : if (st == NULL)
1100 : {
1101 1 : gfc_error ("COMMON block /%s/ not found at %C", n);
1102 1 : goto cleanup;
1103 : }
1104 :
1105 20 : for (sym = st->n.common->head; sym; sym = sym->common_next)
1106 : {
1107 15 : gfc_set_sym_referenced (sym);
1108 15 : p = gfc_get_omp_namelist ();
1109 15 : if (head == NULL)
1110 : head = tail = p;
1111 : else
1112 : {
1113 12 : tail->next = p;
1114 12 : tail = tail->next;
1115 : }
1116 15 : tail->sym = sym;
1117 15 : tail->where = gfc_current_locus;
1118 : }
1119 :
1120 5 : next_item:
1121 11 : if (gfc_match_char (')') == MATCH_YES)
1122 : break;
1123 6 : if (gfc_match_char (',') != MATCH_YES)
1124 0 : goto syntax;
1125 : }
1126 :
1127 5 : if (gfc_match_omp_eos () != MATCH_YES)
1128 : {
1129 1 : gfc_error ("Unexpected junk after !$ACC DECLARE at %C");
1130 1 : goto cleanup;
1131 : }
1132 :
1133 4 : while (*list)
1134 0 : list = &(*list)->next;
1135 4 : *list = head;
1136 4 : return MATCH_YES;
1137 :
1138 0 : syntax:
1139 0 : gfc_error ("Syntax error in !$ACC DECLARE list at %C");
1140 :
1141 4 : cleanup:
1142 4 : gfc_current_locus = old_loc;
1143 4 : return MATCH_ERROR;
1144 : }
1145 :
1146 : /* OpenMP clauses. */
1147 : enum omp_mask1
1148 : {
1149 : OMP_CLAUSE_PRIVATE,
1150 : OMP_CLAUSE_FIRSTPRIVATE,
1151 : OMP_CLAUSE_LASTPRIVATE,
1152 : OMP_CLAUSE_COPYPRIVATE,
1153 : OMP_CLAUSE_SHARED,
1154 : OMP_CLAUSE_COPYIN,
1155 : OMP_CLAUSE_REDUCTION,
1156 : OMP_CLAUSE_IN_REDUCTION,
1157 : OMP_CLAUSE_TASK_REDUCTION,
1158 : OMP_CLAUSE_IF,
1159 : OMP_CLAUSE_NUM_THREADS,
1160 : OMP_CLAUSE_SCHEDULE,
1161 : OMP_CLAUSE_DEFAULT,
1162 : OMP_CLAUSE_ORDER,
1163 : OMP_CLAUSE_ORDERED,
1164 : OMP_CLAUSE_COLLAPSE,
1165 : OMP_CLAUSE_UNTIED,
1166 : OMP_CLAUSE_FINAL,
1167 : OMP_CLAUSE_MERGEABLE,
1168 : OMP_CLAUSE_ALIGNED,
1169 : OMP_CLAUSE_DEPEND,
1170 : OMP_CLAUSE_INBRANCH,
1171 : OMP_CLAUSE_LINEAR,
1172 : OMP_CLAUSE_NOTINBRANCH,
1173 : OMP_CLAUSE_PROC_BIND,
1174 : OMP_CLAUSE_SAFELEN,
1175 : OMP_CLAUSE_SIMDLEN,
1176 : OMP_CLAUSE_UNIFORM,
1177 : OMP_CLAUSE_DEVICE,
1178 : OMP_CLAUSE_MAP,
1179 : OMP_CLAUSE_TO,
1180 : OMP_CLAUSE_FROM,
1181 : OMP_CLAUSE_NUM_TEAMS,
1182 : OMP_CLAUSE_THREAD_LIMIT,
1183 : OMP_CLAUSE_DIST_SCHEDULE,
1184 : OMP_CLAUSE_DEFAULTMAP,
1185 : OMP_CLAUSE_GRAINSIZE,
1186 : OMP_CLAUSE_HINT,
1187 : OMP_CLAUSE_IS_DEVICE_PTR,
1188 : OMP_CLAUSE_LINK,
1189 : OMP_CLAUSE_NOGROUP,
1190 : OMP_CLAUSE_NOTEMPORAL,
1191 : OMP_CLAUSE_NUM_TASKS,
1192 : OMP_CLAUSE_PRIORITY,
1193 : OMP_CLAUSE_SIMD,
1194 : OMP_CLAUSE_THREADS,
1195 : OMP_CLAUSE_USE_DEVICE_PTR,
1196 : OMP_CLAUSE_USE_DEVICE_ADDR, /* OpenMP 5.0. */
1197 : OMP_CLAUSE_DEVICE_TYPE, /* OpenMP 5.0. */
1198 : OMP_CLAUSE_ATOMIC, /* OpenMP 5.0. */
1199 : OMP_CLAUSE_CAPTURE, /* OpenMP 5.0. */
1200 : OMP_CLAUSE_MEMORDER, /* OpenMP 5.0. */
1201 : OMP_CLAUSE_DETACH, /* OpenMP 5.0. */
1202 : OMP_CLAUSE_AFFINITY, /* OpenMP 5.0. */
1203 : OMP_CLAUSE_ALLOCATE, /* OpenMP 5.0. */
1204 : OMP_CLAUSE_BIND, /* OpenMP 5.0. */
1205 : OMP_CLAUSE_FILTER, /* OpenMP 5.1. */
1206 : OMP_CLAUSE_AT, /* OpenMP 5.1. */
1207 : OMP_CLAUSE_MESSAGE, /* OpenMP 5.1. */
1208 : OMP_CLAUSE_SEVERITY, /* OpenMP 5.1. */
1209 : OMP_CLAUSE_COMPARE, /* OpenMP 5.1. */
1210 : OMP_CLAUSE_FAIL, /* OpenMP 5.1. */
1211 : OMP_CLAUSE_WEAK, /* OpenMP 5.1. */
1212 : OMP_CLAUSE_NOWAIT,
1213 : /* This must come last. */
1214 : OMP_MASK1_LAST
1215 : };
1216 :
1217 : /* More OpenMP clauses and OpenACC 2.0+ specific clauses. */
1218 : enum omp_mask2
1219 : {
1220 : OMP_CLAUSE_ASYNC,
1221 : OMP_CLAUSE_NUM_GANGS,
1222 : OMP_CLAUSE_NUM_WORKERS,
1223 : OMP_CLAUSE_VECTOR_LENGTH,
1224 : OMP_CLAUSE_COPY,
1225 : OMP_CLAUSE_COPYOUT,
1226 : OMP_CLAUSE_CREATE,
1227 : OMP_CLAUSE_NO_CREATE,
1228 : OMP_CLAUSE_PRESENT,
1229 : OMP_CLAUSE_DEVICEPTR,
1230 : OMP_CLAUSE_GANG,
1231 : OMP_CLAUSE_WORKER,
1232 : OMP_CLAUSE_VECTOR,
1233 : OMP_CLAUSE_SEQ,
1234 : OMP_CLAUSE_INDEPENDENT,
1235 : OMP_CLAUSE_USE_DEVICE,
1236 : OMP_CLAUSE_DEVICE_RESIDENT,
1237 : OMP_CLAUSE_SELF,
1238 : OMP_CLAUSE_HOST,
1239 : OMP_CLAUSE_WAIT,
1240 : OMP_CLAUSE_DELETE,
1241 : OMP_CLAUSE_AUTO,
1242 : OMP_CLAUSE_TILE,
1243 : OMP_CLAUSE_IF_PRESENT,
1244 : OMP_CLAUSE_FINALIZE,
1245 : OMP_CLAUSE_ATTACH,
1246 : OMP_CLAUSE_NOHOST,
1247 : OMP_CLAUSE_HAS_DEVICE_ADDR, /* OpenMP 5.1 */
1248 : OMP_CLAUSE_ENTER, /* OpenMP 5.2 */
1249 : OMP_CLAUSE_DOACROSS, /* OpenMP 5.2 */
1250 : OMP_CLAUSE_ASSUMPTIONS, /* OpenMP 5.1. */
1251 : OMP_CLAUSE_USES_ALLOCATORS, /* OpenMP 5.0 */
1252 : OMP_CLAUSE_INDIRECT, /* OpenMP 5.1 */
1253 : OMP_CLAUSE_FULL, /* OpenMP 5.1. */
1254 : OMP_CLAUSE_PARTIAL, /* OpenMP 5.1. */
1255 : OMP_CLAUSE_SIZES, /* OpenMP 5.1. */
1256 : OMP_CLAUSE_INIT, /* OpenMP 5.1. */
1257 : OMP_CLAUSE_DESTROY, /* OpenMP 5.1. */
1258 : OMP_CLAUSE_USE, /* OpenMP 5.1. */
1259 : OMP_CLAUSE_NOVARIANTS, /* OpenMP 5.1 */
1260 : OMP_CLAUSE_NOCONTEXT, /* OpenMP 5.1 */
1261 : OMP_CLAUSE_INTEROP, /* OpenMP 5.1 */
1262 : OMP_CLAUSE_LOCAL, /* OpenMP 6.0 */
1263 : OMP_CLAUSE_DYN_GROUPPRIVATE, /* OpenMP 6.1 */
1264 : OMP_CLAUSE_DEVICE_NUM,
1265 : /* This must come last. */
1266 : OMP_MASK2_LAST
1267 : };
1268 :
1269 : struct omp_inv_mask;
1270 :
1271 : /* Customized bitset for up to 128-bits.
1272 : The two enums above provide bit numbers to use, and which of the
1273 : two enums it is determines which of the two mask fields is used.
1274 : Supported operations are defining a mask, like:
1275 : #define XXX_CLAUSES \
1276 : (omp_mask (OMP_CLAUSE_XXX) | OMP_CLAUSE_YYY | OMP_CLAUSE_ZZZ)
1277 : oring such bitsets together or removing selected bits:
1278 : (XXX_CLAUSES | YYY_CLAUSES) & ~(omp_mask (OMP_CLAUSE_VVV))
1279 : and testing individual bits:
1280 : if (mask & OMP_CLAUSE_UUU) */
1281 :
1282 : struct omp_mask {
1283 : const uint64_t mask1;
1284 : const uint64_t mask2;
1285 : inline omp_mask ();
1286 : inline omp_mask (omp_mask1);
1287 : inline omp_mask (omp_mask2);
1288 : inline omp_mask (uint64_t, uint64_t);
1289 : inline omp_mask operator| (omp_mask1) const;
1290 : inline omp_mask operator| (omp_mask2) const;
1291 : inline omp_mask operator| (omp_mask) const;
1292 : inline omp_mask operator& (const omp_inv_mask &) const;
1293 : inline bool operator& (omp_mask1) const;
1294 : inline bool operator& (omp_mask2) const;
1295 : inline omp_inv_mask operator~ () const;
1296 : };
1297 :
1298 : struct omp_inv_mask : public omp_mask {
1299 : inline omp_inv_mask (const omp_mask &);
1300 : };
1301 :
1302 : omp_mask::omp_mask () : mask1 (0), mask2 (0)
1303 : {
1304 : }
1305 :
1306 32972 : omp_mask::omp_mask (omp_mask1 m) : mask1 (((uint64_t) 1) << m), mask2 (0)
1307 : {
1308 : }
1309 :
1310 2244 : omp_mask::omp_mask (omp_mask2 m) : mask1 (0), mask2 (((uint64_t) 1) << m)
1311 : {
1312 : }
1313 :
1314 33859 : omp_mask::omp_mask (uint64_t m1, uint64_t m2) : mask1 (m1), mask2 (m2)
1315 : {
1316 : }
1317 :
1318 : omp_mask
1319 32899 : omp_mask::operator| (omp_mask1 m) const
1320 : {
1321 32899 : return omp_mask (mask1 | (((uint64_t) 1) << m), mask2);
1322 : }
1323 :
1324 : omp_mask
1325 17296 : omp_mask::operator| (omp_mask2 m) const
1326 : {
1327 17296 : return omp_mask (mask1, mask2 | (((uint64_t) 1) << m));
1328 : }
1329 :
1330 : omp_mask
1331 4378 : omp_mask::operator| (omp_mask m) const
1332 : {
1333 4378 : return omp_mask (mask1 | m.mask1, mask2 | m.mask2);
1334 : }
1335 :
1336 : omp_mask
1337 2033 : omp_mask::operator& (const omp_inv_mask &m) const
1338 : {
1339 2033 : return omp_mask (mask1 & ~m.mask1, mask2 & ~m.mask2);
1340 : }
1341 :
1342 : bool
1343 130134 : omp_mask::operator& (omp_mask1 m) const
1344 : {
1345 130134 : return (mask1 & (((uint64_t) 1) << m)) != 0;
1346 : }
1347 :
1348 : bool
1349 92603 : omp_mask::operator& (omp_mask2 m) const
1350 : {
1351 92603 : return (mask2 & (((uint64_t) 1) << m)) != 0;
1352 : }
1353 :
1354 : omp_inv_mask
1355 2033 : omp_mask::operator~ () const
1356 : {
1357 2033 : return omp_inv_mask (*this);
1358 : }
1359 :
1360 2033 : omp_inv_mask::omp_inv_mask (const omp_mask &m) : omp_mask (m)
1361 : {
1362 : }
1363 :
1364 : /* Helper function for OpenACC and OpenMP clauses involving memory
1365 : mapping. */
1366 :
1367 : static bool
1368 5544 : gfc_match_omp_map_clause (gfc_omp_namelist **list, gfc_omp_map_op map_op,
1369 : bool allow_common, bool allow_derived)
1370 : {
1371 5544 : gfc_omp_namelist **head = NULL;
1372 5544 : if (gfc_match_omp_variable_list ("", list, allow_common, NULL, &head, true,
1373 : allow_derived)
1374 : == MATCH_YES)
1375 : {
1376 5535 : gfc_omp_namelist *n;
1377 13409 : for (n = *head; n; n = n->next)
1378 7874 : n->u.map.op = map_op;
1379 : return true;
1380 : }
1381 :
1382 : return false;
1383 : }
1384 :
1385 : static match
1386 8749 : gfc_match_iterator (gfc_namespace **ns, bool permit_var)
1387 : {
1388 8749 : locus old_loc = gfc_current_locus;
1389 :
1390 8749 : if (gfc_match ("iterator ( ") != MATCH_YES)
1391 : return MATCH_NO;
1392 :
1393 142 : gfc_typespec ts;
1394 142 : gfc_symbol *last = NULL;
1395 142 : gfc_expr *begin, *end, *step;
1396 142 : *ns = gfc_build_block_ns (gfc_current_ns);
1397 161 : char name[GFC_MAX_SYMBOL_LEN + 1];
1398 180 : while (true)
1399 : {
1400 161 : locus prev_loc = gfc_current_locus;
1401 161 : if (gfc_match_type_spec (&ts) == MATCH_YES
1402 161 : && gfc_match (" :: ") == MATCH_YES)
1403 : {
1404 5 : if (ts.type != BT_INTEGER)
1405 : {
1406 2 : gfc_error ("Expected INTEGER type at %L", &prev_loc);
1407 5 : return MATCH_ERROR;
1408 : }
1409 : permit_var = false;
1410 : }
1411 : else
1412 : {
1413 156 : ts.type = BT_INTEGER;
1414 156 : ts.kind = gfc_default_integer_kind;
1415 156 : gfc_current_locus = prev_loc;
1416 : }
1417 159 : prev_loc = gfc_current_locus;
1418 159 : if (gfc_match_name (name) != MATCH_YES)
1419 : {
1420 4 : gfc_error ("Expected identifier at %C");
1421 4 : goto failed;
1422 : }
1423 155 : if (gfc_find_symtree ((*ns)->sym_root, name))
1424 : {
1425 2 : gfc_error ("Same identifier %qs specified again at %C", name);
1426 2 : goto failed;
1427 : }
1428 :
1429 153 : gfc_symbol *sym = gfc_new_symbol (name, *ns);
1430 153 : if (last)
1431 17 : last->tlink = sym;
1432 : else
1433 136 : (*ns)->omp_affinity_iterators = sym;
1434 153 : last = sym;
1435 153 : sym->declared_at = prev_loc;
1436 153 : sym->ts = ts;
1437 153 : sym->attr.flavor = FL_VARIABLE;
1438 153 : sym->attr.artificial = 1;
1439 153 : sym->attr.referenced = 1;
1440 153 : sym->refs++;
1441 153 : gfc_symtree *st = gfc_new_symtree (&(*ns)->sym_root, name);
1442 153 : st->n.sym = sym;
1443 :
1444 153 : prev_loc = gfc_current_locus;
1445 153 : if (gfc_match (" = ") != MATCH_YES)
1446 3 : goto failed;
1447 150 : permit_var = false;
1448 150 : begin = end = step = NULL;
1449 150 : if (gfc_match ("%e : ", &begin) != MATCH_YES
1450 150 : || gfc_match ("%e ", &end) != MATCH_YES)
1451 : {
1452 3 : gfc_error ("Expected range-specification at %C");
1453 3 : gfc_free_expr (begin);
1454 3 : gfc_free_expr (end);
1455 3 : return MATCH_ERROR;
1456 : }
1457 147 : if (':' == gfc_peek_ascii_char ())
1458 : {
1459 23 : if (gfc_match (": %e ", &step) != MATCH_YES)
1460 : {
1461 5 : gfc_free_expr (begin);
1462 5 : gfc_free_expr (end);
1463 5 : gfc_free_expr (step);
1464 5 : goto failed;
1465 : }
1466 : }
1467 :
1468 142 : gfc_expr *e = gfc_get_expr ();
1469 142 : e->where = prev_loc;
1470 142 : e->expr_type = EXPR_ARRAY;
1471 142 : e->ts = ts;
1472 142 : e->rank = 1;
1473 142 : e->shape = gfc_get_shape (1);
1474 266 : mpz_init_set_ui (e->shape[0], step ? 3 : 2);
1475 142 : gfc_constructor_append_expr (&e->value.constructor, begin, &begin->where);
1476 142 : gfc_constructor_append_expr (&e->value.constructor, end, &end->where);
1477 142 : if (step)
1478 18 : gfc_constructor_append_expr (&e->value.constructor, step, &step->where);
1479 142 : sym->value = e;
1480 :
1481 142 : if (gfc_match (") ") == MATCH_YES)
1482 : break;
1483 19 : if (gfc_match (", ") != MATCH_YES)
1484 0 : goto failed;
1485 19 : }
1486 123 : return MATCH_YES;
1487 :
1488 14 : failed:
1489 14 : gfc_namespace *prev_ns = NULL;
1490 14 : for (gfc_namespace *it = gfc_current_ns->contained; it; it = it->sibling)
1491 : {
1492 0 : if (it == *ns)
1493 : {
1494 0 : if (prev_ns)
1495 0 : prev_ns->sibling = it->sibling;
1496 : else
1497 0 : gfc_current_ns->contained = it->sibling;
1498 0 : gfc_free_namespace (it);
1499 0 : break;
1500 : }
1501 0 : prev_ns = it;
1502 : }
1503 14 : *ns = NULL;
1504 14 : if (!permit_var)
1505 : return MATCH_ERROR;
1506 4 : gfc_current_locus = old_loc;
1507 4 : return MATCH_NO;
1508 : }
1509 :
1510 : /* Match target update's to/from( [present:] var-list). */
1511 :
1512 : static match
1513 1738 : gfc_match_motion_var_list (const char *str, gfc_omp_namelist **list,
1514 : gfc_omp_namelist ***headp)
1515 : {
1516 1738 : match m = gfc_match (str);
1517 1738 : if (m != MATCH_YES)
1518 : return m;
1519 :
1520 1738 : gfc_namespace *ns_iter = NULL, *ns_curr = gfc_current_ns;
1521 1738 : locus old_loc = gfc_current_locus;
1522 1738 : int present_modifier = 0;
1523 1738 : int iterator_modifier = 0;
1524 1738 : locus second_present_locus = old_loc;
1525 1738 : locus second_iterator_locus = old_loc;
1526 1738 : bool saw_modifier = false;
1527 :
1528 1750 : for (;;)
1529 : {
1530 1744 : locus current_locus = gfc_current_locus;
1531 1744 : if (gfc_match ("present ") == MATCH_YES)
1532 : {
1533 8 : if (present_modifier++ == 1)
1534 0 : second_present_locus = current_locus;
1535 : }
1536 1736 : else if (gfc_match_iterator (&ns_iter, true) == MATCH_YES)
1537 : {
1538 20 : if (iterator_modifier++ == 1)
1539 1 : second_iterator_locus = current_locus;
1540 : }
1541 1716 : else if (!saw_modifier)
1542 : break;
1543 : else
1544 : {
1545 2 : gfc_error ("Expected clause modifier at %C");
1546 4 : return MATCH_ERROR;
1547 : }
1548 :
1549 : /* OpenMP 5.1 syntax mistakenly allowed commas to be optional
1550 : between and after modifiers in a clause. This was corrected
1551 : in 5.2 and later specifications: they're now required between
1552 : modifiers and a trailing comma is not permitted. We implement
1553 : the 5.2 syntax here. */
1554 28 : saw_modifier = true;
1555 28 : if (gfc_match (" : ") == MATCH_YES)
1556 : break;
1557 8 : else if (gfc_match (", ") == MATCH_YES)
1558 6 : continue;
1559 : else
1560 : {
1561 2 : gfc_error ("Expected %<,%> or %<:%> after clause modifier at %C");
1562 2 : return MATCH_ERROR;
1563 : }
1564 6 : }
1565 :
1566 1734 : if (!saw_modifier)
1567 : {
1568 1714 : gfc_current_locus = old_loc;
1569 1714 : present_modifier = 0;
1570 1714 : iterator_modifier = 0;
1571 : }
1572 :
1573 1734 : if (present_modifier > 1)
1574 : {
1575 0 : gfc_error ("Too many %<present%> modifiers at %L", &second_present_locus);
1576 0 : return MATCH_ERROR;
1577 : }
1578 1734 : if (iterator_modifier > 1)
1579 : {
1580 1 : gfc_error ("Too many %<iterator%> modifiers at %L",
1581 : &second_iterator_locus);
1582 1 : return MATCH_ERROR;
1583 : }
1584 :
1585 1733 : if (ns_iter)
1586 14 : gfc_current_ns = ns_iter;
1587 :
1588 1733 : m = gfc_match_omp_variable_list ("", list, false, NULL, headp, true, true);
1589 1733 : gfc_current_ns = ns_curr;
1590 1733 : if (m != MATCH_YES)
1591 : return m;
1592 1731 : gfc_omp_namelist *n;
1593 3536 : for (n = **headp; n; n = n->next)
1594 : {
1595 1805 : if (present_modifier)
1596 6 : n->u.present_modifier = true;
1597 1805 : if (iterator_modifier)
1598 : {
1599 18 : n->u2.ns = ns_iter;
1600 18 : ns_iter->refs++;
1601 : }
1602 : }
1603 : return MATCH_YES;
1604 : }
1605 :
1606 : /* reduction ( reduction-modifier, reduction-operator : variable-list )
1607 : in_reduction ( reduction-operator : variable-list )
1608 : task_reduction ( reduction-operator : variable-list ) */
1609 :
1610 : static match
1611 4361 : gfc_match_omp_clause_reduction (char pc, gfc_omp_clauses *c, bool openacc,
1612 : bool allow_derived, bool openmp_target = false)
1613 : {
1614 4361 : if (pc == 'r' && gfc_match ("reduction ( ") != MATCH_YES)
1615 : return MATCH_NO;
1616 4361 : else if (pc == 'i' && gfc_match ("in_reduction ( ") != MATCH_YES)
1617 : return MATCH_NO;
1618 4249 : else if (pc == 't' && gfc_match ("task_reduction ( ") != MATCH_YES)
1619 : return MATCH_NO;
1620 :
1621 4249 : locus old_loc = gfc_current_locus;
1622 4249 : enum gfc_omp_list_type list_idx = OMP_LIST_NONE;
1623 :
1624 4249 : if (pc == 'r' && !openacc)
1625 : {
1626 2122 : if (gfc_match ("inscan") == MATCH_YES)
1627 : list_idx = OMP_LIST_REDUCTION_INSCAN;
1628 2052 : else if (gfc_match ("task") == MATCH_YES)
1629 : list_idx = OMP_LIST_REDUCTION_TASK;
1630 1947 : else if (gfc_match ("default") == MATCH_YES)
1631 : list_idx = OMP_LIST_REDUCTION;
1632 231 : if (list_idx != OMP_LIST_NONE && gfc_match (", ") != MATCH_YES)
1633 : {
1634 1 : gfc_error ("Comma expected at %C");
1635 1 : gfc_current_locus = old_loc;
1636 1 : return MATCH_NO;
1637 : }
1638 2121 : if (list_idx == OMP_LIST_NONE)
1639 3835 : list_idx = OMP_LIST_REDUCTION;
1640 : }
1641 2127 : else if (pc == 'i')
1642 : list_idx = OMP_LIST_IN_REDUCTION;
1643 2009 : else if (pc == 't')
1644 : list_idx = OMP_LIST_TASK_REDUCTION;
1645 : else
1646 3835 : list_idx = OMP_LIST_REDUCTION;
1647 :
1648 4248 : gfc_omp_reduction_op rop = OMP_REDUCTION_NONE;
1649 4248 : char buffer[GFC_MAX_SYMBOL_LEN + 3];
1650 4248 : if (gfc_match_char ('+') == MATCH_YES)
1651 : rop = OMP_REDUCTION_PLUS;
1652 2224 : else if (gfc_match_char ('*') == MATCH_YES)
1653 : rop = OMP_REDUCTION_TIMES;
1654 1992 : else if (gfc_match_char ('-') == MATCH_YES)
1655 : {
1656 171 : if (!openacc)
1657 16 : gfc_warning (OPT_Wdeprecated_openmp,
1658 : "%<-%> operator at %C for reductions deprecated in "
1659 : "OpenMP 5.2");
1660 : rop = OMP_REDUCTION_MINUS;
1661 : }
1662 1821 : else if (gfc_match (".and.") == MATCH_YES)
1663 : rop = OMP_REDUCTION_AND;
1664 1715 : else if (gfc_match (".or.") == MATCH_YES)
1665 : rop = OMP_REDUCTION_OR;
1666 930 : else if (gfc_match (".eqv.") == MATCH_YES)
1667 : rop = OMP_REDUCTION_EQV;
1668 832 : else if (gfc_match (".neqv.") == MATCH_YES)
1669 : rop = OMP_REDUCTION_NEQV;
1670 16 : if (rop != OMP_REDUCTION_NONE)
1671 3511 : snprintf (buffer, sizeof buffer, "operator %s",
1672 : gfc_op2string ((gfc_intrinsic_op) rop));
1673 737 : else if (gfc_match_defined_op_name (buffer + 1, 1) == MATCH_YES)
1674 : {
1675 38 : buffer[0] = '.';
1676 38 : strcat (buffer, ".");
1677 : }
1678 699 : else if (gfc_match_name (buffer) == MATCH_YES)
1679 : {
1680 698 : gfc_symbol *sym;
1681 698 : const char *n = buffer;
1682 :
1683 698 : gfc_find_symbol (buffer, NULL, 1, &sym);
1684 698 : if (sym != NULL)
1685 : {
1686 217 : if (sym->attr.intrinsic)
1687 139 : n = sym->name;
1688 78 : else if ((sym->attr.flavor != FL_UNKNOWN
1689 76 : && sym->attr.flavor != FL_PROCEDURE)
1690 76 : || sym->attr.external
1691 65 : || sym->attr.generic
1692 65 : || sym->attr.entry
1693 65 : || sym->attr.result
1694 65 : || sym->attr.dummy
1695 65 : || sym->attr.subroutine
1696 64 : || sym->attr.pointer
1697 64 : || sym->attr.target
1698 64 : || sym->attr.cray_pointer
1699 64 : || sym->attr.cray_pointee
1700 64 : || (sym->attr.proc != PROC_UNKNOWN
1701 2 : && sym->attr.proc != PROC_INTRINSIC)
1702 62 : || sym->attr.if_source != IFSRC_UNKNOWN
1703 62 : || sym == sym->ns->proc_name)
1704 : {
1705 : sym = NULL;
1706 : n = NULL;
1707 : }
1708 : else
1709 62 : n = sym->name;
1710 : }
1711 201 : if (n == NULL)
1712 : rop = OMP_REDUCTION_NONE;
1713 682 : else if (strcmp (n, "max") == 0)
1714 : rop = OMP_REDUCTION_MAX;
1715 517 : else if (strcmp (n, "min") == 0)
1716 : rop = OMP_REDUCTION_MIN;
1717 376 : else if (strcmp (n, "iand") == 0)
1718 : rop = OMP_REDUCTION_IAND;
1719 321 : else if (strcmp (n, "ior") == 0)
1720 : rop = OMP_REDUCTION_IOR;
1721 255 : else if (strcmp (n, "ieor") == 0)
1722 : rop = OMP_REDUCTION_IEOR;
1723 : if (rop != OMP_REDUCTION_NONE
1724 477 : && sym != NULL
1725 200 : && ! sym->attr.intrinsic
1726 61 : && ! sym->attr.use_assoc
1727 61 : && ((sym->attr.flavor == FL_UNKNOWN
1728 2 : && !gfc_add_flavor (&sym->attr, FL_PROCEDURE,
1729 : sym->name, NULL))
1730 61 : || !gfc_add_intrinsic (&sym->attr, NULL)))
1731 : rop = OMP_REDUCTION_NONE;
1732 : }
1733 : else
1734 1 : buffer[0] = '\0';
1735 4248 : gfc_omp_udr *udr = (buffer[0] ? gfc_find_omp_udr (gfc_current_ns, buffer, NULL)
1736 : : NULL);
1737 4248 : gfc_omp_namelist **head = NULL;
1738 4248 : if (rop == OMP_REDUCTION_NONE && udr)
1739 251 : rop = OMP_REDUCTION_USER;
1740 :
1741 4248 : if (gfc_match_omp_variable_list (" :", &c->lists[list_idx], false, NULL,
1742 : &head, openacc, allow_derived) != MATCH_YES)
1743 : {
1744 9 : gfc_current_locus = old_loc;
1745 9 : return MATCH_NO;
1746 : }
1747 4239 : gfc_omp_namelist *n;
1748 4239 : if (rop == OMP_REDUCTION_NONE)
1749 : {
1750 6 : n = *head;
1751 6 : *head = NULL;
1752 6 : gfc_error_now ("!$OMP DECLARE REDUCTION %s not found at %L",
1753 : buffer, &old_loc);
1754 6 : gfc_free_omp_namelist (n, OMP_LIST_NONE);
1755 : }
1756 : else
1757 9118 : for (n = *head; n; n = n->next)
1758 : {
1759 4885 : n->u.reduction_op = rop;
1760 4885 : if (udr)
1761 : {
1762 477 : n->u2.udr = gfc_get_omp_namelist_udr ();
1763 477 : n->u2.udr->udr = udr;
1764 : }
1765 4885 : if (openmp_target && list_idx == OMP_LIST_IN_REDUCTION)
1766 : {
1767 40 : gfc_omp_namelist *p = gfc_get_omp_namelist (), **tl;
1768 40 : p->sym = n->sym;
1769 40 : p->where = n->where;
1770 40 : p->u.map.op = OMP_MAP_ALWAYS_TOFROM;
1771 :
1772 40 : tl = &c->lists[OMP_LIST_MAP];
1773 52 : while (*tl)
1774 12 : tl = &((*tl)->next);
1775 40 : *tl = p;
1776 40 : p->next = NULL;
1777 : }
1778 : }
1779 : return MATCH_YES;
1780 : }
1781 :
1782 : static match
1783 47 : gfc_omp_absent_contains_clause (gfc_omp_assumptions **assume, bool is_absent)
1784 : {
1785 47 : if (*assume == NULL)
1786 22 : *assume = gfc_get_omp_assumptions ();
1787 77 : do
1788 : {
1789 62 : gfc_statement st = ST_NONE;
1790 62 : gfc_gobble_whitespace ();
1791 62 : locus old_loc = gfc_current_locus;
1792 62 : char c = gfc_peek_ascii_char ();
1793 62 : enum gfc_omp_directive_kind kind
1794 : = GFC_OMP_DIR_DECLARATIVE; /* Silence warning. */
1795 2369 : for (size_t i = 0; i < ARRAY_SIZE (gfc_omp_directives); i++)
1796 : {
1797 2307 : if (gfc_omp_directives[i].name[0] > c)
1798 : break;
1799 2245 : if (gfc_omp_directives[i].name[0] != c)
1800 1668 : continue;
1801 577 : if (gfc_match (gfc_omp_directives[i].name) == MATCH_YES)
1802 : {
1803 62 : st = gfc_omp_directives[i].st;
1804 62 : kind = gfc_omp_directives[i].kind;
1805 : }
1806 : }
1807 62 : gfc_gobble_whitespace ();
1808 62 : c = gfc_peek_ascii_char ();
1809 62 : if (st == ST_NONE || (c != ',' && c != ')'))
1810 : {
1811 0 : if (st == ST_NONE)
1812 0 : gfc_error ("Unknown directive at %L", &old_loc);
1813 : else
1814 0 : gfc_error ("Invalid combined or composite directive at %L",
1815 : &old_loc);
1816 9 : return MATCH_ERROR;
1817 : }
1818 62 : if (kind == GFC_OMP_DIR_DECLARATIVE
1819 62 : || kind == GFC_OMP_DIR_INFORMATIONAL
1820 : || kind == GFC_OMP_DIR_META)
1821 : {
1822 15 : gfc_error ("Invalid %qs directive at %L in %s clause: declarative, "
1823 : "informational, and meta directives not permitted",
1824 : gfc_ascii_statement (st, true), &old_loc,
1825 : is_absent ? "ABSENT" : "CONTAINS");
1826 9 : return MATCH_ERROR;
1827 : }
1828 53 : if (is_absent)
1829 : {
1830 : /* Use exponential allocation; equivalent to pow2p(x). */
1831 38 : int i = (*assume)->n_absent;
1832 38 : int size = ((i == 0) ? 4
1833 14 : : pow2p_hwi (i) == 1 ? i*2 : 0);
1834 11 : if (size != 0)
1835 35 : (*assume)->absent = XRESIZEVEC (gfc_statement,
1836 : (*assume)->absent, size);
1837 38 : (*assume)->absent[(*assume)->n_absent++] = st;
1838 : }
1839 : else
1840 : {
1841 15 : int i = (*assume)->n_contains;
1842 15 : int size = ((i == 0) ? 4
1843 4 : : pow2p_hwi (i) == 1 ? i*2 : 0);
1844 4 : if (size != 0)
1845 15 : (*assume)->contains = XRESIZEVEC (gfc_statement,
1846 : (*assume)->contains, size);
1847 15 : (*assume)->contains[(*assume)->n_contains++] = st;
1848 : }
1849 53 : gfc_gobble_whitespace ();
1850 53 : if (gfc_match(",") == MATCH_YES)
1851 15 : continue;
1852 38 : if (gfc_match(")") == MATCH_YES)
1853 : break;
1854 0 : gfc_error ("Expected %<,%> or %<)%> at %C");
1855 0 : return MATCH_ERROR;
1856 15 : }
1857 : while (true);
1858 :
1859 38 : return MATCH_YES;
1860 : }
1861 :
1862 : /* Check 'check' argument for duplicated statements in absent and/or contains
1863 : clauses. If 'merge', merge them from check to 'merge'. */
1864 :
1865 : static match
1866 50 : omp_verify_merge_absent_contains (gfc_statement st, gfc_omp_assumptions *check,
1867 : gfc_omp_assumptions *merge, locus *loc)
1868 : {
1869 50 : if (check == NULL)
1870 : return MATCH_YES;
1871 49 : bitmap_head absent_head, contains_head;
1872 49 : bitmap_obstack_initialize (NULL);
1873 49 : bitmap_initialize (&absent_head, &bitmap_default_obstack);
1874 49 : bitmap_initialize (&contains_head, &bitmap_default_obstack);
1875 :
1876 49 : match m = MATCH_YES;
1877 87 : for (int i = 0; i < check->n_absent; i++)
1878 38 : if (!bitmap_set_bit (&absent_head, check->absent[i]))
1879 : {
1880 2 : gfc_error ("%qs directive mentioned multiple times in %s clause in %s "
1881 : "directive at %L",
1882 2 : gfc_ascii_statement (check->absent[i], true),
1883 : "ABSENT", gfc_ascii_statement (st), loc);
1884 2 : m = MATCH_ERROR;
1885 : }
1886 64 : for (int i = 0; i < check->n_contains; i++)
1887 : {
1888 15 : if (!bitmap_set_bit (&contains_head, check->contains[i]))
1889 : {
1890 2 : gfc_error ("%qs directive mentioned multiple times in %s clause in %s "
1891 : "directive at %L",
1892 2 : gfc_ascii_statement (check->contains[i], true),
1893 : "CONTAINS", gfc_ascii_statement (st), loc);
1894 2 : m = MATCH_ERROR;
1895 : }
1896 15 : if (bitmap_bit_p (&absent_head, check->contains[i]))
1897 : {
1898 2 : gfc_error ("%qs directive mentioned both times in ABSENT and CONTAINS "
1899 : "clauses in %s directive at %L",
1900 2 : gfc_ascii_statement (check->absent[i], true),
1901 : gfc_ascii_statement (st), loc);
1902 2 : m = MATCH_ERROR;
1903 : }
1904 : }
1905 :
1906 49 : if (m == MATCH_ERROR)
1907 : return MATCH_ERROR;
1908 43 : if (merge == NULL)
1909 : return MATCH_YES;
1910 3 : if (merge->absent == NULL && check->absent)
1911 : {
1912 1 : merge->n_absent = check->n_absent;
1913 1 : merge->absent = check->absent;
1914 1 : check->absent = NULL;
1915 : }
1916 2 : else if (merge->absent && check->absent)
1917 : {
1918 0 : check->absent = XRESIZEVEC (gfc_statement, check->absent,
1919 : merge->n_absent + check->n_absent);
1920 0 : for (int i = 0; i < merge->n_absent; i++)
1921 0 : if (!bitmap_bit_p (&absent_head, merge->absent[i]))
1922 0 : check->absent[check->n_absent++] = merge->absent[i];
1923 0 : free (merge->absent);
1924 0 : merge->absent = check->absent;
1925 0 : merge->n_absent = check->n_absent;
1926 0 : check->absent = NULL;
1927 : }
1928 3 : if (merge->contains == NULL && check->contains)
1929 : {
1930 0 : merge->n_contains = check->n_contains;
1931 0 : merge->contains = check->contains;
1932 0 : check->contains = NULL;
1933 : }
1934 3 : else if (merge->contains && check->contains)
1935 : {
1936 0 : check->contains = XRESIZEVEC (gfc_statement, check->contains,
1937 : merge->n_contains + check->n_contains);
1938 0 : for (int i = 0; i < merge->n_contains; i++)
1939 0 : if (!bitmap_bit_p (&contains_head, merge->contains[i]))
1940 0 : check->contains[check->n_contains++] = merge->contains[i];
1941 0 : free (merge->contains);
1942 0 : merge->contains = check->contains;
1943 0 : merge->n_contains = check->n_contains;
1944 0 : check->contains = NULL;
1945 : }
1946 : return MATCH_YES;
1947 : }
1948 :
1949 : /* OpenMP 5.0
1950 : uses_allocators ( allocator-list )
1951 :
1952 : allocator:
1953 : predefined-allocator
1954 : variable ( traits-array )
1955 :
1956 : OpenMP 5.2 deprecated, 6.0 deleted: 'variable ( traits-array )'
1957 :
1958 : OpenMP 5.2:
1959 : uses_allocators ( [modifier-list :] allocator-list )
1960 :
1961 : OpenMP 6.0:
1962 : uses_allocators ( [modifier-list :] allocator-list [; ...])
1963 :
1964 : allocator:
1965 : variable or predefined-allocator
1966 : modifier:
1967 : traits ( traits-array )
1968 : memspace ( mem-space-handle ) */
1969 :
1970 : static match
1971 78 : gfc_match_omp_clause_uses_allocators (gfc_omp_clauses *c)
1972 : {
1973 82 : parse_next:
1974 82 : gfc_symbol *memspace_sym = NULL;
1975 82 : gfc_symbol *traits_sym = NULL;
1976 82 : gfc_omp_namelist *head = NULL;
1977 82 : gfc_omp_namelist *p, *tail, **list;
1978 82 : int ntraits, nmemspace;
1979 82 : bool has_modifiers;
1980 82 : locus old_loc, cur_loc;
1981 :
1982 82 : gfc_gobble_whitespace ();
1983 82 : old_loc = gfc_current_locus;
1984 82 : ntraits = nmemspace = 0;
1985 126 : do
1986 : {
1987 104 : cur_loc = gfc_current_locus;
1988 104 : if (gfc_match ("traits ( %S ) ", &traits_sym) == MATCH_YES)
1989 34 : ntraits++;
1990 70 : else if (gfc_match ("memspace ( %S ) ", &memspace_sym) == MATCH_YES)
1991 33 : nmemspace++;
1992 104 : if (ntraits > 1 || nmemspace > 1)
1993 : {
1994 5 : gfc_error ("Duplicate %s modifier at %L in USES_ALLOCATORS clause",
1995 : ntraits > 1 ? "TRAITS" : "MEMSPACE", &cur_loc);
1996 5 : return MATCH_ERROR;
1997 : }
1998 99 : if (gfc_match (", ") == MATCH_YES)
1999 22 : continue;
2000 77 : if (gfc_match (": ") != MATCH_YES)
2001 : {
2002 : /* Assume no modifier. */
2003 39 : memspace_sym = traits_sym = NULL;
2004 39 : gfc_current_locus = old_loc;
2005 39 : break;
2006 : }
2007 : break;
2008 : } while (true);
2009 :
2010 115 : has_modifiers = traits_sym != NULL || memspace_sym != NULL;
2011 179 : do
2012 : {
2013 128 : p = gfc_get_omp_namelist ();
2014 128 : p->where = gfc_current_locus;
2015 128 : if (head == NULL)
2016 : head = tail = p;
2017 : else
2018 : {
2019 51 : tail->next = p;
2020 51 : tail = tail->next;
2021 : }
2022 128 : if (gfc_match ("%S ", &p->sym) != MATCH_YES)
2023 1 : goto error;
2024 127 : if (!has_modifiers)
2025 : {
2026 83 : if (gfc_match ("( %S ) ", &p->u2.traits_sym) == MATCH_YES)
2027 22 : gfc_warning (OPT_Wdeprecated_openmp,
2028 : "The specification of arguments to "
2029 : "%<uses_allocators%> at %L where each item is of "
2030 : "the form %<allocator(traits)%> is deprecated since "
2031 : "OpenMP 5.2; instead use %<uses_allocators(traits(%s"
2032 22 : "): %s)%>", &p->where, p->u2.traits_sym->name,
2033 22 : p->sym->name);
2034 : }
2035 44 : else if (gfc_peek_ascii_char () == '(')
2036 : {
2037 1 : gfc_error ("Unexpected %<(%> at %C");
2038 1 : goto error;
2039 : }
2040 : else
2041 : {
2042 43 : p->u.memspace_sym = memspace_sym;
2043 43 : p->u2.traits_sym = traits_sym;
2044 : }
2045 126 : gfc_gobble_whitespace ();
2046 126 : const char c = gfc_peek_ascii_char ();
2047 126 : if (c == ';' || c == ')')
2048 : break;
2049 53 : if (c != ',')
2050 : {
2051 2 : gfc_error ("Expected %<,%>, %<)%> or %<;%> at %C");
2052 2 : goto error;
2053 : }
2054 51 : gfc_match_char (',');
2055 51 : gfc_gobble_whitespace ();
2056 51 : } while (true);
2057 :
2058 73 : list = &c->lists[OMP_LIST_USES_ALLOCATORS];
2059 91 : while (*list)
2060 18 : list = &(*list)->next;
2061 73 : *list = head;
2062 :
2063 73 : if (gfc_match_char (';') == MATCH_YES)
2064 4 : goto parse_next;
2065 :
2066 69 : gfc_match_char (')');
2067 69 : return MATCH_YES;
2068 :
2069 4 : error:
2070 4 : gfc_free_omp_namelist (head, OMP_LIST_USES_ALLOCATORS);
2071 4 : return MATCH_ERROR;
2072 : }
2073 :
2074 :
2075 : /* Match the 'prefer_type' modifier of the interop 'init' clause:
2076 : with either OpenMP 5.1's
2077 : prefer_type ( <const-int-expr|string literal> [, ...]
2078 : or
2079 : prefer_type ( '{' <fr(...) | attr (...)>, ...] '}' [, '{' ... '}' ] )
2080 : where 'fr' takes a constant expression or a string literal
2081 : and 'attr takes a list of string literals, starting with 'ompx_')
2082 :
2083 : For the foreign runtime identifiers, string values are converted to
2084 : their integer value; unknown string or integer values are set to
2085 : GOMP_INTEROP_IFR_KNOWN.
2086 :
2087 : Data format:
2088 : For the foreign runtime identifiers, string values are converted to
2089 : their integer value; unknown string or integer values are set to 0.
2090 :
2091 : Each item (a) GOMP_INTEROP_IFR_SEPARATOR
2092 : (b) for any 'fr', its integer value.
2093 : Note: Spec only permits 1 'fr' entry (6.0; changed after TR13)
2094 : (c) GOMP_INTEROP_IFR_SEPARATOR
2095 : (d) list of \0-terminated non-empty strings for 'attr'
2096 : (e) '\0'
2097 : Tailing '\0'. */
2098 :
2099 : static match
2100 82 : gfc_match_omp_prefer_type (char **type_str, int *type_str_len)
2101 : {
2102 82 : gfc_expr *e;
2103 82 : std::string type_string, attr_string;
2104 : /* New syntax. */
2105 82 : if (gfc_peek_ascii_char () == '{')
2106 115 : do
2107 : {
2108 85 : attr_string.clear ();
2109 85 : type_string += (char) GOMP_INTEROP_IFR_SEPARATOR;
2110 85 : if (gfc_match ("{ ") != MATCH_YES)
2111 : {
2112 1 : gfc_error ("Expected %<{%> at %C");
2113 1 : return MATCH_ERROR;
2114 : }
2115 : bool fr_found = false;
2116 148 : do
2117 : {
2118 116 : if (gfc_match ("fr ( ") == MATCH_YES)
2119 : {
2120 62 : if (fr_found)
2121 : {
2122 1 : gfc_error ("Duplicated %<fr%> preference-selector-name "
2123 : "at %C");
2124 1 : return MATCH_ERROR;
2125 : }
2126 61 : fr_found = true;
2127 61 : do
2128 : {
2129 61 : bool found_literal = false;
2130 61 : match m = MATCH_YES;
2131 61 : if (gfc_match_literal_constant (&e, false) == MATCH_YES)
2132 : found_literal = true;
2133 : else
2134 12 : m = gfc_match_expr (&e);
2135 12 : if (m != MATCH_YES
2136 61 : || !gfc_resolve_expr (e)
2137 61 : || e->rank != 0
2138 60 : || e->expr_type != EXPR_CONSTANT
2139 59 : || (e->ts.type != BT_INTEGER
2140 43 : && (!found_literal || e->ts.type != BT_CHARACTER))
2141 58 : || (e->ts.type == BT_INTEGER
2142 16 : && !mpz_fits_sint_p (e->value.integer))
2143 70 : || (e->ts.type == BT_CHARACTER
2144 42 : && (e->ts.kind != gfc_default_character_kind
2145 41 : || e->value.character.length == 0)))
2146 : {
2147 5 : gfc_error ("Expected constant scalar integer expression"
2148 : " or non-empty default-kind character "
2149 5 : "literal at %L", &e->where);
2150 5 : gfc_free_expr (e);
2151 5 : return MATCH_ERROR;
2152 : }
2153 56 : gfc_gobble_whitespace ();
2154 56 : int val;
2155 56 : if (e->ts.type == BT_INTEGER)
2156 : {
2157 16 : val = mpz_get_si (e->value.integer);
2158 16 : if (val < 1 || val > GOMP_INTEROP_IFR_LAST)
2159 : {
2160 0 : gfc_warning_now (OPT_Wopenmp,
2161 : "Unknown foreign runtime "
2162 : "identifier %qd at %L",
2163 : val, &e->where);
2164 0 : val = GOMP_INTEROP_IFR_UNKNOWN;
2165 : }
2166 : }
2167 : else
2168 : {
2169 40 : char *str = XALLOCAVEC (char,
2170 : e->value.character.length+1);
2171 229 : for (int i = 0; i < e->value.character.length + 1; i++)
2172 189 : str[i] = e->value.character.string[i];
2173 40 : if (memchr (str, '\0', e->value.character.length) != 0)
2174 : {
2175 0 : gfc_error ("Unexpected null character in character "
2176 : "literal at %L", &e->where);
2177 0 : return MATCH_ERROR;
2178 : }
2179 40 : val = omp_get_fr_id_from_name (str);
2180 40 : if (val == GOMP_INTEROP_IFR_UNKNOWN)
2181 2 : gfc_warning_now (OPT_Wopenmp,
2182 : "Unknown foreign runtime identifier "
2183 2 : "%qs at %L", str, &e->where);
2184 : }
2185 :
2186 56 : type_string += (char) val;
2187 56 : if (gfc_match (") ") == MATCH_YES)
2188 : break;
2189 4 : gfc_error ("Expected %<)%> at %C");
2190 4 : return MATCH_ERROR;
2191 : }
2192 : while (true);
2193 : }
2194 54 : else if (gfc_match ("attr ( ") == MATCH_YES)
2195 : {
2196 60 : do
2197 : {
2198 57 : if (gfc_match_literal_constant (&e, false) != MATCH_YES
2199 56 : || !gfc_resolve_expr (e)
2200 56 : || e->expr_type != EXPR_CONSTANT
2201 56 : || e->rank != 0
2202 56 : || e->ts.type != BT_CHARACTER
2203 113 : || e->ts.kind != gfc_default_character_kind)
2204 : {
2205 1 : gfc_error ("Expected default-kind character literal "
2206 1 : "at %L", &e->where);
2207 1 : gfc_free_expr (e);
2208 1 : return MATCH_ERROR;
2209 : }
2210 56 : gfc_gobble_whitespace ();
2211 56 : char *str = XALLOCAVEC (char, e->value.character.length+1);
2212 564 : for (int i = 0; i < e->value.character.length + 1; i++)
2213 508 : str[i] = e->value.character.string[i];
2214 56 : if (!startswith (str, "ompx_"))
2215 : {
2216 1 : gfc_error ("Character literal at %L must start with "
2217 : "%<ompx_%>", &e->where);
2218 1 : gfc_free_expr (e);
2219 1 : return MATCH_ERROR;
2220 : }
2221 55 : if (memchr (str, '\0', e->value.character.length) != 0
2222 55 : || memchr (str, ',', e->value.character.length) != 0)
2223 : {
2224 1 : gfc_error ("Unexpected null or %<,%> character in "
2225 : "character literal at %L", &e->where);
2226 1 : return MATCH_ERROR;
2227 : }
2228 54 : attr_string += str;
2229 54 : attr_string += '\0';
2230 54 : if (gfc_match (", ") == MATCH_YES)
2231 3 : continue;
2232 51 : if (gfc_match (") ") == MATCH_YES)
2233 : break;
2234 0 : gfc_error ("Expected %<,%> or %<)%> at %C");
2235 0 : return MATCH_ERROR;
2236 3 : }
2237 : while (true);
2238 : }
2239 : else
2240 : {
2241 0 : gfc_error ("Expected %<fr(%> or %<attr(%> at %C");
2242 0 : return MATCH_ERROR;
2243 : }
2244 103 : if (gfc_match (", ") == MATCH_YES)
2245 32 : continue;
2246 71 : if (gfc_match ("} ") == MATCH_YES)
2247 : break;
2248 2 : gfc_error ("Expected %<,%> or %<}%> at %C");
2249 2 : return MATCH_ERROR;
2250 32 : }
2251 : while (true);
2252 69 : type_string += (char) GOMP_INTEROP_IFR_SEPARATOR;
2253 69 : type_string += attr_string;
2254 69 : type_string += '\0';
2255 69 : if (gfc_match (", ") == MATCH_YES)
2256 30 : continue;
2257 39 : if (gfc_match (") ") == MATCH_YES)
2258 : break;
2259 1 : gfc_error ("Expected %<,%> or %<)%> at %C");
2260 1 : return MATCH_ERROR;
2261 30 : }
2262 : while (true);
2263 : else
2264 75 : do
2265 : {
2266 51 : type_string += (char) GOMP_INTEROP_IFR_SEPARATOR;
2267 51 : bool found_literal = false;
2268 51 : match m = MATCH_YES;
2269 51 : if (gfc_match_literal_constant (&e, false) == MATCH_YES)
2270 : found_literal = true;
2271 : else
2272 19 : m = gfc_match_expr (&e);
2273 19 : if (m != MATCH_YES
2274 51 : || !gfc_resolve_expr (e)
2275 51 : || e->rank != 0
2276 50 : || e->expr_type != EXPR_CONSTANT
2277 49 : || (e->ts.type != BT_INTEGER
2278 28 : && (!found_literal || e->ts.type != BT_CHARACTER))
2279 48 : || (e->ts.type == BT_INTEGER
2280 21 : && !mpz_fits_sint_p (e->value.integer))
2281 67 : || (e->ts.type == BT_CHARACTER
2282 27 : && (e->ts.kind != gfc_default_character_kind
2283 27 : || e->value.character.length == 0)))
2284 : {
2285 3 : gfc_error ("Expected constant scalar integer expression or "
2286 3 : "non-empty default-kind character literal at %L", &e->where);
2287 3 : gfc_free_expr (e);
2288 3 : return MATCH_ERROR;
2289 : }
2290 48 : gfc_gobble_whitespace ();
2291 48 : int val;
2292 48 : if (e->ts.type == BT_INTEGER)
2293 : {
2294 21 : val = mpz_get_si (e->value.integer);
2295 21 : if (val < 1 || val > GOMP_INTEROP_IFR_LAST)
2296 : {
2297 3 : gfc_warning_now (OPT_Wopenmp,
2298 : "Unknown foreign runtime identifier %qd at %L",
2299 : val, &e->where);
2300 3 : val = 0;
2301 : }
2302 : }
2303 : else
2304 : {
2305 27 : char *str = XALLOCAVEC (char, e->value.character.length+1);
2306 169 : for (int i = 0; i < e->value.character.length + 1; i++)
2307 142 : str[i] = e->value.character.string[i];
2308 27 : if (memchr (str, '\0', e->value.character.length) != 0)
2309 : {
2310 0 : gfc_error ("Unexpected null character in character "
2311 : "literal at %L", &e->where);
2312 0 : return MATCH_ERROR;
2313 : }
2314 27 : val = omp_get_fr_id_from_name (str);
2315 27 : if (val == GOMP_INTEROP_IFR_UNKNOWN)
2316 5 : gfc_warning_now (OPT_Wopenmp,
2317 : "Unknown foreign runtime identifier %qs at %L",
2318 5 : str, &e->where);
2319 : }
2320 48 : type_string += (char) val;
2321 48 : type_string += (char) GOMP_INTEROP_IFR_SEPARATOR;
2322 48 : type_string += '\0';
2323 48 : gfc_free_expr (e);
2324 48 : if (gfc_match (", ") == MATCH_YES)
2325 24 : continue;
2326 24 : if (gfc_match (") ") == MATCH_YES)
2327 : break;
2328 2 : gfc_error ("Expected %<,%> or %<)%> at %C");
2329 2 : return MATCH_ERROR;
2330 24 : }
2331 : while (true);
2332 60 : type_string += '\0';
2333 60 : *type_str_len = type_string.length();
2334 60 : *type_str = XNEWVEC (char, type_string.length ());
2335 60 : memcpy (*type_str, type_string.data (), type_string.length ());
2336 60 : return MATCH_YES;
2337 82 : }
2338 :
2339 :
2340 : /* Match OpenMP 5.1's 'init'-clause modifiers, used by the 'init' clause of
2341 : the 'interop' directive and the 'append_args' directive of 'declare variant'.
2342 : [prefer_type(...)][,][<target|targetsync>, ...])
2343 :
2344 : If is_init_clause, the modifier parsing ends with a ':'.
2345 : If not is_init_clause (i.e. append_args), the parsing ends with ')'. */
2346 :
2347 : static match
2348 164 : gfc_parser_omp_clause_init_modifiers (bool &target, bool &targetsync,
2349 : char **type_str, int &type_str_len,
2350 : bool is_init_clause)
2351 : {
2352 164 : target = false;
2353 164 : targetsync = false;
2354 164 : *type_str = NULL;
2355 164 : type_str_len = 0;
2356 286 : match m;
2357 :
2358 286 : do
2359 : {
2360 286 : if (gfc_match ("prefer_type ( ") == MATCH_YES)
2361 : {
2362 83 : if (*type_str)
2363 : {
2364 1 : gfc_error ("Duplicate %<prefer_type%> modifier at %C");
2365 1 : return MATCH_ERROR;
2366 : }
2367 82 : m = gfc_match_omp_prefer_type (type_str, &type_str_len);
2368 82 : if (m != MATCH_YES)
2369 : return m;
2370 60 : if (gfc_match (", ") == MATCH_YES)
2371 14 : continue;
2372 46 : if (is_init_clause)
2373 : {
2374 24 : if (gfc_match (": ") == MATCH_YES)
2375 : break;
2376 0 : gfc_error ("Expected %<,%> or %<:%> at %C");
2377 : }
2378 : else
2379 : {
2380 22 : if (gfc_match (") ") == MATCH_YES)
2381 : break;
2382 0 : gfc_error ("Expected %<,%> or %<)%> at %C");
2383 : }
2384 : return MATCH_ERROR;
2385 : }
2386 :
2387 203 : if (gfc_match ("prefer_type ") == MATCH_YES)
2388 : {
2389 2 : gfc_error ("Expected %<(%> after %<prefer_type%> at %C");
2390 2 : return MATCH_ERROR;
2391 : }
2392 :
2393 201 : if (gfc_match ("targetsync ") == MATCH_YES)
2394 : {
2395 57 : if (targetsync)
2396 : {
2397 3 : gfc_error ("Duplicate %<targetsync%> at %C");
2398 3 : return MATCH_ERROR;
2399 : }
2400 54 : targetsync = true;
2401 54 : if (gfc_match (", ") == MATCH_YES)
2402 13 : continue;
2403 41 : if (!is_init_clause)
2404 : {
2405 23 : if (gfc_match (") ") == MATCH_YES)
2406 : break;
2407 0 : gfc_error ("Expected %<,%> or %<)%> at %C");
2408 0 : return MATCH_ERROR;
2409 : }
2410 18 : if (gfc_match (": ") == MATCH_YES)
2411 : break;
2412 1 : gfc_error ("Expected %<,%> or %<:%> at %C");
2413 1 : return MATCH_ERROR;
2414 : }
2415 144 : if (gfc_match ("target ") == MATCH_YES)
2416 : {
2417 135 : if (target)
2418 : {
2419 3 : gfc_error ("Duplicate %<target%> at %C");
2420 3 : return MATCH_ERROR;
2421 : }
2422 132 : target = true;
2423 132 : if (gfc_match (", ") == MATCH_YES)
2424 95 : continue;
2425 37 : if (!is_init_clause)
2426 : {
2427 11 : if (gfc_match (") ") == MATCH_YES)
2428 : break;
2429 0 : gfc_error ("Expected %<,%> or %<)%> at %C");
2430 0 : return MATCH_ERROR;
2431 : }
2432 26 : if (gfc_match (": ") == MATCH_YES)
2433 : break;
2434 1 : gfc_error ("Expected %<,%> or %<:%> at %C");
2435 1 : return MATCH_ERROR;
2436 : }
2437 9 : gfc_error ("Expected %<prefer_type%>, %<target%>, or %<targetsync%> "
2438 : "at %C");
2439 9 : return MATCH_ERROR;
2440 : }
2441 : while (true);
2442 :
2443 122 : if (!target && !targetsync)
2444 : {
2445 4 : gfc_error ("Missing required %<target%> and/or %<targetsync%> "
2446 : "modifier at %C");
2447 4 : return MATCH_ERROR;
2448 : }
2449 : return MATCH_YES;
2450 : }
2451 :
2452 : /* Match OpenMP 5.1's 'init' clause for 'interop' objects:
2453 : init([prefer_type(...)][,][<target|targetsync>, ...] :] interop-obj-list) */
2454 :
2455 : static match
2456 108 : gfc_match_omp_init (gfc_omp_namelist **list)
2457 : {
2458 108 : bool target, targetsync;
2459 108 : char *type_str = NULL;
2460 108 : int type_str_len;
2461 108 : if (gfc_parser_omp_clause_init_modifiers (target, targetsync, &type_str,
2462 : type_str_len, true) == MATCH_ERROR)
2463 : return MATCH_ERROR;
2464 :
2465 64 : gfc_omp_namelist **head = NULL;
2466 64 : if (gfc_match_omp_variable_list ("", list, false, NULL, &head) != MATCH_YES)
2467 : return MATCH_ERROR;
2468 147 : for (gfc_omp_namelist *n = *head; n; n = n->next)
2469 : {
2470 84 : n->u.init.target = target;
2471 84 : n->u.init.targetsync = targetsync;
2472 84 : n->u.init.len = type_str_len;
2473 84 : n->u2.init_interop = type_str;
2474 : }
2475 : return MATCH_YES;
2476 : }
2477 :
2478 : /* Match boolean-type clause with duplicate check. Matches 'name' then matches
2479 : an optional '(const-logical-expr)'; already_set is used for the duplicate
2480 : check. If the clause is not matched NO is returned, if an error occurs ERROR
2481 : and otherwise YES. In the no-error case RES contains the value of the
2482 : expression or true if no expression exists.
2483 : If FALSE_OK, 'false' implies an absent clause, which can be repeated without
2484 : printing an error; that is the case for clause groups.
2485 : If DUPL_MSG is nonnull, the string is used as error message and must contain
2486 : %qs and %L in that order. */
2487 :
2488 : static match
2489 3748 : gfc_match_boolean_clause (bool *res, const char *name, bool already_set,
2490 : bool false_ok = false, const char *dupl_msg = NULL)
2491 : {
2492 3748 : gfc_expr *expr = NULL;
2493 3748 : match m;
2494 3748 : char c;
2495 3748 : locus old_loc = gfc_current_locus;
2496 3748 : locus old_loc2;
2497 3748 : if ((m = gfc_match (name)) != MATCH_YES)
2498 : return m;
2499 : /* Ensure that no partial string is matched. */
2500 2506 : if (gfc_current_form == FORM_FREE
2501 2506 : && gfc_match_eos () != MATCH_YES
2502 3254 : && ((c = gfc_peek_ascii_char ()) == '_' || ISALNUM (c)))
2503 : {
2504 1 : gfc_current_locus = old_loc;
2505 1 : return MATCH_NO;
2506 : }
2507 2505 : if (already_set && !false_ok)
2508 22 : goto dupl;
2509 2483 : if (gfc_match (" (") == MATCH_NO)
2510 : {
2511 2289 : if (already_set)
2512 3 : goto dupl;
2513 2286 : *res = true; /* Implicit boolean true. */
2514 2286 : return MATCH_YES;
2515 : }
2516 194 : old_loc2 = gfc_current_locus;
2517 194 : m = gfc_match_expr (&expr);
2518 194 : if (m != MATCH_YES
2519 193 : || gfc_match (" )") != MATCH_YES
2520 188 : || !gfc_resolve_expr (expr)
2521 188 : || expr->rank != 0
2522 187 : || expr->expr_type != EXPR_CONSTANT
2523 379 : || expr->ts.type != BT_LOGICAL)
2524 : {
2525 13 : gfc_free_expr (expr);
2526 13 : gfc_error ("Expected %<( const-logical-expr )%> at %L", &old_loc2);
2527 13 : return MATCH_ERROR;
2528 : }
2529 181 : if (already_set && expr->value.logical)
2530 4 : goto dupl;
2531 177 : *res = expr->value.logical;
2532 177 : gfc_free_expr (expr);
2533 177 : return MATCH_YES;
2534 :
2535 29 : dupl:
2536 29 : if (dupl_msg)
2537 12 : gfc_error (dupl_msg, name, &old_loc);
2538 : else
2539 17 : gfc_error ("Duplicated %qs clause at %L", name, &old_loc);
2540 : return MATCH_ERROR;
2541 : }
2542 :
2543 :
2544 : /* Match a clause from the atomic clauses set. */
2545 :
2546 : static match
2547 1231 : gfc_match_dupl_atomic (bool *res, const char *name, bool already_set)
2548 : {
2549 1231 : const char *msg = G_("Duplicated atomic clause: unexpected %qs clause at %L");
2550 0 : return gfc_match_boolean_clause (res, name, already_set, true, msg);
2551 : }
2552 :
2553 :
2554 : /* Match a clause from the memory-order clauses set. */
2555 :
2556 : static match
2557 451 : gfc_match_dupl_memorder (bool *res, const char *name, bool already_set)
2558 : {
2559 451 : const char *msg = G_("Duplicated memory-order clause: unexpected %qs clause "
2560 : "at %L");
2561 0 : return gfc_match_boolean_clause (res, name, already_set, true, msg);
2562 : }
2563 :
2564 :
2565 : /* Match a clause from the branch clauses set; interestingly, here
2566 : inbranch(false) branch(false/true) is not permitted! */
2567 :
2568 : static match
2569 62 : gfc_match_dupl_branch_clause (bool *res, const char *name, bool already_set)
2570 : {
2571 62 : const char *msg = G_("Duplicated branch clause: unexpected %qs clause "
2572 : "at %L");
2573 62 : return gfc_match_boolean_clause (res, name, already_set, false, msg);
2574 : }
2575 :
2576 :
2577 : /* Match with duplicate check. Matches 'name'. If expr != NULL, it
2578 : then matches '(expr)', otherwise, if open_parens is true,
2579 : it matches a ' ( ' after 'name'. */
2580 :
2581 : static match
2582 20373 : gfc_match_dupl_check (bool not_dupl, const char *name, bool open_parens = false,
2583 : gfc_expr **expr = NULL)
2584 : {
2585 20373 : match m;
2586 20373 : char c;
2587 20373 : locus old_loc = gfc_current_locus;
2588 20373 : if ((m = gfc_match (name)) != MATCH_YES)
2589 : return m;
2590 : /* Ensure that no partial string is matched. */
2591 16010 : if (gfc_current_form == FORM_FREE
2592 15512 : && gfc_match_eos () != MATCH_YES
2593 29058 : && ((c = gfc_peek_ascii_char ()) == '_' || ISALNUM (c)))
2594 : {
2595 12 : gfc_current_locus = old_loc;
2596 12 : return MATCH_NO;
2597 : }
2598 15998 : if (!not_dupl)
2599 : {
2600 46 : gfc_error ("Duplicated %qs clause at %L", name, &old_loc);
2601 46 : return MATCH_ERROR;
2602 : }
2603 15952 : if (open_parens || expr)
2604 : {
2605 10156 : if (gfc_match (" ( ") != MATCH_YES)
2606 : {
2607 25 : gfc_error ("Expected %<(%> after %qs at %C", name);
2608 25 : return MATCH_ERROR;
2609 : }
2610 10131 : if (expr)
2611 : {
2612 3404 : if (gfc_match ("%e )", expr) != MATCH_YES)
2613 : {
2614 9 : gfc_error ("Invalid expression after %<%s(%> at %C", name);
2615 9 : return MATCH_ERROR;
2616 : }
2617 : }
2618 : }
2619 : return MATCH_YES;
2620 : }
2621 :
2622 : /* Search upwards though namespace NS and its parents to find an
2623 : !$omp declare mapper named MAPPER_ID, for typespec TS. The default
2624 : mapper has mapper_id == "". */
2625 :
2626 : gfc_omp_udm *
2627 1002 : gfc_find_omp_udm (gfc_namespace *ns, const char *mapper_id, gfc_typespec *ts)
2628 : {
2629 1002 : gfc_symtree *st;
2630 :
2631 1002 : if (ns == NULL)
2632 0 : ns = gfc_current_ns;
2633 :
2634 1181 : do
2635 : {
2636 1181 : gfc_omp_udm *omp_udm;
2637 :
2638 1181 : st = gfc_find_symtree (ns->omp_udm_root, mapper_id);
2639 :
2640 1181 : if (st != NULL)
2641 : {
2642 29 : for (omp_udm = st->n.omp_udm; omp_udm; omp_udm = omp_udm->next)
2643 29 : if (gfc_compare_types (&omp_udm->ts, ts))
2644 : return omp_udm;
2645 : }
2646 :
2647 : /* Don't escape an interface block. */
2648 1154 : if (ns && !ns->has_import_set
2649 1154 : && ns->proc_name && ns->proc_name->attr.if_source == IFSRC_IFBODY)
2650 : break;
2651 :
2652 1154 : ns = ns->parent;
2653 : }
2654 1154 : while (ns != NULL);
2655 :
2656 : return NULL;
2657 : }
2658 :
2659 :
2660 : /* Match OpenMP and OpenACC directive clauses. MASK is a bitmask of
2661 : clauses that are allowed for a particular directive. */
2662 :
2663 : static match
2664 35216 : gfc_match_omp_clauses (gfc_omp_clauses **cp, const omp_mask mask,
2665 : bool first_no_comma = true, bool needs_space = true,
2666 : bool openacc = false, bool openmp_target = false,
2667 : gfc_omp_map_op default_map_op = OMP_MAP_TOFROM)
2668 : {
2669 35216 : bool error = false;
2670 35216 : bool bval;
2671 35216 : gfc_omp_clauses *c = gfc_get_omp_clauses ();
2672 35216 : gfc_omp_clauses *cfalse = openacc ? NULL : gfc_get_omp_clauses ();
2673 21348 : locus old_loc;
2674 : /* Determine whether we're dealing with an OpenACC directive that permits
2675 : derived type member accesses. This in particular disallows
2676 : "!$acc declare" from using such accesses, because it's not clear if/how
2677 : that should work. */
2678 21348 : bool allow_derived = (openacc
2679 13868 : && ((mask & OMP_CLAUSE_ATTACH)
2680 6326 : || (mask & OMP_CLAUSE_DETACH)));
2681 :
2682 35216 : gcc_checking_assert (OMP_MASK1_LAST <= 64 && OMP_MASK2_LAST <= 64);
2683 35216 : *cp = NULL;
2684 129422 : while (1)
2685 : {
2686 82319 : match m = MATCH_NO;
2687 82234 : if ((first_no_comma || (m = gfc_match_char (',')) != MATCH_YES)
2688 164108 : && (needs_space && gfc_match_space () != MATCH_YES))
2689 : break;
2690 77785 : needs_space = false;
2691 77785 : first_no_comma = false;
2692 77785 : gfc_gobble_whitespace ();
2693 77785 : bool end_colon;
2694 77785 : gfc_omp_namelist **head;
2695 77785 : old_loc = gfc_current_locus;
2696 77785 : char pc = gfc_peek_ascii_char ();
2697 77785 : if (pc == '\n' && m == MATCH_YES)
2698 : {
2699 1 : gfc_error ("Clause expected at %C after trailing comma");
2700 1 : goto error;
2701 : }
2702 77784 : switch (pc)
2703 : {
2704 1339 : case 'a':
2705 1339 : end_colon = false;
2706 1339 : head = NULL;
2707 1364 : if ((mask & OMP_CLAUSE_ASSUMPTIONS)
2708 1339 : && gfc_match ("absent ( ") == MATCH_YES)
2709 : {
2710 28 : if (gfc_omp_absent_contains_clause (&c->assume, true)
2711 : != MATCH_YES)
2712 3 : goto error;
2713 25 : continue;
2714 : }
2715 1311 : if ((mask & OMP_CLAUSE_ALIGNED)
2716 1311 : && gfc_match_omp_variable_list ("aligned (",
2717 : &c->lists[OMP_LIST_ALIGNED],
2718 : false, &end_colon,
2719 : &head) == MATCH_YES)
2720 : {
2721 112 : gfc_expr *alignment = NULL;
2722 112 : gfc_omp_namelist *n;
2723 :
2724 112 : if (end_colon && gfc_match (" %e )", &alignment) != MATCH_YES)
2725 : {
2726 0 : gfc_free_omp_namelist (*head, OMP_LIST_ALIGNED);
2727 0 : gfc_current_locus = old_loc;
2728 0 : *head = NULL;
2729 0 : break;
2730 : }
2731 268 : for (n = *head; n; n = n->next)
2732 156 : if (n->next && alignment)
2733 42 : n->expr = gfc_copy_expr (alignment);
2734 : else
2735 114 : n->expr = alignment;
2736 112 : continue;
2737 112 : }
2738 1218 : if ((mask & OMP_CLAUSE_MEMORDER)
2739 1234 : && (m = gfc_match_dupl_memorder (&bval, "acq_rel",
2740 35 : c->memorder != OMP_MEMORDER_UNSET)) != MATCH_NO)
2741 : {
2742 19 : if (m == MATCH_ERROR)
2743 0 : goto error;
2744 19 : if (bval)
2745 12 : c->memorder = OMP_MEMORDER_ACQ_REL;
2746 19 : continue;
2747 : }
2748 1196 : if ((mask & OMP_CLAUSE_MEMORDER)
2749 1196 : && (m = gfc_match_dupl_memorder (&bval, "acquire",
2750 16 : c->memorder != OMP_MEMORDER_UNSET)) != MATCH_NO)
2751 : {
2752 16 : if (m == MATCH_ERROR)
2753 0 : goto error;
2754 16 : if (bval)
2755 9 : c->memorder = OMP_MEMORDER_ACQUIRE;
2756 16 : continue;
2757 : }
2758 1164 : if ((mask & OMP_CLAUSE_AFFINITY)
2759 1164 : && gfc_match ("affinity ( ") == MATCH_YES)
2760 : {
2761 41 : gfc_namespace *ns_iter = NULL, *ns_curr = gfc_current_ns;
2762 41 : m = gfc_match_iterator (&ns_iter, true);
2763 41 : if (m == MATCH_ERROR)
2764 : break;
2765 31 : if (m == MATCH_YES && gfc_match (" : ") != MATCH_YES)
2766 : {
2767 1 : gfc_error ("Expected %<:%> at %C");
2768 1 : break;
2769 : }
2770 30 : if (ns_iter)
2771 18 : gfc_current_ns = ns_iter;
2772 30 : head = NULL;
2773 30 : m = gfc_match_omp_variable_list ("", &c->lists[OMP_LIST_AFFINITY],
2774 : false, NULL, &head, true);
2775 30 : gfc_current_ns = ns_curr;
2776 30 : if (m == MATCH_ERROR)
2777 : break;
2778 27 : if (ns_iter)
2779 : {
2780 45 : for (gfc_omp_namelist *n = *head; n; n = n->next)
2781 : {
2782 27 : n->u2.ns = ns_iter;
2783 27 : ns_iter->refs++;
2784 : }
2785 : }
2786 27 : continue;
2787 27 : }
2788 1123 : if ((mask & OMP_CLAUSE_ALLOCATE)
2789 1123 : && gfc_match ("allocate ( ") == MATCH_YES)
2790 : {
2791 281 : gfc_expr *allocator = NULL;
2792 281 : gfc_expr *align = NULL;
2793 281 : old_loc = gfc_current_locus;
2794 281 : if ((m = gfc_match ("allocator ( %e )", &allocator)) == MATCH_YES)
2795 50 : gfc_match (" , align ( %e )", &align);
2796 231 : else if ((m = gfc_match ("align ( %e )", &align)) == MATCH_YES)
2797 29 : gfc_match (" , allocator ( %e )", &allocator);
2798 :
2799 79 : if (m == MATCH_YES)
2800 : {
2801 79 : if (gfc_match (" : ") != MATCH_YES)
2802 : {
2803 5 : gfc_error ("Expected %<:%> at %C");
2804 8 : goto error;
2805 : }
2806 : }
2807 : else
2808 : {
2809 202 : m = gfc_match_expr (&allocator);
2810 202 : if (m == MATCH_YES && gfc_match (" : ") != MATCH_YES)
2811 : {
2812 : /* If no ":" then there is no allocator, we backtrack
2813 : and read the variable list. */
2814 101 : gfc_free_expr (allocator);
2815 101 : allocator = NULL;
2816 101 : gfc_current_locus = old_loc;
2817 : }
2818 : }
2819 276 : gfc_omp_namelist **head = NULL;
2820 276 : m = gfc_match_omp_variable_list ("", &c->lists[OMP_LIST_ALLOCATE],
2821 : true, NULL, &head);
2822 :
2823 276 : if (m != MATCH_YES)
2824 : {
2825 3 : gfc_free_expr (allocator);
2826 3 : gfc_free_expr (align);
2827 3 : gfc_error ("Expected variable list at %C");
2828 3 : goto error;
2829 : }
2830 :
2831 729 : for (gfc_omp_namelist *n = *head; n; n = n->next)
2832 : {
2833 456 : n->u2.allocator = allocator;
2834 456 : n->u.align = (align) ? gfc_copy_expr (align) : NULL;
2835 : }
2836 273 : gfc_free_expr (align);
2837 273 : continue;
2838 273 : }
2839 905 : if ((mask & OMP_CLAUSE_AT)
2840 842 : && (m = gfc_match_dupl_check (c->at == OMP_AT_UNSET, "at", true))
2841 : != MATCH_NO)
2842 : {
2843 69 : if (m == MATCH_ERROR)
2844 2 : goto error;
2845 67 : if (gfc_match ("compilation )") == MATCH_YES)
2846 15 : c->at = OMP_AT_COMPILATION;
2847 52 : else if (gfc_match ("execution )") == MATCH_YES)
2848 48 : c->at = OMP_AT_EXECUTION;
2849 : else
2850 : {
2851 4 : gfc_error ("Expected COMPILATION or EXECUTION in AT clause "
2852 : "at %C");
2853 4 : goto error;
2854 : }
2855 63 : continue;
2856 : }
2857 1416 : if ((mask & OMP_CLAUSE_ASYNC)
2858 773 : && (m = gfc_match_dupl_check (!c->async, "async")) != MATCH_NO)
2859 : {
2860 643 : if (m == MATCH_ERROR)
2861 0 : goto error;
2862 643 : c->async = true;
2863 643 : m = gfc_match (" ( %e )", &c->async_expr);
2864 643 : if (m == MATCH_ERROR)
2865 : {
2866 0 : gfc_current_locus = old_loc;
2867 0 : break;
2868 : }
2869 643 : else if (m == MATCH_NO)
2870 : {
2871 133 : c->async_expr
2872 133 : = gfc_get_constant_expr (BT_INTEGER,
2873 : gfc_default_integer_kind,
2874 : &gfc_current_locus);
2875 133 : mpz_set_si (c->async_expr->value.integer, GOMP_ASYNC_NOVAL);
2876 : }
2877 643 : continue;
2878 : }
2879 193 : if ((mask & OMP_CLAUSE_AUTO)
2880 130 : && (m = gfc_match_dupl_check (!c->par_auto, "auto"))
2881 : != MATCH_NO)
2882 : {
2883 63 : if (m == MATCH_ERROR)
2884 0 : goto error;
2885 63 : c->par_auto = true;
2886 63 : continue;
2887 : }
2888 128 : if ((mask & OMP_CLAUSE_ATTACH)
2889 62 : && gfc_match ("attach ( ") == MATCH_YES
2890 128 : && gfc_match_omp_map_clause (&c->lists[OMP_LIST_MAP],
2891 : OMP_MAP_ATTACH, false,
2892 : allow_derived))
2893 61 : continue;
2894 : break;
2895 36 : case 'b':
2896 70 : if ((mask & OMP_CLAUSE_BIND)
2897 36 : && (m = gfc_match_dupl_check (c->bind == OMP_BIND_UNSET, "bind",
2898 : true)) != MATCH_NO)
2899 : {
2900 36 : if (m == MATCH_ERROR)
2901 1 : goto error;
2902 35 : if (gfc_match ("teams )") == MATCH_YES)
2903 11 : c->bind = OMP_BIND_TEAMS;
2904 24 : else if (gfc_match ("parallel )") == MATCH_YES)
2905 15 : c->bind = OMP_BIND_PARALLEL;
2906 9 : else if (gfc_match ("thread )") == MATCH_YES)
2907 8 : c->bind = OMP_BIND_THREAD;
2908 : else
2909 : {
2910 1 : gfc_error ("Expected TEAMS, PARALLEL or THREAD as binding in "
2911 : "BIND at %C");
2912 1 : break;
2913 : }
2914 34 : continue;
2915 : }
2916 : break;
2917 7123 : case 'c':
2918 7399 : if ((mask & OMP_CLAUSE_CAPTURE)
2919 7571 : && (m = gfc_match_boolean_clause (&bval, "capture",
2920 448 : c->capture || cfalse->capture)) != MATCH_NO)
2921 : {
2922 277 : if (m == MATCH_ERROR)
2923 1 : goto error;
2924 276 : if (bval)
2925 273 : c->capture = true;
2926 : else
2927 3 : cfalse->capture = true;
2928 276 : continue;
2929 : }
2930 6846 : if (mask & OMP_CLAUSE_COLLAPSE)
2931 : {
2932 1996 : gfc_expr *cexpr = NULL;
2933 1996 : if ((m = gfc_match_dupl_check (!c->collapse, "collapse", true,
2934 : &cexpr)) != MATCH_NO)
2935 : {
2936 1506 : int collapse;
2937 1506 : if (m == MATCH_ERROR)
2938 0 : goto error;
2939 1506 : if (gfc_extract_int (cexpr, &collapse, -1))
2940 4 : collapse = 1;
2941 1502 : else if (collapse <= 0)
2942 : {
2943 8 : gfc_error_now ("COLLAPSE clause argument not constant "
2944 : "positive integer at %C");
2945 8 : collapse = 1;
2946 : }
2947 1506 : gfc_free_expr (cexpr);
2948 1506 : c->collapse = collapse;
2949 1506 : continue;
2950 1506 : }
2951 : }
2952 5510 : if ((mask & OMP_CLAUSE_COMPARE)
2953 5511 : && (m = gfc_match_boolean_clause (&bval, "compare",
2954 171 : c->compare || cfalse->compare)) != MATCH_NO)
2955 : {
2956 171 : if (m == MATCH_ERROR)
2957 1 : goto error;
2958 170 : if (bval)
2959 167 : c->compare = true;
2960 : else
2961 3 : cfalse->compare = true;
2962 170 : continue;
2963 : }
2964 5182 : if ((mask & OMP_CLAUSE_ASSUMPTIONS)
2965 5169 : && gfc_match ("contains ( ") == MATCH_YES)
2966 : {
2967 19 : if (gfc_omp_absent_contains_clause (&c->assume, false)
2968 : != MATCH_YES)
2969 6 : goto error;
2970 13 : continue;
2971 : }
2972 7266 : if ((mask & OMP_CLAUSE_COPY)
2973 3723 : && gfc_match ("copy ( ") == MATCH_YES
2974 7267 : && gfc_match_omp_map_clause (&c->lists[OMP_LIST_MAP],
2975 : OMP_MAP_TOFROM, true,
2976 : allow_derived))
2977 2116 : continue;
2978 3034 : if (mask & OMP_CLAUSE_COPYIN)
2979 : {
2980 2628 : if (openacc)
2981 : {
2982 2529 : if (gfc_match ("copyin ( ") == MATCH_YES)
2983 : {
2984 1458 : bool readonly = gfc_match ("readonly : ") == MATCH_YES;
2985 1458 : head = NULL;
2986 1458 : if (gfc_match_omp_variable_list ("",
2987 : &c->lists[OMP_LIST_MAP],
2988 : true, NULL, &head, true,
2989 : allow_derived)
2990 : == MATCH_YES)
2991 : {
2992 1452 : gfc_omp_namelist *n;
2993 3349 : for (n = *head; n; n = n->next)
2994 : {
2995 1897 : n->u.map.op = OMP_MAP_TO;
2996 1897 : n->u.map.readonly = readonly;
2997 : }
2998 1452 : continue;
2999 1452 : }
3000 : }
3001 : }
3002 99 : else if (gfc_match_omp_variable_list ("copyin (",
3003 : &c->lists[OMP_LIST_COPYIN],
3004 : true) == MATCH_YES)
3005 97 : continue;
3006 : }
3007 2556 : if ((mask & OMP_CLAUSE_COPYOUT)
3008 1216 : && gfc_match ("copyout ( ") == MATCH_YES
3009 2556 : && gfc_match_omp_map_clause (&c->lists[OMP_LIST_MAP],
3010 : OMP_MAP_FROM, true, allow_derived))
3011 1071 : continue;
3012 498 : if ((mask & OMP_CLAUSE_COPYPRIVATE)
3013 414 : && gfc_match_omp_variable_list ("copyprivate (",
3014 : &c->lists[OMP_LIST_COPYPRIVATE],
3015 : true) == MATCH_YES)
3016 84 : continue;
3017 651 : if ((mask & OMP_CLAUSE_CREATE)
3018 328 : && gfc_match ("create ( ") == MATCH_YES
3019 651 : && gfc_match_omp_map_clause (&c->lists[OMP_LIST_MAP],
3020 : OMP_MAP_ALLOC, true, allow_derived))
3021 321 : continue;
3022 : break;
3023 4190 : case 'd':
3024 4190 : if ((mask & OMP_CLAUSE_DEFAULTMAP)
3025 4190 : && gfc_match ("defaultmap ( ") == MATCH_YES)
3026 : {
3027 181 : enum gfc_omp_defaultmap behavior;
3028 181 : gfc_omp_defaultmap_category category
3029 : = OMP_DEFAULTMAP_CAT_UNCATEGORIZED;
3030 181 : if (gfc_match ("alloc ") == MATCH_YES)
3031 : behavior = OMP_DEFAULTMAP_ALLOC;
3032 175 : else if (gfc_match ("tofrom ") == MATCH_YES)
3033 : behavior = OMP_DEFAULTMAP_TOFROM;
3034 143 : else if (gfc_match ("to ") == MATCH_YES)
3035 : behavior = OMP_DEFAULTMAP_TO;
3036 133 : else if (gfc_match ("from ") == MATCH_YES)
3037 : behavior = OMP_DEFAULTMAP_FROM;
3038 130 : else if (gfc_match ("firstprivate ") == MATCH_YES)
3039 : behavior = OMP_DEFAULTMAP_FIRSTPRIVATE;
3040 95 : else if (gfc_match ("present ") == MATCH_YES)
3041 : behavior = OMP_DEFAULTMAP_PRESENT;
3042 91 : else if (gfc_match ("none ") == MATCH_YES)
3043 : behavior = OMP_DEFAULTMAP_NONE;
3044 10 : else if (gfc_match ("default ") == MATCH_YES)
3045 : behavior = OMP_DEFAULTMAP_DEFAULT;
3046 : else
3047 : {
3048 1 : gfc_error ("Expected ALLOC, TO, FROM, TOFROM, FIRSTPRIVATE, "
3049 : "PRESENT, NONE or DEFAULT at %C");
3050 1 : break;
3051 : }
3052 180 : if (')' == gfc_peek_ascii_char ())
3053 : ;
3054 102 : else if (gfc_match (": ") != MATCH_YES)
3055 : break;
3056 : else
3057 : {
3058 102 : if (gfc_match ("scalar ") == MATCH_YES)
3059 : category = OMP_DEFAULTMAP_CAT_SCALAR;
3060 67 : else if (gfc_match ("aggregate ") == MATCH_YES)
3061 : category = OMP_DEFAULTMAP_CAT_AGGREGATE;
3062 43 : else if (gfc_match ("allocatable ") == MATCH_YES)
3063 : category = OMP_DEFAULTMAP_CAT_ALLOCATABLE;
3064 31 : else if (gfc_match ("pointer ") == MATCH_YES)
3065 : category = OMP_DEFAULTMAP_CAT_POINTER;
3066 14 : else if (gfc_match ("all ") == MATCH_YES)
3067 : category = OMP_DEFAULTMAP_CAT_ALL;
3068 : else
3069 : {
3070 1 : gfc_error ("Expected SCALAR, AGGREGATE, ALLOCATABLE, "
3071 : "POINTER or ALL at %C");
3072 1 : break;
3073 : }
3074 : }
3075 1200 : for (int i = 0; i < OMP_DEFAULTMAP_CAT_NUM; ++i)
3076 : {
3077 1034 : if (i != category
3078 1034 : && category != OMP_DEFAULTMAP_CAT_UNCATEGORIZED
3079 486 : && category != OMP_DEFAULTMAP_CAT_ALL
3080 486 : && i != OMP_DEFAULTMAP_CAT_UNCATEGORIZED
3081 341 : && i != OMP_DEFAULTMAP_CAT_ALL)
3082 254 : continue;
3083 780 : if (c->defaultmap[i] != OMP_DEFAULTMAP_UNSET)
3084 : {
3085 13 : const char *pcategory = NULL;
3086 13 : switch (i)
3087 : {
3088 : case OMP_DEFAULTMAP_CAT_UNCATEGORIZED: break;
3089 3 : case OMP_DEFAULTMAP_CAT_ALL: pcategory = "ALL"; break;
3090 1 : case OMP_DEFAULTMAP_CAT_SCALAR: pcategory = "SCALAR"; break;
3091 2 : case OMP_DEFAULTMAP_CAT_AGGREGATE:
3092 2 : pcategory = "AGGREGATE";
3093 2 : break;
3094 1 : case OMP_DEFAULTMAP_CAT_ALLOCATABLE:
3095 1 : pcategory = "ALLOCATABLE";
3096 1 : break;
3097 : case OMP_DEFAULTMAP_CAT_POINTER:
3098 : pcategory = "POINTER";
3099 : break;
3100 0 : default: gcc_unreachable ();
3101 : }
3102 7 : if (i == OMP_DEFAULTMAP_CAT_UNCATEGORIZED)
3103 4 : gfc_error ("DEFAULTMAP at %C but prior DEFAULTMAP with "
3104 : "unspecified category");
3105 : else
3106 9 : gfc_error ("DEFAULTMAP at %C but prior DEFAULTMAP for "
3107 : "category %s", pcategory);
3108 13 : goto error;
3109 : }
3110 : }
3111 166 : c->defaultmap[category] = behavior;
3112 166 : if (gfc_match (")") != MATCH_YES)
3113 : break;
3114 166 : continue;
3115 166 : }
3116 4976 : if ((mask & OMP_CLAUSE_DEFAULT)
3117 4009 : && (m = gfc_match_dupl_check (c->default_sharing
3118 : == OMP_DEFAULT_UNKNOWN, "default",
3119 : true)) != MATCH_NO)
3120 : {
3121 1012 : if (m == MATCH_ERROR)
3122 6 : goto error;
3123 1006 : if (gfc_match ("none") == MATCH_YES)
3124 596 : c->default_sharing = OMP_DEFAULT_NONE;
3125 410 : else if (openacc)
3126 : {
3127 225 : if (gfc_match ("present") == MATCH_YES)
3128 195 : c->default_sharing = OMP_DEFAULT_PRESENT;
3129 : }
3130 : else
3131 : {
3132 185 : if (gfc_match ("firstprivate") == MATCH_YES)
3133 8 : c->default_sharing = OMP_DEFAULT_FIRSTPRIVATE;
3134 177 : else if (gfc_match ("private") == MATCH_YES)
3135 24 : c->default_sharing = OMP_DEFAULT_PRIVATE;
3136 153 : else if (gfc_match ("shared") == MATCH_YES)
3137 153 : c->default_sharing = OMP_DEFAULT_SHARED;
3138 : }
3139 1006 : if (c->default_sharing == OMP_DEFAULT_UNKNOWN)
3140 : {
3141 30 : if (openacc)
3142 30 : gfc_error ("Expected NONE or PRESENT in DEFAULT clause "
3143 : "at %C");
3144 : else
3145 0 : gfc_error ("Expected NONE, FIRSTPRIVATE, PRIVATE or SHARED "
3146 : "in DEFAULT clause at %C");
3147 30 : goto error;
3148 : }
3149 976 : if (gfc_match (" )") != MATCH_YES)
3150 9 : goto error;
3151 967 : continue;
3152 : }
3153 3305 : if ((mask & OMP_CLAUSE_DELETE)
3154 345 : && gfc_match ("delete ( ") == MATCH_YES
3155 3305 : && gfc_match_omp_map_clause (&c->lists[OMP_LIST_MAP],
3156 : OMP_MAP_RELEASE, true,
3157 : allow_derived))
3158 308 : continue;
3159 : /* DOACROSS: match 'doacross' and 'depend' with sink/source.
3160 : DEPEND: match 'depend' but not sink/source. */
3161 2689 : m = MATCH_NO;
3162 2689 : if (((mask & OMP_CLAUSE_DOACROSS)
3163 383 : && gfc_match ("doacross ( ") == MATCH_YES)
3164 3045 : || (((mask & OMP_CLAUSE_DEPEND) || (mask & OMP_CLAUSE_DOACROSS))
3165 1601 : && (m = gfc_match ("depend ( ")) == MATCH_YES))
3166 : {
3167 1101 : bool has_omp_all_memory;
3168 1101 : bool is_depend = m == MATCH_YES;
3169 1101 : gfc_namespace *ns_iter = NULL, *ns_curr = gfc_current_ns;
3170 1101 : match m_it = MATCH_NO;
3171 1101 : if (is_depend)
3172 1074 : m_it = gfc_match_iterator (&ns_iter, false);
3173 1074 : if (m_it == MATCH_ERROR)
3174 : break;
3175 1096 : if (m_it == MATCH_YES && gfc_match (" , ") != MATCH_YES)
3176 : break;
3177 1096 : m = MATCH_YES;
3178 1096 : gfc_omp_depend_doacross_op depend_op = OMP_DEPEND_OUT;
3179 1096 : if (gfc_match ("inoutset") == MATCH_YES)
3180 : depend_op = OMP_DEPEND_INOUTSET;
3181 1084 : else if (gfc_match ("inout") == MATCH_YES)
3182 : depend_op = OMP_DEPEND_INOUT;
3183 992 : else if (gfc_match ("in") == MATCH_YES)
3184 : depend_op = OMP_DEPEND_IN;
3185 704 : else if (gfc_match ("out") == MATCH_YES)
3186 : depend_op = OMP_DEPEND_OUT;
3187 442 : else if (gfc_match ("mutexinoutset") == MATCH_YES)
3188 : depend_op = OMP_DEPEND_MUTEXINOUTSET;
3189 424 : else if (gfc_match ("depobj") == MATCH_YES)
3190 : depend_op = OMP_DEPEND_DEPOBJ;
3191 387 : else if (gfc_match ("source") == MATCH_YES)
3192 : {
3193 143 : if (m_it == MATCH_YES)
3194 : {
3195 1 : gfc_error ("ITERATOR may not be combined with SOURCE "
3196 : "at %C");
3197 17 : goto error;
3198 : }
3199 142 : if (!(mask & OMP_CLAUSE_DOACROSS))
3200 : {
3201 1 : gfc_error ("SOURCE at %C not permitted as dependence-type"
3202 : " for this directive");
3203 1 : goto error;
3204 : }
3205 141 : if (c->doacross_source)
3206 : {
3207 0 : gfc_error ("Duplicated clause with SOURCE dependence-type"
3208 : " at %C");
3209 0 : goto error;
3210 : }
3211 141 : gfc_gobble_whitespace ();
3212 141 : m = gfc_match (": ");
3213 141 : if (m != MATCH_YES && !is_depend)
3214 : {
3215 1 : gfc_error ("Expected %<:%> at %C");
3216 1 : goto error;
3217 : }
3218 140 : if (gfc_match (")") != MATCH_YES
3219 146 : && !(m == MATCH_YES
3220 6 : && gfc_match ("omp_cur_iteration )") == MATCH_YES))
3221 : {
3222 2 : gfc_error ("Expected %<)%> or %<omp_cur_iteration)%> "
3223 : "at %C");
3224 2 : goto error;
3225 : }
3226 138 : if (is_depend)
3227 130 : gfc_warning (OPT_Wdeprecated_openmp,
3228 : "%<source%> modifier with %<depend%> clause "
3229 : "at %L deprecated since OpenMP 5.2, use with "
3230 : "%<doacross%>", &old_loc);
3231 138 : c->doacross_source = true;
3232 138 : c->depend_source = is_depend;
3233 1079 : continue;
3234 : }
3235 244 : else if (gfc_match ("sink ") == MATCH_YES)
3236 : {
3237 244 : if (!(mask & OMP_CLAUSE_DOACROSS))
3238 : {
3239 2 : gfc_error ("SINK at %C not permitted as dependence-type "
3240 : "for this directive");
3241 2 : goto error;
3242 : }
3243 242 : if (gfc_match (": ") != MATCH_YES)
3244 : {
3245 1 : gfc_error ("Expected %<:%> at %C");
3246 1 : goto error;
3247 : }
3248 241 : if (m_it == MATCH_YES)
3249 : {
3250 0 : gfc_error ("ITERATOR may not be combined with SINK "
3251 : "at %C");
3252 0 : goto error;
3253 : }
3254 241 : if (is_depend)
3255 226 : gfc_warning (OPT_Wdeprecated_openmp,
3256 : "%<sink%> modifier with %<depend%> clause at "
3257 : "%L deprecated since OpenMP 5.2, use with "
3258 : "%<doacross%>", &old_loc);
3259 241 : m = gfc_match_omp_doacross_sink (&c->lists[OMP_LIST_DEPEND],
3260 : is_depend);
3261 241 : if (m == MATCH_YES)
3262 238 : continue;
3263 3 : goto error;
3264 : }
3265 : else
3266 : m = MATCH_NO;
3267 709 : if (!(mask & OMP_CLAUSE_DEPEND))
3268 : {
3269 0 : gfc_error ("Expected dependence-type SINK or SOURCE at %C");
3270 0 : goto error;
3271 : }
3272 709 : head = NULL;
3273 709 : if (ns_iter)
3274 40 : gfc_current_ns = ns_iter;
3275 709 : if (m == MATCH_YES)
3276 709 : m = gfc_match_omp_variable_list (" : ",
3277 : &c->lists[OMP_LIST_DEPEND],
3278 : false, NULL, &head, true,
3279 : false, &has_omp_all_memory);
3280 709 : if (m != MATCH_YES)
3281 2 : goto error;
3282 707 : gfc_current_ns = ns_curr;
3283 707 : if (has_omp_all_memory && depend_op != OMP_DEPEND_INOUT
3284 21 : && depend_op != OMP_DEPEND_OUT)
3285 : {
3286 4 : gfc_error ("%<omp_all_memory%> used with DEPEND kind "
3287 : "other than OUT or INOUT at %C");
3288 4 : goto error;
3289 : }
3290 703 : gfc_omp_namelist *n;
3291 1437 : for (n = *head; n; n = n->next)
3292 : {
3293 734 : n->u.depend_doacross_op = depend_op;
3294 734 : n->u2.ns = ns_iter;
3295 734 : if (ns_iter)
3296 39 : ns_iter->refs++;
3297 : }
3298 703 : continue;
3299 703 : }
3300 1609 : if ((mask & OMP_CLAUSE_DESTROY)
3301 1588 : && gfc_match_omp_variable_list ("destroy (",
3302 : &c->lists[OMP_LIST_DESTROY],
3303 : true) == MATCH_YES)
3304 21 : continue;
3305 1693 : if ((mask & OMP_CLAUSE_DETACH)
3306 164 : && !openacc
3307 127 : && !c->detach
3308 1693 : && gfc_match_omp_detach (&c->detach) == MATCH_YES)
3309 126 : continue;
3310 1478 : if ((mask & OMP_CLAUSE_DETACH)
3311 38 : && openacc
3312 37 : && gfc_match ("detach ( ") == MATCH_YES
3313 1478 : && gfc_match_omp_map_clause (&c->lists[OMP_LIST_MAP],
3314 : OMP_MAP_DETACH, false,
3315 : allow_derived))
3316 37 : continue;
3317 1440 : if ((mask & OMP_CLAUSE_DEVICEPTR)
3318 87 : && gfc_match ("deviceptr ( ") == MATCH_YES
3319 1442 : && gfc_match_omp_map_clause (&c->lists[OMP_LIST_MAP],
3320 : OMP_MAP_FORCE_DEVICEPTR, false,
3321 : allow_derived))
3322 36 : continue;
3323 823 : if ((mask & OMP_CLAUSE_DEVICE_TYPE) && openacc
3324 444 : && gfc_match_dupl_check (!c->oacc_device_type_present,
3325 : "device_type", true) == MATCH_YES
3326 1700 : && match_oacc_device_type (c) == MATCH_YES)
3327 326 : continue;
3328 497 : if ((mask & OMP_CLAUSE_DEVICE_TYPE) && !openacc
3329 1421 : && gfc_match_dupl_check (c->device_type == OMP_DEVICE_TYPE_UNSET,
3330 : "device_type", true) == MATCH_YES)
3331 : {
3332 95 : if (gfc_match ("host") == MATCH_YES)
3333 32 : c->device_type = OMP_DEVICE_TYPE_HOST;
3334 63 : else if (gfc_match ("nohost") == MATCH_YES)
3335 24 : c->device_type = OMP_DEVICE_TYPE_NOHOST;
3336 39 : else if (gfc_match ("any") == MATCH_YES)
3337 38 : c->device_type = OMP_DEVICE_TYPE_ANY;
3338 : else
3339 : {
3340 1 : gfc_error ("Expected HOST, NOHOST or ANY at %C");
3341 1 : break;
3342 : }
3343 94 : if (gfc_match (" )") != MATCH_YES)
3344 : break;
3345 94 : continue;
3346 : }
3347 1054 : if ((mask & OMP_CLAUSE_DEVICE_NUM)
3348 947 : && (m = gfc_match_dupl_check (!c->device_num_expr,
3349 : "device_num")) != MATCH_NO)
3350 : {
3351 109 : if (m == MATCH_ERROR)
3352 2 : goto error;
3353 107 : if (gfc_match ("( %e )", &c->device_num_expr) != MATCH_YES)
3354 0 : goto error;
3355 107 : continue;
3356 : }
3357 886 : if ((mask & OMP_CLAUSE_DEVICE_RESIDENT)
3358 887 : && gfc_match_omp_variable_list
3359 49 : ("device_resident (",
3360 : &c->lists[OMP_LIST_DEVICE_RESIDENT], true) == MATCH_YES)
3361 48 : continue;
3362 1102 : if ((mask & OMP_CLAUSE_DEVICE)
3363 705 : && openacc
3364 314 : && gfc_match ("device ( ") == MATCH_YES
3365 1103 : && gfc_match_omp_map_clause (&c->lists[OMP_LIST_MAP],
3366 : OMP_MAP_FORCE_TO, true,
3367 : /* allow_derived = */ true))
3368 312 : continue;
3369 478 : if ((mask & OMP_CLAUSE_DEVICE)
3370 393 : && !openacc
3371 869 : && ((m = gfc_match_dupl_check (!c->device, "device", true))
3372 : != MATCH_NO))
3373 : {
3374 351 : if (m == MATCH_ERROR)
3375 0 : goto error;
3376 351 : c->ancestor = false;
3377 351 : if (gfc_match ("device_num : ") == MATCH_YES)
3378 : {
3379 18 : if (gfc_match ("%e )", &c->device) != MATCH_YES)
3380 : {
3381 1 : gfc_error ("Expected integer expression at %C");
3382 1 : break;
3383 : }
3384 : }
3385 333 : else if (gfc_match ("ancestor : ") == MATCH_YES)
3386 : {
3387 45 : bool has_requires = false;
3388 45 : c->ancestor = true;
3389 82 : for (gfc_namespace *ns = gfc_current_ns; ns; ns = ns->parent)
3390 80 : if (ns->omp_requires & OMP_REQ_REVERSE_OFFLOAD)
3391 : {
3392 : has_requires = true;
3393 : break;
3394 : }
3395 45 : if (!has_requires)
3396 : {
3397 2 : gfc_error ("%<ancestor%> device modifier not "
3398 : "preceded by %<requires%> directive "
3399 : "with %<reverse_offload%> clause at %C");
3400 5 : break;
3401 : }
3402 43 : locus old_loc2 = gfc_current_locus;
3403 43 : if (gfc_match ("%e )", &c->device) == MATCH_YES)
3404 : {
3405 43 : int device = 0;
3406 43 : if (!gfc_extract_int (c->device, &device) && device != 1)
3407 : {
3408 1 : gfc_current_locus = old_loc2;
3409 1 : gfc_error ("the %<device%> clause expression must "
3410 : "evaluate to %<1%> at %C");
3411 1 : break;
3412 : }
3413 : }
3414 : else
3415 : {
3416 0 : gfc_error ("Expected integer expression at %C");
3417 0 : break;
3418 : }
3419 : }
3420 288 : else if (gfc_match ("%e )", &c->device) != MATCH_YES)
3421 : {
3422 13 : gfc_error ("Expected integer expression or a single device-"
3423 : "modifier %<device_num%> or %<ancestor%> at %C");
3424 13 : break;
3425 : }
3426 334 : continue;
3427 334 : }
3428 127 : if ((mask & OMP_CLAUSE_DIST_SCHEDULE)
3429 97 : && c->dist_sched_kind == OMP_SCHED_NONE
3430 224 : && gfc_match ("dist_schedule ( static") == MATCH_YES)
3431 : {
3432 97 : m = MATCH_NO;
3433 97 : c->dist_sched_kind = OMP_SCHED_STATIC;
3434 97 : m = gfc_match (" , %e )", &c->dist_chunk_size);
3435 97 : if (m != MATCH_YES)
3436 14 : m = gfc_match_char (')');
3437 14 : if (m != MATCH_YES)
3438 : {
3439 0 : c->dist_sched_kind = OMP_SCHED_NONE;
3440 0 : gfc_current_locus = old_loc;
3441 : }
3442 : else
3443 97 : continue;
3444 : }
3445 41 : if ((mask & OMP_CLAUSE_DYN_GROUPPRIVATE)
3446 30 : && gfc_match_dupl_check (!c->dyn_groupprivate,
3447 : "dyn_groupprivate", true) == MATCH_YES)
3448 : {
3449 12 : if (gfc_match ("fallback ( abort ) : ") == MATCH_YES)
3450 1 : c->fallback = OMP_FALLBACK_ABORT;
3451 11 : else if (gfc_match ("fallback ( default_mem ) : ") == MATCH_YES)
3452 1 : c->fallback = OMP_FALLBACK_DEFAULT_MEM;
3453 10 : else if (gfc_match ("fallback ( null ) : ") == MATCH_YES)
3454 1 : c->fallback = OMP_FALLBACK_NULL;
3455 12 : if (gfc_match_expr (&c->dyn_groupprivate) != MATCH_YES)
3456 0 : return MATCH_ERROR;
3457 12 : if (gfc_match (" )") != MATCH_YES)
3458 1 : goto error;
3459 11 : continue;
3460 : }
3461 : break;
3462 98 : case 'e':
3463 98 : if ((mask & OMP_CLAUSE_ENTER))
3464 : {
3465 98 : m = gfc_match_omp_to_link ("enter (", &c->lists[OMP_LIST_ENTER]);
3466 98 : if (m == MATCH_ERROR)
3467 0 : goto error;
3468 98 : if (m == MATCH_YES)
3469 98 : continue;
3470 : }
3471 : break;
3472 2326 : case 'f':
3473 2375 : if ((mask & OMP_CLAUSE_FAIL)
3474 2326 : && (m = gfc_match_dupl_check (c->fail == OMP_MEMORDER_UNSET,
3475 : "fail", true)) != MATCH_NO)
3476 : {
3477 58 : if (m == MATCH_ERROR)
3478 3 : goto error;
3479 55 : if (gfc_match ("seq_cst") == MATCH_YES)
3480 6 : c->fail = OMP_MEMORDER_SEQ_CST;
3481 49 : else if (gfc_match ("acquire") == MATCH_YES)
3482 14 : c->fail = OMP_MEMORDER_ACQUIRE;
3483 35 : else if (gfc_match ("relaxed") == MATCH_YES)
3484 30 : c->fail = OMP_MEMORDER_RELAXED;
3485 : else
3486 : {
3487 5 : gfc_error ("Expected SEQ_CST, ACQUIRE or RELAXED at %C");
3488 5 : break;
3489 : }
3490 50 : if (gfc_match (" )") != MATCH_YES)
3491 1 : goto error;
3492 49 : continue;
3493 : }
3494 2311 : if ((mask & OMP_CLAUSE_FILTER)
3495 2268 : && (m = gfc_match_dupl_check (!c->filter, "filter", true,
3496 : &c->filter)) != MATCH_NO)
3497 : {
3498 44 : if (m == MATCH_ERROR)
3499 1 : goto error;
3500 43 : continue;
3501 : }
3502 2288 : if ((mask & OMP_CLAUSE_FINAL)
3503 2224 : && (m = gfc_match_dupl_check (!c->final_expr, "final", true,
3504 : &c->final_expr)) != MATCH_NO)
3505 : {
3506 64 : if (m == MATCH_ERROR)
3507 0 : goto error;
3508 64 : continue;
3509 : }
3510 2186 : if ((mask & OMP_CLAUSE_FINALIZE)
3511 2160 : && (m = gfc_match_dupl_check (!c->finalize, "finalize"))
3512 : != MATCH_NO)
3513 : {
3514 26 : if (m == MATCH_ERROR)
3515 0 : goto error;
3516 26 : c->finalize = true;
3517 26 : continue;
3518 : }
3519 3176 : if ((mask & OMP_CLAUSE_FIRSTPRIVATE)
3520 2134 : && gfc_match_omp_variable_list ("firstprivate (",
3521 : &c->lists[OMP_LIST_FIRSTPRIVATE],
3522 : true) == MATCH_YES)
3523 1042 : continue;
3524 2095 : if ((mask & OMP_CLAUSE_FROM)
3525 1092 : && gfc_match_motion_var_list ("from (", &c->lists[OMP_LIST_FROM],
3526 : &head) == MATCH_YES)
3527 1003 : continue;
3528 158 : if ((mask & OMP_CLAUSE_FULL)
3529 165 : && (m = gfc_match_boolean_clause (&bval, "full",
3530 76 : c->full || cfalse->full)) != MATCH_NO)
3531 : {
3532 76 : if (m == MATCH_ERROR)
3533 7 : goto error;
3534 69 : if (bval)
3535 68 : c->full = true;
3536 : else
3537 1 : cfalse->full = true;
3538 69 : continue;
3539 : }
3540 : break;
3541 1231 : case 'g':
3542 2423 : if ((mask & OMP_CLAUSE_GANG)
3543 1231 : && (m = gfc_match_dupl_check (!c->gang, "gang")) != MATCH_NO)
3544 : {
3545 1197 : if (m == MATCH_ERROR)
3546 0 : goto error;
3547 1197 : c->gang = true;
3548 1197 : m = match_oacc_clause_gwv (c, GOMP_DIM_GANG);
3549 1197 : if (m == MATCH_ERROR)
3550 : {
3551 5 : gfc_current_locus = old_loc;
3552 5 : break;
3553 : }
3554 1192 : continue;
3555 : }
3556 68 : if ((mask & OMP_CLAUSE_GRAINSIZE)
3557 34 : && (m = gfc_match_dupl_check (!c->grainsize, "grainsize", true))
3558 : != MATCH_NO)
3559 : {
3560 34 : if (m == MATCH_ERROR)
3561 0 : goto error;
3562 34 : if (gfc_match ("strict : ") == MATCH_YES)
3563 1 : c->grainsize_strict = true;
3564 34 : if (gfc_match (" %e )", &c->grainsize) != MATCH_YES)
3565 0 : goto error;
3566 34 : continue;
3567 : }
3568 : break;
3569 474 : case 'h':
3570 523 : if ((mask & OMP_CLAUSE_HAS_DEVICE_ADDR)
3571 523 : && gfc_match_omp_variable_list
3572 49 : ("has_device_addr (", &c->lists[OMP_LIST_HAS_DEVICE_ADDR],
3573 : false, NULL, NULL, true) == MATCH_YES)
3574 49 : continue;
3575 473 : if ((mask & OMP_CLAUSE_HINT)
3576 425 : && (m = gfc_match_dupl_check (!c->hint, "hint", true, &c->hint))
3577 : != MATCH_NO)
3578 : {
3579 48 : if (m == MATCH_ERROR)
3580 0 : goto error;
3581 48 : continue;
3582 : }
3583 377 : if ((mask & OMP_CLAUSE_ASSUMPTIONS)
3584 377 : && gfc_match ("holds ( ") == MATCH_YES)
3585 : {
3586 22 : gfc_expr *e;
3587 22 : if (gfc_match ("%e )", &e) != MATCH_YES)
3588 0 : goto error;
3589 22 : if (c->assume == NULL)
3590 15 : c->assume = gfc_get_omp_assumptions ();
3591 22 : gfc_expr_list *el = XCNEW (gfc_expr_list);
3592 22 : el->expr = e;
3593 22 : el->next = c->assume->holds;
3594 22 : c->assume->holds = el;
3595 22 : continue;
3596 22 : }
3597 709 : if ((mask & OMP_CLAUSE_HOST)
3598 355 : && gfc_match ("host ( ") == MATCH_YES
3599 710 : && gfc_match_omp_map_clause (&c->lists[OMP_LIST_MAP],
3600 : OMP_MAP_FORCE_FROM, true,
3601 : /* allow_derived = */ true))
3602 354 : continue;
3603 : break;
3604 2251 : case 'i':
3605 2274 : if ((mask & OMP_CLAUSE_IF_PRESENT)
3606 2251 : && (m = gfc_match_dupl_check (!c->if_present, "if_present"))
3607 : != MATCH_NO)
3608 : {
3609 23 : if (m == MATCH_ERROR)
3610 0 : goto error;
3611 23 : c->if_present = true;
3612 23 : continue;
3613 : }
3614 2228 : if ((mask & OMP_CLAUSE_IF)
3615 2228 : && (m = gfc_match_dupl_check (!c->if_expr, "if", true))
3616 : != MATCH_NO)
3617 : {
3618 1470 : if (m == MATCH_ERROR)
3619 14 : goto error;
3620 1456 : if (!openacc)
3621 : {
3622 : /* This should match the enum gfc_omp_if_kind order. */
3623 : static const char *ifs[OMP_IF_LAST] = {
3624 : "cancel : %e )",
3625 : "parallel : %e )",
3626 : "simd : %e )",
3627 : "task : %e )",
3628 : "taskloop : %e )",
3629 : "target : %e )",
3630 : "target data : %e )",
3631 : "target update : %e )",
3632 : "target enter data : %e )",
3633 : "target exit data : %e )" };
3634 : static const char *ifs2[] = {
3635 : "target_data : %e )",
3636 : "target_update : %e )",
3637 : "target_enter_data : %e )",
3638 : "target_exit_data : %e )" };
3639 : int i;
3640 4951 : for (i = 0; i < OMP_IF_LAST; i++)
3641 4543 : if (c->if_exprs[i] == NULL
3642 4543 : && gfc_match (ifs[i], &c->if_exprs[i]) == MATCH_YES)
3643 : break;
3644 546 : if (i < OMP_IF_LAST)
3645 138 : continue;
3646 2030 : for (i = 0; i < (int) ARRAY_SIZE (ifs2); i++)
3647 1626 : if (c->if_exprs[OMP_IF_TARGET_DATA + i] == NULL
3648 1626 : && (gfc_match (ifs2[i],
3649 : &c->if_exprs[OMP_IF_TARGET_DATA + i])
3650 : == MATCH_YES))
3651 : break;
3652 408 : if (i < (int) ARRAY_SIZE (ifs2))
3653 4 : continue;
3654 : }
3655 1314 : if (gfc_match (" %e )", &c->if_expr) == MATCH_YES)
3656 1309 : continue;
3657 5 : goto error;
3658 : }
3659 875 : if ((mask & OMP_CLAUSE_IN_REDUCTION)
3660 758 : && gfc_match_omp_clause_reduction (pc, c, openacc, allow_derived,
3661 : openmp_target) == MATCH_YES)
3662 117 : continue;
3663 668 : if ((mask & OMP_CLAUSE_INBRANCH)
3664 670 : && (m = gfc_match_dupl_branch_clause (&bval, "inbranch",
3665 29 : c->notinbranch || cfalse->notinbranch
3666 27 : || c->inbranch || cfalse->inbranch)) != MATCH_NO)
3667 : {
3668 29 : if (m == MATCH_ERROR)
3669 2 : goto error;
3670 27 : if (bval)
3671 25 : c->inbranch = true;
3672 : else
3673 2 : cfalse->inbranch = true;
3674 27 : continue;
3675 : }
3676 854 : if ((mask & OMP_CLAUSE_INDEPENDENT)
3677 612 : && (m = gfc_match_dupl_check (!c->independent, "independent"))
3678 : != MATCH_NO)
3679 : {
3680 242 : if (m == MATCH_ERROR)
3681 0 : goto error;
3682 242 : c->independent = true;
3683 242 : continue;
3684 : }
3685 426 : if ((mask & OMP_CLAUSE_INDIRECT)
3686 431 : && (m = gfc_match_boolean_clause (&bval, "indirect",
3687 61 : c->indirect || cfalse->indirect)) != MATCH_NO)
3688 : {
3689 61 : if (m == MATCH_ERROR)
3690 5 : goto error;
3691 56 : if (bval)
3692 51 : c->indirect = true;
3693 : else
3694 5 : cfalse->indirect = true;
3695 56 : continue;
3696 : }
3697 309 : if ((mask & OMP_CLAUSE_INIT)
3698 309 : && gfc_match ("init ( ") == MATCH_YES)
3699 : {
3700 108 : m = gfc_match_omp_init (&c->lists[OMP_LIST_INIT]);
3701 108 : if (m == MATCH_YES)
3702 63 : continue;
3703 45 : goto error;
3704 : }
3705 201 : if ((mask & OMP_CLAUSE_INTEROP)
3706 201 : && (m = gfc_match_dupl_check (!c->lists[OMP_LIST_INTEROP],
3707 : "interop", true)) != MATCH_NO)
3708 : {
3709 : /* Note: the interop objects are saved in reverse order to match
3710 : the order in C/C++. */
3711 125 : if (m == MATCH_YES
3712 63 : && (gfc_match_omp_variable_list ("",
3713 : &c->lists[OMP_LIST_INTEROP],
3714 : false, NULL, NULL, false,
3715 : false, NULL, false, true)
3716 : == MATCH_YES))
3717 62 : continue;
3718 1 : goto error;
3719 : }
3720 258 : if ((mask & OMP_CLAUSE_IS_DEVICE_PTR)
3721 258 : && gfc_match_omp_variable_list
3722 120 : ("is_device_ptr (",
3723 : &c->lists[OMP_LIST_IS_DEVICE_PTR], false) == MATCH_YES)
3724 120 : continue;
3725 : break;
3726 2360 : case 'l':
3727 2360 : if ((mask & OMP_CLAUSE_LASTPRIVATE)
3728 2360 : && gfc_match ("lastprivate ( ") == MATCH_YES)
3729 : {
3730 1433 : bool conditional = gfc_match ("conditional : ") == MATCH_YES;
3731 1433 : head = NULL;
3732 1433 : if (gfc_match_omp_variable_list ("",
3733 : &c->lists[OMP_LIST_LASTPRIVATE],
3734 : false, NULL, &head) == MATCH_YES)
3735 : {
3736 1433 : gfc_omp_namelist *n;
3737 3741 : for (n = *head; n; n = n->next)
3738 2308 : n->u.lastprivate_conditional = conditional;
3739 1433 : continue;
3740 1433 : }
3741 0 : gfc_current_locus = old_loc;
3742 0 : break;
3743 : }
3744 927 : end_colon = false;
3745 927 : head = NULL;
3746 927 : if ((mask & OMP_CLAUSE_LINEAR)
3747 927 : && gfc_match ("linear (") == MATCH_YES)
3748 : {
3749 849 : bool old_linear_modifier = false;
3750 849 : gfc_omp_linear_op linear_op = OMP_LINEAR_DEFAULT;
3751 849 : gfc_expr *step = NULL;
3752 849 : locus saved_loc = gfc_current_locus;
3753 :
3754 849 : if (gfc_match_omp_variable_list (" ref (",
3755 : &c->lists[OMP_LIST_LINEAR],
3756 : false, NULL, &head)
3757 : == MATCH_YES)
3758 : {
3759 : linear_op = OMP_LINEAR_REF;
3760 : old_linear_modifier = true;
3761 : }
3762 821 : else if (gfc_match_omp_variable_list (" val (",
3763 : &c->lists[OMP_LIST_LINEAR],
3764 : false, NULL, &head)
3765 : == MATCH_YES)
3766 : {
3767 : linear_op = OMP_LINEAR_VAL;
3768 : old_linear_modifier = true;
3769 : }
3770 810 : else if (gfc_match_omp_variable_list (" uval (",
3771 : &c->lists[OMP_LIST_LINEAR],
3772 : false, NULL, &head)
3773 : == MATCH_YES)
3774 : {
3775 : linear_op = OMP_LINEAR_UVAL;
3776 : old_linear_modifier = true;
3777 : }
3778 801 : else if (gfc_match_omp_variable_list ("",
3779 : &c->lists[OMP_LIST_LINEAR],
3780 : false, &end_colon, &head)
3781 : == MATCH_YES)
3782 : linear_op = OMP_LINEAR_DEFAULT;
3783 : else
3784 : {
3785 2 : gfc_current_locus = old_loc;
3786 2 : break;
3787 : }
3788 : if (linear_op != OMP_LINEAR_DEFAULT)
3789 : {
3790 48 : if (gfc_match (" :") == MATCH_YES)
3791 31 : end_colon = true;
3792 17 : else if (gfc_match (" )") != MATCH_YES)
3793 : {
3794 0 : gfc_free_omp_namelist (*head, OMP_LIST_LINEAR);
3795 0 : gfc_current_locus = old_loc;
3796 0 : *head = NULL;
3797 0 : break;
3798 : }
3799 : }
3800 847 : gfc_gobble_whitespace ();
3801 847 : if (old_linear_modifier && end_colon)
3802 : {
3803 31 : if (gfc_match (" %e )", &step) != MATCH_YES)
3804 : {
3805 1 : gfc_free_omp_namelist (*head, OMP_LIST_LINEAR);
3806 1 : gfc_current_locus = old_loc;
3807 1 : *head = NULL;
3808 5 : goto error;
3809 : }
3810 : }
3811 47 : if (old_linear_modifier)
3812 : {
3813 47 : char var_names[512]{};
3814 47 : int count, offset = 0;
3815 106 : for (gfc_omp_namelist *n = *head; n; n = n->next)
3816 : {
3817 59 : if (!n->next)
3818 47 : count = snprintf (var_names + offset,
3819 47 : sizeof (var_names) - offset,
3820 47 : "%s", n->sym->name);
3821 : else
3822 12 : count = snprintf (var_names + offset,
3823 12 : sizeof (var_names) - offset,
3824 12 : "%s, ", n->sym->name);
3825 59 : if (count < 0 || count >= ((int)sizeof (var_names))
3826 59 : - offset)
3827 : {
3828 0 : snprintf (var_names, 512, "%s, ..., ",
3829 0 : (*head)->sym->name);
3830 0 : while (n->next)
3831 : n = n->next;
3832 0 : offset = strlen (var_names);
3833 0 : snprintf (var_names + offset,
3834 0 : sizeof (var_names) - offset,
3835 0 : "%s", n->sym->name);
3836 0 : break;
3837 : }
3838 59 : offset += count;
3839 : }
3840 47 : char *var_names_for_warn = var_names;
3841 47 : const char *op_name;
3842 47 : switch (linear_op)
3843 : {
3844 : case OMP_LINEAR_REF: op_name = "ref"; break;
3845 10 : case OMP_LINEAR_VAL: op_name = "val"; break;
3846 9 : case OMP_LINEAR_UVAL: op_name = "uval"; break;
3847 0 : default: gcc_unreachable ();
3848 : }
3849 47 : gfc_warning (OPT_Wdeprecated_openmp,
3850 : "Specification of the list items as "
3851 : "arguments to the modifiers at %L is "
3852 : "deprecated; since OpenMP 5.2, use "
3853 : "%<linear(%s : %s%s)%>", &saved_loc,
3854 : var_names_for_warn, op_name,
3855 47 : step == nullptr ? "" : ", step(...)");
3856 : }
3857 799 : else if (end_colon)
3858 : {
3859 732 : bool has_error = false;
3860 : bool has_modifiers = false;
3861 : bool has_step = false;
3862 732 : bool duplicate_step = false;
3863 732 : bool duplicate_mod = false;
3864 732 : while (true)
3865 : {
3866 732 : old_loc = gfc_current_locus;
3867 732 : bool close_paren = gfc_match ("val )") == MATCH_YES;
3868 732 : if (close_paren || gfc_match ("val , ") == MATCH_YES)
3869 : {
3870 23 : if (linear_op != OMP_LINEAR_DEFAULT)
3871 : {
3872 : duplicate_mod = true;
3873 : break;
3874 : }
3875 22 : linear_op = OMP_LINEAR_VAL;
3876 22 : has_modifiers = true;
3877 22 : if (close_paren)
3878 : break;
3879 16 : continue;
3880 : }
3881 709 : close_paren = gfc_match ("uval )") == MATCH_YES;
3882 709 : if (close_paren || gfc_match ("uval , ") == MATCH_YES)
3883 : {
3884 7 : if (linear_op != OMP_LINEAR_DEFAULT)
3885 : {
3886 : duplicate_mod = true;
3887 : break;
3888 : }
3889 7 : linear_op = OMP_LINEAR_UVAL;
3890 7 : has_modifiers = true;
3891 7 : if (close_paren)
3892 : break;
3893 2 : continue;
3894 : }
3895 702 : close_paren = gfc_match ("ref )") == MATCH_YES;
3896 702 : if (close_paren || gfc_match ("ref , ") == MATCH_YES)
3897 : {
3898 16 : if (linear_op != OMP_LINEAR_DEFAULT)
3899 : {
3900 : duplicate_mod = true;
3901 : break;
3902 : }
3903 15 : linear_op = OMP_LINEAR_REF;
3904 15 : has_modifiers = true;
3905 15 : if (close_paren)
3906 : break;
3907 7 : continue;
3908 : }
3909 686 : close_paren = (gfc_match ("step ( %e ) )", &step)
3910 : == MATCH_YES);
3911 697 : if (close_paren
3912 686 : || gfc_match ("step ( %e ) , ", &step) == MATCH_YES)
3913 : {
3914 50 : if (has_step)
3915 : {
3916 : duplicate_step = true;
3917 : break;
3918 : }
3919 49 : has_modifiers = has_step = true;
3920 49 : if (close_paren)
3921 : break;
3922 11 : continue;
3923 : }
3924 636 : if (!has_modifiers
3925 636 : && gfc_match ("%e )", &step) == MATCH_YES)
3926 : {
3927 636 : if ((step->expr_type == EXPR_FUNCTION
3928 635 : || step->expr_type == EXPR_VARIABLE)
3929 31 : && strcmp (step->symtree->name, "step") == 0)
3930 : {
3931 1 : gfc_current_locus = old_loc;
3932 1 : gfc_match ("step (");
3933 1 : has_error = true;
3934 : }
3935 : break;
3936 : }
3937 : has_error = true;
3938 : break;
3939 : }
3940 61 : if (duplicate_mod || duplicate_step)
3941 : {
3942 3 : gfc_error ("Multiple %qs modifiers specified at %C",
3943 : duplicate_mod ? "linear" : "step");
3944 3 : has_error = true;
3945 : }
3946 696 : if (has_error)
3947 : {
3948 4 : gfc_free_omp_namelist (*head, OMP_LIST_LINEAR);
3949 4 : *head = NULL;
3950 4 : goto error;
3951 : }
3952 : }
3953 842 : if (step == NULL)
3954 : {
3955 130 : step = gfc_get_constant_expr (BT_INTEGER,
3956 : gfc_default_integer_kind,
3957 : &old_loc);
3958 130 : mpz_set_si (step->value.integer, 1);
3959 : }
3960 842 : (*head)->expr = step;
3961 842 : if (linear_op != OMP_LINEAR_DEFAULT || old_linear_modifier)
3962 188 : for (gfc_omp_namelist *n = *head; n; n = n->next)
3963 : {
3964 100 : n->u.linear.op = linear_op;
3965 100 : n->u.linear.old_modifier = old_linear_modifier;
3966 : }
3967 842 : continue;
3968 842 : }
3969 82 : if ((mask & OMP_CLAUSE_LINK)
3970 78 : && openacc
3971 86 : && (gfc_match_oacc_clause_link ("link (",
3972 : &c->lists[OMP_LIST_LINK])
3973 : == MATCH_YES))
3974 4 : continue;
3975 123 : else if ((mask & OMP_CLAUSE_LINK)
3976 74 : && !openacc
3977 144 : && (gfc_match_omp_to_link ("link (",
3978 : &c->lists[OMP_LIST_LINK])
3979 : == MATCH_YES))
3980 49 : continue;
3981 46 : if ((mask & OMP_CLAUSE_LOCAL)
3982 25 : && (gfc_match_omp_to_link ("local (", &c->lists[OMP_LIST_LOCAL])
3983 : == MATCH_YES))
3984 21 : continue;
3985 : break;
3986 5962 : case 'm':
3987 5962 : if ((mask & OMP_CLAUSE_MAP)
3988 5962 : && gfc_match ("map ( ") == MATCH_YES)
3989 : {
3990 5856 : locus old_loc2 = gfc_current_locus;
3991 5856 : int always_modifier = 0;
3992 5856 : int close_modifier = 0;
3993 5856 : int present_modifier = 0;
3994 5856 : int mapper_modifier = 0;
3995 5856 : int iterator_modifier = 0;
3996 5856 : gfc_namespace *ns_iter = NULL, *ns_curr = gfc_current_ns;
3997 5856 : locus second_always_locus = old_loc2;
3998 5856 : locus second_close_locus = old_loc2;
3999 5856 : locus second_mapper_locus = old_loc2;
4000 5856 : locus second_present_locus = old_loc2;
4001 5856 : char mapper_id[GFC_MAX_SYMBOL_LEN + 1] = { '\0' };
4002 5856 : locus second_iterator_locus = old_loc2;
4003 :
4004 6524 : for (;;)
4005 : {
4006 6190 : locus current_locus = gfc_current_locus;
4007 6190 : if (gfc_match ("always ") == MATCH_YES)
4008 : {
4009 148 : if (always_modifier++ == 1)
4010 5 : second_always_locus = current_locus;
4011 : }
4012 6042 : else if (gfc_match ("close ") == MATCH_YES)
4013 : {
4014 69 : if (close_modifier++ == 1)
4015 5 : second_close_locus = current_locus;
4016 : }
4017 5973 : else if (gfc_match ("present ") == MATCH_YES)
4018 : {
4019 67 : if (present_modifier++ == 1)
4020 4 : second_present_locus = current_locus;
4021 : }
4022 5906 : else if (gfc_match ("mapper ( ") == MATCH_YES)
4023 : {
4024 8 : if (mapper_modifier++ == 1)
4025 0 : second_mapper_locus = current_locus;
4026 8 : m = gfc_match (" %n ) ", mapper_id);
4027 8 : if (m != MATCH_YES)
4028 0 : goto error;
4029 8 : if (strcmp (mapper_id, "default") == 0)
4030 3 : mapper_id[0] = '\0';
4031 : }
4032 5898 : else if (gfc_match_iterator (&ns_iter, true) == MATCH_YES)
4033 : {
4034 42 : if (iterator_modifier++ == 1)
4035 1 : second_iterator_locus = current_locus;
4036 : }
4037 : else
4038 : break;
4039 334 : if (gfc_match (", ") != MATCH_YES)
4040 62 : gfc_warning (OPT_Wdeprecated_openmp,
4041 : "The specification of modifiers without "
4042 : "comma separators for the %<map%> clause "
4043 : "at %C has been deprecated since "
4044 : "OpenMP 5.2");
4045 334 : }
4046 :
4047 5856 : gfc_omp_map_op map_op = default_map_op;
4048 5856 : int always_present_modifier
4049 5856 : = always_modifier && present_modifier;
4050 :
4051 5856 : if (gfc_match ("alloc : ") == MATCH_YES)
4052 799 : map_op = (present_modifier ? OMP_MAP_PRESENT_ALLOC
4053 : : OMP_MAP_ALLOC);
4054 5057 : else if (gfc_match ("tofrom : ") == MATCH_YES)
4055 954 : map_op = (always_present_modifier ? OMP_MAP_ALWAYS_PRESENT_TOFROM
4056 950 : : present_modifier ? OMP_MAP_PRESENT_TOFROM
4057 945 : : always_modifier ? OMP_MAP_ALWAYS_TOFROM
4058 : : OMP_MAP_TOFROM);
4059 4103 : else if (gfc_match ("to : ") == MATCH_YES)
4060 1815 : map_op = (always_present_modifier ? OMP_MAP_ALWAYS_PRESENT_TO
4061 1809 : : present_modifier ? OMP_MAP_PRESENT_TO
4062 1797 : : always_modifier ? OMP_MAP_ALWAYS_TO
4063 : : OMP_MAP_TO);
4064 2288 : else if (gfc_match ("from : ") == MATCH_YES)
4065 1656 : map_op = (always_present_modifier ? OMP_MAP_ALWAYS_PRESENT_FROM
4066 1652 : : present_modifier ? OMP_MAP_PRESENT_FROM
4067 1647 : : always_modifier ? OMP_MAP_ALWAYS_FROM
4068 : : OMP_MAP_FROM);
4069 632 : else if (gfc_match ("release : ") == MATCH_YES)
4070 : map_op = OMP_MAP_RELEASE;
4071 578 : else if (gfc_match ("delete : ") == MATCH_YES)
4072 : map_op = OMP_MAP_DELETE;
4073 : else
4074 : {
4075 501 : gfc_current_locus = old_loc2;
4076 501 : always_modifier = 0;
4077 501 : close_modifier = 0;
4078 501 : mapper_modifier = 0;
4079 : }
4080 :
4081 1579 : if (always_modifier > 1)
4082 : {
4083 5 : gfc_error ("too many %<always%> modifiers at %L",
4084 : &second_always_locus);
4085 24 : break;
4086 : }
4087 5851 : if (close_modifier > 1)
4088 : {
4089 4 : gfc_error ("too many %<close%> modifiers at %L",
4090 : &second_close_locus);
4091 4 : break;
4092 : }
4093 5847 : if (present_modifier > 1)
4094 : {
4095 4 : gfc_error ("too many %<present%> modifiers at %L",
4096 : &second_present_locus);
4097 4 : break;
4098 : }
4099 5843 : if (mapper_modifier > 1)
4100 : {
4101 0 : gfc_error ("too many %<mapper%> modifiers at %L",
4102 : &second_mapper_locus);
4103 0 : break;
4104 : }
4105 5843 : if (iterator_modifier > 1)
4106 : {
4107 1 : gfc_error ("too many %<iterator%> modifiers at %L",
4108 : &second_iterator_locus);
4109 1 : break;
4110 : }
4111 :
4112 5842 : head = NULL;
4113 5842 : if (ns_iter)
4114 40 : gfc_current_ns = ns_iter;
4115 5842 : m = gfc_match_omp_variable_list ("", &c->lists[OMP_LIST_MAP],
4116 : false, NULL, &head, true, true);
4117 5842 : gfc_current_ns = ns_curr;
4118 5842 : if (m == MATCH_YES)
4119 : {
4120 5837 : gfc_omp_namelist *n;
4121 13257 : for (n = *head; n; n = n->next)
4122 : {
4123 7420 : n->u.map.op = map_op;
4124 7420 : if (mapper_id[0] != '\0')
4125 : {
4126 5 : n->u3.udm = gfc_get_omp_namelist_udm ();
4127 5 : n->u3.udm->requested_mapper_id
4128 5 : = gfc_get_string ("%s", mapper_id);
4129 : }
4130 7420 : n->u2.ns = ns_iter;
4131 7420 : if (ns_iter)
4132 42 : ns_iter->refs++;
4133 : }
4134 5837 : continue;
4135 5837 : }
4136 5 : gfc_current_locus = old_loc;
4137 5 : break;
4138 : }
4139 140 : if ((mask & OMP_CLAUSE_MERGEABLE)
4140 140 : && (m = gfc_match_boolean_clause (&bval, "mergeable",
4141 34 : c->mergeable || cfalse->mergeable)) != MATCH_NO)
4142 : {
4143 34 : if (m == MATCH_ERROR)
4144 0 : goto error;
4145 34 : if (bval)
4146 34 : c->mergeable = true;
4147 : else
4148 0 : cfalse->mergeable = true;
4149 34 : continue;
4150 : }
4151 139 : if ((mask & OMP_CLAUSE_MESSAGE)
4152 72 : && (m = gfc_match_dupl_check (!c->message, "message", true,
4153 : &c->message)) != MATCH_NO)
4154 : {
4155 72 : if (m == MATCH_ERROR)
4156 5 : goto error;
4157 67 : continue;
4158 : }
4159 : break;
4160 3033 : case 'n':
4161 3085 : if ((mask & OMP_CLAUSE_NO_CREATE)
4162 1343 : && gfc_match ("no_create ( ") == MATCH_YES
4163 3085 : && gfc_match_omp_map_clause (&c->lists[OMP_LIST_MAP],
4164 : OMP_MAP_IF_PRESENT, true,
4165 : allow_derived))
4166 52 : continue;
4167 2984 : if ((mask & OMP_CLAUSE_ASSUMPTIONS)
4168 3015 : && ((m = gfc_match_boolean_clause (&bval, "no_openmp_constructs",
4169 34 : (c->assume && c->assume->no_openmp_constructs)
4170 31 : || (cfalse->assume && cfalse->assume->no_openmp_constructs)))
4171 : != MATCH_NO))
4172 : {
4173 4 : if (m == MATCH_ERROR)
4174 1 : goto error;
4175 3 : if (bval)
4176 : {
4177 2 : if (c->assume == NULL)
4178 0 : c->assume = gfc_get_omp_assumptions ();
4179 2 : c->assume->no_openmp_constructs = true;
4180 : }
4181 : else
4182 : {
4183 1 : if (cfalse->assume == NULL)
4184 0 : cfalse->assume = gfc_get_omp_assumptions ();
4185 1 : cfalse->assume->no_openmp_constructs = true;
4186 : }
4187 3 : continue;
4188 : }
4189 2992 : if ((mask & OMP_CLAUSE_ASSUMPTIONS)
4190 3007 : && ((m = gfc_match_boolean_clause (&bval, "no_openmp_routines",
4191 30 : (c->assume && c->assume->no_openmp_routines)
4192 29 : || (cfalse->assume && cfalse->assume->no_openmp_routines)))
4193 : != MATCH_NO))
4194 : {
4195 15 : if (m == MATCH_ERROR)
4196 0 : goto error;
4197 15 : if (bval)
4198 : {
4199 14 : if (c->assume == NULL)
4200 12 : c->assume = gfc_get_omp_assumptions ();
4201 14 : c->assume->no_openmp_routines = true;
4202 : }
4203 : else
4204 : {
4205 1 : if (cfalse->assume == NULL)
4206 0 : cfalse->assume = gfc_get_omp_assumptions ();
4207 1 : cfalse->assume->no_openmp_routines = true;
4208 : }
4209 15 : continue;
4210 : }
4211 2968 : if ((mask & OMP_CLAUSE_ASSUMPTIONS)
4212 2977 : && ((m = gfc_match_boolean_clause (&bval, "no_openmp",
4213 15 : (c->assume && c->assume->no_openmp)
4214 13 : || (cfalse->assume && cfalse->assume->no_openmp)))
4215 : != MATCH_NO))
4216 : {
4217 6 : if (m == MATCH_ERROR)
4218 0 : goto error;
4219 6 : if (bval)
4220 : {
4221 5 : if (c->assume == NULL)
4222 5 : c->assume = gfc_get_omp_assumptions ();
4223 5 : c->assume->no_openmp = true;
4224 : }
4225 : else
4226 : {
4227 1 : if (cfalse->assume == NULL)
4228 1 : cfalse->assume = gfc_get_omp_assumptions ();
4229 1 : cfalse->assume->no_openmp = true;
4230 : }
4231 6 : continue;
4232 : }
4233 2964 : if ((mask & OMP_CLAUSE_ASSUMPTIONS)
4234 2965 : && ((m = gfc_match_boolean_clause (&bval, "no_parallelism",
4235 9 : (c->assume && c->assume->no_parallelism)
4236 9 : || (cfalse->assume && cfalse->assume->no_parallelism)))
4237 : != MATCH_NO))
4238 : {
4239 8 : if (m == MATCH_ERROR)
4240 0 : goto error;
4241 8 : if (bval)
4242 : {
4243 7 : if (c->assume == NULL)
4244 6 : c->assume = gfc_get_omp_assumptions ();
4245 7 : c->assume->no_parallelism = true;
4246 : }
4247 : else
4248 : {
4249 1 : if (cfalse->assume == NULL)
4250 0 : cfalse->assume = gfc_get_omp_assumptions ();
4251 1 : cfalse->assume->no_parallelism = true;
4252 : }
4253 8 : continue;
4254 : }
4255 :
4256 2958 : if ((mask & OMP_CLAUSE_NOVARIANTS)
4257 2948 : && (m = gfc_match_dupl_check (!c->novariants, "novariants", true,
4258 : &c->novariants))
4259 : != MATCH_NO)
4260 : {
4261 12 : if (m == MATCH_ERROR)
4262 2 : goto error;
4263 10 : continue;
4264 : }
4265 2949 : if ((mask & OMP_CLAUSE_NOCONTEXT)
4266 2936 : && (m = gfc_match_dupl_check (!c->nocontext, "nocontext", true,
4267 : &c->nocontext))
4268 : != MATCH_NO)
4269 : {
4270 15 : if (m == MATCH_ERROR)
4271 2 : goto error;
4272 13 : continue;
4273 : }
4274 2935 : if ((mask & OMP_CLAUSE_NOGROUP)
4275 3005 : && ((m = gfc_match_boolean_clause (&bval, "nogroup",
4276 84 : c->nogroup || cfalse->nogroup))
4277 : != MATCH_NO))
4278 : {
4279 14 : if (m == MATCH_ERROR)
4280 0 : goto error;
4281 14 : if (bval)
4282 14 : c->nogroup = true;
4283 : else
4284 0 : cfalse->nogroup = true;
4285 14 : continue;
4286 : }
4287 3057 : if ((mask & OMP_CLAUSE_NOHOST)
4288 2907 : && (m = gfc_match_dupl_check (!c->nohost, "nohost")) != MATCH_NO)
4289 : {
4290 151 : if (m == MATCH_ERROR)
4291 1 : goto error;
4292 150 : c->nohost = true;
4293 150 : continue;
4294 : }
4295 2798 : if ((mask & OMP_CLAUSE_NOTEMPORAL)
4296 2756 : && gfc_match_omp_variable_list ("nontemporal (",
4297 : &c->lists[OMP_LIST_NONTEMPORAL],
4298 : true) == MATCH_YES)
4299 42 : continue;
4300 2744 : if ((mask & OMP_CLAUSE_NOTINBRANCH)
4301 2747 : && (m = gfc_match_dupl_branch_clause (&bval, "notinbranch",
4302 33 : c->notinbranch || cfalse->notinbranch
4303 33 : || c->inbranch || cfalse->inbranch)) != MATCH_NO)
4304 : {
4305 33 : if (m == MATCH_ERROR)
4306 3 : goto error;
4307 30 : if (bval)
4308 27 : c->notinbranch = true;
4309 : else
4310 3 : cfalse->notinbranch = true;
4311 30 : continue;
4312 : }
4313 2814 : if ((mask & OMP_CLAUSE_NOWAIT)
4314 2681 : && (m = gfc_match_dupl_check (!c->nowait, "nowait")) != MATCH_NO)
4315 : {
4316 136 : if (m == MATCH_ERROR)
4317 3 : goto error;
4318 133 : c->nowait = true;
4319 133 : continue;
4320 : }
4321 3227 : if ((mask & OMP_CLAUSE_NUM_GANGS)
4322 2545 : && (m = gfc_match_dupl_check (!c->num_gangs_expr, "num_gangs",
4323 : true)) != MATCH_NO)
4324 : {
4325 686 : if (m == MATCH_ERROR)
4326 2 : goto error;
4327 684 : if (gfc_match (" %e )", &c->num_gangs_expr) != MATCH_YES)
4328 2 : goto error;
4329 682 : continue;
4330 : }
4331 1885 : if ((mask & OMP_CLAUSE_NUM_TASKS)
4332 1859 : && (m = gfc_match_dupl_check (!c->num_tasks, "num_tasks", true))
4333 : != MATCH_NO)
4334 : {
4335 26 : if (m == MATCH_ERROR)
4336 0 : goto error;
4337 26 : if (gfc_match ("strict : ") == MATCH_YES)
4338 1 : c->num_tasks_strict = true;
4339 26 : if (gfc_match (" %e )", &c->num_tasks) != MATCH_YES)
4340 0 : goto error;
4341 26 : continue;
4342 : }
4343 1833 : if ((mask & OMP_CLAUSE_NUM_TEAMS)
4344 1833 : && (m = gfc_match_dupl_check (!c->num_teams_list,
4345 : "num_teams", true)) != MATCH_NO)
4346 : {
4347 174 : if (m == MATCH_ERROR)
4348 20 : goto error;
4349 172 : gfc_expr *expr;
4350 172 : if (gfc_match ("dims ( %e ) : ", &expr) == MATCH_YES
4351 172 : && match_omp_oacc_expr_list (NULL, &c->num_teams_list,
4352 : false, true) == MATCH_YES)
4353 : {
4354 19 : int num = 0;
4355 19 : gfc_expr_list *el;
4356 55 : for (el = c->num_teams_list; el; el = el->next)
4357 36 : ++num;
4358 19 : if (!gfc_resolve_expr (expr)
4359 19 : || expr->ts.type != BT_INTEGER
4360 18 : || expr->rank != 0
4361 17 : || expr->expr_type != EXPR_CONSTANT
4362 34 : || mpz_sgn (expr->value.integer) <= 0)
4363 : {
4364 5 : gfc_error ("DIMS must be a constant positive integer "
4365 5 : "at %L", &expr->where);
4366 5 : goto error;
4367 : }
4368 14 : if (mpz_cmp_si (expr->value.integer, num) != 0)
4369 : {
4370 1 : gfc_error ("The number of arguments (%d) must be the same"
4371 : " as specified for DIMS at %L", num,
4372 : &expr->where);
4373 1 : goto error;
4374 : }
4375 13 : c->num_teams_dims = true;
4376 154 : continue;
4377 13 : }
4378 153 : else if (gfc_match ("%e ", &expr) == MATCH_YES)
4379 : {
4380 150 : c->num_teams_list = gfc_get_expr_list();
4381 150 : c->num_teams_list->expr = expr;
4382 150 : if (gfc_peek_ascii_char () == ':')
4383 : {
4384 30 : expr = NULL;
4385 30 : if (gfc_match (": %e ", &expr) == MATCH_YES)
4386 : {
4387 29 : c->num_teams_list->next = gfc_get_expr_list();
4388 29 : c->num_teams_list->next->expr = expr;
4389 29 : if (gfc_match (") ") == MATCH_YES)
4390 27 : continue;
4391 : }
4392 : }
4393 120 : else if (gfc_match (") ") == MATCH_YES)
4394 114 : continue;
4395 : }
4396 12 : gfc_error ("Expected either %<[lower-expr : ] upper-expr%> or "
4397 : "%<dims(N): expr-list%> at %C");
4398 12 : goto error;
4399 : }
4400 1659 : if ((mask & OMP_CLAUSE_NUM_THREADS)
4401 1659 : && (m = gfc_match_dupl_check (!c->num_threads_list,
4402 : "num_threads", true, NULL))
4403 : != MATCH_NO)
4404 : {
4405 1018 : int nstrict = 0, nrelaxed = 0, ndims = 0;
4406 1018 : bool fail = false;
4407 1018 : gfc_expr *dims = NULL;
4408 1018 : locus old_loc = gfc_current_locus;
4409 :
4410 1018 : if (m == MATCH_ERROR)
4411 27 : goto error;
4412 1068 : while (true)
4413 : {
4414 1042 : if (gfc_match ("strict ") == MATCH_YES)
4415 16 : nstrict++;
4416 1026 : else if (gfc_match ("relaxed ") == MATCH_YES)
4417 21 : nrelaxed++;
4418 1005 : else if (gfc_match ("dims ") == MATCH_YES)
4419 : {
4420 32 : ndims++;
4421 32 : if (dims)
4422 3 : gfc_free_expr (dims);
4423 32 : if (gfc_match ("( %e ) ", &dims) != MATCH_YES)
4424 : break;
4425 : }
4426 : else
4427 : {
4428 : fail = true;
4429 : break;
4430 : }
4431 68 : if (gfc_match (", ") == MATCH_YES)
4432 26 : continue;
4433 : break;
4434 : }
4435 1016 : if (gfc_match (" : ") == MATCH_YES)
4436 : {
4437 40 : if (nstrict + nrelaxed + ndims == 0 || fail)
4438 : {
4439 1 : gfc_error ("Expected STRICT, RELAXED or DIMS modifier at "
4440 : "%C");
4441 1 : goto error;
4442 : }
4443 39 : else if (nstrict + nrelaxed > 1)
4444 : {
4445 8 : gfc_error ("Only one STRICT or RELAXED modifier permitted"
4446 : " at %L", &old_loc);
4447 8 : goto error;
4448 : }
4449 31 : if (ndims > 1)
4450 : {
4451 3 : gfc_error ("Duplicated DIMS expression at %L",
4452 3 : &dims->where);
4453 3 : goto error;
4454 : }
4455 28 : if (nstrict || (dims && !nrelaxed))
4456 17 : c->num_threads_strict = true;
4457 : }
4458 : else
4459 : {
4460 976 : gfc_free_expr (dims);
4461 976 : dims = NULL;
4462 976 : gfc_current_locus = old_loc;
4463 : }
4464 :
4465 1004 : m = match_omp_oacc_expr_list (NULL, &c->num_threads_list, false,
4466 : true);
4467 1004 : if (m != MATCH_YES)
4468 : {
4469 7 : gfc_error ("Expected a list of integer expressions followed "
4470 : "by a %<)%> and optionally preceded by the STRICT,"
4471 : " RELAXED, or DIMS as modifiers and a colon at %C");
4472 7 : goto error;
4473 : }
4474 997 : if (dims)
4475 : {
4476 17 : int num = 0;
4477 17 : gfc_expr_list *el;
4478 46 : for (el = c->num_threads_list; el; el = el->next)
4479 29 : ++num;
4480 17 : if (!gfc_resolve_expr (dims)
4481 17 : || dims->ts.type != BT_INTEGER
4482 16 : || dims->rank != 0
4483 15 : || dims->expr_type != EXPR_CONSTANT
4484 30 : || mpz_sgn (dims->value.integer) <= 0)
4485 : {
4486 5 : gfc_error ("DIMS must be a constant positive integer "
4487 5 : "at %L", &dims->where);
4488 5 : goto error;
4489 : }
4490 12 : if (mpz_cmp_si (dims->value.integer, num) != 0)
4491 : {
4492 1 : gfc_error ("The number of arguments (%d) must be the same"
4493 : " as specified for DIMS at %L", num,
4494 : &dims->where);
4495 1 : goto error;
4496 : }
4497 11 : c->num_threads_dims = true;
4498 : }
4499 991 : continue;
4500 991 : }
4501 1240 : if ((mask & OMP_CLAUSE_NUM_WORKERS)
4502 641 : && (m = gfc_match_dupl_check (!c->num_workers_expr, "num_workers",
4503 : true, &c->num_workers_expr))
4504 : != MATCH_NO)
4505 : {
4506 603 : if (m == MATCH_ERROR)
4507 4 : goto error;
4508 599 : continue;
4509 : }
4510 : break;
4511 591 : case 'o':
4512 591 : if ((mask & OMP_CLAUSE_ORDERED)
4513 591 : && (m = gfc_match_dupl_check (!c->ordered, "ordered"))
4514 : != MATCH_NO)
4515 : {
4516 343 : if (m == MATCH_ERROR)
4517 0 : goto error;
4518 343 : gfc_expr *cexpr = NULL;
4519 343 : m = gfc_match (" ( %e )", &cexpr);
4520 :
4521 343 : c->ordered = true;
4522 343 : if (m == MATCH_YES)
4523 : {
4524 144 : int ordered = 0;
4525 144 : if (gfc_extract_int (cexpr, &ordered, -1))
4526 0 : ordered = 0;
4527 144 : else if (ordered <= 0)
4528 : {
4529 0 : gfc_error_now ("ORDERED clause argument not"
4530 : " constant positive integer at %C");
4531 0 : ordered = 0;
4532 : }
4533 144 : c->orderedc = ordered;
4534 144 : gfc_free_expr (cexpr);
4535 144 : continue;
4536 144 : }
4537 :
4538 199 : continue;
4539 199 : }
4540 482 : if ((mask & OMP_CLAUSE_ORDER)
4541 248 : && (m = gfc_match_dupl_check (!c->order_concurrent, "order", true))
4542 : != MATCH_NO)
4543 : {
4544 247 : if (m == MATCH_ERROR)
4545 10 : goto error;
4546 237 : if (gfc_match (" reproducible : concurrent )") == MATCH_YES)
4547 55 : c->order_reproducible = true;
4548 182 : else if (gfc_match (" concurrent )") == MATCH_YES)
4549 : ;
4550 50 : else if (gfc_match (" unconstrained : concurrent )") == MATCH_YES)
4551 47 : c->order_unconstrained = true;
4552 : else
4553 : {
4554 3 : gfc_error ("Expected ORDER(CONCURRENT) at %C "
4555 : "with optional %<reproducible%> or "
4556 : "%<unconstrained%> modifier");
4557 3 : goto error;
4558 : }
4559 234 : c->order_concurrent = true;
4560 234 : continue;
4561 : }
4562 : break;
4563 3107 : case 'p':
4564 3107 : if (mask & OMP_CLAUSE_PARTIAL)
4565 : {
4566 276 : if ((m = gfc_match_dupl_check (!c->partial, "partial"))
4567 : != MATCH_NO)
4568 : {
4569 276 : int expr;
4570 276 : if (m == MATCH_ERROR)
4571 0 : goto error;
4572 :
4573 276 : c->partial = -1;
4574 :
4575 276 : gfc_expr *cexpr = NULL;
4576 276 : m = gfc_match (" ( %e )", &cexpr);
4577 276 : if (m == MATCH_NO)
4578 : ;
4579 251 : else if (m == MATCH_YES
4580 251 : && !gfc_extract_int (cexpr, &expr, -1)
4581 502 : && expr > 0)
4582 247 : c->partial = expr;
4583 : else
4584 4 : gfc_error_now ("PARTIAL clause argument not constant "
4585 : "positive integer at %C");
4586 276 : gfc_free_expr (cexpr);
4587 276 : continue;
4588 276 : }
4589 : }
4590 2900 : if ((mask & OMP_CLAUSE_COPY)
4591 877 : && gfc_match ("pcopy ( ") == MATCH_YES
4592 2901 : && gfc_match_omp_map_clause (&c->lists[OMP_LIST_MAP],
4593 : OMP_MAP_TOFROM, true, allow_derived))
4594 69 : continue;
4595 2836 : if ((mask & OMP_CLAUSE_COPYIN)
4596 1910 : && gfc_match ("pcopyin ( ") == MATCH_YES
4597 2836 : && gfc_match_omp_map_clause (&c->lists[OMP_LIST_MAP],
4598 : OMP_MAP_TO, true, allow_derived))
4599 74 : continue;
4600 2761 : if ((mask & OMP_CLAUSE_COPYOUT)
4601 735 : && gfc_match ("pcopyout ( ") == MATCH_YES
4602 2761 : && gfc_match_omp_map_clause (&c->lists[OMP_LIST_MAP],
4603 : OMP_MAP_FROM, true, allow_derived))
4604 73 : continue;
4605 2630 : if ((mask & OMP_CLAUSE_CREATE)
4606 672 : && gfc_match ("pcreate ( ") == MATCH_YES
4607 2630 : && gfc_match_omp_map_clause (&c->lists[OMP_LIST_MAP],
4608 : OMP_MAP_ALLOC, true, allow_derived))
4609 15 : continue;
4610 3016 : if ((mask & OMP_CLAUSE_PRESENT)
4611 647 : && gfc_match ("present ( ") == MATCH_YES
4612 3018 : && gfc_match_omp_map_clause (&c->lists[OMP_LIST_MAP],
4613 : OMP_MAP_FORCE_PRESENT, false,
4614 : allow_derived))
4615 416 : continue;
4616 2207 : if ((mask & OMP_CLAUSE_COPY)
4617 231 : && gfc_match ("present_or_copy ( ") == MATCH_YES
4618 2207 : && gfc_match_omp_map_clause (&c->lists[OMP_LIST_MAP],
4619 : OMP_MAP_TOFROM, true,
4620 : allow_derived))
4621 23 : continue;
4622 2201 : if ((mask & OMP_CLAUSE_COPYIN)
4623 1309 : && gfc_match ("present_or_copyin ( ") == MATCH_YES
4624 2201 : && gfc_match_omp_map_clause (&c->lists[OMP_LIST_MAP],
4625 : OMP_MAP_TO, true, allow_derived))
4626 40 : continue;
4627 2156 : if ((mask & OMP_CLAUSE_COPYOUT)
4628 173 : && gfc_match ("present_or_copyout ( ") == MATCH_YES
4629 2156 : && gfc_match_omp_map_clause (&c->lists[OMP_LIST_MAP],
4630 : OMP_MAP_FROM, true, allow_derived))
4631 35 : continue;
4632 2114 : if ((mask & OMP_CLAUSE_CREATE)
4633 143 : && gfc_match ("present_or_create ( ") == MATCH_YES
4634 2114 : && gfc_match_omp_map_clause (&c->lists[OMP_LIST_MAP],
4635 : OMP_MAP_ALLOC, true, allow_derived))
4636 28 : continue;
4637 2092 : if ((mask & OMP_CLAUSE_PRIORITY)
4638 2058 : && (m = gfc_match_dupl_check (!c->priority, "priority", true,
4639 : &c->priority)) != MATCH_NO)
4640 : {
4641 34 : if (m == MATCH_ERROR)
4642 0 : goto error;
4643 34 : continue;
4644 : }
4645 3971 : if ((mask & OMP_CLAUSE_PRIVATE)
4646 2024 : && gfc_match_omp_variable_list ("private (",
4647 : &c->lists[OMP_LIST_PRIVATE],
4648 : true) == MATCH_YES)
4649 1947 : continue;
4650 141 : if ((mask & OMP_CLAUSE_PROC_BIND)
4651 141 : && (m = gfc_match_dupl_check ((c->proc_bind
4652 64 : == OMP_PROC_BIND_UNKNOWN),
4653 : "proc_bind", true)) != MATCH_NO)
4654 : {
4655 64 : if (m == MATCH_ERROR)
4656 0 : goto error;
4657 64 : if (gfc_match ("primary )") == MATCH_YES)
4658 1 : c->proc_bind = OMP_PROC_BIND_PRIMARY;
4659 63 : else if (gfc_match ("master )") == MATCH_YES)
4660 : {
4661 9 : gfc_warning (OPT_Wdeprecated_openmp,
4662 : "%<master%> affinity policy at %C deprecated "
4663 : "since OpenMP 5.1, use %<primary%>");
4664 9 : c->proc_bind = OMP_PROC_BIND_MASTER;
4665 : }
4666 54 : else if (gfc_match ("spread )") == MATCH_YES)
4667 53 : c->proc_bind = OMP_PROC_BIND_SPREAD;
4668 1 : else if (gfc_match ("close )") == MATCH_YES)
4669 1 : c->proc_bind = OMP_PROC_BIND_CLOSE;
4670 : else
4671 0 : goto error;
4672 64 : continue;
4673 : }
4674 : break;
4675 4613 : case 'r':
4676 5114 : if ((mask & OMP_CLAUSE_ATOMIC)
4677 5160 : && (m = gfc_match_dupl_atomic (&bval, "read",
4678 547 : c->atomic_op != GFC_OMP_ATOMIC_UNSET)) != MATCH_NO)
4679 : {
4680 501 : if (m == MATCH_ERROR)
4681 0 : goto error;
4682 501 : if (bval)
4683 493 : c->atomic_op = GFC_OMP_ATOMIC_READ;
4684 501 : continue;
4685 : }
4686 8169 : if ((mask & OMP_CLAUSE_REDUCTION)
4687 4112 : && gfc_match_omp_clause_reduction (pc, c, openacc,
4688 : allow_derived) == MATCH_YES)
4689 4057 : continue;
4690 74 : if ((mask & OMP_CLAUSE_MEMORDER)
4691 101 : && (m = gfc_match_dupl_memorder (&bval, "relaxed",
4692 46 : c->memorder != OMP_MEMORDER_UNSET)) != MATCH_NO)
4693 : {
4694 19 : if (m == MATCH_ERROR)
4695 0 : goto error;
4696 19 : if (bval)
4697 12 : c->memorder = OMP_MEMORDER_RELAXED;
4698 19 : continue;
4699 : }
4700 61 : if ((mask & OMP_CLAUSE_MEMORDER)
4701 63 : && (m = gfc_match_dupl_memorder (&bval, "release",
4702 27 : c->memorder != OMP_MEMORDER_UNSET)) != MATCH_NO)
4703 : {
4704 27 : if (m == MATCH_ERROR)
4705 2 : goto error;
4706 25 : if (bval)
4707 17 : c->memorder = OMP_MEMORDER_RELEASE;
4708 25 : continue;
4709 : }
4710 : break;
4711 3060 : case 's':
4712 3153 : if ((mask & OMP_CLAUSE_SAFELEN)
4713 3060 : && (m = gfc_match_dupl_check (!c->safelen_expr, "safelen",
4714 : true, &c->safelen_expr))
4715 : != MATCH_NO)
4716 : {
4717 93 : if (m == MATCH_ERROR)
4718 0 : goto error;
4719 93 : continue;
4720 : }
4721 2967 : if ((mask & OMP_CLAUSE_SCHEDULE)
4722 2967 : && (m = gfc_match_dupl_check (c->sched_kind == OMP_SCHED_NONE,
4723 : "schedule", true)) != MATCH_NO)
4724 : {
4725 809 : if (m == MATCH_ERROR)
4726 0 : goto error;
4727 809 : int nmodifiers = 0;
4728 809 : locus old_loc2 = gfc_current_locus;
4729 827 : do
4730 : {
4731 818 : if (gfc_match ("simd") == MATCH_YES)
4732 : {
4733 18 : c->sched_simd = true;
4734 18 : nmodifiers++;
4735 : }
4736 800 : else if (gfc_match ("monotonic") == MATCH_YES)
4737 : {
4738 30 : c->sched_monotonic = true;
4739 30 : nmodifiers++;
4740 : }
4741 770 : else if (gfc_match ("nonmonotonic") == MATCH_YES)
4742 : {
4743 35 : c->sched_nonmonotonic = true;
4744 35 : nmodifiers++;
4745 : }
4746 : else
4747 : {
4748 735 : if (nmodifiers)
4749 0 : gfc_current_locus = old_loc2;
4750 : break;
4751 : }
4752 92 : if (nmodifiers == 1
4753 83 : && gfc_match (" , ") == MATCH_YES)
4754 9 : continue;
4755 74 : else if (gfc_match (" : ") == MATCH_YES)
4756 : break;
4757 0 : gfc_current_locus = old_loc2;
4758 0 : break;
4759 : }
4760 : while (1);
4761 809 : if (gfc_match ("static") == MATCH_YES)
4762 425 : c->sched_kind = OMP_SCHED_STATIC;
4763 384 : else if (gfc_match ("dynamic") == MATCH_YES)
4764 164 : c->sched_kind = OMP_SCHED_DYNAMIC;
4765 220 : else if (gfc_match ("guided") == MATCH_YES)
4766 127 : c->sched_kind = OMP_SCHED_GUIDED;
4767 93 : else if (gfc_match ("runtime") == MATCH_YES)
4768 85 : c->sched_kind = OMP_SCHED_RUNTIME;
4769 8 : else if (gfc_match ("auto") == MATCH_YES)
4770 8 : c->sched_kind = OMP_SCHED_AUTO;
4771 809 : if (c->sched_kind != OMP_SCHED_NONE)
4772 : {
4773 809 : m = MATCH_NO;
4774 809 : if (c->sched_kind != OMP_SCHED_RUNTIME
4775 724 : && c->sched_kind != OMP_SCHED_AUTO)
4776 716 : m = gfc_match (" , %e )", &c->chunk_size);
4777 716 : if (m != MATCH_YES)
4778 299 : m = gfc_match_char (')');
4779 299 : if (m != MATCH_YES)
4780 0 : c->sched_kind = OMP_SCHED_NONE;
4781 : }
4782 809 : if (c->sched_kind != OMP_SCHED_NONE)
4783 809 : continue;
4784 : else
4785 0 : gfc_current_locus = old_loc;
4786 : }
4787 2341 : if ((mask & OMP_CLAUSE_SELF)
4788 335 : && !(mask & OMP_CLAUSE_HOST) /* OpenACC compute construct */
4789 2398 : && (m = gfc_match_dupl_check (!c->self_expr, "self"))
4790 : != MATCH_NO)
4791 : {
4792 186 : if (m == MATCH_ERROR)
4793 3 : goto error;
4794 183 : m = gfc_match (" ( %e )", &c->self_expr);
4795 183 : if (m == MATCH_ERROR)
4796 : {
4797 0 : gfc_current_locus = old_loc;
4798 0 : break;
4799 : }
4800 183 : else if (m == MATCH_NO)
4801 9 : c->self_expr = gfc_get_logical_expr (gfc_default_logical_kind,
4802 : NULL, true);
4803 183 : continue;
4804 : }
4805 2066 : if ((mask & OMP_CLAUSE_SELF)
4806 149 : && (mask & OMP_CLAUSE_HOST) /* OpenACC 'update' directive */
4807 95 : && gfc_match ("self ( ") == MATCH_YES
4808 2067 : && gfc_match_omp_map_clause (&c->lists[OMP_LIST_MAP],
4809 : OMP_MAP_FORCE_FROM, true,
4810 : /* allow_derived = */ true))
4811 94 : continue;
4812 2226 : if ((mask & OMP_CLAUSE_SEQ)
4813 1878 : && (m = gfc_match_dupl_check (!c->seq, "seq")) != MATCH_NO)
4814 : {
4815 348 : if (m == MATCH_ERROR)
4816 0 : goto error;
4817 348 : c->seq = true;
4818 348 : continue;
4819 : }
4820 1679 : if ((mask & OMP_CLAUSE_MEMORDER)
4821 1679 : && (m = gfc_match_dupl_memorder (&bval, "seq_cst",
4822 149 : c->memorder != OMP_MEMORDER_UNSET)) != MATCH_NO)
4823 : {
4824 149 : if (m == MATCH_ERROR)
4825 0 : goto error;
4826 149 : if (bval)
4827 143 : c->memorder = OMP_MEMORDER_SEQ_CST;
4828 149 : continue;
4829 : }
4830 2356 : if ((mask & OMP_CLAUSE_SHARED)
4831 1381 : && gfc_match_omp_variable_list ("shared (",
4832 : &c->lists[OMP_LIST_SHARED],
4833 : true) == MATCH_YES)
4834 975 : continue;
4835 524 : if ((mask & OMP_CLAUSE_SIMDLEN)
4836 406 : && (m = gfc_match_dupl_check (!c->simdlen_expr, "simdlen", true,
4837 : &c->simdlen_expr)) != MATCH_NO)
4838 : {
4839 118 : if (m == MATCH_ERROR)
4840 0 : goto error;
4841 118 : continue;
4842 : }
4843 314 : if ((mask & OMP_CLAUSE_SIMD)
4844 314 : && ((m = gfc_match_boolean_clause (&bval, "simd",
4845 26 : c->simd || cfalse->simd))
4846 : != MATCH_NO))
4847 : {
4848 26 : if (m == MATCH_ERROR)
4849 0 : goto error;
4850 26 : if (bval)
4851 24 : c->simd = true;
4852 : else
4853 2 : cfalse->simd = false;
4854 26 : continue;
4855 : }
4856 313 : if ((mask & OMP_CLAUSE_SEVERITY)
4857 262 : && (m = gfc_match_dupl_check (!c->severity, "severity", true))
4858 : != MATCH_NO)
4859 : {
4860 57 : if (m == MATCH_ERROR)
4861 2 : goto error;
4862 55 : if (gfc_match ("fatal )") == MATCH_YES)
4863 15 : c->severity = OMP_SEVERITY_FATAL;
4864 40 : else if (gfc_match ("warning )") == MATCH_YES)
4865 36 : c->severity = OMP_SEVERITY_WARNING;
4866 : else
4867 : {
4868 4 : gfc_error ("Expected FATAL or WARNING in SEVERITY clause "
4869 : "at %C");
4870 4 : goto error;
4871 : }
4872 51 : continue;
4873 : }
4874 205 : if ((mask & OMP_CLAUSE_SIZES)
4875 205 : && ((m = gfc_match_dupl_check (!c->sizes_list, "sizes"))
4876 : != MATCH_NO))
4877 : {
4878 203 : if (m == MATCH_ERROR)
4879 0 : goto error;
4880 203 : m = match_omp_oacc_expr_list (" (", &c->sizes_list, false, true);
4881 203 : if (m == MATCH_ERROR)
4882 7 : goto error;
4883 196 : if (m == MATCH_YES)
4884 195 : continue;
4885 1 : gfc_error ("Expected %<(%> after %qs at %C", "sizes");
4886 1 : goto error;
4887 : }
4888 : break;
4889 1286 : case 't':
4890 1351 : if ((mask & OMP_CLAUSE_TASK_REDUCTION)
4891 1286 : && gfc_match_omp_clause_reduction (pc, c, openacc,
4892 : allow_derived) == MATCH_YES)
4893 65 : continue;
4894 1221 : if ((mask & OMP_CLAUSE_THREAD_LIMIT)
4895 1221 : && (m = gfc_match_dupl_check (!c->thread_limit_list, "thread_limit",
4896 : true, NULL)) != MATCH_NO)
4897 : {
4898 131 : int nstrict = 0, nrelaxed = 0, ndims = 0;
4899 131 : bool fail = false;
4900 131 : gfc_expr *dims = NULL;
4901 131 : locus old_loc = gfc_current_locus;
4902 :
4903 131 : if (m == MATCH_ERROR)
4904 28 : goto error;
4905 177 : while (true)
4906 : {
4907 153 : if (gfc_match ("strict ") == MATCH_YES)
4908 15 : nstrict++;
4909 138 : else if (gfc_match ("relaxed ") == MATCH_YES)
4910 25 : nrelaxed++;
4911 113 : else if (gfc_match ("dims ") == MATCH_YES)
4912 : {
4913 31 : ndims++;
4914 31 : if (dims)
4915 3 : gfc_free_expr (dims);
4916 31 : if (gfc_match ("( %e ) ", &dims) != MATCH_YES)
4917 : break;
4918 : }
4919 : else
4920 : {
4921 : fail = true;
4922 : break;
4923 : }
4924 70 : if (gfc_match (", ") == MATCH_YES)
4925 24 : continue;
4926 : break;
4927 : }
4928 129 : if (gfc_match (" : ") == MATCH_YES)
4929 : {
4930 44 : if (nstrict + nrelaxed + ndims == 0 || fail)
4931 : {
4932 1 : gfc_error ("Expected STRICT, RELAXED or DIMS modifier at "
4933 : "%C");
4934 1 : goto error;
4935 : }
4936 43 : else if (nstrict + nrelaxed > 1)
4937 : {
4938 8 : gfc_error ("Only one STRICT or RELAXED modifier permitted"
4939 : " at %L", &old_loc);
4940 8 : goto error;
4941 : }
4942 35 : if (ndims > 1)
4943 : {
4944 3 : gfc_error ("Duplicated DIMS expression at %L",
4945 3 : &dims->where);
4946 3 : goto error;
4947 : }
4948 : }
4949 : else
4950 : {
4951 85 : gfc_free_expr (dims);
4952 85 : dims = NULL;
4953 85 : gfc_current_locus = old_loc;
4954 : }
4955 :
4956 117 : m = match_omp_oacc_expr_list (NULL, &c->thread_limit_list,
4957 : false, true);
4958 117 : if (m != MATCH_YES)
4959 : {
4960 7 : gfc_error ("Expected a list of integer expressions followed "
4961 : "by a %<)%> and optionally preceded by the STRICT,"
4962 : " RELAXED, or DIMS as modifiers and a colon at %C");
4963 7 : goto error;
4964 : }
4965 110 : c->thread_limit_strict = (nstrict != 0) || (dims && !nrelaxed);
4966 :
4967 110 : if (!dims && c->thread_limit_list->next)
4968 : {
4969 1 : gfc_error ("Without the DIM modifier, only a single integer "
4970 : "expression may be specified at %L",
4971 1 : &c->thread_limit_list->next->expr->where);
4972 1 : goto error;
4973 : }
4974 109 : else if (dims)
4975 : {
4976 16 : int num = 0;
4977 16 : gfc_expr_list *el;
4978 53 : for (el = c->thread_limit_list; el; el = el->next)
4979 37 : ++num;
4980 16 : if (!gfc_resolve_expr (dims)
4981 16 : || dims->ts.type != BT_INTEGER
4982 15 : || dims->rank != 0
4983 14 : || dims->expr_type != EXPR_CONSTANT
4984 28 : || mpz_sgn (dims->value.integer) <= 0)
4985 : {
4986 5 : gfc_error ("DIMS must be a constant positive integer "
4987 5 : "at %L", &dims->where);
4988 5 : goto error;
4989 : }
4990 11 : if (mpz_cmp_si (dims->value.integer, num) != 0)
4991 : {
4992 1 : gfc_error ("The number of arguments (%d) must be the same"
4993 : " as specified for DIMS at %L", num,
4994 : &dims->where);
4995 1 : goto error;
4996 : }
4997 10 : c->thread_limit_dims = true;
4998 : }
4999 103 : continue;
5000 103 : }
5001 1107 : if ((mask & OMP_CLAUSE_THREADS)
5002 1107 : && ((m = gfc_match_boolean_clause (&bval, "threads",
5003 17 : c->threads || cfalse->threads))
5004 : != MATCH_NO))
5005 : {
5006 17 : if (m == MATCH_ERROR)
5007 0 : goto error;
5008 17 : if (bval)
5009 15 : c->threads = true;
5010 : else
5011 2 : cfalse->threads = false;
5012 17 : continue;
5013 : }
5014 1270 : if ((mask & OMP_CLAUSE_TILE)
5015 221 : && !c->tile_list
5016 1294 : && match_omp_oacc_expr_list ("tile (", &c->tile_list,
5017 : true, false) == MATCH_YES)
5018 197 : continue;
5019 876 : if ((mask & OMP_CLAUSE_TO) && (mask & OMP_CLAUSE_LINK))
5020 : {
5021 : /* Declare target: 'to' is an alias for 'enter';
5022 : 'to' is deprecated since 5.2. */
5023 117 : m = gfc_match_omp_to_link ("to (", &c->lists[OMP_LIST_TO]);
5024 117 : if (m == MATCH_ERROR)
5025 0 : goto error;
5026 117 : if (m == MATCH_YES)
5027 : {
5028 117 : gfc_warning (OPT_Wdeprecated_openmp,
5029 : "%<to%> clause with %<declare target%> at %L "
5030 : "deprecated since OpenMP 5.2, use %<enter%>",
5031 : &old_loc);
5032 117 : continue;
5033 : }
5034 : }
5035 1487 : else if ((mask & OMP_CLAUSE_TO)
5036 759 : && gfc_match_motion_var_list ("to (", &c->lists[OMP_LIST_TO],
5037 : &head) == MATCH_YES)
5038 728 : continue;
5039 : break;
5040 1551 : case 'u':
5041 1609 : if ((mask & OMP_CLAUSE_UNIFORM)
5042 1551 : && gfc_match_omp_variable_list ("uniform (",
5043 : &c->lists[OMP_LIST_UNIFORM],
5044 : false) == MATCH_YES)
5045 58 : continue;
5046 1636 : if ((mask & OMP_CLAUSE_UNTIED)
5047 1636 : && ((m = gfc_match_boolean_clause (&bval, "untied",
5048 143 : c->untied || cfalse->untied))
5049 : != MATCH_NO))
5050 : {
5051 143 : if (m == MATCH_ERROR)
5052 0 : goto error;
5053 143 : if (bval)
5054 142 : c->untied = true;
5055 : else
5056 1 : cfalse->untied = true;
5057 143 : continue;
5058 : }
5059 1605 : if ((mask & OMP_CLAUSE_ATOMIC)
5060 1606 : && (m = gfc_match_dupl_atomic (&bval, "update",
5061 256 : c->atomic_op != GFC_OMP_ATOMIC_UNSET)) != MATCH_NO)
5062 : {
5063 256 : if (m == MATCH_ERROR)
5064 1 : goto error;
5065 255 : if (bval)
5066 249 : c->atomic_op = GFC_OMP_ATOMIC_UPDATE;
5067 255 : continue;
5068 : }
5069 1116 : if ((mask & OMP_CLAUSE_USE)
5070 1094 : && gfc_match_omp_variable_list ("use (",
5071 : &c->lists[OMP_LIST_USE],
5072 : true) == MATCH_YES)
5073 22 : continue;
5074 1132 : if ((mask & OMP_CLAUSE_USE_DEVICE)
5075 1072 : && gfc_match_omp_variable_list ("use_device (",
5076 : &c->lists[OMP_LIST_USE_DEVICE],
5077 : true) == MATCH_YES)
5078 60 : continue;
5079 1175 : if ((mask & OMP_CLAUSE_USE_DEVICE_PTR)
5080 1940 : && gfc_match_omp_variable_list
5081 928 : ("use_device_ptr (",
5082 : &c->lists[OMP_LIST_USE_DEVICE_PTR], false) == MATCH_YES)
5083 163 : continue;
5084 1614 : if ((mask & OMP_CLAUSE_USE_DEVICE_ADDR)
5085 1614 : && gfc_match_omp_variable_list
5086 765 : ("use_device_addr (", &c->lists[OMP_LIST_USE_DEVICE_ADDR],
5087 : false, NULL, NULL, true) == MATCH_YES)
5088 765 : continue;
5089 153 : if ((mask & OMP_CLAUSE_USES_ALLOCATORS)
5090 84 : && (gfc_match ("uses_allocators ( ") == MATCH_YES))
5091 : {
5092 78 : if (gfc_match_omp_clause_uses_allocators (c) != MATCH_YES)
5093 9 : goto error;
5094 69 : continue;
5095 : }
5096 : break;
5097 1570 : case 'v':
5098 : /* VECTOR_LENGTH must be matched before VECTOR, because the latter
5099 : doesn't unconditionally match '('. */
5100 2139 : if ((mask & OMP_CLAUSE_VECTOR_LENGTH)
5101 1570 : && (m = gfc_match_dupl_check (!c->vector_length_expr,
5102 : "vector_length", true,
5103 : &c->vector_length_expr))
5104 : != MATCH_NO)
5105 : {
5106 573 : if (m == MATCH_ERROR)
5107 4 : goto error;
5108 569 : continue;
5109 : }
5110 1989 : if ((mask & OMP_CLAUSE_VECTOR)
5111 997 : && (m = gfc_match_dupl_check (!c->vector, "vector")) != MATCH_NO)
5112 : {
5113 995 : if (m == MATCH_ERROR)
5114 0 : goto error;
5115 995 : c->vector = true;
5116 995 : m = match_oacc_clause_gwv (c, GOMP_DIM_VECTOR);
5117 995 : if (m == MATCH_ERROR)
5118 3 : goto error;
5119 992 : continue;
5120 : }
5121 : break;
5122 1505 : case 'w':
5123 1505 : if ((mask & OMP_CLAUSE_WAIT)
5124 1505 : && gfc_match ("wait") == MATCH_YES)
5125 : {
5126 192 : m = match_omp_oacc_expr_list (" (", &c->wait_list, false, false);
5127 192 : if (m == MATCH_ERROR)
5128 9 : goto error;
5129 183 : else if (m == MATCH_NO)
5130 : {
5131 47 : gfc_expr *expr
5132 47 : = gfc_get_constant_expr (BT_INTEGER,
5133 : gfc_default_integer_kind,
5134 : &gfc_current_locus);
5135 47 : mpz_set_si (expr->value.integer, GOMP_ASYNC_NOVAL);
5136 47 : gfc_expr_list **expr_list = &c->wait_list;
5137 56 : while (*expr_list)
5138 9 : expr_list = &(*expr_list)->next;
5139 47 : *expr_list = gfc_get_expr_list ();
5140 47 : (*expr_list)->expr = expr;
5141 47 : needs_space = true;
5142 : }
5143 183 : continue;
5144 183 : }
5145 1330 : if ((mask & OMP_CLAUSE_WEAK)
5146 1759 : && ((m = gfc_match_boolean_clause (&bval, "weak",
5147 446 : c->weak || cfalse->weak))
5148 : != MATCH_NO))
5149 : {
5150 18 : if (m == MATCH_ERROR)
5151 1 : goto error;
5152 17 : if (bval)
5153 14 : c->weak = true;
5154 : else
5155 3 : cfalse->weak = true;
5156 17 : continue;
5157 : }
5158 2156 : if ((mask & OMP_CLAUSE_WORKER)
5159 1295 : && (m = gfc_match_dupl_check (!c->worker, "worker")) != MATCH_NO)
5160 : {
5161 864 : if (m == MATCH_ERROR)
5162 0 : goto error;
5163 864 : c->worker = true;
5164 864 : m = match_oacc_clause_gwv (c, GOMP_DIM_WORKER);
5165 864 : if (m == MATCH_ERROR)
5166 3 : goto error;
5167 861 : continue;
5168 : }
5169 856 : if ((mask & OMP_CLAUSE_ATOMIC)
5170 859 : && (m = gfc_match_dupl_atomic (&bval, "write",
5171 428 : c->atomic_op != GFC_OMP_ATOMIC_UNSET)) != MATCH_NO)
5172 : {
5173 428 : if (m == MATCH_ERROR)
5174 3 : goto error;
5175 425 : if (bval)
5176 418 : c->atomic_op = GFC_OMP_ATOMIC_WRITE;
5177 425 : continue;
5178 : }
5179 : break;
5180 : }
5181 : break;
5182 47103 : }
5183 :
5184 35216 : end:
5185 35216 : if (cfalse)
5186 21348 : gfc_free_omp_clauses (cfalse);
5187 35216 : if (error || gfc_match_omp_eos () != MATCH_YES)
5188 : {
5189 656 : if (!gfc_error_flag_test ())
5190 149 : gfc_error ("Failed to match clause at %C");
5191 656 : gfc_free_omp_clauses (c);
5192 656 : return MATCH_ERROR;
5193 : }
5194 :
5195 34560 : *cp = c;
5196 34560 : return MATCH_YES;
5197 :
5198 359 : error:
5199 359 : error = true;
5200 359 : goto end;
5201 : }
5202 :
5203 :
5204 : #define OACC_PARALLEL_CLAUSES \
5205 : (omp_mask (OMP_CLAUSE_IF) | OMP_CLAUSE_ASYNC | OMP_CLAUSE_NUM_GANGS \
5206 : | OMP_CLAUSE_NUM_WORKERS | OMP_CLAUSE_VECTOR_LENGTH | OMP_CLAUSE_REDUCTION \
5207 : | OMP_CLAUSE_COPY | OMP_CLAUSE_COPYIN | OMP_CLAUSE_COPYOUT \
5208 : | OMP_CLAUSE_CREATE | OMP_CLAUSE_NO_CREATE | OMP_CLAUSE_PRESENT \
5209 : | OMP_CLAUSE_DEVICEPTR | OMP_CLAUSE_PRIVATE | OMP_CLAUSE_FIRSTPRIVATE \
5210 : | OMP_CLAUSE_DEFAULT | OMP_CLAUSE_WAIT | OMP_CLAUSE_ATTACH \
5211 : | OMP_CLAUSE_SELF)
5212 : #define OACC_KERNELS_CLAUSES \
5213 : (omp_mask (OMP_CLAUSE_IF) | OMP_CLAUSE_ASYNC | OMP_CLAUSE_NUM_GANGS \
5214 : | OMP_CLAUSE_NUM_WORKERS | OMP_CLAUSE_VECTOR_LENGTH | OMP_CLAUSE_DEVICEPTR \
5215 : | OMP_CLAUSE_COPY | OMP_CLAUSE_COPYIN | OMP_CLAUSE_COPYOUT \
5216 : | OMP_CLAUSE_CREATE | OMP_CLAUSE_NO_CREATE | OMP_CLAUSE_PRESENT \
5217 : | OMP_CLAUSE_DEFAULT | OMP_CLAUSE_WAIT | OMP_CLAUSE_ATTACH \
5218 : | OMP_CLAUSE_SELF)
5219 : #define OACC_SERIAL_CLAUSES \
5220 : (omp_mask (OMP_CLAUSE_IF) | OMP_CLAUSE_ASYNC | OMP_CLAUSE_REDUCTION \
5221 : | OMP_CLAUSE_COPY | OMP_CLAUSE_COPYIN | OMP_CLAUSE_COPYOUT \
5222 : | OMP_CLAUSE_CREATE | OMP_CLAUSE_NO_CREATE | OMP_CLAUSE_PRESENT \
5223 : | OMP_CLAUSE_DEVICEPTR | OMP_CLAUSE_PRIVATE | OMP_CLAUSE_FIRSTPRIVATE \
5224 : | OMP_CLAUSE_DEFAULT | OMP_CLAUSE_WAIT | OMP_CLAUSE_ATTACH \
5225 : | OMP_CLAUSE_SELF)
5226 : #define OACC_DATA_CLAUSES \
5227 : (omp_mask (OMP_CLAUSE_IF) | OMP_CLAUSE_DEVICEPTR | OMP_CLAUSE_COPY \
5228 : | OMP_CLAUSE_COPYIN | OMP_CLAUSE_COPYOUT | OMP_CLAUSE_CREATE \
5229 : | OMP_CLAUSE_NO_CREATE | OMP_CLAUSE_PRESENT | OMP_CLAUSE_ATTACH \
5230 : | OMP_CLAUSE_DEFAULT)
5231 : #define OACC_LOOP_CLAUSES \
5232 : (omp_mask (OMP_CLAUSE_COLLAPSE) | OMP_CLAUSE_GANG | OMP_CLAUSE_WORKER \
5233 : | OMP_CLAUSE_VECTOR | OMP_CLAUSE_SEQ | OMP_CLAUSE_INDEPENDENT \
5234 : | OMP_CLAUSE_PRIVATE | OMP_CLAUSE_REDUCTION | OMP_CLAUSE_AUTO \
5235 : | OMP_CLAUSE_TILE)
5236 : #define OACC_PARALLEL_LOOP_CLAUSES \
5237 : (OACC_LOOP_CLAUSES | OACC_PARALLEL_CLAUSES)
5238 : #define OACC_KERNELS_LOOP_CLAUSES \
5239 : (OACC_LOOP_CLAUSES | OACC_KERNELS_CLAUSES)
5240 : #define OACC_SERIAL_LOOP_CLAUSES \
5241 : (OACC_LOOP_CLAUSES | OACC_SERIAL_CLAUSES)
5242 : #define OACC_HOST_DATA_CLAUSES \
5243 : (omp_mask (OMP_CLAUSE_USE_DEVICE) \
5244 : | OMP_CLAUSE_IF \
5245 : | OMP_CLAUSE_IF_PRESENT)
5246 : #define OACC_DECLARE_CLAUSES \
5247 : (omp_mask (OMP_CLAUSE_COPY) | OMP_CLAUSE_COPYIN | OMP_CLAUSE_COPYOUT \
5248 : | OMP_CLAUSE_CREATE | OMP_CLAUSE_DEVICEPTR | OMP_CLAUSE_DEVICE_RESIDENT \
5249 : | OMP_CLAUSE_PRESENT \
5250 : | OMP_CLAUSE_LINK)
5251 : #define OACC_UPDATE_CLAUSES \
5252 : (omp_mask (OMP_CLAUSE_IF) | OMP_CLAUSE_ASYNC | OMP_CLAUSE_HOST \
5253 : | OMP_CLAUSE_DEVICE | OMP_CLAUSE_WAIT | OMP_CLAUSE_IF_PRESENT \
5254 : | OMP_CLAUSE_SELF)
5255 : #define OACC_ENTER_DATA_CLAUSES \
5256 : (omp_mask (OMP_CLAUSE_IF) | OMP_CLAUSE_ASYNC | OMP_CLAUSE_WAIT \
5257 : | OMP_CLAUSE_COPYIN | OMP_CLAUSE_CREATE | OMP_CLAUSE_ATTACH)
5258 : #define OACC_EXIT_DATA_CLAUSES \
5259 : (omp_mask (OMP_CLAUSE_IF) | OMP_CLAUSE_ASYNC | OMP_CLAUSE_WAIT \
5260 : | OMP_CLAUSE_COPYOUT | OMP_CLAUSE_DELETE | OMP_CLAUSE_FINALIZE \
5261 : | OMP_CLAUSE_DETACH)
5262 : #define OACC_WAIT_CLAUSES \
5263 : omp_mask (OMP_CLAUSE_ASYNC) | OMP_CLAUSE_IF
5264 : #define OACC_ROUTINE_CLAUSES \
5265 : (omp_mask (OMP_CLAUSE_GANG) | OMP_CLAUSE_WORKER | OMP_CLAUSE_VECTOR \
5266 : | OMP_CLAUSE_SEQ \
5267 : | OMP_CLAUSE_NOHOST)
5268 : #define OACC_INIT_CLAUSES \
5269 : (omp_mask (OMP_CLAUSE_IF) | OMP_CLAUSE_DEVICE_NUM | OMP_CLAUSE_DEVICE_TYPE)
5270 : #define OACC_SHUTDOWN_CLAUSES \
5271 : (omp_mask (OMP_CLAUSE_IF) | OMP_CLAUSE_DEVICE_NUM | OMP_CLAUSE_DEVICE_TYPE)
5272 : #define OACC_SET_CLAUSES \
5273 : (omp_mask (OMP_CLAUSE_IF) | OMP_CLAUSE_DEVICE_NUM | OMP_CLAUSE_DEVICE_TYPE)
5274 :
5275 :
5276 : static match
5277 12198 : match_acc (gfc_exec_op op, const omp_mask mask)
5278 : {
5279 12198 : gfc_omp_clauses *c;
5280 12198 : if (gfc_match_omp_clauses (&c, mask, false, false, true) != MATCH_YES)
5281 : return MATCH_ERROR;
5282 11969 : new_st.op = op;
5283 11969 : new_st.ext.omp_clauses = c;
5284 11969 : return MATCH_YES;
5285 : }
5286 :
5287 : match
5288 1378 : gfc_match_oacc_parallel_loop (void)
5289 : {
5290 1378 : return match_acc (EXEC_OACC_PARALLEL_LOOP, OACC_PARALLEL_LOOP_CLAUSES);
5291 : }
5292 :
5293 :
5294 : match
5295 2974 : gfc_match_oacc_parallel (void)
5296 : {
5297 2974 : return match_acc (EXEC_OACC_PARALLEL, OACC_PARALLEL_CLAUSES);
5298 : }
5299 :
5300 :
5301 : match
5302 129 : gfc_match_oacc_kernels_loop (void)
5303 : {
5304 129 : return match_acc (EXEC_OACC_KERNELS_LOOP, OACC_KERNELS_LOOP_CLAUSES);
5305 : }
5306 :
5307 :
5308 : match
5309 906 : gfc_match_oacc_kernels (void)
5310 : {
5311 906 : return match_acc (EXEC_OACC_KERNELS, OACC_KERNELS_CLAUSES);
5312 : }
5313 :
5314 :
5315 : match
5316 230 : gfc_match_oacc_serial_loop (void)
5317 : {
5318 230 : return match_acc (EXEC_OACC_SERIAL_LOOP, OACC_SERIAL_LOOP_CLAUSES);
5319 : }
5320 :
5321 :
5322 : match
5323 359 : gfc_match_oacc_serial (void)
5324 : {
5325 359 : return match_acc (EXEC_OACC_SERIAL, OACC_SERIAL_CLAUSES);
5326 : }
5327 :
5328 :
5329 : match
5330 689 : gfc_match_oacc_data (void)
5331 : {
5332 689 : return match_acc (EXEC_OACC_DATA, OACC_DATA_CLAUSES);
5333 : }
5334 :
5335 :
5336 : match
5337 65 : gfc_match_oacc_host_data (void)
5338 : {
5339 65 : return match_acc (EXEC_OACC_HOST_DATA, OACC_HOST_DATA_CLAUSES);
5340 : }
5341 :
5342 :
5343 : match
5344 3585 : gfc_match_oacc_loop (void)
5345 : {
5346 3585 : return match_acc (EXEC_OACC_LOOP, OACC_LOOP_CLAUSES);
5347 : }
5348 :
5349 :
5350 : match
5351 178 : gfc_match_oacc_declare (void)
5352 : {
5353 178 : gfc_omp_clauses *c;
5354 178 : gfc_omp_namelist *n;
5355 178 : gfc_namespace *ns = gfc_current_ns;
5356 178 : gfc_oacc_declare *new_oc;
5357 178 : bool module_var = false;
5358 178 : locus where = gfc_current_locus;
5359 :
5360 178 : if (gfc_match_omp_clauses (&c, OACC_DECLARE_CLAUSES, false, false, true)
5361 : != MATCH_YES)
5362 : return MATCH_ERROR;
5363 :
5364 262 : for (n = c->lists[OMP_LIST_DEVICE_RESIDENT]; n != NULL; n = n->next)
5365 90 : n->sym->attr.oacc_declare_device_resident = 1;
5366 :
5367 192 : for (n = c->lists[OMP_LIST_LINK]; n != NULL; n = n->next)
5368 20 : n->sym->attr.oacc_declare_link = 1;
5369 :
5370 318 : for (n = c->lists[OMP_LIST_MAP]; n != NULL; n = n->next)
5371 : {
5372 156 : gfc_symbol *s = n->sym;
5373 :
5374 156 : if (gfc_current_ns->proc_name
5375 156 : && gfc_current_ns->proc_name->attr.flavor == FL_MODULE)
5376 : {
5377 52 : if (n->u.map.op != OMP_MAP_ALLOC && n->u.map.op != OMP_MAP_TO)
5378 : {
5379 6 : gfc_error ("Invalid clause in module with !$ACC DECLARE at %L",
5380 : &where);
5381 6 : return MATCH_ERROR;
5382 : }
5383 :
5384 : module_var = true;
5385 : }
5386 :
5387 150 : if (s->attr.use_assoc)
5388 : {
5389 0 : gfc_error ("Variable is USE-associated with !$ACC DECLARE at %L",
5390 : &where);
5391 0 : return MATCH_ERROR;
5392 : }
5393 :
5394 150 : if ((s->result == s && s->ns->contained != gfc_current_ns)
5395 150 : || ((s->attr.flavor == FL_UNKNOWN || s->attr.flavor == FL_VARIABLE)
5396 135 : && s->ns != gfc_current_ns))
5397 : {
5398 2 : gfc_error ("Variable %qs shall be declared in the same scoping unit "
5399 : "as !$ACC DECLARE at %L", s->name, &where);
5400 2 : return MATCH_ERROR;
5401 : }
5402 :
5403 148 : if ((s->attr.dimension || s->attr.codimension)
5404 76 : && s->attr.dummy && s->as->type != AS_EXPLICIT)
5405 : {
5406 2 : gfc_error ("Assumed-size dummy array with !$ACC DECLARE at %L",
5407 : &where);
5408 2 : return MATCH_ERROR;
5409 : }
5410 :
5411 146 : switch (n->u.map.op)
5412 : {
5413 49 : case OMP_MAP_FORCE_ALLOC:
5414 49 : case OMP_MAP_ALLOC:
5415 49 : s->attr.oacc_declare_create = 1;
5416 49 : break;
5417 :
5418 63 : case OMP_MAP_FORCE_TO:
5419 63 : case OMP_MAP_TO:
5420 63 : s->attr.oacc_declare_copyin = 1;
5421 63 : break;
5422 :
5423 1 : case OMP_MAP_FORCE_DEVICEPTR:
5424 1 : s->attr.oacc_declare_deviceptr = 1;
5425 1 : break;
5426 :
5427 : default:
5428 : break;
5429 : }
5430 : }
5431 :
5432 162 : new_oc = gfc_get_oacc_declare ();
5433 162 : new_oc->next = ns->oacc_declare;
5434 162 : new_oc->module_var = module_var;
5435 162 : new_oc->clauses = c;
5436 162 : new_oc->loc = gfc_current_locus;
5437 162 : ns->oacc_declare = new_oc;
5438 :
5439 162 : return MATCH_YES;
5440 : }
5441 :
5442 :
5443 : match
5444 760 : gfc_match_oacc_update (void)
5445 : {
5446 760 : gfc_omp_clauses *c;
5447 760 : locus here = gfc_current_locus;
5448 :
5449 760 : if (gfc_match_omp_clauses (&c, OACC_UPDATE_CLAUSES, false, false, true)
5450 : != MATCH_YES)
5451 : return MATCH_ERROR;
5452 :
5453 756 : if (!c->lists[OMP_LIST_MAP])
5454 : {
5455 1 : gfc_error ("%<acc update%> must contain at least one "
5456 : "%<device%> or %<host%> or %<self%> clause at %L", &here);
5457 1 : return MATCH_ERROR;
5458 : }
5459 :
5460 755 : new_st.op = EXEC_OACC_UPDATE;
5461 755 : new_st.ext.omp_clauses = c;
5462 755 : return MATCH_YES;
5463 : }
5464 :
5465 :
5466 : match
5467 877 : gfc_match_oacc_enter_data (void)
5468 : {
5469 877 : return match_acc (EXEC_OACC_ENTER_DATA, OACC_ENTER_DATA_CLAUSES);
5470 : }
5471 :
5472 :
5473 : match
5474 612 : gfc_match_oacc_exit_data (void)
5475 : {
5476 612 : return match_acc (EXEC_OACC_EXIT_DATA, OACC_EXIT_DATA_CLAUSES);
5477 : }
5478 :
5479 :
5480 : match
5481 202 : gfc_match_oacc_wait (void)
5482 : {
5483 202 : gfc_omp_clauses *c = gfc_get_omp_clauses ();
5484 202 : gfc_expr_list *wait_list = NULL, *el;
5485 202 : bool space = true;
5486 202 : match m;
5487 :
5488 202 : m = match_omp_oacc_expr_list (" (", &wait_list, true, false);
5489 202 : if (m == MATCH_ERROR)
5490 : return m;
5491 196 : else if (m == MATCH_YES)
5492 126 : space = false;
5493 :
5494 196 : if (gfc_match_omp_clauses (&c, OACC_WAIT_CLAUSES, space, space, true)
5495 : == MATCH_ERROR)
5496 : return MATCH_ERROR;
5497 :
5498 184 : if (wait_list)
5499 261 : for (el = wait_list; el; el = el->next)
5500 : {
5501 140 : if (el->expr == NULL)
5502 : {
5503 2 : gfc_error ("Invalid argument to !$ACC WAIT at %C");
5504 2 : return MATCH_ERROR;
5505 : }
5506 :
5507 138 : if (!gfc_resolve_expr (el->expr)
5508 138 : || el->expr->ts.type != BT_INTEGER || el->expr->rank != 0)
5509 : {
5510 3 : gfc_error ("WAIT clause at %L requires a scalar INTEGER expression",
5511 3 : &el->expr->where);
5512 :
5513 3 : return MATCH_ERROR;
5514 : }
5515 : }
5516 179 : c->wait_list = wait_list;
5517 179 : new_st.op = EXEC_OACC_WAIT;
5518 179 : new_st.ext.omp_clauses = c;
5519 179 : return MATCH_YES;
5520 : }
5521 :
5522 :
5523 : match
5524 97 : gfc_match_oacc_cache (void)
5525 : {
5526 97 : bool readonly = false;
5527 97 : gfc_omp_clauses *c = gfc_get_omp_clauses ();
5528 : /* The OpenACC cache directive explicitly only allows "array elements or
5529 : subarrays", which we're currently not checking here. Either check this
5530 : after the call of gfc_match_omp_variable_list, or add something like a
5531 : only_sections variant next to its allow_sections parameter. */
5532 97 : match m = gfc_match (" ( ");
5533 97 : if (m != MATCH_YES)
5534 : {
5535 0 : gfc_free_omp_clauses(c);
5536 0 : return m;
5537 : }
5538 :
5539 97 : if (gfc_match ("readonly : ") == MATCH_YES)
5540 8 : readonly = true;
5541 :
5542 97 : gfc_omp_namelist **head = NULL;
5543 97 : m = gfc_match_omp_variable_list ("", &c->lists[OMP_LIST_CACHE], true,
5544 : NULL, &head, true);
5545 97 : if (m != MATCH_YES)
5546 : {
5547 2 : gfc_free_omp_clauses(c);
5548 2 : return m;
5549 : }
5550 :
5551 95 : if (readonly)
5552 24 : for (gfc_omp_namelist *n = *head; n; n = n->next)
5553 16 : n->u.map.readonly = true;
5554 :
5555 95 : if (gfc_current_state() != COMP_DO
5556 56 : && gfc_current_state() != COMP_DO_CONCURRENT)
5557 : {
5558 2 : gfc_error ("ACC CACHE directive must be inside of loop %C");
5559 2 : gfc_free_omp_clauses(c);
5560 2 : return MATCH_ERROR;
5561 : }
5562 :
5563 93 : new_st.op = EXEC_OACC_CACHE;
5564 93 : new_st.ext.omp_clauses = c;
5565 93 : return MATCH_YES;
5566 : }
5567 :
5568 : match
5569 134 : gfc_match_oacc_init (void)
5570 : {
5571 134 : return match_acc (EXEC_OACC_INIT, OACC_INIT_CLAUSES);
5572 : }
5573 :
5574 : match
5575 130 : gfc_match_oacc_shutdown (void)
5576 : {
5577 130 : return match_acc (EXEC_OACC_SHUTDOWN, OACC_SHUTDOWN_CLAUSES);
5578 : }
5579 :
5580 : match
5581 130 : gfc_match_oacc_set (void)
5582 : {
5583 130 : return match_acc (EXEC_OACC_SET, OACC_SET_CLAUSES);
5584 : }
5585 :
5586 : /* Determine the OpenACC 'routine' directive's level of parallelism. */
5587 :
5588 : static oacc_routine_lop
5589 734 : gfc_oacc_routine_lop (gfc_omp_clauses *clauses)
5590 : {
5591 734 : oacc_routine_lop ret = OACC_ROUTINE_LOP_SEQ;
5592 :
5593 734 : if (clauses)
5594 : {
5595 584 : unsigned n_lop_clauses = 0;
5596 :
5597 584 : if (clauses->gang)
5598 : {
5599 164 : ++n_lop_clauses;
5600 164 : ret = OACC_ROUTINE_LOP_GANG;
5601 : }
5602 584 : if (clauses->worker)
5603 : {
5604 114 : ++n_lop_clauses;
5605 114 : ret = OACC_ROUTINE_LOP_WORKER;
5606 : }
5607 584 : if (clauses->vector)
5608 : {
5609 116 : ++n_lop_clauses;
5610 116 : ret = OACC_ROUTINE_LOP_VECTOR;
5611 : }
5612 584 : if (clauses->seq)
5613 : {
5614 206 : ++n_lop_clauses;
5615 206 : ret = OACC_ROUTINE_LOP_SEQ;
5616 : }
5617 :
5618 584 : if (n_lop_clauses > 1)
5619 47 : ret = OACC_ROUTINE_LOP_ERROR;
5620 : }
5621 :
5622 734 : return ret;
5623 : }
5624 :
5625 : match
5626 698 : gfc_match_oacc_routine (void)
5627 : {
5628 698 : locus old_loc;
5629 698 : match m;
5630 698 : gfc_intrinsic_sym *isym = NULL;
5631 698 : gfc_symbol *sym = NULL;
5632 698 : gfc_omp_clauses *c = NULL;
5633 698 : gfc_oacc_routine_name *n = NULL;
5634 698 : oacc_routine_lop lop = OACC_ROUTINE_LOP_NONE;
5635 698 : bool nohost;
5636 :
5637 698 : old_loc = gfc_current_locus;
5638 :
5639 698 : m = gfc_match (" (");
5640 :
5641 698 : if (gfc_current_ns->proc_name
5642 696 : && gfc_current_ns->proc_name->attr.if_source == IFSRC_IFBODY
5643 90 : && m == MATCH_YES)
5644 : {
5645 3 : gfc_error ("Only the !$ACC ROUTINE form without "
5646 : "list is allowed in interface block at %C");
5647 3 : goto cleanup;
5648 : }
5649 :
5650 608 : if (m == MATCH_YES)
5651 : {
5652 295 : char buffer[GFC_MAX_SYMBOL_LEN + 1];
5653 :
5654 295 : m = gfc_match_name (buffer);
5655 295 : if (m == MATCH_YES)
5656 : {
5657 294 : gfc_symtree *st = NULL;
5658 :
5659 : /* First look for an intrinsic symbol. */
5660 294 : isym = gfc_find_function (buffer);
5661 294 : if (!isym)
5662 294 : isym = gfc_find_subroutine (buffer);
5663 : /* If no intrinsic symbol found, search the current namespace. */
5664 294 : if (!isym)
5665 276 : st = gfc_find_symtree (gfc_current_ns->sym_root, buffer);
5666 276 : if (st)
5667 : {
5668 270 : sym = st->n.sym;
5669 : /* If the name in a 'routine' directive refers to the containing
5670 : subroutine or function, then make sure that we'll later handle
5671 : this accordingly. */
5672 270 : if (gfc_current_ns->proc_name != NULL
5673 270 : && strcmp (sym->name, gfc_current_ns->proc_name->name) == 0)
5674 294 : sym = NULL;
5675 : }
5676 :
5677 294 : if (isym == NULL && st == NULL)
5678 : {
5679 6 : gfc_error ("Invalid NAME %qs in !$ACC ROUTINE ( NAME ) at %C",
5680 : buffer);
5681 6 : gfc_current_locus = old_loc;
5682 9 : return MATCH_ERROR;
5683 : }
5684 : }
5685 : else
5686 : {
5687 1 : gfc_error ("Syntax error in !$ACC ROUTINE ( NAME ) at %C");
5688 1 : gfc_current_locus = old_loc;
5689 1 : return MATCH_ERROR;
5690 : }
5691 :
5692 288 : if (gfc_match_char (')') != MATCH_YES)
5693 : {
5694 2 : gfc_error ("Syntax error in !$ACC ROUTINE ( NAME ) at %C, expecting"
5695 : " %<)%> after NAME");
5696 2 : gfc_current_locus = old_loc;
5697 2 : return MATCH_ERROR;
5698 : }
5699 : }
5700 :
5701 686 : if (gfc_match_omp_eos () != MATCH_YES
5702 686 : && (gfc_match_omp_clauses (&c, OACC_ROUTINE_CLAUSES, false, false, true)
5703 : != MATCH_YES))
5704 : return MATCH_ERROR;
5705 :
5706 683 : lop = gfc_oacc_routine_lop (c);
5707 683 : if (lop == OACC_ROUTINE_LOP_ERROR)
5708 : {
5709 47 : gfc_error ("Multiple loop axes specified for routine at %C");
5710 47 : goto cleanup;
5711 : }
5712 636 : nohost = c ? c->nohost : false;
5713 :
5714 636 : if (isym != NULL)
5715 : {
5716 : /* Diagnose any OpenACC 'routine' directive that doesn't match the
5717 : (implicit) one with a 'seq' clause. */
5718 16 : if (c && (c->gang || c->worker || c->vector))
5719 : {
5720 10 : gfc_error ("Intrinsic symbol specified in !$ACC ROUTINE ( NAME )"
5721 : " at %C marked with incompatible GANG, WORKER, or VECTOR"
5722 : " clause");
5723 10 : goto cleanup;
5724 : }
5725 : /* ..., and no 'nohost' clause. */
5726 6 : if (nohost)
5727 : {
5728 2 : gfc_error ("Intrinsic symbol specified in !$ACC ROUTINE ( NAME )"
5729 : " at %C marked with incompatible NOHOST clause");
5730 2 : goto cleanup;
5731 : }
5732 : }
5733 620 : else if (sym != NULL)
5734 : {
5735 151 : bool add = true;
5736 :
5737 : /* For a repeated OpenACC 'routine' directive, diagnose if it doesn't
5738 : match the first one. */
5739 151 : for (gfc_oacc_routine_name *n_p = gfc_current_ns->oacc_routine_names;
5740 346 : n_p;
5741 195 : n_p = n_p->next)
5742 235 : if (n_p->sym == sym)
5743 : {
5744 51 : add = false;
5745 51 : bool nohost_p = n_p->clauses ? n_p->clauses->nohost : false;
5746 51 : if (lop != gfc_oacc_routine_lop (n_p->clauses)
5747 51 : || nohost != nohost_p)
5748 : {
5749 40 : gfc_error ("!$ACC ROUTINE already applied at %C");
5750 40 : goto cleanup;
5751 : }
5752 : }
5753 :
5754 111 : if (add)
5755 : {
5756 100 : sym->attr.oacc_routine_lop = lop;
5757 100 : sym->attr.oacc_routine_nohost = nohost;
5758 :
5759 100 : n = gfc_get_oacc_routine_name ();
5760 100 : n->sym = sym;
5761 100 : n->clauses = c;
5762 100 : n->next = gfc_current_ns->oacc_routine_names;
5763 100 : n->loc = old_loc;
5764 100 : gfc_current_ns->oacc_routine_names = n;
5765 : }
5766 : }
5767 469 : else if (gfc_current_ns->proc_name)
5768 : {
5769 : /* For a repeated OpenACC 'routine' directive, diagnose if it doesn't
5770 : match the first one. */
5771 468 : oacc_routine_lop lop_p = gfc_current_ns->proc_name->attr.oacc_routine_lop;
5772 468 : bool nohost_p = gfc_current_ns->proc_name->attr.oacc_routine_nohost;
5773 468 : if (lop_p != OACC_ROUTINE_LOP_NONE
5774 86 : && (lop != lop_p
5775 86 : || nohost != nohost_p))
5776 : {
5777 56 : gfc_error ("!$ACC ROUTINE already applied at %C");
5778 56 : goto cleanup;
5779 : }
5780 :
5781 412 : if (!gfc_add_omp_declare_target (&gfc_current_ns->proc_name->attr,
5782 : gfc_current_ns->proc_name->name,
5783 : &old_loc))
5784 1 : goto cleanup;
5785 411 : gfc_current_ns->proc_name->attr.oacc_routine_lop = lop;
5786 411 : gfc_current_ns->proc_name->attr.oacc_routine_nohost = nohost;
5787 : }
5788 : else
5789 : /* Something has gone wrong, possibly a syntax error. */
5790 1 : goto cleanup;
5791 :
5792 526 : if (gfc_pure (NULL) && c && (c->gang || c->worker || c->vector))
5793 : {
5794 6 : gfc_error ("!$ACC ROUTINE with GANG, WORKER, or VECTOR clause is not "
5795 : "permitted in PURE procedure at %C");
5796 6 : goto cleanup;
5797 : }
5798 :
5799 :
5800 520 : if (n)
5801 100 : n->clauses = c;
5802 420 : else if (gfc_current_ns->oacc_routine)
5803 0 : gfc_current_ns->oacc_routine_clauses = c;
5804 :
5805 520 : new_st.op = EXEC_OACC_ROUTINE;
5806 520 : new_st.ext.omp_clauses = c;
5807 520 : return MATCH_YES;
5808 :
5809 166 : cleanup:
5810 166 : gfc_current_locus = old_loc;
5811 166 : return MATCH_ERROR;
5812 : }
5813 :
5814 :
5815 : #define OMP_PARALLEL_CLAUSES \
5816 : (omp_mask (OMP_CLAUSE_PRIVATE) | OMP_CLAUSE_FIRSTPRIVATE \
5817 : | OMP_CLAUSE_SHARED | OMP_CLAUSE_COPYIN | OMP_CLAUSE_REDUCTION \
5818 : | OMP_CLAUSE_IF | OMP_CLAUSE_NUM_THREADS | OMP_CLAUSE_DEFAULT \
5819 : | OMP_CLAUSE_PROC_BIND | OMP_CLAUSE_ALLOCATE | OMP_CLAUSE_MESSAGE \
5820 : | OMP_CLAUSE_SEVERITY)
5821 : #define OMP_DECLARE_SIMD_CLAUSES \
5822 : (omp_mask (OMP_CLAUSE_SIMDLEN) | OMP_CLAUSE_LINEAR \
5823 : | OMP_CLAUSE_UNIFORM | OMP_CLAUSE_ALIGNED | OMP_CLAUSE_INBRANCH \
5824 : | OMP_CLAUSE_NOTINBRANCH)
5825 : #define OMP_DO_CLAUSES \
5826 : (omp_mask (OMP_CLAUSE_PRIVATE) | OMP_CLAUSE_FIRSTPRIVATE \
5827 : | OMP_CLAUSE_LASTPRIVATE | OMP_CLAUSE_REDUCTION \
5828 : | OMP_CLAUSE_SCHEDULE | OMP_CLAUSE_ORDERED | OMP_CLAUSE_COLLAPSE \
5829 : | OMP_CLAUSE_LINEAR | OMP_CLAUSE_ORDER | OMP_CLAUSE_ALLOCATE \
5830 : | OMP_CLAUSE_NOWAIT)
5831 : #define OMP_LOOP_CLAUSES \
5832 : (omp_mask (OMP_CLAUSE_BIND) | OMP_CLAUSE_COLLAPSE | OMP_CLAUSE_ORDER \
5833 : | OMP_CLAUSE_PRIVATE | OMP_CLAUSE_LASTPRIVATE | OMP_CLAUSE_REDUCTION)
5834 :
5835 : #define OMP_SCOPE_CLAUSES \
5836 : (omp_mask (OMP_CLAUSE_PRIVATE) |OMP_CLAUSE_FIRSTPRIVATE \
5837 : | OMP_CLAUSE_REDUCTION | OMP_CLAUSE_ALLOCATE | OMP_CLAUSE_NOWAIT)
5838 : #define OMP_SECTIONS_CLAUSES \
5839 : (omp_mask (OMP_CLAUSE_PRIVATE) | OMP_CLAUSE_FIRSTPRIVATE \
5840 : | OMP_CLAUSE_LASTPRIVATE | OMP_CLAUSE_REDUCTION \
5841 : | OMP_CLAUSE_ALLOCATE | OMP_CLAUSE_NOWAIT)
5842 : #define OMP_SIMD_CLAUSES \
5843 : (omp_mask (OMP_CLAUSE_PRIVATE) | OMP_CLAUSE_LASTPRIVATE \
5844 : | OMP_CLAUSE_REDUCTION | OMP_CLAUSE_COLLAPSE | OMP_CLAUSE_SAFELEN \
5845 : | OMP_CLAUSE_LINEAR | OMP_CLAUSE_ALIGNED | OMP_CLAUSE_SIMDLEN \
5846 : | OMP_CLAUSE_IF | OMP_CLAUSE_ORDER | OMP_CLAUSE_NOTEMPORAL)
5847 : #define OMP_TASK_CLAUSES \
5848 : (omp_mask (OMP_CLAUSE_PRIVATE) | OMP_CLAUSE_FIRSTPRIVATE \
5849 : | OMP_CLAUSE_SHARED | OMP_CLAUSE_IF | OMP_CLAUSE_DEFAULT \
5850 : | OMP_CLAUSE_UNTIED | OMP_CLAUSE_FINAL | OMP_CLAUSE_MERGEABLE \
5851 : | OMP_CLAUSE_DEPEND | OMP_CLAUSE_PRIORITY | OMP_CLAUSE_IN_REDUCTION \
5852 : | OMP_CLAUSE_DETACH | OMP_CLAUSE_AFFINITY | OMP_CLAUSE_ALLOCATE)
5853 : #define OMP_TASKLOOP_CLAUSES \
5854 : (omp_mask (OMP_CLAUSE_PRIVATE) | OMP_CLAUSE_FIRSTPRIVATE \
5855 : | OMP_CLAUSE_LASTPRIVATE | OMP_CLAUSE_SHARED | OMP_CLAUSE_IF \
5856 : | OMP_CLAUSE_DEFAULT | OMP_CLAUSE_UNTIED | OMP_CLAUSE_FINAL \
5857 : | OMP_CLAUSE_MERGEABLE | OMP_CLAUSE_PRIORITY | OMP_CLAUSE_GRAINSIZE \
5858 : | OMP_CLAUSE_NUM_TASKS | OMP_CLAUSE_COLLAPSE | OMP_CLAUSE_NOGROUP \
5859 : | OMP_CLAUSE_REDUCTION | OMP_CLAUSE_IN_REDUCTION | OMP_CLAUSE_ALLOCATE)
5860 : #define OMP_TASKGROUP_CLAUSES \
5861 : (omp_mask (OMP_CLAUSE_TASK_REDUCTION) | OMP_CLAUSE_ALLOCATE)
5862 : #define OMP_TARGET_CLAUSES \
5863 : (omp_mask (OMP_CLAUSE_DEVICE) | OMP_CLAUSE_MAP | OMP_CLAUSE_IF \
5864 : | OMP_CLAUSE_DEPEND | OMP_CLAUSE_NOWAIT | OMP_CLAUSE_PRIVATE \
5865 : | OMP_CLAUSE_FIRSTPRIVATE | OMP_CLAUSE_DEFAULTMAP \
5866 : | OMP_CLAUSE_IS_DEVICE_PTR | OMP_CLAUSE_IN_REDUCTION \
5867 : | OMP_CLAUSE_THREAD_LIMIT | OMP_CLAUSE_ALLOCATE \
5868 : | OMP_CLAUSE_HAS_DEVICE_ADDR | OMP_CLAUSE_USES_ALLOCATORS \
5869 : | OMP_CLAUSE_DYN_GROUPPRIVATE | OMP_CLAUSE_DEVICE_TYPE \
5870 : | OMP_CLAUSE_MESSAGE | OMP_CLAUSE_SEVERITY)
5871 : #define OMP_TARGET_DATA_CLAUSES \
5872 : (omp_mask (OMP_CLAUSE_DEVICE) | OMP_CLAUSE_MAP | OMP_CLAUSE_IF \
5873 : | OMP_CLAUSE_USE_DEVICE_PTR | OMP_CLAUSE_USE_DEVICE_ADDR)
5874 : #define OMP_TARGET_ENTER_DATA_CLAUSES \
5875 : (omp_mask (OMP_CLAUSE_DEVICE) | OMP_CLAUSE_MAP | OMP_CLAUSE_IF \
5876 : | OMP_CLAUSE_DEPEND | OMP_CLAUSE_NOWAIT)
5877 : #define OMP_TARGET_EXIT_DATA_CLAUSES \
5878 : (omp_mask (OMP_CLAUSE_DEVICE) | OMP_CLAUSE_MAP | OMP_CLAUSE_IF \
5879 : | OMP_CLAUSE_DEPEND | OMP_CLAUSE_NOWAIT)
5880 : #define OMP_TARGET_UPDATE_CLAUSES \
5881 : (omp_mask (OMP_CLAUSE_DEVICE) | OMP_CLAUSE_IF | OMP_CLAUSE_TO \
5882 : | OMP_CLAUSE_FROM | OMP_CLAUSE_DEPEND | OMP_CLAUSE_NOWAIT)
5883 : #define OMP_TEAMS_CLAUSES \
5884 : (omp_mask (OMP_CLAUSE_NUM_TEAMS) | OMP_CLAUSE_THREAD_LIMIT \
5885 : | OMP_CLAUSE_DEFAULT | OMP_CLAUSE_PRIVATE | OMP_CLAUSE_FIRSTPRIVATE \
5886 : | OMP_CLAUSE_SHARED | OMP_CLAUSE_REDUCTION | OMP_CLAUSE_ALLOCATE \
5887 : | OMP_CLAUSE_MESSAGE | OMP_CLAUSE_SEVERITY)
5888 : #define OMP_DISTRIBUTE_CLAUSES \
5889 : (omp_mask (OMP_CLAUSE_PRIVATE) | OMP_CLAUSE_FIRSTPRIVATE \
5890 : | OMP_CLAUSE_LASTPRIVATE | OMP_CLAUSE_COLLAPSE | OMP_CLAUSE_DIST_SCHEDULE \
5891 : | OMP_CLAUSE_ORDER | OMP_CLAUSE_ALLOCATE)
5892 : #define OMP_SINGLE_CLAUSES \
5893 : (omp_mask (OMP_CLAUSE_PRIVATE) | OMP_CLAUSE_FIRSTPRIVATE \
5894 : | OMP_CLAUSE_ALLOCATE | OMP_CLAUSE_NOWAIT | OMP_CLAUSE_COPYPRIVATE)
5895 : #define OMP_ORDERED_CLAUSES \
5896 : (omp_mask (OMP_CLAUSE_THREADS) | OMP_CLAUSE_SIMD)
5897 : #define OMP_DECLARE_TARGET_CLAUSES \
5898 : (omp_mask (OMP_CLAUSE_ENTER) | OMP_CLAUSE_LINK | OMP_CLAUSE_DEVICE_TYPE \
5899 : | OMP_CLAUSE_TO | OMP_CLAUSE_INDIRECT | OMP_CLAUSE_LOCAL)
5900 : #define OMP_ATOMIC_CLAUSES \
5901 : (omp_mask (OMP_CLAUSE_ATOMIC) | OMP_CLAUSE_CAPTURE | OMP_CLAUSE_HINT \
5902 : | OMP_CLAUSE_MEMORDER | OMP_CLAUSE_COMPARE | OMP_CLAUSE_FAIL \
5903 : | OMP_CLAUSE_WEAK)
5904 : #define OMP_MASKED_CLAUSES \
5905 : (omp_mask (OMP_CLAUSE_FILTER))
5906 : #define OMP_ERROR_CLAUSES \
5907 : (omp_mask (OMP_CLAUSE_AT) | OMP_CLAUSE_MESSAGE | OMP_CLAUSE_SEVERITY)
5908 : #define OMP_WORKSHARE_CLAUSES \
5909 : omp_mask (OMP_CLAUSE_NOWAIT)
5910 : #define OMP_UNROLL_CLAUSES \
5911 : (omp_mask (OMP_CLAUSE_FULL) | OMP_CLAUSE_PARTIAL)
5912 : #define OMP_TILE_CLAUSES \
5913 : (omp_mask (OMP_CLAUSE_SIZES))
5914 : #define OMP_ALLOCATORS_CLAUSES \
5915 : omp_mask (OMP_CLAUSE_ALLOCATE)
5916 : #define OMP_INTEROP_CLAUSES \
5917 : (omp_mask (OMP_CLAUSE_DEPEND) | OMP_CLAUSE_NOWAIT | OMP_CLAUSE_DEVICE \
5918 : | OMP_CLAUSE_INIT | OMP_CLAUSE_DESTROY | OMP_CLAUSE_USE)
5919 : #define OMP_DISPATCH_CLAUSES \
5920 : (omp_mask (OMP_CLAUSE_DEVICE) | OMP_CLAUSE_DEPEND | OMP_CLAUSE_NOVARIANTS \
5921 : | OMP_CLAUSE_NOCONTEXT | OMP_CLAUSE_IS_DEVICE_PTR | OMP_CLAUSE_NOWAIT \
5922 : | OMP_CLAUSE_HAS_DEVICE_ADDR | OMP_CLAUSE_INTEROP)
5923 :
5924 :
5925 : static match
5926 17391 : match_omp (gfc_exec_op op, const omp_mask mask)
5927 : {
5928 17391 : gfc_omp_clauses *c;
5929 17391 : if (gfc_match_omp_clauses (&c, mask, false, true, false,
5930 : op == EXEC_OMP_TARGET) != MATCH_YES)
5931 : return MATCH_ERROR;
5932 17046 : new_st.op = op;
5933 17046 : new_st.ext.omp_clauses = c;
5934 17046 : return MATCH_YES;
5935 : }
5936 :
5937 : /* Handles both declarative and (deprecated) executable ALLOCATE directive;
5938 : accepts optional list (for executable) and common blocks.
5939 : If no variables have been provided, the single omp namelist has sym == NULL.
5940 :
5941 : Note that the executable ALLOCATE directive permits structure elements only
5942 : in OpenMP 5.0 and 5.1 but not longer in 5.2. See also the comment on the
5943 : 'omp allocators' directive below. The accidental change was reverted for
5944 : OpenMP TR12, permitting them again. See also gfc_match_omp_allocators.
5945 :
5946 : Hence, structure elements are rejected for now, also to make resolving
5947 : OMP_LIST_ALLOCATE simpler (check for duplicates, same symbol in
5948 : Fortran allocate stmt). TODO: Permit structure elements. */
5949 :
5950 : match
5951 274 : gfc_match_omp_allocate (void)
5952 : {
5953 274 : match m;
5954 274 : gfc_omp_namelist *vars = NULL;
5955 274 : gfc_expr *align = NULL;
5956 274 : gfc_expr *allocator = NULL;
5957 274 : locus loc = gfc_current_locus;
5958 :
5959 274 : m = gfc_match_omp_variable_list (" (", &vars, true, NULL, NULL, true, true,
5960 : NULL, true);
5961 :
5962 274 : if (m == MATCH_ERROR)
5963 : return m;
5964 :
5965 502 : while (true)
5966 : {
5967 502 : gfc_gobble_whitespace ();
5968 502 : if (gfc_match_omp_eos () == MATCH_YES)
5969 : break;
5970 234 : gfc_match (", "); /* optionally */
5971 234 : if ((m = gfc_match_dupl_check (!align, "align", true, &align))
5972 : != MATCH_NO)
5973 : {
5974 62 : if (m == MATCH_ERROR)
5975 1 : goto error;
5976 61 : continue;
5977 : }
5978 172 : if ((m = gfc_match_dupl_check (!allocator, "allocator",
5979 : true, &allocator)) != MATCH_NO)
5980 : {
5981 171 : if (m == MATCH_ERROR)
5982 1 : goto error;
5983 170 : continue;
5984 : }
5985 1 : gfc_error ("Expected ALIGN or ALLOCATOR clause at %C");
5986 1 : return MATCH_ERROR;
5987 : }
5988 541 : for (gfc_omp_namelist *n = vars; n; n = n->next)
5989 276 : if (n->expr)
5990 : {
5991 3 : if ((n->expr->ref && n->expr->ref->type == REF_COMPONENT)
5992 3 : || (n->expr->ref->next && n->expr->ref->type == REF_COMPONENT))
5993 1 : gfc_error ("Sorry, structure-element list item at %L in ALLOCATE "
5994 : "directive is not yet supported", &n->expr->where);
5995 : else
5996 2 : gfc_error ("Unexpected expression as list item at %L in ALLOCATE "
5997 : "directive", &n->expr->where);
5998 :
5999 3 : gfc_free_omp_namelist (vars, OMP_LIST_ALLOCATE);
6000 3 : goto error;
6001 : }
6002 :
6003 265 : new_st.op = EXEC_OMP_ALLOCATE;
6004 265 : new_st.ext.omp_clauses = gfc_get_omp_clauses ();
6005 265 : if (vars == NULL)
6006 : {
6007 27 : vars = gfc_get_omp_namelist ();
6008 27 : vars->where = loc;
6009 27 : vars->u.align = align;
6010 27 : vars->u2.allocator = allocator;
6011 27 : new_st.ext.omp_clauses->lists[OMP_LIST_ALLOCATE] = vars;
6012 : }
6013 : else
6014 : {
6015 238 : new_st.ext.omp_clauses->lists[OMP_LIST_ALLOCATE] = vars;
6016 511 : for (; vars; vars = vars->next)
6017 : {
6018 273 : vars->u.align = (align) ? gfc_copy_expr (align) : NULL;
6019 273 : vars->u2.allocator = allocator;
6020 : }
6021 238 : gfc_free_expr (align);
6022 : }
6023 : return MATCH_YES;
6024 :
6025 5 : error:
6026 5 : gfc_free_expr (align);
6027 5 : gfc_free_expr (allocator);
6028 5 : return MATCH_ERROR;
6029 : }
6030 :
6031 : /* In line with OpenMP 5.2 derived-type components are rejected.
6032 : See also comment before gfc_match_omp_allocate. */
6033 :
6034 : match
6035 26 : gfc_match_omp_allocators (void)
6036 : {
6037 26 : return match_omp (EXEC_OMP_ALLOCATORS, OMP_ALLOCATORS_CLAUSES);
6038 : }
6039 :
6040 :
6041 : match
6042 25 : gfc_match_omp_assume (void)
6043 : {
6044 25 : gfc_omp_clauses *c;
6045 25 : locus loc = gfc_current_locus;
6046 32 : if ((gfc_match_omp_clauses (&c, omp_mask (OMP_CLAUSE_ASSUMPTIONS), false)
6047 : != MATCH_YES)
6048 25 : || (omp_verify_merge_absent_contains (ST_OMP_ASSUME, c->assume, NULL,
6049 : &loc) != MATCH_YES))
6050 : return MATCH_ERROR;
6051 18 : new_st.op = EXEC_OMP_ASSUME;
6052 18 : new_st.ext.omp_clauses = c;
6053 18 : return MATCH_YES;
6054 : }
6055 :
6056 :
6057 : match
6058 38 : gfc_match_omp_assumes (void)
6059 : {
6060 38 : gfc_omp_clauses *c;
6061 38 : locus loc = gfc_current_locus;
6062 38 : if (!gfc_current_ns->proc_name
6063 37 : || (gfc_current_ns->proc_name->attr.flavor != FL_MODULE
6064 23 : && !gfc_current_ns->proc_name->attr.subroutine
6065 10 : && !gfc_current_ns->proc_name->attr.function))
6066 : {
6067 2 : gfc_error ("!$OMP ASSUMES at %C must be in the specification part of a "
6068 : "subprogram or module");
6069 2 : return MATCH_ERROR;
6070 : }
6071 46 : if ((gfc_match_omp_clauses (&c, omp_mask (OMP_CLAUSE_ASSUMPTIONS), false)
6072 : != MATCH_YES)
6073 65 : || (omp_verify_merge_absent_contains (ST_OMP_ASSUMES, c->assume,
6074 29 : gfc_current_ns->omp_assumes, &loc)
6075 : != MATCH_YES))
6076 : return MATCH_ERROR;
6077 26 : if (gfc_current_ns->omp_assumes == NULL)
6078 : {
6079 23 : gfc_current_ns->omp_assumes = c->assume;
6080 23 : c->assume = NULL;
6081 : }
6082 3 : else if (gfc_current_ns->omp_assumes && c->assume)
6083 : {
6084 3 : gfc_current_ns->omp_assumes->no_openmp |= c->assume->no_openmp;
6085 3 : gfc_current_ns->omp_assumes->no_openmp_routines
6086 3 : |= c->assume->no_openmp_routines;
6087 3 : gfc_current_ns->omp_assumes->no_openmp_constructs
6088 3 : |= c->assume->no_openmp_constructs;
6089 3 : gfc_current_ns->omp_assumes->no_parallelism |= c->assume->no_parallelism;
6090 3 : if (gfc_current_ns->omp_assumes->holds && c->assume->holds)
6091 : {
6092 : gfc_expr_list *el = gfc_current_ns->omp_assumes->holds;
6093 1 : for ( ; el->next ; el = el->next)
6094 : ;
6095 1 : el->next = c->assume->holds;
6096 1 : }
6097 2 : else if (c->assume->holds)
6098 1 : gfc_current_ns->omp_assumes->holds = c->assume->holds;
6099 3 : c->assume->holds = NULL;
6100 : }
6101 26 : gfc_free_omp_clauses (c);
6102 26 : return MATCH_YES;
6103 : }
6104 :
6105 :
6106 : match
6107 168 : gfc_match_omp_critical (void)
6108 : {
6109 168 : char n[GFC_MAX_SYMBOL_LEN+1];
6110 168 : gfc_omp_clauses *c = NULL;
6111 :
6112 168 : if (gfc_match (" ( %n )", n) != MATCH_YES)
6113 117 : n[0] = '\0';
6114 :
6115 168 : if (gfc_match_omp_clauses (&c, omp_mask (OMP_CLAUSE_HINT), false,
6116 168 : /* needs_space = */ n[0] == '\0') != MATCH_YES)
6117 : return MATCH_ERROR;
6118 :
6119 166 : new_st.op = EXEC_OMP_CRITICAL;
6120 166 : new_st.ext.omp_clauses = c;
6121 166 : if (n[0])
6122 51 : c->critical_name = xstrdup (n);
6123 : return MATCH_YES;
6124 : }
6125 :
6126 :
6127 : match
6128 166 : gfc_match_omp_end_critical (void)
6129 : {
6130 166 : char n[GFC_MAX_SYMBOL_LEN+1];
6131 :
6132 166 : if (gfc_match (" ( %n )", n) != MATCH_YES)
6133 115 : n[0] = '\0';
6134 166 : if (gfc_match_omp_eos () != MATCH_YES)
6135 : {
6136 1 : gfc_error ("Unexpected junk after $OMP CRITICAL statement at %C");
6137 1 : return MATCH_ERROR;
6138 : }
6139 :
6140 165 : new_st.op = EXEC_OMP_END_CRITICAL;
6141 165 : new_st.ext.omp_name = n[0] ? xstrdup (n) : NULL;
6142 165 : return MATCH_YES;
6143 : }
6144 :
6145 : /* depobj(depobj) depend(dep-type:loc)|destroy|update(dep-type)
6146 : dep-type = in/out/inout/mutexinoutset/depobj/source/sink
6147 : depend: !source, !sink
6148 : update: !source, !sink, !depobj
6149 : locator = exactly one list item .*/
6150 : match
6151 128 : gfc_match_omp_depobj (void)
6152 : {
6153 128 : gfc_omp_clauses *c = NULL;
6154 128 : gfc_expr *depobj;
6155 :
6156 128 : if (gfc_match (" ( %v ) ", &depobj) != MATCH_YES)
6157 : {
6158 2 : gfc_error ("Expected %<( depobj )%> at %C");
6159 2 : return MATCH_ERROR;
6160 : }
6161 126 : gfc_match (", "); /* optionally */
6162 126 : if (gfc_match ("update ( ") == MATCH_YES)
6163 : {
6164 12 : c = gfc_get_omp_clauses ();
6165 12 : if (gfc_match ("inoutset )") == MATCH_YES)
6166 2 : c->depobj_update = OMP_DEPEND_INOUTSET;
6167 10 : else if (gfc_match ("inout )") == MATCH_YES)
6168 1 : c->depobj_update = OMP_DEPEND_INOUT;
6169 9 : else if (gfc_match ("in )") == MATCH_YES)
6170 2 : c->depobj_update = OMP_DEPEND_IN;
6171 7 : else if (gfc_match ("out )") == MATCH_YES)
6172 2 : c->depobj_update = OMP_DEPEND_OUT;
6173 5 : else if (gfc_match ("mutexinoutset )") == MATCH_YES)
6174 2 : c->depobj_update = OMP_DEPEND_MUTEXINOUTSET;
6175 : else
6176 : {
6177 3 : gfc_error ("Expected IN, OUT, INOUT, INOUTSET or MUTEXINOUTSET "
6178 : "followed by %<)%> at %C");
6179 3 : goto error;
6180 : }
6181 : }
6182 114 : else if (gfc_match ("destroy ") == MATCH_YES)
6183 : {
6184 18 : gfc_expr *destroyobj = NULL;
6185 18 : c = gfc_get_omp_clauses ();
6186 18 : c->destroy = true;
6187 :
6188 18 : if (gfc_match (" ( %v ) ", &destroyobj) == MATCH_YES)
6189 : {
6190 3 : if (destroyobj->symtree != depobj->symtree)
6191 2 : gfc_warning (OPT_Wopenmp, "The same depend object should be used as"
6192 : " DEPOBJ argument at %L and as DESTROY argument at %L",
6193 : &depobj->where, &destroyobj->where);
6194 3 : gfc_free_expr (destroyobj);
6195 : }
6196 : }
6197 96 : else if (gfc_match_omp_clauses (&c, omp_mask (OMP_CLAUSE_DEPEND), false, false)
6198 : != MATCH_YES)
6199 2 : goto error;
6200 :
6201 121 : if (c->depobj_update == OMP_DEPEND_UNSET && !c->destroy)
6202 : {
6203 94 : if (!c->doacross_source && !c->lists[OMP_LIST_DEPEND])
6204 : {
6205 1 : gfc_error ("Expected DEPEND, UPDATE, or DESTROY clause at %C");
6206 1 : goto error;
6207 : }
6208 93 : if (c->lists[OMP_LIST_DEPEND]->u.depend_doacross_op == OMP_DEPEND_DEPOBJ)
6209 : {
6210 1 : gfc_error ("DEPEND clause at %L of OMP DEPOBJ construct shall not "
6211 : "have dependence-type DEPOBJ",
6212 : c->lists[OMP_LIST_DEPEND]
6213 : ? &c->lists[OMP_LIST_DEPEND]->where : &gfc_current_locus);
6214 1 : goto error;
6215 : }
6216 92 : if (c->lists[OMP_LIST_DEPEND]->next)
6217 : {
6218 1 : gfc_error ("DEPEND clause at %L of OMP DEPOBJ construct shall have "
6219 : "only a single locator",
6220 : &c->lists[OMP_LIST_DEPEND]->next->where);
6221 1 : goto error;
6222 : }
6223 : }
6224 :
6225 118 : c->depobj = depobj;
6226 118 : new_st.op = EXEC_OMP_DEPOBJ;
6227 118 : new_st.ext.omp_clauses = c;
6228 118 : return MATCH_YES;
6229 :
6230 8 : error:
6231 8 : gfc_free_expr (depobj);
6232 8 : gfc_free_omp_clauses (c);
6233 8 : return MATCH_ERROR;
6234 : }
6235 :
6236 : match
6237 160 : gfc_match_omp_dispatch (void)
6238 : {
6239 160 : return match_omp (EXEC_OMP_DISPATCH, OMP_DISPATCH_CLAUSES);
6240 : }
6241 :
6242 : match
6243 57 : gfc_match_omp_distribute (void)
6244 : {
6245 57 : return match_omp (EXEC_OMP_DISTRIBUTE, OMP_DISTRIBUTE_CLAUSES);
6246 : }
6247 :
6248 :
6249 : match
6250 44 : gfc_match_omp_distribute_parallel_do (void)
6251 : {
6252 44 : return match_omp (EXEC_OMP_DISTRIBUTE_PARALLEL_DO,
6253 44 : (OMP_DISTRIBUTE_CLAUSES | OMP_PARALLEL_CLAUSES
6254 44 : | OMP_DO_CLAUSES)
6255 44 : & ~(omp_mask (OMP_CLAUSE_ORDERED)
6256 44 : | OMP_CLAUSE_LINEAR | OMP_CLAUSE_NOWAIT));
6257 : }
6258 :
6259 :
6260 : match
6261 34 : gfc_match_omp_distribute_parallel_do_simd (void)
6262 : {
6263 34 : return match_omp (EXEC_OMP_DISTRIBUTE_PARALLEL_DO_SIMD,
6264 34 : (OMP_DISTRIBUTE_CLAUSES | OMP_PARALLEL_CLAUSES
6265 34 : | OMP_DO_CLAUSES | OMP_SIMD_CLAUSES)
6266 34 : & ~(omp_mask (OMP_CLAUSE_ORDERED) | OMP_CLAUSE_NOWAIT));
6267 : }
6268 :
6269 :
6270 : match
6271 52 : gfc_match_omp_distribute_simd (void)
6272 : {
6273 52 : return match_omp (EXEC_OMP_DISTRIBUTE_SIMD,
6274 52 : OMP_DISTRIBUTE_CLAUSES | OMP_SIMD_CLAUSES);
6275 : }
6276 :
6277 :
6278 : match
6279 1255 : gfc_match_omp_do (void)
6280 : {
6281 1255 : return match_omp (EXEC_OMP_DO, OMP_DO_CLAUSES);
6282 : }
6283 :
6284 :
6285 : match
6286 139 : gfc_match_omp_do_simd (void)
6287 : {
6288 139 : return match_omp (EXEC_OMP_DO_SIMD, OMP_DO_CLAUSES | OMP_SIMD_CLAUSES);
6289 : }
6290 :
6291 :
6292 : match
6293 70 : gfc_match_omp_loop (void)
6294 : {
6295 70 : return match_omp (EXEC_OMP_LOOP, OMP_LOOP_CLAUSES);
6296 : }
6297 :
6298 :
6299 : match
6300 35 : gfc_match_omp_teams_loop (void)
6301 : {
6302 35 : return match_omp (EXEC_OMP_TEAMS_LOOP, OMP_TEAMS_CLAUSES | OMP_LOOP_CLAUSES);
6303 : }
6304 :
6305 :
6306 : match
6307 18 : gfc_match_omp_target_teams_loop (void)
6308 : {
6309 18 : return match_omp (EXEC_OMP_TARGET_TEAMS_LOOP,
6310 18 : OMP_TARGET_CLAUSES | OMP_TEAMS_CLAUSES | OMP_LOOP_CLAUSES);
6311 : }
6312 :
6313 :
6314 : match
6315 31 : gfc_match_omp_parallel_loop (void)
6316 : {
6317 31 : return match_omp (EXEC_OMP_PARALLEL_LOOP,
6318 31 : OMP_PARALLEL_CLAUSES | OMP_LOOP_CLAUSES);
6319 : }
6320 :
6321 :
6322 : match
6323 16 : gfc_match_omp_target_parallel_loop (void)
6324 : {
6325 16 : return match_omp (EXEC_OMP_TARGET_PARALLEL_LOOP,
6326 16 : (OMP_TARGET_CLAUSES | OMP_PARALLEL_CLAUSES
6327 16 : | OMP_LOOP_CLAUSES));
6328 : }
6329 :
6330 :
6331 : match
6332 104 : gfc_match_omp_error (void)
6333 : {
6334 104 : locus loc = gfc_current_locus;
6335 104 : match m = match_omp (EXEC_OMP_ERROR, OMP_ERROR_CLAUSES);
6336 104 : if (m != MATCH_YES)
6337 : return m;
6338 :
6339 85 : gfc_omp_clauses *c = new_st.ext.omp_clauses;
6340 85 : if (c->severity == OMP_SEVERITY_UNSET)
6341 48 : c->severity = OMP_SEVERITY_FATAL;
6342 85 : if (new_st.ext.omp_clauses->at == OMP_AT_EXECUTION)
6343 : return MATCH_YES;
6344 37 : if (c->message
6345 37 : && (!gfc_resolve_expr (c->message)
6346 16 : || c->message->ts.type != BT_CHARACTER
6347 14 : || c->message->ts.kind != gfc_default_character_kind
6348 13 : || c->message->rank != 0))
6349 : {
6350 4 : gfc_error ("MESSAGE clause at %L requires a scalar default-kind "
6351 : "CHARACTER expression",
6352 4 : &new_st.ext.omp_clauses->message->where);
6353 4 : return MATCH_ERROR;
6354 : }
6355 33 : if (c->message && !gfc_is_constant_expr (c->message))
6356 : {
6357 2 : gfc_error ("Constant character expression required in MESSAGE clause "
6358 2 : "at %L", &new_st.ext.omp_clauses->message->where);
6359 2 : return MATCH_ERROR;
6360 : }
6361 31 : if (c->message)
6362 : {
6363 10 : const char *msg = G_("$OMP ERROR encountered at %L: %s");
6364 10 : gcc_assert (c->message->expr_type == EXPR_CONSTANT);
6365 10 : gfc_charlen_t slen = c->message->value.character.length;
6366 10 : int i = gfc_validate_kind (BT_CHARACTER, gfc_default_character_kind,
6367 : false);
6368 10 : size_t size = slen * gfc_character_kinds[i].bit_size / 8;
6369 10 : unsigned char *s = XCNEWVAR (unsigned char, size + 1);
6370 10 : gfc_encode_character (gfc_default_character_kind, slen,
6371 10 : c->message->value.character.string,
6372 : (unsigned char *) s, size);
6373 10 : s[size] = '\0';
6374 10 : if (c->severity == OMP_SEVERITY_WARNING)
6375 6 : gfc_warning_now (0, msg, &loc, s);
6376 : else
6377 4 : gfc_error_now (msg, &loc, s);
6378 10 : free (s);
6379 : }
6380 : else
6381 : {
6382 21 : const char *msg = G_("$OMP ERROR encountered at %L");
6383 21 : if (c->severity == OMP_SEVERITY_WARNING)
6384 7 : gfc_warning_now (0, msg, &loc);
6385 : else
6386 14 : gfc_error_now (msg, &loc);
6387 : }
6388 : return MATCH_YES;
6389 : }
6390 :
6391 : match
6392 100 : gfc_match_omp_flush (void)
6393 : {
6394 100 : gfc_omp_namelist *list = NULL;
6395 100 : gfc_omp_clauses *c = NULL;
6396 100 : gfc_gobble_whitespace ();
6397 100 : enum gfc_omp_memorder mo = OMP_MEMORDER_UNSET;
6398 100 : if (gfc_match_omp_variable_list (" (", &list, true) == MATCH_ERROR)
6399 : return MATCH_ERROR;
6400 : match m = MATCH_YES;
6401 150 : while (gfc_match_omp_eos () != MATCH_YES)
6402 : {
6403 59 : gfc_gobble_whitespace ();
6404 59 : gfc_match (", "); /* optionally */
6405 59 : enum gfc_omp_memorder mo2 = OMP_MEMORDER_UNSET;
6406 59 : bool bval = false;
6407 59 : locus loc = gfc_current_locus;
6408 59 : if ((m = gfc_match_dupl_memorder (&bval, "seq_cst",
6409 : mo != OMP_MEMORDER_UNSET)) != MATCH_NO)
6410 : mo2 = OMP_MEMORDER_SEQ_CST;
6411 48 : else if ((m = gfc_match_dupl_memorder (&bval, "acq_rel",
6412 : mo != OMP_MEMORDER_UNSET))
6413 : != MATCH_NO)
6414 : mo2 = OMP_MEMORDER_ACQ_REL;
6415 35 : else if ((m = gfc_match_dupl_memorder (&bval, "release",
6416 : mo != OMP_MEMORDER_UNSET))
6417 : != MATCH_NO)
6418 : mo2 = OMP_MEMORDER_RELEASE;
6419 24 : else if ((m = gfc_match_dupl_memorder (&bval, "acquire",
6420 : mo != OMP_MEMORDER_UNSET))
6421 : != MATCH_NO)
6422 : mo2 = OMP_MEMORDER_ACQUIRE;
6423 12 : else if ((m = gfc_match_dupl_memorder (&bval, "relaxed",
6424 : mo != OMP_MEMORDER_UNSET))
6425 : != MATCH_NO)
6426 : {
6427 10 : if (m == MATCH_YES && bval)
6428 : {
6429 : /* relaxed only permitted with 'false'. */
6430 2 : gfc_current_locus = loc;
6431 2 : m = MATCH_NO;
6432 2 : break;
6433 : }
6434 : }
6435 : else
6436 : break;
6437 55 : if (m == MATCH_ERROR)
6438 5 : return MATCH_ERROR;
6439 50 : if (bval)
6440 18 : mo = mo2;
6441 : }
6442 95 : if (m == MATCH_NO)
6443 : {
6444 4 : gfc_error ("Expected SEQ_CST, AQC_REL, RELEASE, or ACQUIRE at %C");
6445 4 : gfc_free_omp_namelist (list, OMP_LIST_NONE);
6446 4 : return MATCH_ERROR;
6447 : }
6448 91 : if (list && mo != OMP_MEMORDER_UNSET)
6449 : {
6450 1 : gfc_error ("List specified together with memory order clause in FLUSH "
6451 : "directive at %C");
6452 1 : gfc_free_omp_namelist (list, OMP_LIST_NONE);
6453 1 : return MATCH_ERROR;
6454 : }
6455 90 : if (gfc_match_omp_eos () != MATCH_YES)
6456 : {
6457 0 : gfc_error ("Unexpected junk after $OMP FLUSH statement at %C");
6458 0 : gfc_free_omp_namelist (list, OMP_LIST_NONE);
6459 0 : return MATCH_ERROR;
6460 : }
6461 90 : if (mo != OMP_MEMORDER_UNSET)
6462 : {
6463 16 : c = gfc_get_omp_clauses ();
6464 16 : c->memorder = mo;
6465 : }
6466 90 : new_st.op = EXEC_OMP_FLUSH;
6467 90 : new_st.ext.omp_namelist = list;
6468 90 : new_st.ext.omp_clauses = c;
6469 90 : return MATCH_YES;
6470 : }
6471 :
6472 :
6473 : match
6474 203 : gfc_match_omp_declare_simd (void)
6475 : {
6476 203 : locus where = gfc_current_locus;
6477 203 : gfc_symbol *proc_name;
6478 203 : gfc_omp_clauses *c;
6479 203 : gfc_omp_declare_simd *ods;
6480 203 : bool needs_space = false;
6481 :
6482 203 : switch (gfc_match (" ( "))
6483 : {
6484 145 : case MATCH_YES:
6485 145 : if (gfc_match_symbol (&proc_name, /* host assoc = */ true) != MATCH_YES
6486 145 : || gfc_match (" ) ") != MATCH_YES)
6487 : return MATCH_ERROR;
6488 : break;
6489 58 : case MATCH_NO: proc_name = NULL; needs_space = true; break;
6490 : case MATCH_ERROR: return MATCH_ERROR;
6491 : }
6492 :
6493 203 : if (gfc_match_omp_clauses (&c, OMP_DECLARE_SIMD_CLAUSES, false,
6494 : needs_space) != MATCH_YES)
6495 : return MATCH_ERROR;
6496 :
6497 194 : if (gfc_current_ns->is_block_data)
6498 : {
6499 1 : gfc_free_omp_clauses (c);
6500 1 : return MATCH_YES;
6501 : }
6502 :
6503 193 : ods = gfc_get_omp_declare_simd ();
6504 193 : ods->where = where;
6505 193 : ods->proc_name = proc_name;
6506 193 : ods->clauses = c;
6507 193 : ods->next = gfc_current_ns->omp_declare_simd;
6508 193 : gfc_current_ns->omp_declare_simd = ods;
6509 193 : return MATCH_YES;
6510 : }
6511 :
6512 :
6513 : /* Find a matching "!$omp declare mapper" for typespec TS in symtree ST. */
6514 :
6515 : gfc_omp_udm *
6516 37 : gfc_omp_udm_find (gfc_symtree *st, gfc_typespec *ts)
6517 : {
6518 37 : gfc_omp_udm *omp_udm;
6519 :
6520 37 : if (st == NULL)
6521 : return NULL;
6522 :
6523 14 : gfc_symbol *dt = (ts->type == BT_CLASS
6524 0 : ? CLASS_DATA (ts->u.derived)->ts.u.derived
6525 : : ts->u.derived);
6526 15 : for (omp_udm = st->n.omp_udm; omp_udm; omp_udm = omp_udm->next)
6527 : {
6528 5 : if (dt == omp_udm->ts.u.derived)
6529 : return omp_udm;
6530 : /* Special case for comparing derived types across namespaces. If the
6531 : true names and module names are the same and the module name is
6532 : nonnull, then they are equal. */
6533 1 : if (dt->module && omp_udm->ts.u.derived->module
6534 1 : && strcmp (dt->name, omp_udm->ts.u.derived->name) == 0
6535 1 : && strcmp (dt->module, omp_udm->ts.u.derived->module) == 0)
6536 : return omp_udm;
6537 : }
6538 :
6539 : return NULL;
6540 : }
6541 :
6542 :
6543 : /* Match !$omp declare mapper([ mapper-identifier : ] type :: var) clauses-list */
6544 :
6545 : match
6546 35 : gfc_match_omp_declare_mapper (void)
6547 : {
6548 35 : match m;
6549 35 : gfc_typespec ts;
6550 35 : char mapper_id[GFC_MAX_SYMBOL_LEN + 1];
6551 35 : char var[GFC_MAX_SYMBOL_LEN + 1];
6552 35 : gfc_namespace *mapper_ns = NULL;
6553 35 : gfc_symtree *var_st;
6554 35 : gfc_symtree *st;
6555 35 : gfc_omp_udm *omp_udm = NULL, *prev_udm = NULL;
6556 35 : locus where = gfc_current_locus;
6557 :
6558 35 : if (gfc_match_char ('(') != MATCH_YES)
6559 : {
6560 1 : gfc_error ("Expected %<(%> at %C");
6561 1 : return MATCH_ERROR;
6562 : }
6563 :
6564 34 : locus old_locus = gfc_current_locus;
6565 :
6566 34 : m = gfc_match (" %n : ", mapper_id);
6567 :
6568 34 : if (m == MATCH_ERROR)
6569 : return MATCH_ERROR;
6570 :
6571 : /* As a special case, a mapper named "default" and an unnamed mapper are
6572 : both the default mapper for a given type. */
6573 34 : if (strcmp (mapper_id, "default") == 0)
6574 0 : mapper_id[0] = '\0';
6575 :
6576 34 : if (gfc_peek_ascii_char () == ':')
6577 : {
6578 : /* If we see '::', the user did not name the mapper, and instead we just
6579 : saw the type. So backtrack and try parsing as a type instead. */
6580 15 : mapper_id[0] = '\0';
6581 15 : gfc_current_locus = old_locus;
6582 : }
6583 34 : old_locus = gfc_current_locus;
6584 :
6585 34 : m = gfc_match_type_spec (&ts);
6586 34 : if (m != MATCH_YES)
6587 : {
6588 4 : gfc_error ("Expected either a type name at %L or a map-type "
6589 : "identifier, a colon, or a type name", &old_locus);
6590 4 : return MATCH_ERROR;
6591 : }
6592 :
6593 30 : if (ts.type != BT_DERIVED)
6594 : {
6595 1 : gfc_error ("!$OMP DECLARE MAPPER with non-derived type at %L", &old_locus);
6596 1 : return MATCH_ERROR;
6597 : }
6598 :
6599 29 : if (gfc_match (" :: ") != MATCH_YES)
6600 : {
6601 0 : gfc_error ("Expected %<::%> at %C");
6602 0 : return MATCH_ERROR;
6603 : }
6604 :
6605 29 : if (gfc_match_name (var) != MATCH_YES)
6606 : {
6607 1 : gfc_error ("Expected variable name at %C");
6608 1 : return MATCH_ERROR;
6609 : }
6610 :
6611 28 : if (gfc_match_char (')') != MATCH_YES)
6612 : {
6613 2 : gfc_error ("Expected %<)%> at %C");
6614 2 : return MATCH_ERROR;
6615 : }
6616 :
6617 26 : st = gfc_find_symtree (gfc_current_ns->omp_udm_root, mapper_id);
6618 :
6619 : /* Now we need to set up a new namespace, and create a new sym_tree for our
6620 : dummy variable so we can use it in the following list of mapping
6621 : clauses. */
6622 :
6623 26 : gfc_current_ns = mapper_ns = gfc_get_namespace (gfc_current_ns, 1);
6624 26 : mapper_ns->proc_name = mapper_ns->parent->proc_name;
6625 26 : mapper_ns->omp_udm_ns = 1;
6626 :
6627 26 : gfc_get_sym_tree (var, mapper_ns, &var_st, false);
6628 26 : var_st->n.sym->ts = ts;
6629 26 : var_st->n.sym->attr.omp_udm_artificial_var = 1;
6630 26 : var_st->n.sym->attr.flavor = FL_VARIABLE;
6631 26 : gfc_commit_symbols ();
6632 :
6633 26 : gfc_omp_clauses *clauses = NULL;
6634 :
6635 26 : m = gfc_match_omp_clauses (&clauses, omp_mask (OMP_CLAUSE_MAP), false, false,
6636 : false, false, OMP_MAP_UNSET);
6637 26 : if (m != MATCH_YES)
6638 1 : goto failure;
6639 :
6640 25 : omp_udm = gfc_get_omp_udm ();
6641 25 : omp_udm->next = NULL;
6642 25 : omp_udm->where = where;
6643 25 : omp_udm->mapper_id = gfc_get_string ("%s", mapper_id);
6644 25 : omp_udm->ts = ts;
6645 25 : omp_udm->var_sym = var_st->n.sym;
6646 25 : omp_udm->mapper_ns = mapper_ns;
6647 25 : omp_udm->clauses = clauses;
6648 :
6649 25 : gfc_current_ns = mapper_ns->parent;
6650 :
6651 25 : prev_udm = gfc_omp_udm_find (st, &ts);
6652 25 : if (prev_udm)
6653 : {
6654 2 : if (mapper_id[0])
6655 1 : gfc_error ("Redefinition of !$OMP DECLARE MAPPER at %L for type %qs with id %qs",
6656 : &where, gfc_typename (&ts), mapper_id);
6657 : else
6658 1 : gfc_error ("Redefinition of !$OMP DECLARE MAPPER at %L for type %qs",
6659 : &where, gfc_typename (&ts));
6660 2 : inform (gfc_get_location (&prev_udm->where),
6661 : "Previous !$OMP DECLARE MAPPER here");
6662 2 : return MATCH_ERROR;
6663 : }
6664 23 : else if (st)
6665 : {
6666 0 : omp_udm->next = st->n.omp_udm;
6667 0 : st->n.omp_udm = omp_udm;
6668 : }
6669 : else
6670 : {
6671 23 : st = gfc_new_symtree (&gfc_current_ns->omp_udm_root, mapper_id);
6672 23 : st->n.omp_udm = omp_udm;
6673 : }
6674 :
6675 : return MATCH_YES;
6676 :
6677 1 : failure:
6678 1 : if (mapper_ns)
6679 1 : gfc_current_ns = mapper_ns->parent;
6680 1 : gfc_free_omp_udm (omp_udm);
6681 :
6682 1 : return MATCH_ERROR;
6683 : }
6684 :
6685 : /* For 'declare reduction', matches either the combiner or initializer
6686 : expression, either can be an assignment of 'omp_sym1 = ...'
6687 : or a subroutine call, i.e. 'subroutine-name(argument-list)'. */
6688 :
6689 : static bool
6690 935 : match_udr_expr (gfc_symtree *omp_sym1, gfc_symtree *omp_sym2)
6691 : {
6692 935 : match m;
6693 935 : locus old_loc = gfc_current_locus;
6694 935 : char sname[GFC_MAX_SYMBOL_LEN + 1];
6695 935 : gfc_symbol *sym;
6696 935 : gfc_namespace *ns = gfc_current_ns;
6697 935 : gfc_expr *lvalue = NULL, *rvalue = NULL;
6698 935 : gfc_symtree *st;
6699 935 : gfc_actual_arglist *arglist;
6700 :
6701 935 : m = gfc_match (" %v =", &lvalue);
6702 935 : if (m != MATCH_YES)
6703 210 : gfc_current_locus = old_loc;
6704 : else
6705 : {
6706 725 : m = gfc_match (" %e )", &rvalue);
6707 725 : if (m == MATCH_YES)
6708 : {
6709 715 : ns->code = gfc_get_code (EXEC_ASSIGN);
6710 715 : ns->code->expr1 = lvalue;
6711 715 : ns->code->expr2 = rvalue;
6712 715 : ns->code->loc = old_loc;
6713 715 : return true;
6714 : }
6715 :
6716 10 : gfc_current_locus = old_loc;
6717 10 : gfc_free_expr (lvalue);
6718 : }
6719 :
6720 220 : m = gfc_match (" %n", sname);
6721 220 : if (m != MATCH_YES)
6722 4 : goto syntax;
6723 :
6724 216 : if (strcmp (sname, omp_sym1->name) == 0
6725 203 : || strcmp (sname, omp_sym2->name) == 0)
6726 14 : goto syntax;
6727 :
6728 202 : gfc_current_ns = ns->parent;
6729 202 : if (gfc_get_ha_sym_tree (sname, &st))
6730 0 : goto syntax;
6731 :
6732 202 : sym = st->n.sym;
6733 202 : if (sym->attr.flavor != FL_PROCEDURE
6734 74 : && sym->attr.flavor != FL_UNKNOWN)
6735 1 : goto syntax;
6736 :
6737 201 : if (!sym->attr.generic
6738 191 : && !sym->attr.subroutine
6739 73 : && !sym->attr.function)
6740 : {
6741 73 : if (!(sym->attr.external && !sym->attr.referenced))
6742 : {
6743 : /* ...create a symbol in this scope... */
6744 73 : if (sym->ns != gfc_current_ns
6745 73 : && gfc_get_sym_tree (sname, NULL, &st, false) == 1)
6746 0 : goto syntax;
6747 :
6748 73 : if (sym != st->n.sym)
6749 73 : sym = st->n.sym;
6750 : }
6751 :
6752 : /* ...and then to try to make the symbol into a subroutine. */
6753 73 : if (!gfc_add_subroutine (&sym->attr, sym->name, NULL))
6754 0 : goto syntax;
6755 : }
6756 :
6757 201 : gfc_set_sym_referenced (sym);
6758 201 : gfc_gobble_whitespace ();
6759 201 : if (gfc_peek_ascii_char () != '(')
6760 6 : goto syntax;
6761 :
6762 195 : gfc_current_ns = ns;
6763 195 : m = gfc_match_actual_arglist (1, &arglist);
6764 195 : if (m != MATCH_YES)
6765 0 : goto syntax;
6766 :
6767 195 : if (gfc_match_char (')') != MATCH_YES)
6768 0 : goto syntax;
6769 :
6770 195 : gfc_clear_error ();
6771 195 : ns->code = gfc_get_code (EXEC_CALL);
6772 195 : ns->code->symtree = st;
6773 195 : ns->code->ext.actual = arglist;
6774 195 : ns->code->loc = old_loc;
6775 195 : return true;
6776 25 : syntax:
6777 25 : gfc_clear_error ();
6778 25 : gfc_error ("Expected either %<%s = expr%> or %<subroutine-name(argument-list)"
6779 : "%> followed by %<)%> at %L", omp_sym1->name, &old_loc);
6780 25 : return false;
6781 : }
6782 :
6783 : static bool
6784 1217 : gfc_omp_udr_predef (gfc_omp_reduction_op rop, const char *name,
6785 : gfc_typespec *ts, const char **n)
6786 : {
6787 1217 : if (!gfc_numeric_ts (ts) && ts->type != BT_LOGICAL)
6788 : return false;
6789 :
6790 675 : switch (rop)
6791 : {
6792 19 : case OMP_REDUCTION_PLUS:
6793 19 : case OMP_REDUCTION_MINUS:
6794 19 : case OMP_REDUCTION_TIMES:
6795 19 : return ts->type != BT_LOGICAL;
6796 12 : case OMP_REDUCTION_AND:
6797 12 : case OMP_REDUCTION_OR:
6798 12 : case OMP_REDUCTION_EQV:
6799 12 : case OMP_REDUCTION_NEQV:
6800 12 : return ts->type == BT_LOGICAL;
6801 643 : case OMP_REDUCTION_USER:
6802 643 : if (name[0] != '.' && (ts->type == BT_INTEGER || ts->type == BT_REAL))
6803 : {
6804 571 : gfc_symbol *sym;
6805 :
6806 571 : gfc_find_symbol (name, NULL, 1, &sym);
6807 571 : if (sym != NULL)
6808 : {
6809 94 : if (sym->attr.intrinsic)
6810 0 : *n = sym->name;
6811 94 : else if ((sym->attr.flavor != FL_UNKNOWN
6812 82 : && sym->attr.flavor != FL_PROCEDURE)
6813 70 : || sym->attr.external
6814 55 : || sym->attr.generic
6815 55 : || sym->attr.entry
6816 55 : || sym->attr.result
6817 55 : || sym->attr.dummy
6818 55 : || sym->attr.subroutine
6819 51 : || sym->attr.pointer
6820 51 : || sym->attr.target
6821 51 : || sym->attr.cray_pointer
6822 51 : || sym->attr.cray_pointee
6823 51 : || (sym->attr.proc != PROC_UNKNOWN
6824 1 : && sym->attr.proc != PROC_INTRINSIC)
6825 50 : || sym->attr.if_source != IFSRC_UNKNOWN
6826 50 : || sym == sym->ns->proc_name)
6827 44 : *n = NULL;
6828 : else
6829 50 : *n = sym->name;
6830 : }
6831 : else
6832 477 : *n = name;
6833 571 : if (*n
6834 527 : && (strcmp (*n, "max") == 0 || strcmp (*n, "min") == 0))
6835 56 : return true;
6836 533 : else if (*n
6837 489 : && ts->type == BT_INTEGER
6838 403 : && (strcmp (*n, "iand") == 0
6839 397 : || strcmp (*n, "ior") == 0
6840 391 : || strcmp (*n, "ieor") == 0))
6841 : return true;
6842 : }
6843 : break;
6844 : default:
6845 : break;
6846 : }
6847 : return false;
6848 : }
6849 :
6850 : gfc_omp_udr *
6851 673 : gfc_omp_udr_find (gfc_symtree *st, gfc_typespec *ts)
6852 : {
6853 673 : gfc_omp_udr *omp_udr;
6854 :
6855 673 : if (st == NULL)
6856 : return NULL;
6857 :
6858 112 : gfc_symbol *dt = NULL;
6859 112 : if (ts->type == BT_DERIVED || ts->type == BT_CLASS)
6860 25 : dt = (ts->type == BT_CLASS
6861 0 : ? CLASS_DATA (ts->u.derived)->ts.u.derived : ts->u.derived);
6862 260 : for (omp_udr = st->n.omp_udr; omp_udr; omp_udr = omp_udr->next)
6863 161 : if (omp_udr->ts.type == ts->type
6864 91 : || (dt && omp_udr->ts.type == BT_DERIVED))
6865 : {
6866 70 : if (dt && omp_udr->ts.type == BT_DERIVED)
6867 : {
6868 15 : gfc_symbol *dtu = omp_udr->ts.u.derived;
6869 15 : if (dt == dtu)
6870 : return omp_udr;
6871 : /* Special case for comparing derived types across namespaces. If
6872 : the true names and module names are the same and the module name
6873 : is nonnull, then they are equal. */
6874 7 : if (dt->module && dtu->module
6875 1 : && strcmp (dt->name, dtu->name) == 0
6876 1 : && strcmp (dt->module, dtu->module) == 0)
6877 : return omp_udr;
6878 : }
6879 55 : else if (omp_udr->ts.kind == ts->kind)
6880 : {
6881 20 : if (omp_udr->ts.type == BT_CHARACTER)
6882 : {
6883 17 : if (omp_udr->ts.u.cl->length == NULL
6884 15 : || ts->u.cl->length == NULL)
6885 : return omp_udr;
6886 15 : if (omp_udr->ts.u.cl->length->expr_type != EXPR_CONSTANT)
6887 : return omp_udr;
6888 15 : if (ts->u.cl->length->expr_type != EXPR_CONSTANT)
6889 : return omp_udr;
6890 15 : if (omp_udr->ts.u.cl->length->ts.type != BT_INTEGER)
6891 : return omp_udr;
6892 15 : if (ts->u.cl->length->ts.type != BT_INTEGER)
6893 : return omp_udr;
6894 15 : if (gfc_compare_expr (omp_udr->ts.u.cl->length,
6895 : ts->u.cl->length, INTRINSIC_EQ) != 0)
6896 15 : continue;
6897 : }
6898 : return omp_udr;
6899 : }
6900 : }
6901 : return NULL;
6902 : }
6903 :
6904 : match
6905 594 : gfc_match_omp_declare_reduction (void)
6906 : {
6907 594 : match m;
6908 594 : gfc_intrinsic_op op;
6909 594 : char name[GFC_MAX_SYMBOL_LEN + 3];
6910 594 : auto_vec<gfc_typespec, 5> tss;
6911 594 : gfc_typespec ts;
6912 594 : unsigned int i;
6913 594 : gfc_symtree *st;
6914 594 : locus where = gfc_current_locus;
6915 594 : locus end_loc = gfc_current_locus;
6916 594 : bool end_loc_set = false;
6917 594 : gfc_omp_reduction_op rop = OMP_REDUCTION_NONE;
6918 :
6919 594 : if (gfc_match_char ('(') != MATCH_YES)
6920 : {
6921 4 : gfc_error ("Expected %<(%> at %C");
6922 4 : return MATCH_ERROR;
6923 : }
6924 :
6925 590 : m = gfc_match (" %o : ", &op);
6926 590 : if (m == MATCH_ERROR)
6927 : return MATCH_ERROR;
6928 590 : if (m == MATCH_YES)
6929 : {
6930 142 : snprintf (name, sizeof name, "operator %s", gfc_op2string (op));
6931 142 : rop = (gfc_omp_reduction_op) op;
6932 : }
6933 : else
6934 : {
6935 448 : m = gfc_match_defined_op_name (name + 1, 1);
6936 448 : if (m == MATCH_ERROR)
6937 : return MATCH_ERROR;
6938 447 : if (m == MATCH_YES)
6939 : {
6940 41 : name[0] = '.';
6941 41 : strcat (name, ".");
6942 41 : if (gfc_match (" : ") != MATCH_YES)
6943 : {
6944 0 : gfc_error ("Expected %<:%> at %C");
6945 0 : return MATCH_ERROR;
6946 : }
6947 : }
6948 : else
6949 : {
6950 406 : if (gfc_match (" %n : ", name) != MATCH_YES)
6951 : {
6952 4 : gfc_error ("Expected an identfifier or operator as reduction "
6953 : "identifier followed by a colon at %C");
6954 4 : return MATCH_ERROR;
6955 : }
6956 : }
6957 : rop = OMP_REDUCTION_USER;
6958 : }
6959 :
6960 585 : m = gfc_match_type_spec (&ts);
6961 585 : if (m != MATCH_YES)
6962 : {
6963 4 : gfc_error ("Expected type spec at %C");
6964 4 : return MATCH_ERROR;
6965 : }
6966 : /* Treat len=: the same as len=*. */
6967 581 : if (ts.type == BT_CHARACTER)
6968 61 : ts.deferred = false;
6969 581 : tss.safe_push (ts);
6970 :
6971 1203 : while (gfc_match_char (',') == MATCH_YES)
6972 : {
6973 42 : m = gfc_match_type_spec (&ts);
6974 42 : if (m != MATCH_YES)
6975 : {
6976 1 : gfc_error ("Expected type spec at %C");
6977 1 : return MATCH_ERROR;
6978 : }
6979 41 : tss.safe_push (ts);
6980 : }
6981 580 : if (gfc_match_char (':') != MATCH_YES)
6982 : {
6983 6 : gfc_error ("Expected %<:%> or %<,%> at %C");
6984 6 : return MATCH_ERROR;
6985 : }
6986 :
6987 574 : st = gfc_find_symtree (gfc_current_ns->omp_udr_root, name);
6988 1699 : for (i = 0; i < tss.length (); i++)
6989 : {
6990 610 : gfc_symtree *omp_out, *omp_in;
6991 610 : gfc_symtree *omp_priv = NULL, *omp_orig = NULL;
6992 610 : gfc_namespace *combiner_ns, *initializer_ns = NULL;
6993 610 : gfc_omp_udr *prev_udr, *omp_udr;
6994 610 : const char *predef_name = NULL;
6995 :
6996 610 : omp_udr = gfc_get_omp_udr ();
6997 610 : omp_udr->name = gfc_get_string ("%s", name);
6998 610 : omp_udr->rop = rop;
6999 610 : omp_udr->ts = tss[i];
7000 610 : omp_udr->where = where;
7001 :
7002 610 : gfc_current_ns = combiner_ns = gfc_get_namespace (gfc_current_ns, 1);
7003 610 : combiner_ns->proc_name = combiner_ns->parent->proc_name;
7004 :
7005 610 : gfc_get_sym_tree ("omp_out", combiner_ns, &omp_out, false);
7006 610 : gfc_get_sym_tree ("omp_in", combiner_ns, &omp_in, false);
7007 610 : combiner_ns->omp_udr_ns = 1;
7008 610 : omp_out->n.sym->ts = tss[i];
7009 610 : omp_in->n.sym->ts = tss[i];
7010 610 : omp_out->n.sym->attr.omp_udr_artificial_var = 1;
7011 610 : omp_in->n.sym->attr.omp_udr_artificial_var = 1;
7012 610 : omp_out->n.sym->attr.flavor = FL_VARIABLE;
7013 610 : omp_in->n.sym->attr.flavor = FL_VARIABLE;
7014 610 : gfc_commit_symbols ();
7015 610 : omp_udr->combiner_ns = combiner_ns;
7016 610 : omp_udr->omp_out = omp_out->n.sym;
7017 610 : omp_udr->omp_in = omp_in->n.sym;
7018 :
7019 610 : locus old_loc = gfc_current_locus;
7020 :
7021 610 : if (!match_udr_expr (omp_out, omp_in))
7022 : {
7023 19 : syntax:
7024 59 : gfc_current_ns = combiner_ns->parent;
7025 59 : gfc_undo_symbols ();
7026 59 : gfc_free_omp_udr (omp_udr);
7027 59 : return MATCH_ERROR;
7028 : }
7029 591 : gfc_match_char (','); /* optionally */
7030 591 : if (gfc_match (" initializer ( ") == MATCH_YES)
7031 : {
7032 325 : gfc_current_ns = combiner_ns->parent;
7033 325 : initializer_ns = gfc_get_namespace (gfc_current_ns, 1);
7034 325 : gfc_current_ns = initializer_ns;
7035 325 : initializer_ns->proc_name = initializer_ns->parent->proc_name;
7036 :
7037 325 : gfc_get_sym_tree ("omp_priv", initializer_ns, &omp_priv, false);
7038 325 : gfc_get_sym_tree ("omp_orig", initializer_ns, &omp_orig, false);
7039 325 : initializer_ns->omp_udr_ns = 1;
7040 325 : omp_priv->n.sym->ts = tss[i];
7041 325 : omp_orig->n.sym->ts = tss[i];
7042 325 : omp_priv->n.sym->attr.omp_udr_artificial_var = 1;
7043 325 : omp_orig->n.sym->attr.omp_udr_artificial_var = 1;
7044 325 : omp_priv->n.sym->attr.flavor = FL_VARIABLE;
7045 325 : omp_orig->n.sym->attr.flavor = FL_VARIABLE;
7046 325 : gfc_commit_symbols ();
7047 325 : omp_udr->initializer_ns = initializer_ns;
7048 325 : omp_udr->omp_priv = omp_priv->n.sym;
7049 325 : omp_udr->omp_orig = omp_orig->n.sym;
7050 :
7051 325 : if (!match_udr_expr (omp_priv, omp_orig))
7052 6 : goto syntax;
7053 : }
7054 :
7055 585 : gfc_current_ns = combiner_ns->parent;
7056 585 : if (!end_loc_set)
7057 : {
7058 549 : end_loc_set = true;
7059 549 : end_loc = gfc_current_locus;
7060 : }
7061 585 : gfc_current_locus = old_loc;
7062 :
7063 585 : prev_udr = gfc_omp_udr_find (st, &tss[i]);
7064 585 : if (gfc_omp_udr_predef (rop, name, &tss[i], &predef_name)
7065 : /* Don't error on !$omp declare reduction (min : integer : ...)
7066 : just yet, there could be integer :: min afterwards,
7067 : making it valid. When the UDR is resolved, we'll get
7068 : to it again. */
7069 585 : && (rop != OMP_REDUCTION_USER || name[0] == '.'))
7070 : {
7071 27 : if (predef_name)
7072 0 : gfc_error_now ("Redefinition of predefined %qs in "
7073 : "!$OMP DECLARE REDUCTION at %L",
7074 : predef_name, &where);
7075 : else
7076 27 : gfc_error_now ("Redefinition of predefined %qs in "
7077 : "!$OMP DECLARE REDUCTION at %L", name, &where);
7078 27 : goto syntax;
7079 : }
7080 558 : else if (prev_udr)
7081 : {
7082 7 : gfc_error_now ("Redefinition of %qs in !$OMP DECLARE REDUCTION at %L",
7083 : name, &where);
7084 7 : inform (gfc_get_location (&prev_udr->where),
7085 : "Previous !$OMP DECLARE REDUCTION");
7086 7 : goto syntax;
7087 : }
7088 551 : else if (st)
7089 : {
7090 98 : omp_udr->next = st->n.omp_udr;
7091 98 : st->n.omp_udr = omp_udr;
7092 : }
7093 : else
7094 : {
7095 453 : st = gfc_new_symtree (&gfc_current_ns->omp_udr_root, name);
7096 453 : st->n.omp_udr = omp_udr;
7097 : }
7098 : }
7099 :
7100 515 : if (end_loc_set)
7101 : {
7102 515 : gfc_current_locus = end_loc;
7103 515 : if (gfc_match_omp_eos () != MATCH_YES)
7104 : {
7105 4 : gfc_error ("Unexpected junk at %C");
7106 4 : return MATCH_ERROR;
7107 : }
7108 : return MATCH_YES;
7109 : }
7110 : return MATCH_ERROR;
7111 594 : }
7112 :
7113 :
7114 : match
7115 490 : gfc_match_omp_declare_target (void)
7116 : {
7117 490 : locus old_loc;
7118 490 : match m;
7119 490 : gfc_omp_clauses *c = NULL;
7120 490 : enum gfc_omp_list_type list;
7121 490 : gfc_omp_namelist *n;
7122 490 : gfc_symbol *s;
7123 :
7124 490 : old_loc = gfc_current_locus;
7125 :
7126 490 : if (gfc_current_ns->proc_name
7127 490 : && gfc_match_omp_eos () == MATCH_YES)
7128 : {
7129 138 : if (!gfc_add_omp_declare_target (&gfc_current_ns->proc_name->attr,
7130 138 : gfc_current_ns->proc_name->name,
7131 : &old_loc))
7132 0 : goto cleanup;
7133 : return MATCH_YES;
7134 : }
7135 :
7136 352 : if (gfc_current_ns->proc_name
7137 352 : && gfc_current_ns->proc_name->attr.if_source == IFSRC_IFBODY)
7138 : {
7139 2 : gfc_error ("Only the !$OMP DECLARE TARGET form without "
7140 : "clauses is allowed in interface block at %C");
7141 2 : goto cleanup;
7142 : }
7143 :
7144 350 : m = gfc_match (" (");
7145 350 : if (m == MATCH_YES)
7146 : {
7147 86 : c = gfc_get_omp_clauses ();
7148 86 : gfc_current_locus = old_loc;
7149 86 : m = gfc_match_omp_to_link (" (", &c->lists[OMP_LIST_ENTER]);
7150 86 : if (m != MATCH_YES)
7151 0 : goto syntax;
7152 86 : if (gfc_match_omp_eos () != MATCH_YES)
7153 : {
7154 0 : gfc_error ("Unexpected junk after !$OMP DECLARE TARGET at %C");
7155 0 : goto cleanup;
7156 : }
7157 : }
7158 264 : else if (gfc_match_omp_clauses (&c, OMP_DECLARE_TARGET_CLAUSES, false)
7159 : != MATCH_YES)
7160 : return MATCH_ERROR;
7161 :
7162 344 : gfc_buffer_error (false);
7163 :
7164 344 : static const enum gfc_omp_list_type to_enter_link_lists[]
7165 : = { OMP_LIST_TO, OMP_LIST_ENTER, OMP_LIST_LINK, OMP_LIST_LOCAL };
7166 1720 : for (size_t listn = 0; listn < ARRAY_SIZE (to_enter_link_lists)
7167 1720 : && (list = to_enter_link_lists[listn], true); ++listn)
7168 1941 : for (n = c->lists[list]; n; n = n->next)
7169 565 : if (n->sym)
7170 523 : n->sym->mark = 0;
7171 42 : else if (n->u.common->head)
7172 42 : n->u.common->head->mark = 0;
7173 :
7174 344 : if (c->device_type == OMP_DEVICE_TYPE_UNSET)
7175 276 : c->device_type = OMP_DEVICE_TYPE_ANY;
7176 1720 : for (size_t listn = 0; listn < ARRAY_SIZE (to_enter_link_lists)
7177 1720 : && (list = to_enter_link_lists[listn], true); ++listn)
7178 1941 : for (n = c->lists[list]; n; n = n->next)
7179 565 : if (n->sym)
7180 : {
7181 523 : if (n->sym->attr.in_common)
7182 1 : gfc_error_now ("OMP DECLARE TARGET variable at %L is an "
7183 : "element of a COMMON block", &n->where);
7184 522 : else if (n->sym->attr.omp_groupprivate && list != OMP_LIST_LOCAL)
7185 12 : gfc_error_now ("List item %qs at %L should not appear in the %qs "
7186 : "clause, as it was previously specified in a "
7187 : "GROUPPRIVATE directive", n->sym->name, &n->where,
7188 : list == OMP_LIST_LINK
7189 5 : ? "link" : list == OMP_LIST_TO ? "to" : "enter");
7190 515 : else if (n->sym->mark)
7191 11 : gfc_error_now ("Variable at %L mentioned multiple times in "
7192 : "clauses of the same OMP DECLARE TARGET directive",
7193 : &n->where);
7194 504 : else if ((list != OMP_LIST_LINK
7195 471 : && n->sym->attr.omp_declare_target_link)
7196 469 : || (list != OMP_LIST_LOCAL
7197 488 : && n->sym->attr.omp_declare_target_local))
7198 10 : gfc_error_now ("OMP DECLARE TARGET variable at %L previously "
7199 : "mentioned in %s clause and later in %s clause",
7200 : &n->where,
7201 5 : n->sym->attr.omp_declare_target_link ? "LINK"
7202 : : "LOCAL",
7203 : (list == OMP_LIST_LOCAL ? "LOCAL"
7204 : : list == OMP_LIST_LINK ? "LINK"
7205 : : list == OMP_LIST_TO ? "TO" : "ENTER"));
7206 499 : else if (n->sym->attr.omp_declare_target
7207 15 : && (list == OMP_LIST_LINK || list == OMP_LIST_LOCAL))
7208 3 : gfc_error_now ("OMP DECLARE TARGET variable at %L previously "
7209 : "mentioned in TO or ENTER clause and later in "
7210 : "%s clause", &n->where,
7211 : list == OMP_LIST_LINK ? "LINK" : "LOCAL");
7212 : else
7213 : {
7214 497 : if (list == OMP_LIST_TO || list == OMP_LIST_ENTER)
7215 453 : gfc_add_omp_declare_target (&n->sym->attr, n->sym->name,
7216 : &n->sym->declared_at);
7217 497 : if (list == OMP_LIST_LINK)
7218 31 : gfc_add_omp_declare_target_link (&n->sym->attr, n->sym->name,
7219 31 : &n->sym->declared_at);
7220 497 : if (list == OMP_LIST_LOCAL)
7221 13 : gfc_add_omp_declare_target_local (&n->sym->attr, n->sym->name,
7222 13 : &n->sym->declared_at);
7223 : }
7224 523 : if (n->sym->attr.omp_device_type != OMP_DEVICE_TYPE_UNSET
7225 43 : && n->sym->attr.omp_device_type != c->device_type)
7226 : {
7227 12 : const char *dt = "any";
7228 12 : if (n->sym->attr.omp_device_type == OMP_DEVICE_TYPE_NOHOST)
7229 : dt = "nohost";
7230 8 : else if (n->sym->attr.omp_device_type == OMP_DEVICE_TYPE_HOST)
7231 4 : dt = "host";
7232 12 : if (n->sym->attr.omp_groupprivate)
7233 1 : gfc_error_now ("List item %qs at %L set in previous OMP "
7234 : "GROUPPRIVATE directive to the different "
7235 : "DEVICE_TYPE %qs", n->sym->name, &n->where, dt);
7236 : else
7237 11 : gfc_error_now ("List item %qs at %L set in previous OMP "
7238 : "DECLARE TARGET directive to the different "
7239 : "DEVICE_TYPE %qs", n->sym->name, &n->where, dt);
7240 : }
7241 523 : n->sym->attr.omp_device_type = c->device_type;
7242 523 : if (c->indirect && c->device_type != OMP_DEVICE_TYPE_ANY)
7243 : {
7244 1 : gfc_error_now ("DEVICE_TYPE must be ANY when used with INDIRECT "
7245 : "at %L", &n->where);
7246 1 : c->indirect = 0;
7247 : }
7248 523 : n->sym->attr.omp_declare_target_indirect = c->indirect;
7249 523 : if (list == OMP_LIST_LINK && c->device_type == OMP_DEVICE_TYPE_NOHOST)
7250 3 : gfc_error_now ("List item %qs at %L set with NOHOST specified may "
7251 : "not appear in a LINK clause", n->sym->name,
7252 : &n->where);
7253 523 : n->sym->mark = 1;
7254 : }
7255 : else /* common block */
7256 : {
7257 42 : if (n->u.common->omp_groupprivate && list != OMP_LIST_LOCAL)
7258 7 : gfc_error_now ("Common block %</%s/%> at %L not appear in the %qs "
7259 : "clause as it was previously specified in a "
7260 : "GROUPPRIVATE directive",
7261 7 : n->u.common->name, &n->where,
7262 : list == OMP_LIST_LINK
7263 5 : ? "link" : list == OMP_LIST_TO ? "to" : "enter");
7264 35 : else if (n->u.common->head && n->u.common->head->mark)
7265 4 : gfc_error_now ("Common block %</%s/%> at %L mentioned multiple "
7266 : "times in clauses of the same OMP DECLARE TARGET "
7267 4 : "directive", n->u.common->name, &n->where);
7268 31 : else if ((n->u.common->omp_declare_target_link
7269 27 : || n->u.common->omp_declare_target_local)
7270 : && list != OMP_LIST_LINK
7271 6 : && list != OMP_LIST_LOCAL)
7272 2 : gfc_error_now ("Common block %</%s/%> at %L previously mentioned "
7273 : "in %s clause and later in %s clause",
7274 1 : n->u.common->name, &n->where,
7275 : n->u.common->omp_declare_target_link ? "LINK"
7276 : : "LOCAL",
7277 : list == OMP_LIST_TO ? "TO" : "ENTER");
7278 30 : else if (n->u.common->omp_declare_target
7279 4 : && (list == OMP_LIST_LINK || list == OMP_LIST_LOCAL))
7280 1 : gfc_error_now ("Common block %</%s/%> at %L previously mentioned "
7281 : "in TO or ENTER clause and later in %s clause",
7282 1 : n->u.common->name, &n->where,
7283 : list == OMP_LIST_LINK ? "LINK" : "LOCAL");
7284 42 : if (n->u.common->omp_device_type != OMP_DEVICE_TYPE_UNSET
7285 21 : && n->u.common->omp_device_type != c->device_type)
7286 : {
7287 1 : const char *dt = "any";
7288 1 : if (n->u.common->omp_device_type == OMP_DEVICE_TYPE_NOHOST)
7289 : dt = "nohost";
7290 0 : else if (n->u.common->omp_device_type == OMP_DEVICE_TYPE_HOST)
7291 0 : dt = "host";
7292 1 : if (n->u.common->omp_groupprivate)
7293 1 : gfc_error_now ("Common block %</%s/%> at %L set in previous OMP "
7294 : "GROUPPRIVATE directive to the different "
7295 1 : "DEVICE_TYPE %qs", n->u.common->name, &n->where,
7296 : dt);
7297 : else
7298 0 : gfc_error_now ("Common block %</%s/%> at %L set in previous OMP "
7299 : "DECLARE TARGET directive to the different "
7300 0 : "DEVICE_TYPE %qs", n->u.common->name, &n->where,
7301 : dt);
7302 : }
7303 42 : n->u.common->omp_device_type = c->device_type;
7304 :
7305 42 : if (c->indirect && c->device_type != OMP_DEVICE_TYPE_ANY)
7306 : {
7307 0 : gfc_error_now ("DEVICE_TYPE must be ANY when used with INDIRECT "
7308 : "at %L", &n->where);
7309 0 : c->indirect = 0;
7310 : }
7311 42 : if (list == OMP_LIST_LINK && c->device_type == OMP_DEVICE_TYPE_NOHOST)
7312 1 : gfc_error_now ("Common block %</%s/%> at %L set with NOHOST "
7313 : "specified may not appear in a LINK clause",
7314 1 : n->u.common->name, &n->where);
7315 :
7316 42 : if (list == OMP_LIST_TO || list == OMP_LIST_ENTER)
7317 21 : n->u.common->omp_declare_target = 1;
7318 42 : if (list == OMP_LIST_LINK)
7319 15 : n->u.common->omp_declare_target_link = 1;
7320 42 : if (list == OMP_LIST_LOCAL)
7321 6 : n->u.common->omp_declare_target_local = 1;
7322 :
7323 112 : for (s = n->u.common->head; s; s = s->common_next)
7324 : {
7325 70 : s->mark = 1;
7326 70 : if (list == OMP_LIST_TO || list == OMP_LIST_ENTER)
7327 33 : gfc_add_omp_declare_target (&s->attr, s->name, &n->where);
7328 70 : if (list == OMP_LIST_LINK)
7329 31 : gfc_add_omp_declare_target_link (&s->attr, s->name, &n->where);
7330 70 : if (list == OMP_LIST_LOCAL)
7331 6 : gfc_add_omp_declare_target_local (&s->attr, s->name, &n->where);
7332 70 : s->attr.omp_device_type = c->device_type;
7333 70 : s->attr.omp_declare_target_indirect = c->indirect;
7334 : }
7335 : }
7336 344 : if ((c->device_type || c->indirect)
7337 344 : && !c->lists[OMP_LIST_ENTER]
7338 161 : && !c->lists[OMP_LIST_TO]
7339 56 : && !c->lists[OMP_LIST_LINK]
7340 17 : && !c->lists[OMP_LIST_LOCAL])
7341 2 : gfc_warning_now (OPT_Wopenmp,
7342 : "OMP DECLARE TARGET directive at %L with only "
7343 : "DEVICE_TYPE or INDIRECT clauses is ignored",
7344 : &old_loc);
7345 :
7346 344 : gfc_buffer_error (true);
7347 :
7348 344 : if (c)
7349 344 : gfc_free_omp_clauses (c);
7350 : return MATCH_YES;
7351 :
7352 0 : syntax:
7353 0 : gfc_error ("Syntax error in !$OMP DECLARE TARGET list at %C");
7354 :
7355 2 : cleanup:
7356 2 : gfc_current_locus = old_loc;
7357 2 : if (c)
7358 0 : gfc_free_omp_clauses (c);
7359 : return MATCH_ERROR;
7360 : }
7361 :
7362 : /* Skip over and ignore trait-property-extensions.
7363 :
7364 : trait-property-extension :
7365 : trait-property-name
7366 : identifier (trait-property-extension[, trait-property-extension[, ...]])
7367 : constant integer expression
7368 : */
7369 :
7370 : static match gfc_ignore_trait_property_extension_list (void);
7371 :
7372 : static match
7373 7 : gfc_ignore_trait_property_extension (void)
7374 : {
7375 7 : char buf[GFC_MAX_SYMBOL_LEN + 1];
7376 7 : gfc_expr *expr;
7377 :
7378 : /* Identifier form of trait-property name, possibly followed by
7379 : a list of (recursive) trait-property-extensions. */
7380 7 : if (gfc_match_name (buf) == MATCH_YES)
7381 : {
7382 0 : if (gfc_match (" (") == MATCH_YES)
7383 0 : return gfc_ignore_trait_property_extension_list ();
7384 : return MATCH_YES;
7385 : }
7386 :
7387 : /* Literal constant. */
7388 7 : if (gfc_match_literal_constant (&expr, 0) == MATCH_YES)
7389 : return MATCH_YES;
7390 :
7391 : /* FIXME: constant integer expressions. */
7392 0 : gfc_error ("Expected trait-property-extension at %C");
7393 0 : return MATCH_ERROR;
7394 : }
7395 :
7396 : static match
7397 5 : gfc_ignore_trait_property_extension_list (void)
7398 : {
7399 9 : while (1)
7400 : {
7401 7 : if (gfc_ignore_trait_property_extension () != MATCH_YES)
7402 : return MATCH_ERROR;
7403 7 : if (gfc_match (" ,") == MATCH_YES)
7404 2 : continue;
7405 5 : if (gfc_match (" )") == MATCH_YES)
7406 : return MATCH_YES;
7407 0 : gfc_error ("expected %<)%> at %C");
7408 0 : return MATCH_ERROR;
7409 : }
7410 : }
7411 :
7412 :
7413 : match
7414 110 : gfc_match_omp_interop (void)
7415 : {
7416 110 : return match_omp (EXEC_OMP_INTEROP, OMP_INTEROP_CLAUSES);
7417 : }
7418 :
7419 :
7420 : /* OpenMP 5.0:
7421 :
7422 : trait-selector:
7423 : trait-selector-name[([trait-score:]trait-property[,trait-property[,...]])]
7424 :
7425 : trait-score:
7426 : score(score-expression) */
7427 :
7428 : static match
7429 650 : gfc_match_omp_context_selector (gfc_omp_set_selector *oss)
7430 : {
7431 789 : do
7432 : {
7433 789 : char selector[GFC_MAX_SYMBOL_LEN + 1];
7434 :
7435 789 : if (gfc_match_name (selector) != MATCH_YES)
7436 : {
7437 2 : gfc_error ("expected trait selector name at %C");
7438 39 : return MATCH_ERROR;
7439 : }
7440 :
7441 787 : gfc_omp_selector *os = gfc_get_omp_selector ();
7442 787 : if (oss->code == OMP_TRAIT_SET_CONSTRUCT
7443 341 : && !strcmp (selector, "do"))
7444 48 : os->code = OMP_TRAIT_CONSTRUCT_FOR;
7445 739 : else if (oss->code == OMP_TRAIT_SET_CONSTRUCT
7446 293 : && !strcmp (selector, "for"))
7447 1 : os->code = OMP_TRAIT_INVALID;
7448 : else
7449 738 : os->code = omp_lookup_ts_code (oss->code, selector);
7450 787 : os->next = oss->trait_selectors;
7451 787 : oss->trait_selectors = os;
7452 :
7453 787 : if (os->code == OMP_TRAIT_INVALID)
7454 : {
7455 18 : gfc_warning (OPT_Wopenmp,
7456 : "unknown selector %qs for context selector set %qs "
7457 : "at %C",
7458 18 : selector, omp_tss_map[oss->code]);
7459 18 : if (gfc_match (" (") == MATCH_YES
7460 18 : && gfc_ignore_trait_property_extension_list () != MATCH_YES)
7461 : return MATCH_ERROR;
7462 18 : if (gfc_match (" ,") == MATCH_YES)
7463 1 : continue;
7464 611 : break;
7465 : }
7466 :
7467 769 : enum omp_tp_type property_kind = omp_ts_map[os->code].tp_type;
7468 769 : bool allow_score = omp_ts_map[os->code].allow_score;
7469 :
7470 769 : if (gfc_match (" (") == MATCH_YES)
7471 : {
7472 439 : if (property_kind == OMP_TRAIT_PROPERTY_NONE)
7473 : {
7474 6 : gfc_error ("selector %qs does not accept any properties at %C",
7475 : selector);
7476 6 : return MATCH_ERROR;
7477 : }
7478 :
7479 433 : if (gfc_match (" score") == MATCH_YES)
7480 : {
7481 63 : if (!allow_score)
7482 : {
7483 10 : gfc_error ("%<score%> cannot be specified in traits "
7484 : "in the %qs trait-selector-set at %C",
7485 10 : omp_tss_map[oss->code]);
7486 10 : return MATCH_ERROR;
7487 : }
7488 53 : if (gfc_match (" (") != MATCH_YES)
7489 : {
7490 0 : gfc_error ("expected %<(%> at %C");
7491 0 : return MATCH_ERROR;
7492 : }
7493 53 : if (gfc_match_expr (&os->score) != MATCH_YES)
7494 : return MATCH_ERROR;
7495 :
7496 52 : if (gfc_match (" )") != MATCH_YES)
7497 : {
7498 0 : gfc_error ("expected %<)%> at %C");
7499 0 : return MATCH_ERROR;
7500 : }
7501 :
7502 52 : if (gfc_match (" :") != MATCH_YES)
7503 : {
7504 0 : gfc_error ("expected : at %C");
7505 0 : return MATCH_ERROR;
7506 : }
7507 : }
7508 :
7509 422 : gfc_omp_trait_property *otp = gfc_get_omp_trait_property ();
7510 422 : otp->property_kind = property_kind;
7511 422 : otp->next = os->properties;
7512 422 : os->properties = otp;
7513 :
7514 422 : switch (property_kind)
7515 : {
7516 25 : case OMP_TRAIT_PROPERTY_ID:
7517 25 : {
7518 25 : char buf[GFC_MAX_SYMBOL_LEN + 1];
7519 25 : if (gfc_match_name (buf) == MATCH_YES)
7520 : {
7521 24 : otp->name = XNEWVEC (char, strlen (buf) + 1);
7522 24 : strcpy (otp->name, buf);
7523 : }
7524 : else
7525 : {
7526 1 : gfc_error ("expected identifier at %C");
7527 1 : free (otp);
7528 1 : os->properties = nullptr;
7529 1 : return MATCH_ERROR;
7530 : }
7531 : }
7532 24 : break;
7533 290 : case OMP_TRAIT_PROPERTY_NAME_LIST:
7534 343 : do
7535 : {
7536 290 : char buf[GFC_MAX_SYMBOL_LEN + 1];
7537 290 : if (gfc_match_name (buf) == MATCH_YES)
7538 : {
7539 170 : otp->name = XNEWVEC (char, strlen (buf) + 1);
7540 170 : strcpy (otp->name, buf);
7541 170 : otp->is_name = true;
7542 : }
7543 120 : else if (gfc_match_literal_constant (&otp->expr, 0)
7544 : != MATCH_YES
7545 120 : || otp->expr->ts.type != BT_CHARACTER)
7546 : {
7547 5 : gfc_error ("expected identifier or string literal "
7548 : "at %C");
7549 5 : free (otp);
7550 5 : os->properties = nullptr;
7551 5 : return MATCH_ERROR;
7552 : }
7553 :
7554 285 : if (gfc_match (" ,") == MATCH_YES)
7555 : {
7556 53 : otp = gfc_get_omp_trait_property ();
7557 53 : otp->property_kind = property_kind;
7558 53 : otp->next = os->properties;
7559 53 : os->properties = otp;
7560 : }
7561 : else
7562 : break;
7563 53 : }
7564 : while (1);
7565 232 : break;
7566 145 : case OMP_TRAIT_PROPERTY_DEV_NUM_EXPR:
7567 145 : case OMP_TRAIT_PROPERTY_BOOL_EXPR:
7568 145 : if (gfc_match_expr (&otp->expr) != MATCH_YES)
7569 : {
7570 3 : gfc_error ("expected expression at %C");
7571 3 : free (otp);
7572 3 : os->properties = nullptr;
7573 3 : return MATCH_ERROR;
7574 : }
7575 : break;
7576 15 : case OMP_TRAIT_PROPERTY_CLAUSE_LIST:
7577 15 : {
7578 15 : if (os->code == OMP_TRAIT_CONSTRUCT_SIMD)
7579 : {
7580 15 : gfc_matching_omp_context_selector = true;
7581 15 : if (gfc_match_omp_clauses (&otp->clauses,
7582 15 : OMP_DECLARE_SIMD_CLAUSES,
7583 : true, false, false)
7584 : != MATCH_YES)
7585 : {
7586 1 : gfc_matching_omp_context_selector = false;
7587 1 : gfc_error ("expected simd clause at %C");
7588 1 : return MATCH_ERROR;
7589 : }
7590 14 : gfc_matching_omp_context_selector = false;
7591 : }
7592 0 : else if (os->code == OMP_TRAIT_IMPLEMENTATION_REQUIRES)
7593 : {
7594 : /* FIXME: The "requires" selector was added in OpenMP 5.1.
7595 : Currently only the now-deprecated syntax
7596 : from OpenMP 5.0 is supported.
7597 : TODO: When implementing, update modules.cc as well. */
7598 0 : sorry_at (gfc_get_location (&gfc_current_locus),
7599 : "%<requires%> selector is not supported yet");
7600 0 : return MATCH_ERROR;
7601 : }
7602 : else
7603 0 : gcc_unreachable ();
7604 14 : break;
7605 : }
7606 0 : default:
7607 0 : gcc_unreachable ();
7608 : }
7609 :
7610 412 : if (gfc_match (" )") != MATCH_YES)
7611 : {
7612 2 : gfc_error ("expected %<)%> at %C");
7613 2 : return MATCH_ERROR;
7614 : }
7615 : }
7616 330 : else if (property_kind != OMP_TRAIT_PROPERTY_NONE
7617 330 : && property_kind != OMP_TRAIT_PROPERTY_CLAUSE_LIST
7618 8 : && property_kind != OMP_TRAIT_PROPERTY_EXTENSION)
7619 : {
7620 8 : if (gfc_match (" (") != MATCH_YES)
7621 : {
7622 8 : gfc_error ("expected %<(%> at %C");
7623 8 : return MATCH_ERROR;
7624 : }
7625 : }
7626 :
7627 732 : if (gfc_match (" ,") != MATCH_YES)
7628 : break;
7629 : }
7630 : while (1);
7631 :
7632 611 : return MATCH_YES;
7633 : }
7634 :
7635 : /* OpenMP 5.0:
7636 :
7637 : trait-set-selector[,trait-set-selector[,...]]
7638 :
7639 : trait-set-selector:
7640 : trait-set-selector-name = { trait-selector[, trait-selector[, ...]] }
7641 :
7642 : trait-set-selector-name:
7643 : constructor
7644 : device
7645 : implementation
7646 : user */
7647 :
7648 : static match
7649 590 : gfc_match_omp_context_selector_specification (gfc_omp_set_selector **oss_head)
7650 : {
7651 726 : do
7652 : {
7653 658 : match m;
7654 658 : char buf[GFC_MAX_SYMBOL_LEN + 1];
7655 658 : enum omp_tss_code set = OMP_TRAIT_SET_INVALID;
7656 :
7657 658 : m = gfc_match_name (buf);
7658 658 : if (m == MATCH_YES)
7659 656 : set = omp_lookup_tss_code (buf);
7660 :
7661 656 : if (set == OMP_TRAIT_SET_INVALID)
7662 : {
7663 5 : gfc_error ("expected context selector set name at %C");
7664 47 : return MATCH_ERROR;
7665 : }
7666 :
7667 653 : m = gfc_match (" =");
7668 653 : if (m != MATCH_YES)
7669 : {
7670 1 : gfc_error ("expected %<=%> at %C");
7671 1 : return MATCH_ERROR;
7672 : }
7673 :
7674 652 : m = gfc_match (" {");
7675 652 : if (m != MATCH_YES)
7676 : {
7677 2 : gfc_error ("expected %<{%> at %C");
7678 2 : return MATCH_ERROR;
7679 : }
7680 :
7681 650 : gfc_omp_set_selector *oss = gfc_get_omp_set_selector ();
7682 650 : oss->next = *oss_head;
7683 650 : oss->code = set;
7684 650 : *oss_head = oss;
7685 :
7686 650 : if (gfc_match_omp_context_selector (oss) != MATCH_YES)
7687 : return MATCH_ERROR;
7688 :
7689 611 : m = gfc_match (" }");
7690 611 : if (m != MATCH_YES)
7691 : {
7692 0 : gfc_error ("expected %<}%> at %C");
7693 0 : return MATCH_ERROR;
7694 : }
7695 :
7696 611 : m = gfc_match (" ,");
7697 611 : if (m != MATCH_YES)
7698 : break;
7699 68 : }
7700 : while (1);
7701 :
7702 543 : return MATCH_YES;
7703 : }
7704 :
7705 :
7706 : match
7707 426 : gfc_match_omp_declare_variant (void)
7708 : {
7709 426 : char buf[GFC_MAX_SYMBOL_LEN + 1];
7710 :
7711 426 : if (gfc_match (" (") != MATCH_YES)
7712 : {
7713 2 : gfc_error ("expected %<(%> at %C");
7714 2 : return MATCH_ERROR;
7715 : }
7716 :
7717 424 : gfc_symtree *base_proc_st, *variant_proc_st;
7718 424 : if (gfc_match_name (buf) != MATCH_YES)
7719 : {
7720 2 : gfc_error ("expected name at %C");
7721 2 : return MATCH_ERROR;
7722 : }
7723 :
7724 422 : if (gfc_get_ha_sym_tree (buf, &base_proc_st))
7725 : return MATCH_ERROR;
7726 :
7727 422 : if (gfc_match (" :") == MATCH_YES)
7728 : {
7729 16 : if (gfc_match_name (buf) != MATCH_YES)
7730 : {
7731 0 : gfc_error ("expected variant name at %C");
7732 0 : return MATCH_ERROR;
7733 : }
7734 :
7735 16 : if (gfc_get_ha_sym_tree (buf, &variant_proc_st))
7736 : return MATCH_ERROR;
7737 : }
7738 : else
7739 : {
7740 : /* Base procedure not specified. */
7741 406 : variant_proc_st = base_proc_st;
7742 406 : base_proc_st = NULL;
7743 : }
7744 :
7745 422 : gfc_omp_declare_variant *odv;
7746 422 : odv = gfc_get_omp_declare_variant ();
7747 422 : odv->where = gfc_current_locus;
7748 422 : odv->variant_proc_symtree = variant_proc_st;
7749 422 : odv->adjust_args_list = NULL;
7750 422 : odv->base_proc_symtree = base_proc_st;
7751 422 : odv->next = NULL;
7752 422 : odv->error_p = false;
7753 :
7754 : /* Add the new declare variant to the end of the list. */
7755 422 : gfc_omp_declare_variant **prev_next = &gfc_current_ns->omp_declare_variant;
7756 577 : while (*prev_next)
7757 155 : prev_next = &((*prev_next)->next);
7758 422 : *prev_next = odv;
7759 :
7760 422 : if (gfc_match (" )") != MATCH_YES)
7761 : {
7762 1 : gfc_error ("expected %<)%> at %C");
7763 1 : return MATCH_ERROR;
7764 : }
7765 :
7766 421 : bool has_match = false, has_adjust_args = false, has_append_args = false;
7767 421 : bool error_p = false;
7768 421 : locus adjust_args_loc;
7769 421 : locus append_args_loc;
7770 :
7771 421 : gfc_gobble_whitespace ();
7772 421 : gfc_match_char (',');
7773 639 : for (;;)
7774 : {
7775 530 : gfc_gobble_whitespace ();
7776 :
7777 530 : enum clause
7778 : {
7779 : clause_match,
7780 : clause_adjust_args,
7781 : clause_append_args
7782 : } ccode;
7783 :
7784 530 : if (gfc_match ("match") == MATCH_YES)
7785 : ccode = clause_match;
7786 119 : else if (gfc_match ("adjust_args") == MATCH_YES)
7787 : {
7788 524 : ccode = clause_adjust_args;
7789 : adjust_args_loc = gfc_current_locus;
7790 : }
7791 38 : else if (gfc_match ("append_args") == MATCH_YES)
7792 : {
7793 524 : ccode = clause_append_args;
7794 : append_args_loc = gfc_current_locus;
7795 : }
7796 : else
7797 : {
7798 : error_p = true;
7799 : break;
7800 : }
7801 :
7802 524 : if (gfc_match (" ( ") != MATCH_YES)
7803 : {
7804 1 : gfc_error ("expected %<(%> at %C");
7805 1 : return MATCH_ERROR;
7806 : }
7807 :
7808 523 : if (ccode == clause_match)
7809 : {
7810 410 : if (has_match)
7811 : {
7812 1 : gfc_error ("%qs clause at %L specified more than once",
7813 : "match", &gfc_current_locus);
7814 1 : return MATCH_ERROR;
7815 : }
7816 409 : has_match = true;
7817 409 : if (gfc_match_omp_context_selector_specification (&odv->set_selectors)
7818 : != MATCH_YES)
7819 : return MATCH_ERROR;
7820 369 : if (gfc_match (" )") != MATCH_YES)
7821 : {
7822 0 : gfc_error ("expected %<)%> at %C");
7823 0 : return MATCH_ERROR;
7824 : }
7825 : }
7826 113 : else if (ccode == clause_adjust_args)
7827 : {
7828 81 : has_adjust_args = true;
7829 81 : bool need_device_ptr_p = false;
7830 81 : bool need_device_addr_p = false;
7831 81 : if (gfc_match ("nothing ") == MATCH_YES)
7832 : ;
7833 58 : else if (gfc_match ("need_device_ptr ") == MATCH_YES)
7834 : need_device_ptr_p = true;
7835 9 : else if (gfc_match ("need_device_addr ") == MATCH_YES)
7836 : need_device_addr_p = true;
7837 : else
7838 : {
7839 2 : gfc_error ("expected %<nothing%>, %<need_device_ptr%> or "
7840 : "%<need_device_addr%> at %C");
7841 2 : return MATCH_ERROR;
7842 : }
7843 79 : if (gfc_match (": ") != MATCH_YES)
7844 : {
7845 1 : gfc_error ("expected %<:%> at %C");
7846 1 : return MATCH_ERROR;
7847 : }
7848 : gfc_omp_namelist *tail = NULL;
7849 : bool need_range = false, have_range = false;
7850 125 : while (true)
7851 : {
7852 125 : gfc_omp_namelist *p = gfc_get_omp_namelist ();
7853 125 : p->where = gfc_current_locus;
7854 125 : p->u.adj_args.need_ptr = need_device_ptr_p;
7855 125 : p->u.adj_args.need_addr = need_device_addr_p;
7856 125 : if (tail)
7857 : {
7858 47 : tail->next = p;
7859 47 : tail = tail->next;
7860 : }
7861 : else
7862 : {
7863 78 : gfc_omp_namelist **q = &odv->adjust_args_list;
7864 78 : if (*q)
7865 : {
7866 50 : for (; (*q)->next; q = &(*q)->next)
7867 : ;
7868 28 : (*q)->next = p;
7869 : }
7870 : else
7871 50 : *q = p;
7872 : tail = p;
7873 : }
7874 125 : if (gfc_match (": ") == MATCH_YES)
7875 : {
7876 2 : if (have_range)
7877 : {
7878 0 : gfc_error ("unexpected %<:%> at %C");
7879 2 : return MATCH_ERROR;
7880 : }
7881 2 : p->u.adj_args.range_start = have_range = true;
7882 2 : need_range = false;
7883 47 : continue;
7884 : }
7885 123 : if (have_range && gfc_match (", ") == MATCH_YES)
7886 : {
7887 1 : have_range = false;
7888 1 : continue;
7889 : }
7890 122 : if (have_range && gfc_match (") ") == MATCH_YES)
7891 : break;
7892 121 : locus saved_loc = gfc_current_locus;
7893 :
7894 : /* Without ranges, only arg names or integer literals permitted;
7895 : handle literals here as gfc_match_expr simplifies the expr. */
7896 121 : if (gfc_match_literal_constant (&p->expr, true) == MATCH_YES)
7897 : {
7898 17 : gfc_gobble_whitespace ();
7899 17 : char c = gfc_peek_ascii_char ();
7900 17 : if (c != ')' && c != ',' && c != ':')
7901 : {
7902 1 : gfc_free_expr (p->expr);
7903 1 : p->expr = NULL;
7904 1 : gfc_current_locus = saved_loc;
7905 : }
7906 : }
7907 121 : if (!p->expr && gfc_match ("omp_num_args") == MATCH_YES)
7908 : {
7909 6 : if (!have_range)
7910 3 : p->u.adj_args.range_start = need_range = true;
7911 : else
7912 : need_range = false;
7913 :
7914 6 : locus saved_loc2 = gfc_current_locus;
7915 6 : gfc_gobble_whitespace ();
7916 6 : char c = gfc_peek_ascii_char ();
7917 6 : if (c == '+' || c == '-')
7918 : {
7919 5 : if (gfc_match ("+ %e", &p->expr) == MATCH_YES)
7920 1 : p->u.adj_args.omp_num_args_plus = true;
7921 4 : else if (gfc_match ("- %e", &p->expr) == MATCH_YES)
7922 4 : p->u.adj_args.omp_num_args_minus = true;
7923 0 : else if (!gfc_error_check ())
7924 : {
7925 0 : gfc_error ("expected constant integer expression "
7926 : "at %C");
7927 0 : p->u.adj_args.error_p = true;
7928 0 : return MATCH_ERROR;
7929 : }
7930 5 : p->where = gfc_get_location_range (&saved_loc, 1,
7931 : &saved_loc, 1,
7932 : &gfc_current_locus);
7933 : }
7934 : else
7935 : {
7936 1 : p->where = gfc_get_location_range (&saved_loc, 1,
7937 : &saved_loc, 1,
7938 : &saved_loc2);
7939 1 : p->u.adj_args.omp_num_args_plus = true;
7940 : }
7941 : }
7942 115 : else if (!p->expr)
7943 : {
7944 99 : match m = gfc_match_expr (&p->expr);
7945 99 : if (m != MATCH_YES)
7946 : {
7947 1 : gfc_error ("expected dummy parameter name, "
7948 : "%<omp_num_args%> or constant positive integer"
7949 : " at %C");
7950 1 : p->u.adj_args.error_p = true;
7951 1 : return MATCH_ERROR;
7952 : }
7953 98 : if (p->expr->expr_type == EXPR_CONSTANT && !have_range)
7954 98 : need_range = true; /* Constant expr but not literal. */
7955 98 : p->where = p->expr->where;
7956 : }
7957 : else
7958 16 : p->where = p->expr->where;
7959 120 : gfc_gobble_whitespace ();
7960 120 : match m = gfc_match (": ");
7961 120 : if (need_range && m != MATCH_YES)
7962 : {
7963 1 : gfc_error ("expected %<:%> at %C");
7964 1 : return MATCH_ERROR;
7965 : }
7966 119 : if (m == MATCH_YES)
7967 : {
7968 6 : p->u.adj_args.range_start = have_range = true;
7969 6 : need_range = false;
7970 6 : continue;
7971 : }
7972 113 : need_range = have_range = false;
7973 113 : if (gfc_match (", ") == MATCH_YES)
7974 38 : continue;
7975 75 : if (gfc_match (") ") == MATCH_YES)
7976 : break;
7977 : }
7978 : }
7979 32 : else if (ccode == clause_append_args)
7980 : {
7981 32 : if (has_append_args)
7982 : {
7983 1 : gfc_error ("%qs clause at %L specified more than once",
7984 : "append_args", &gfc_current_locus);
7985 1 : return MATCH_ERROR;
7986 : }
7987 56 : has_append_args = true;
7988 : gfc_omp_namelist *append_args_last = NULL;
7989 81 : do
7990 : {
7991 56 : gfc_gobble_whitespace ();
7992 56 : if (gfc_match ("interop ") != MATCH_YES)
7993 : {
7994 0 : gfc_error ("expected %<interop%> at %C");
7995 3 : return MATCH_ERROR;
7996 : }
7997 56 : if (gfc_match ("( ") != MATCH_YES)
7998 : {
7999 0 : gfc_error ("expected %<(%> at %C");
8000 0 : return MATCH_ERROR;
8001 : }
8002 :
8003 56 : bool target, targetsync;
8004 56 : char *type_str = NULL;
8005 56 : int type_str_len;
8006 56 : locus loc = gfc_current_locus;
8007 56 : if (gfc_parser_omp_clause_init_modifiers (target, targetsync,
8008 : &type_str, type_str_len,
8009 : false) == MATCH_ERROR)
8010 : return MATCH_ERROR;
8011 :
8012 54 : gfc_omp_namelist *n = gfc_get_omp_namelist();
8013 54 : n->where = loc;
8014 54 : n->u.init.target = target;
8015 54 : n->u.init.targetsync = targetsync;
8016 54 : n->u.init.len = type_str_len;
8017 54 : n->u2.init_interop = type_str;
8018 54 : if (odv->append_args_list)
8019 : {
8020 25 : append_args_last->next = n;
8021 25 : append_args_last = n;
8022 : }
8023 : else
8024 29 : append_args_last = odv->append_args_list = n;
8025 :
8026 54 : gfc_gobble_whitespace ();
8027 54 : if (gfc_match_char (',') == MATCH_YES)
8028 25 : continue;
8029 29 : if (gfc_match_char (')') == MATCH_YES)
8030 : break;
8031 1 : gfc_error ("Expected %<,%> or %<)%> at %C");
8032 1 : return MATCH_ERROR;
8033 25 : }
8034 : while (true);
8035 : }
8036 473 : gfc_gobble_whitespace ();
8037 473 : if (gfc_match_omp_eos () == MATCH_YES)
8038 : break;
8039 109 : gfc_match_char (',');
8040 109 : }
8041 :
8042 370 : if (error_p || (!has_match && !has_adjust_args && !has_append_args))
8043 : {
8044 6 : gfc_error ("expected %<match%>, %<adjust_args%> or %<append_args%> at %C");
8045 6 : return MATCH_ERROR;
8046 : }
8047 :
8048 364 : if (!has_match)
8049 : {
8050 3 : gfc_error ("expected %<match%> clause at %C");
8051 3 : return MATCH_ERROR;
8052 : }
8053 :
8054 : return MATCH_YES;
8055 : }
8056 :
8057 :
8058 : static match
8059 166 : match_omp_metadirective (bool begin_p)
8060 : {
8061 166 : locus old_loc = gfc_current_locus;
8062 166 : gfc_omp_variant *variants_head;
8063 166 : gfc_omp_variant **next_variant = &variants_head;
8064 166 : bool default_seen = false;
8065 :
8066 : /* Parse the context selectors. */
8067 674 : for (;;)
8068 : {
8069 420 : bool default_p = false;
8070 420 : gfc_omp_set_selector *selectors = NULL;
8071 :
8072 420 : gfc_gobble_whitespace ();
8073 420 : if (gfc_match_eos () == MATCH_YES)
8074 : break;
8075 272 : gfc_match_char (',');
8076 272 : gfc_gobble_whitespace ();
8077 :
8078 272 : locus variant_locus = gfc_current_locus;
8079 :
8080 272 : if (gfc_match ("default ( ") == MATCH_YES)
8081 : {
8082 82 : default_p = true;
8083 82 : gfc_warning (OPT_Wdeprecated_openmp,
8084 : "%<default%> clause with metadirective at %L "
8085 : "deprecated since OpenMP 5.2", &variant_locus);
8086 : }
8087 190 : else if (gfc_match ("otherwise ( ") == MATCH_YES)
8088 : default_p = true;
8089 183 : else if (gfc_match ("when ( ") != MATCH_YES)
8090 : {
8091 1 : gfc_error ("expected %<when%>, %<otherwise%>, or %<default%> at %C");
8092 1 : gfc_current_locus = old_loc;
8093 18 : return MATCH_ERROR;
8094 : }
8095 89 : if (default_p && default_seen)
8096 : {
8097 3 : gfc_error ("too many %<otherwise%> or %<default%> clauses "
8098 : "in %<metadirective%> at %C");
8099 3 : gfc_current_locus = old_loc;
8100 3 : return MATCH_ERROR;
8101 : }
8102 268 : else if (default_seen)
8103 : {
8104 1 : gfc_error ("%<otherwise%> or %<default%> clause "
8105 : "must appear last in %<metadirective%> at %C");
8106 1 : gfc_current_locus = old_loc;
8107 1 : return MATCH_ERROR;
8108 : }
8109 :
8110 267 : if (!default_p)
8111 : {
8112 181 : if (gfc_match_omp_context_selector_specification (&selectors)
8113 : != MATCH_YES)
8114 : return MATCH_ERROR;
8115 :
8116 174 : if (gfc_match (" : ") != MATCH_YES)
8117 : {
8118 1 : gfc_error ("expected %<:%> at %C");
8119 1 : gfc_current_locus = old_loc;
8120 1 : return MATCH_ERROR;
8121 : }
8122 :
8123 173 : gfc_commit_symbols ();
8124 : }
8125 :
8126 259 : gfc_matching_omp_context_selector = true;
8127 259 : gfc_statement directive = match_omp_directive ();
8128 259 : gfc_matching_omp_context_selector = false;
8129 :
8130 259 : if (is_omp_declarative_stmt (directive))
8131 0 : sorry_at (gfc_get_location (&gfc_current_locus),
8132 : "declarative directive variants are not supported");
8133 :
8134 259 : if (gfc_error_flag_test ())
8135 : {
8136 2 : gfc_current_locus = old_loc;
8137 2 : return MATCH_ERROR;
8138 : }
8139 :
8140 257 : if (gfc_match (" )") != MATCH_YES)
8141 : {
8142 0 : gfc_error ("Expected %<)%> at %C");
8143 0 : gfc_current_locus = old_loc;
8144 0 : return MATCH_ERROR;
8145 : }
8146 :
8147 257 : gfc_commit_symbols ();
8148 :
8149 257 : if (begin_p
8150 257 : && directive != ST_NONE
8151 257 : && gfc_omp_end_stmt (directive) == ST_NONE)
8152 : {
8153 3 : gfc_error ("variant directive used in OMP BEGIN METADIRECTIVE "
8154 : "at %C must have a corresponding end directive");
8155 3 : gfc_current_locus = old_loc;
8156 3 : return MATCH_ERROR;
8157 : }
8158 :
8159 254 : if (default_p)
8160 : default_seen = true;
8161 :
8162 254 : gfc_omp_variant *omv = gfc_get_omp_variant ();
8163 254 : omv->selectors = selectors;
8164 254 : omv->stmt = directive;
8165 254 : omv->where = variant_locus;
8166 :
8167 254 : if (directive == ST_NONE)
8168 : {
8169 : /* The directive was a 'nothing' directive. */
8170 15 : omv->code = gfc_get_code (EXEC_CONTINUE);
8171 15 : omv->code->ext.omp_clauses = NULL;
8172 : }
8173 : else
8174 : {
8175 239 : omv->code = gfc_get_code (new_st.op);
8176 239 : omv->code->ext.omp_clauses = new_st.ext.omp_clauses;
8177 : /* Prevent the OpenMP clauses from being freed via NEW_ST. */
8178 239 : new_st.ext.omp_clauses = NULL;
8179 : }
8180 :
8181 254 : *next_variant = omv;
8182 254 : next_variant = &omv->next;
8183 254 : }
8184 :
8185 148 : if (gfc_match_omp_eos () != MATCH_YES)
8186 : {
8187 0 : gfc_error ("Unexpected junk after OMP METADIRECTIVE at %C");
8188 0 : gfc_current_locus = old_loc;
8189 0 : return MATCH_ERROR;
8190 : }
8191 :
8192 : /* Add a 'default (nothing)' clause if no default is explicitly given. */
8193 148 : if (!default_seen)
8194 : {
8195 71 : gfc_omp_variant *omv = gfc_get_omp_variant ();
8196 71 : omv->stmt = ST_NONE;
8197 71 : omv->code = gfc_get_code (EXEC_CONTINUE);
8198 71 : omv->code->ext.omp_clauses = NULL;
8199 71 : omv->where = old_loc;
8200 71 : omv->selectors = NULL;
8201 :
8202 71 : *next_variant = omv;
8203 71 : next_variant = &omv->next;
8204 : }
8205 :
8206 148 : new_st.op = EXEC_OMP_METADIRECTIVE;
8207 148 : new_st.ext.omp_variants = variants_head;
8208 :
8209 148 : return MATCH_YES;
8210 : }
8211 :
8212 : match
8213 46 : gfc_match_omp_begin_metadirective (void)
8214 : {
8215 46 : return match_omp_metadirective (true);
8216 : }
8217 :
8218 : match
8219 120 : gfc_match_omp_metadirective (void)
8220 : {
8221 120 : return match_omp_metadirective (false);
8222 : }
8223 :
8224 : /* Match 'omp threadprivate' or 'omp groupprivate'. */
8225 : static match
8226 262 : gfc_match_omp_thread_group_private (bool is_groupprivate)
8227 : {
8228 262 : locus old_loc;
8229 262 : char n[GFC_MAX_SYMBOL_LEN+1];
8230 262 : gfc_symbol *sym;
8231 262 : match m;
8232 262 : gfc_symtree *st;
8233 262 : struct sym_loc_t { gfc_symbol *sym; gfc_common_head *com; locus loc; };
8234 262 : auto_vec<sym_loc_t> syms;
8235 :
8236 262 : old_loc = gfc_current_locus;
8237 :
8238 262 : m = gfc_match (" ( ");
8239 262 : if (m != MATCH_YES)
8240 : return m;
8241 :
8242 372 : for (;;)
8243 : {
8244 317 : locus sym_loc = gfc_current_locus;
8245 317 : m = gfc_match_symbol (&sym, 0);
8246 317 : switch (m)
8247 : {
8248 212 : case MATCH_YES:
8249 212 : if (sym->attr.in_common)
8250 0 : gfc_error_now ("%qs variable at %L is an element of a COMMON block",
8251 : is_groupprivate ? "groupprivate" : "threadprivate",
8252 : &sym_loc);
8253 212 : else if (!is_groupprivate
8254 212 : && !gfc_add_threadprivate (&sym->attr, sym->name, &sym_loc))
8255 16 : goto cleanup;
8256 210 : else if (is_groupprivate)
8257 : {
8258 33 : if (!gfc_add_omp_groupprivate (&sym->attr, sym->name, &sym_loc))
8259 4 : goto cleanup;
8260 29 : syms.safe_push ({sym, nullptr, sym_loc});
8261 : }
8262 206 : goto next_item;
8263 : case MATCH_NO:
8264 : break;
8265 0 : case MATCH_ERROR:
8266 0 : goto cleanup;
8267 : }
8268 :
8269 105 : m = gfc_match (" / %n /", n);
8270 105 : if (m == MATCH_ERROR)
8271 0 : goto cleanup;
8272 105 : if (m == MATCH_NO || n[0] == '\0')
8273 0 : goto syntax;
8274 :
8275 105 : st = gfc_find_symtree (gfc_current_ns->common_root, n);
8276 105 : if (st == NULL)
8277 : {
8278 2 : gfc_error ("COMMON block /%s/ not found at %L", n, &sym_loc);
8279 2 : goto cleanup;
8280 : }
8281 103 : syms.safe_push ({nullptr, st->n.common, sym_loc});
8282 103 : if (is_groupprivate)
8283 30 : st->n.common->omp_groupprivate = 1;
8284 : else
8285 73 : st->n.common->threadprivate = 1;
8286 236 : for (sym = st->n.common->head; sym; sym = sym->common_next)
8287 141 : if (!is_groupprivate
8288 141 : && !gfc_add_threadprivate (&sym->attr, sym->name, &sym_loc))
8289 3 : goto cleanup;
8290 138 : else if (is_groupprivate
8291 138 : && !gfc_add_omp_groupprivate (&sym->attr, sym->name, &sym_loc))
8292 5 : goto cleanup;
8293 :
8294 95 : next_item:
8295 301 : if (gfc_match_char (')') == MATCH_YES)
8296 : break;
8297 55 : if (gfc_match_char (',') != MATCH_YES)
8298 0 : goto syntax;
8299 55 : }
8300 :
8301 246 : if (is_groupprivate)
8302 : {
8303 42 : gfc_omp_clauses *c;
8304 42 : m = gfc_match_omp_clauses (&c, omp_mask (OMP_CLAUSE_DEVICE_TYPE), false, false);
8305 42 : if (m == MATCH_ERROR)
8306 0 : return MATCH_ERROR;
8307 :
8308 42 : if (c->device_type == OMP_DEVICE_TYPE_UNSET)
8309 19 : c->device_type = OMP_DEVICE_TYPE_ANY;
8310 :
8311 92 : for (size_t i = 0; i < syms.length (); i++)
8312 50 : if (syms[i].sym)
8313 : {
8314 27 : sym_loc_t &n = syms[i];
8315 27 : if (n.sym->attr.in_common)
8316 0 : gfc_error_now ("Variable %qs at %L is an element of a COMMON "
8317 : "block", n.sym->name, &n.loc);
8318 27 : else if (n.sym->attr.omp_declare_target
8319 26 : || n.sym->attr.omp_declare_target_link)
8320 2 : gfc_error_now ("List item %qs at %L implies OMP DECLARE TARGET "
8321 : "with the LOCAL clause, but it has been specified"
8322 : " with a different clause before",
8323 : n.sym->name, &n.loc);
8324 27 : if (n.sym->attr.omp_device_type != OMP_DEVICE_TYPE_UNSET
8325 5 : && n.sym->attr.omp_device_type != c->device_type)
8326 : {
8327 2 : const char *dt = "any";
8328 2 : if (n.sym->attr.omp_device_type == OMP_DEVICE_TYPE_HOST)
8329 : dt = "host";
8330 0 : else if (n.sym->attr.omp_device_type == OMP_DEVICE_TYPE_NOHOST)
8331 0 : dt = "nohost";
8332 2 : gfc_error_now ("List item %qs at %L set in previous OMP DECLARE "
8333 : "TARGET directive to the different DEVICE_TYPE %qs",
8334 : n.sym->name, &n.loc, dt);
8335 : }
8336 27 : gfc_add_omp_declare_target_local (&n.sym->attr, n.sym->name,
8337 : &n.loc);
8338 27 : n.sym->attr.omp_device_type = c->device_type;
8339 : }
8340 : else /* Common block. */
8341 : {
8342 23 : sym_loc_t &n = syms[i];
8343 23 : if (n.com->omp_declare_target
8344 22 : || n.com->omp_declare_target_link)
8345 2 : gfc_error_now ("List item %</%s/%> at %L implies OMP DECLARE "
8346 : "TARGET with the LOCAL clause, but it has been "
8347 : "specified with a different clause before",
8348 2 : n.com->name, &n.loc);
8349 23 : if (n.com->omp_device_type != OMP_DEVICE_TYPE_UNSET
8350 5 : && n.com->omp_device_type != c->device_type)
8351 : {
8352 2 : const char *dt = "any";
8353 2 : if (n.com->omp_device_type == OMP_DEVICE_TYPE_HOST)
8354 : dt = "host";
8355 0 : else if (n.com->omp_device_type == OMP_DEVICE_TYPE_NOHOST)
8356 0 : dt = "nohost";
8357 2 : gfc_error_now ("List item %qs at %L set in previous OMP DECLARE"
8358 : " TARGET directive to the different DEVICE_TYPE "
8359 2 : "%qs", n.com->name, &n.loc, dt);
8360 : }
8361 23 : n.com->omp_declare_target_local = 1;
8362 23 : n.com->omp_device_type = c->device_type;
8363 46 : for (gfc_symbol *s = n.com->head; s; s = s->common_next)
8364 : {
8365 23 : gfc_add_omp_declare_target_local (&s->attr, s->name, &n.loc);
8366 23 : s->attr.omp_device_type = c->device_type;
8367 : }
8368 : }
8369 42 : free (c);
8370 : }
8371 :
8372 246 : if (gfc_match_omp_eos () != MATCH_YES)
8373 : {
8374 0 : gfc_error ("Unexpected junk after OMP %s at %C",
8375 : is_groupprivate ? "GROUPPRIVATE" : "THREADPRIVATE");
8376 0 : goto cleanup;
8377 : }
8378 :
8379 : return MATCH_YES;
8380 :
8381 0 : syntax:
8382 0 : gfc_error ("Syntax error in !$OMP %s list at %C",
8383 : is_groupprivate ? "GROUPPRIVATE" : "THREADPRIVATE");
8384 :
8385 16 : cleanup:
8386 16 : gfc_current_locus = old_loc;
8387 16 : return MATCH_ERROR;
8388 262 : }
8389 :
8390 :
8391 : match
8392 51 : gfc_match_omp_groupprivate (void)
8393 : {
8394 51 : return gfc_match_omp_thread_group_private (true);
8395 : }
8396 :
8397 :
8398 : match
8399 211 : gfc_match_omp_threadprivate (void)
8400 : {
8401 211 : return gfc_match_omp_thread_group_private (false);
8402 : }
8403 :
8404 :
8405 : match
8406 2213 : gfc_match_omp_parallel (void)
8407 : {
8408 2213 : return match_omp (EXEC_OMP_PARALLEL, OMP_PARALLEL_CLAUSES);
8409 : }
8410 :
8411 :
8412 : match
8413 1203 : gfc_match_omp_parallel_do (void)
8414 : {
8415 1203 : return match_omp (EXEC_OMP_PARALLEL_DO,
8416 1203 : (OMP_PARALLEL_CLAUSES | OMP_DO_CLAUSES)
8417 1203 : & ~(omp_mask (OMP_CLAUSE_NOWAIT)));
8418 : }
8419 :
8420 :
8421 : match
8422 298 : gfc_match_omp_parallel_do_simd (void)
8423 : {
8424 298 : return match_omp (EXEC_OMP_PARALLEL_DO_SIMD,
8425 298 : (OMP_PARALLEL_CLAUSES | OMP_DO_CLAUSES | OMP_SIMD_CLAUSES)
8426 298 : & ~(omp_mask (OMP_CLAUSE_NOWAIT)));
8427 : }
8428 :
8429 :
8430 : match
8431 14 : gfc_match_omp_parallel_masked (void)
8432 : {
8433 14 : return match_omp (EXEC_OMP_PARALLEL_MASKED,
8434 14 : OMP_PARALLEL_CLAUSES | OMP_MASKED_CLAUSES);
8435 : }
8436 :
8437 : match
8438 10 : gfc_match_omp_parallel_masked_taskloop (void)
8439 : {
8440 10 : return match_omp (EXEC_OMP_PARALLEL_MASKED_TASKLOOP,
8441 10 : (OMP_PARALLEL_CLAUSES | OMP_MASKED_CLAUSES
8442 10 : | OMP_TASKLOOP_CLAUSES)
8443 10 : & ~(omp_mask (OMP_CLAUSE_IN_REDUCTION)));
8444 : }
8445 :
8446 : match
8447 13 : gfc_match_omp_parallel_masked_taskloop_simd (void)
8448 : {
8449 13 : return match_omp (EXEC_OMP_PARALLEL_MASKED_TASKLOOP_SIMD,
8450 13 : (OMP_PARALLEL_CLAUSES | OMP_MASKED_CLAUSES
8451 13 : | OMP_TASKLOOP_CLAUSES | OMP_SIMD_CLAUSES)
8452 13 : & ~(omp_mask (OMP_CLAUSE_IN_REDUCTION)));
8453 : }
8454 :
8455 : match
8456 14 : gfc_match_omp_parallel_master (void)
8457 : {
8458 14 : gfc_warning (OPT_Wdeprecated_openmp,
8459 : "%<master%> construct at %C deprecated since OpenMP 5.1, use "
8460 : "%<masked%>");
8461 14 : return match_omp (EXEC_OMP_PARALLEL_MASTER, OMP_PARALLEL_CLAUSES);
8462 : }
8463 :
8464 : match
8465 15 : gfc_match_omp_parallel_master_taskloop (void)
8466 : {
8467 15 : gfc_warning (OPT_Wdeprecated_openmp,
8468 : "%<master%> construct at %C deprecated since OpenMP 5.1, "
8469 : "use %<masked%>");
8470 15 : return match_omp (EXEC_OMP_PARALLEL_MASTER_TASKLOOP,
8471 15 : (OMP_PARALLEL_CLAUSES | OMP_TASKLOOP_CLAUSES)
8472 15 : & ~(omp_mask (OMP_CLAUSE_IN_REDUCTION)));
8473 : }
8474 :
8475 : match
8476 21 : gfc_match_omp_parallel_master_taskloop_simd (void)
8477 : {
8478 21 : gfc_warning (OPT_Wdeprecated_openmp,
8479 : "%<master%> construct at %C deprecated since OpenMP 5.1, "
8480 : "use %<masked%>");
8481 21 : return match_omp (EXEC_OMP_PARALLEL_MASTER_TASKLOOP_SIMD,
8482 21 : (OMP_PARALLEL_CLAUSES | OMP_TASKLOOP_CLAUSES
8483 21 : | OMP_SIMD_CLAUSES)
8484 21 : & ~(omp_mask (OMP_CLAUSE_IN_REDUCTION)));
8485 : }
8486 :
8487 : match
8488 59 : gfc_match_omp_parallel_sections (void)
8489 : {
8490 59 : return match_omp (EXEC_OMP_PARALLEL_SECTIONS,
8491 59 : (OMP_PARALLEL_CLAUSES | OMP_SECTIONS_CLAUSES)
8492 59 : & ~(omp_mask (OMP_CLAUSE_NOWAIT)));
8493 : }
8494 :
8495 :
8496 : match
8497 56 : gfc_match_omp_parallel_workshare (void)
8498 : {
8499 56 : return match_omp (EXEC_OMP_PARALLEL_WORKSHARE, OMP_PARALLEL_CLAUSES);
8500 : }
8501 :
8502 : void
8503 50464 : gfc_check_omp_requires (gfc_namespace *ns, int ref_omp_requires)
8504 : {
8505 50464 : const char *msg = G_("Program unit at %L has OpenMP device "
8506 : "constructs/routines but does not set !$OMP REQUIRES %s "
8507 : "but other program units do");
8508 50464 : if (ns->omp_target_seen
8509 1303 : && (ns->omp_requires & OMP_REQ_TARGET_MASK)
8510 1303 : != (ref_omp_requires & OMP_REQ_TARGET_MASK))
8511 : {
8512 6 : gcc_assert (ns->proc_name);
8513 6 : if ((ref_omp_requires & OMP_REQ_REVERSE_OFFLOAD)
8514 5 : && !(ns->omp_requires & OMP_REQ_REVERSE_OFFLOAD))
8515 4 : gfc_error (msg, &ns->proc_name->declared_at, "REVERSE_OFFLOAD");
8516 6 : if ((ref_omp_requires & OMP_REQ_UNIFIED_ADDRESS)
8517 1 : && !(ns->omp_requires & OMP_REQ_UNIFIED_ADDRESS))
8518 1 : gfc_error (msg, &ns->proc_name->declared_at, "UNIFIED_ADDRESS");
8519 6 : if ((ref_omp_requires & OMP_REQ_UNIFIED_SHARED_MEMORY)
8520 4 : && !(ns->omp_requires & OMP_REQ_UNIFIED_SHARED_MEMORY))
8521 2 : gfc_error (msg, &ns->proc_name->declared_at, "UNIFIED_SHARED_MEMORY");
8522 6 : if ((ref_omp_requires & OMP_REQ_SELF_MAPS)
8523 1 : && !(ns->omp_requires & OMP_REQ_UNIFIED_SHARED_MEMORY))
8524 1 : gfc_error (msg, &ns->proc_name->declared_at, "SELF_MAPS");
8525 : }
8526 50464 : }
8527 :
8528 : bool
8529 138 : gfc_omp_requires_add_clause (gfc_omp_requires_kind clause,
8530 : const char *clause_name, locus *loc,
8531 : const char *module_name)
8532 : {
8533 138 : gfc_namespace *prog_unit = gfc_current_ns;
8534 162 : while (prog_unit->parent)
8535 : {
8536 26 : if (gfc_state_stack->previous
8537 26 : && gfc_state_stack->previous->state == COMP_INTERFACE)
8538 : break;
8539 : /* A submodule namespace may have its parent set to the ancestor module
8540 : for host-association purposes. Do not escape the submodule boundary:
8541 : the submodule itself is the program unit for OMP REQUIRES purposes. */
8542 25 : if (prog_unit->proc_name
8543 25 : && prog_unit->proc_name->attr.flavor == FL_MODULE)
8544 : break;
8545 24 : prog_unit = prog_unit->parent;
8546 : }
8547 :
8548 : /* Requires added after use. */
8549 138 : if (prog_unit->omp_target_seen
8550 24 : && (clause & OMP_REQ_TARGET_MASK)
8551 24 : && !(prog_unit->omp_requires & clause))
8552 : {
8553 0 : if (module_name)
8554 0 : gfc_error ("!$OMP REQUIRES clause %qs specified via module %qs use "
8555 : "at %L comes after using a device construct/routine",
8556 : clause_name, module_name, loc);
8557 : else
8558 0 : gfc_error ("!$OMP REQUIRES clause %qs specified at %L comes after "
8559 : "using a device construct/routine", clause_name, loc);
8560 : return false;
8561 : }
8562 :
8563 : /* Overriding atomic_default_mem_order clause value. */
8564 138 : if ((clause & OMP_REQ_ATOMIC_MEM_ORDER_MASK)
8565 34 : && (prog_unit->omp_requires & OMP_REQ_ATOMIC_MEM_ORDER_MASK)
8566 6 : && (prog_unit->omp_requires & OMP_REQ_ATOMIC_MEM_ORDER_MASK)
8567 6 : != (int) clause)
8568 : {
8569 3 : const char *other;
8570 3 : switch (prog_unit->omp_requires & OMP_REQ_ATOMIC_MEM_ORDER_MASK)
8571 : {
8572 : case OMP_REQ_ATOMIC_MEM_ORDER_SEQ_CST: other = "seq_cst"; break;
8573 0 : case OMP_REQ_ATOMIC_MEM_ORDER_ACQ_REL: other = "acq_rel"; break;
8574 1 : case OMP_REQ_ATOMIC_MEM_ORDER_ACQUIRE: other = "acquire"; break;
8575 1 : case OMP_REQ_ATOMIC_MEM_ORDER_RELAXED: other = "relaxed"; break;
8576 0 : case OMP_REQ_ATOMIC_MEM_ORDER_RELEASE: other = "release"; break;
8577 0 : default: gcc_unreachable ();
8578 : }
8579 :
8580 3 : if (module_name)
8581 0 : gfc_error ("!$OMP REQUIRES clause %<atomic_default_mem_order(%s)%> "
8582 : "specified via module %qs use at %L overrides a previous "
8583 : "%<atomic_default_mem_order(%s)%> (which might be through "
8584 : "using a module)", clause_name, module_name, loc, other);
8585 : else
8586 3 : gfc_error ("!$OMP REQUIRES clause %<atomic_default_mem_order(%s)%> "
8587 : "specified at %L overrides a previous "
8588 : "%<atomic_default_mem_order(%s)%> (which might be through "
8589 : "using a module)", clause_name, loc, other);
8590 : return false;
8591 : }
8592 :
8593 : /* Requires via module not at program-unit level and not repeating clause. */
8594 135 : if (prog_unit != gfc_current_ns && !(prog_unit->omp_requires & clause))
8595 : {
8596 0 : if (clause & OMP_REQ_ATOMIC_MEM_ORDER_MASK)
8597 0 : gfc_error ("!$OMP REQUIRES clause %<atomic_default_mem_order(%s)%> "
8598 : "specified via module %qs use at %L but same clause is "
8599 : "not specified for the program unit", clause_name,
8600 : module_name, loc);
8601 : else
8602 0 : gfc_error ("!$OMP REQUIRES clause %qs specified via module %qs use at "
8603 : "%L but same clause is not specified for the program unit",
8604 : clause_name, module_name, loc);
8605 : return false;
8606 : }
8607 :
8608 135 : if (!gfc_state_stack->previous
8609 127 : || gfc_state_stack->previous->state != COMP_INTERFACE)
8610 134 : prog_unit->omp_requires |= clause;
8611 : return true;
8612 : }
8613 :
8614 : match
8615 110 : gfc_match_omp_requires (void)
8616 : {
8617 110 : static const char *clauses[] = {"reverse_offload",
8618 : "unified_address",
8619 : "unified_shared_memory",
8620 : "self_maps",
8621 : "dynamic_allocators",
8622 : "atomic_default_mem_order"};
8623 110 : const char *clause = NULL;
8624 110 : int requires_clauses = 0;
8625 110 : int seen_clauses = 0;
8626 110 : bool first = true;
8627 110 : locus old_loc;
8628 :
8629 : /* A submodule's namespace may have its parent pointer set to the ancestor
8630 : module namespace for host-association purposes. The submodule spec part
8631 : is still a valid program-unit spec part for OMP REQUIRES. Only reject
8632 : the directive when we are genuinely nested inside a procedure. */
8633 110 : if (gfc_current_ns->parent
8634 8 : && !(gfc_current_ns->proc_name
8635 8 : && gfc_current_ns->proc_name->attr.flavor == FL_MODULE)
8636 7 : && (!gfc_state_stack->previous
8637 7 : || gfc_state_stack->previous->state != COMP_INTERFACE))
8638 : {
8639 6 : gfc_error ("!$OMP REQUIRES at %C must appear in the specification part "
8640 : "of a program unit");
8641 6 : return MATCH_ERROR;
8642 : }
8643 :
8644 : /* Specifying '<clause>(.false.)' in this directive does not affect requirements
8645 : set in another 'requires' directive in the same compilation unit; however,
8646 : specifying it multiple times in the same directive is disallowed. */
8647 336 : while (true)
8648 : {
8649 220 : bool bval;
8650 220 : match m;
8651 220 : old_loc = gfc_current_locus;
8652 220 : gfc_omp_requires_kind requires_clause = OMP_REQ_NONE;
8653 220 : if (gfc_match_char (',') != MATCH_YES
8654 220 : && (first && gfc_match_space () != MATCH_YES))
8655 17 : goto error;
8656 220 : first = false;
8657 220 : gfc_gobble_whitespace ();
8658 220 : old_loc = gfc_current_locus;
8659 :
8660 220 : if (gfc_match_omp_eos () != MATCH_NO)
8661 : break;
8662 133 : if ((m = gfc_match_boolean_clause (&bval, clauses[0],
8663 133 : seen_clauses & OMP_REQ_REVERSE_OFFLOAD)) != MATCH_NO)
8664 : {
8665 40 : if (m == MATCH_ERROR)
8666 2 : goto error;
8667 38 : clause = clauses[0];
8668 38 : seen_clauses |= OMP_REQ_REVERSE_OFFLOAD;
8669 38 : if (bval)
8670 : requires_clause = OMP_REQ_REVERSE_OFFLOAD;
8671 : }
8672 93 : else if ((m = gfc_match_boolean_clause (&bval, clauses[1],
8673 93 : seen_clauses & OMP_REQ_UNIFIED_ADDRESS)) != MATCH_NO)
8674 : {
8675 14 : if (m == MATCH_ERROR)
8676 2 : goto error;
8677 12 : clause = clauses[1];
8678 12 : seen_clauses |= OMP_REQ_UNIFIED_ADDRESS;
8679 12 : if (bval)
8680 : requires_clause = OMP_REQ_UNIFIED_ADDRESS;
8681 : }
8682 79 : else if ((m = gfc_match_boolean_clause (&bval, clauses[2],
8683 79 : seen_clauses & OMP_REQ_UNIFIED_SHARED_MEMORY))
8684 : != MATCH_NO)
8685 : {
8686 17 : if (m == MATCH_ERROR)
8687 1 : goto error;
8688 16 : clause = clauses[2];
8689 16 : seen_clauses |= OMP_REQ_UNIFIED_SHARED_MEMORY;
8690 16 : if (bval)
8691 : requires_clause = OMP_REQ_UNIFIED_SHARED_MEMORY;
8692 : }
8693 62 : else if ((m = gfc_match_boolean_clause (&bval, clauses[3],
8694 62 : seen_clauses & OMP_REQ_SELF_MAPS)) != MATCH_NO)
8695 : {
8696 19 : if (m == MATCH_ERROR)
8697 4 : goto error;
8698 15 : clause = clauses[3];
8699 15 : seen_clauses |= OMP_REQ_SELF_MAPS;
8700 15 : if (bval)
8701 : requires_clause = OMP_REQ_SELF_MAPS;
8702 : }
8703 43 : else if ((m = gfc_match_boolean_clause (&bval, clauses[4],
8704 43 : seen_clauses & OMP_REQ_DYNAMIC_ALLOCATORS)) != MATCH_NO)
8705 : {
8706 11 : if (m == MATCH_ERROR)
8707 1 : goto error;
8708 10 : clause = clauses[4];
8709 10 : seen_clauses |= OMP_REQ_DYNAMIC_ALLOCATORS;
8710 10 : if (bval)
8711 : requires_clause = OMP_REQ_DYNAMIC_ALLOCATORS;
8712 : }
8713 32 : else if ((m = gfc_match_dupl_check (
8714 32 : !(seen_clauses & OMP_REQ_ATOMIC_MEM_ORDER_MASK),
8715 : clauses[5], true)) != MATCH_NO)
8716 : {
8717 31 : if (m == MATCH_ERROR)
8718 1 : goto error;
8719 30 : seen_clauses |= OMP_REQ_ATOMIC_MEM_ORDER_MASK;
8720 30 : if (gfc_match (" seq_cst )") == MATCH_YES)
8721 : {
8722 : clause = "seq_cst";
8723 : requires_clause = OMP_REQ_ATOMIC_MEM_ORDER_SEQ_CST;
8724 : }
8725 18 : else if (gfc_match (" acq_rel )") == MATCH_YES)
8726 : {
8727 : clause = "acq_rel";
8728 : requires_clause = OMP_REQ_ATOMIC_MEM_ORDER_ACQ_REL;
8729 : }
8730 12 : else if (gfc_match (" acquire )") == MATCH_YES)
8731 : {
8732 : clause = "acquire";
8733 : requires_clause = OMP_REQ_ATOMIC_MEM_ORDER_ACQUIRE;
8734 : }
8735 9 : else if (gfc_match (" relaxed )") == MATCH_YES)
8736 : {
8737 : clause = "relaxed";
8738 : requires_clause = OMP_REQ_ATOMIC_MEM_ORDER_RELAXED;
8739 : }
8740 5 : else if (gfc_match (" release )") == MATCH_YES)
8741 : {
8742 : clause = "release";
8743 : requires_clause = OMP_REQ_ATOMIC_MEM_ORDER_RELEASE;
8744 : }
8745 : else
8746 : {
8747 2 : gfc_error ("Expected ACQ_REL, ACQUIRE, RELAXED, RELEASE or "
8748 : "SEQ_CST for ATOMIC_DEFAULT_MEM_ORDER clause at %C");
8749 2 : goto error;
8750 : }
8751 : }
8752 : else
8753 1 : goto error;
8754 :
8755 : if (requires_clause != OMP_REQ_NONE
8756 107 : && !gfc_omp_requires_add_clause (requires_clause, clause, &old_loc, NULL))
8757 3 : goto error;
8758 116 : requires_clauses |= requires_clause;
8759 116 : }
8760 :
8761 87 : if (requires_clauses == 0)
8762 2 : goto error;
8763 : return MATCH_YES;
8764 :
8765 19 : error:
8766 19 : if (!gfc_error_flag_test ())
8767 3 : gfc_error ("Expected UNIFIED_ADDRESS, UNIFIED_SHARED_MEMORY, SELF_MAPS, "
8768 : "DYNAMIC_ALLOCATORS, REVERSE_OFFLOAD, or "
8769 : "ATOMIC_DEFAULT_MEM_ORDER clause at %L", &old_loc);
8770 : return MATCH_ERROR;
8771 : }
8772 :
8773 :
8774 : match
8775 51 : gfc_match_omp_scan (void)
8776 : {
8777 51 : bool incl;
8778 51 : gfc_omp_clauses *c = gfc_get_omp_clauses ();
8779 51 : gfc_gobble_whitespace ();
8780 51 : gfc_match (", "); /* optionally */
8781 51 : if ((incl = (gfc_match ("inclusive") == MATCH_YES))
8782 51 : || gfc_match ("exclusive") == MATCH_YES)
8783 : {
8784 70 : if (gfc_match_omp_variable_list (" (", &c->lists[incl ? OMP_LIST_SCAN_IN
8785 : : OMP_LIST_SCAN_EX],
8786 : false) != MATCH_YES)
8787 : {
8788 0 : gfc_free_omp_clauses (c);
8789 0 : return MATCH_ERROR;
8790 : }
8791 : }
8792 : else
8793 : {
8794 1 : gfc_error ("Expected INCLUSIVE or EXCLUSIVE clause at %C");
8795 1 : gfc_free_omp_clauses (c);
8796 1 : return MATCH_ERROR;
8797 : }
8798 50 : if (gfc_match_omp_eos () != MATCH_YES)
8799 : {
8800 1 : gfc_error ("Unexpected junk after !$OMP SCAN at %C");
8801 1 : gfc_free_omp_clauses (c);
8802 1 : return MATCH_ERROR;
8803 : }
8804 :
8805 49 : new_st.op = EXEC_OMP_SCAN;
8806 49 : new_st.ext.omp_clauses = c;
8807 49 : return MATCH_YES;
8808 : }
8809 :
8810 :
8811 : match
8812 58 : gfc_match_omp_scope (void)
8813 : {
8814 58 : return match_omp (EXEC_OMP_SCOPE, OMP_SCOPE_CLAUSES);
8815 : }
8816 :
8817 :
8818 : match
8819 82 : gfc_match_omp_sections (void)
8820 : {
8821 82 : return match_omp (EXEC_OMP_SECTIONS, OMP_SECTIONS_CLAUSES);
8822 : }
8823 :
8824 :
8825 : match
8826 785 : gfc_match_omp_simd (void)
8827 : {
8828 785 : return match_omp (EXEC_OMP_SIMD, OMP_SIMD_CLAUSES);
8829 : }
8830 :
8831 :
8832 : match
8833 574 : gfc_match_omp_single (void)
8834 : {
8835 574 : return match_omp (EXEC_OMP_SINGLE, OMP_SINGLE_CLAUSES);
8836 : }
8837 :
8838 :
8839 : match
8840 2250 : gfc_match_omp_target (void)
8841 : {
8842 2250 : return match_omp (EXEC_OMP_TARGET, OMP_TARGET_CLAUSES);
8843 : }
8844 :
8845 :
8846 : match
8847 1401 : gfc_match_omp_target_data (void)
8848 : {
8849 1401 : return match_omp (EXEC_OMP_TARGET_DATA, OMP_TARGET_DATA_CLAUSES);
8850 : }
8851 :
8852 :
8853 : match
8854 472 : gfc_match_omp_target_enter_data (void)
8855 : {
8856 472 : return match_omp (EXEC_OMP_TARGET_ENTER_DATA, OMP_TARGET_ENTER_DATA_CLAUSES);
8857 : }
8858 :
8859 :
8860 : match
8861 367 : gfc_match_omp_target_exit_data (void)
8862 : {
8863 367 : return match_omp (EXEC_OMP_TARGET_EXIT_DATA, OMP_TARGET_EXIT_DATA_CLAUSES);
8864 : }
8865 :
8866 :
8867 : match
8868 29 : gfc_match_omp_target_parallel (void)
8869 : {
8870 29 : return match_omp (EXEC_OMP_TARGET_PARALLEL,
8871 29 : (OMP_TARGET_CLAUSES | OMP_PARALLEL_CLAUSES)
8872 29 : & ~(omp_mask (OMP_CLAUSE_COPYIN)));
8873 : }
8874 :
8875 :
8876 : match
8877 81 : gfc_match_omp_target_parallel_do (void)
8878 : {
8879 81 : return match_omp (EXEC_OMP_TARGET_PARALLEL_DO,
8880 81 : (OMP_TARGET_CLAUSES | OMP_PARALLEL_CLAUSES
8881 81 : | OMP_DO_CLAUSES) & ~(omp_mask (OMP_CLAUSE_COPYIN)));
8882 : }
8883 :
8884 :
8885 : match
8886 20 : gfc_match_omp_target_parallel_do_simd (void)
8887 : {
8888 20 : return match_omp (EXEC_OMP_TARGET_PARALLEL_DO_SIMD,
8889 20 : (OMP_TARGET_CLAUSES | OMP_PARALLEL_CLAUSES | OMP_DO_CLAUSES
8890 20 : | OMP_SIMD_CLAUSES) & ~(omp_mask (OMP_CLAUSE_COPYIN)));
8891 : }
8892 :
8893 :
8894 : match
8895 34 : gfc_match_omp_target_simd (void)
8896 : {
8897 34 : return match_omp (EXEC_OMP_TARGET_SIMD,
8898 34 : OMP_TARGET_CLAUSES | OMP_SIMD_CLAUSES);
8899 : }
8900 :
8901 :
8902 : match
8903 76 : gfc_match_omp_target_teams (void)
8904 : {
8905 76 : return match_omp (EXEC_OMP_TARGET_TEAMS,
8906 76 : OMP_TARGET_CLAUSES | OMP_TEAMS_CLAUSES);
8907 : }
8908 :
8909 :
8910 : match
8911 19 : gfc_match_omp_target_teams_distribute (void)
8912 : {
8913 19 : return match_omp (EXEC_OMP_TARGET_TEAMS_DISTRIBUTE,
8914 19 : OMP_TARGET_CLAUSES | OMP_TEAMS_CLAUSES
8915 19 : | OMP_DISTRIBUTE_CLAUSES);
8916 : }
8917 :
8918 :
8919 : match
8920 66 : gfc_match_omp_target_teams_distribute_parallel_do (void)
8921 : {
8922 66 : return match_omp (EXEC_OMP_TARGET_TEAMS_DISTRIBUTE_PARALLEL_DO,
8923 66 : (OMP_TARGET_CLAUSES | OMP_TEAMS_CLAUSES
8924 66 : | OMP_DISTRIBUTE_CLAUSES | OMP_PARALLEL_CLAUSES
8925 66 : | OMP_DO_CLAUSES)
8926 66 : & ~(omp_mask (OMP_CLAUSE_ORDERED))
8927 66 : & ~(omp_mask (OMP_CLAUSE_LINEAR)));
8928 : }
8929 :
8930 :
8931 : match
8932 36 : gfc_match_omp_target_teams_distribute_parallel_do_simd (void)
8933 : {
8934 36 : return match_omp (EXEC_OMP_TARGET_TEAMS_DISTRIBUTE_PARALLEL_DO_SIMD,
8935 36 : (OMP_TARGET_CLAUSES | OMP_TEAMS_CLAUSES
8936 36 : | OMP_DISTRIBUTE_CLAUSES | OMP_PARALLEL_CLAUSES
8937 36 : | OMP_DO_CLAUSES | OMP_SIMD_CLAUSES)
8938 36 : & ~(omp_mask (OMP_CLAUSE_ORDERED)));
8939 : }
8940 :
8941 :
8942 : match
8943 21 : gfc_match_omp_target_teams_distribute_simd (void)
8944 : {
8945 21 : return match_omp (EXEC_OMP_TARGET_TEAMS_DISTRIBUTE_SIMD,
8946 21 : OMP_TARGET_CLAUSES | OMP_TEAMS_CLAUSES
8947 21 : | OMP_DISTRIBUTE_CLAUSES | OMP_SIMD_CLAUSES);
8948 : }
8949 :
8950 :
8951 : match
8952 1727 : gfc_match_omp_target_update (void)
8953 : {
8954 1727 : return match_omp (EXEC_OMP_TARGET_UPDATE, OMP_TARGET_UPDATE_CLAUSES);
8955 : }
8956 :
8957 :
8958 : match
8959 1184 : gfc_match_omp_task (void)
8960 : {
8961 1184 : return match_omp (EXEC_OMP_TASK, OMP_TASK_CLAUSES);
8962 : }
8963 :
8964 :
8965 : match
8966 72 : gfc_match_omp_taskloop (void)
8967 : {
8968 72 : return match_omp (EXEC_OMP_TASKLOOP, OMP_TASKLOOP_CLAUSES);
8969 : }
8970 :
8971 :
8972 : match
8973 40 : gfc_match_omp_taskloop_simd (void)
8974 : {
8975 40 : return match_omp (EXEC_OMP_TASKLOOP_SIMD,
8976 40 : OMP_TASKLOOP_CLAUSES | OMP_SIMD_CLAUSES);
8977 : }
8978 :
8979 :
8980 : match
8981 149 : gfc_match_omp_taskwait (void)
8982 : {
8983 149 : if (gfc_match_omp_eos () == MATCH_YES)
8984 : {
8985 135 : new_st.op = EXEC_OMP_TASKWAIT;
8986 135 : new_st.ext.omp_clauses = NULL;
8987 135 : return MATCH_YES;
8988 : }
8989 14 : return match_omp (EXEC_OMP_TASKWAIT,
8990 14 : omp_mask (OMP_CLAUSE_DEPEND) | OMP_CLAUSE_NOWAIT);
8991 : }
8992 :
8993 :
8994 : match
8995 10 : gfc_match_omp_taskyield (void)
8996 : {
8997 10 : if (gfc_match_omp_eos () != MATCH_YES)
8998 : {
8999 0 : gfc_error ("Unexpected junk after TASKYIELD clause at %C");
9000 0 : return MATCH_ERROR;
9001 : }
9002 10 : new_st.op = EXEC_OMP_TASKYIELD;
9003 10 : new_st.ext.omp_clauses = NULL;
9004 10 : return MATCH_YES;
9005 : }
9006 :
9007 :
9008 : match
9009 218 : gfc_match_omp_teams (void)
9010 : {
9011 218 : return match_omp (EXEC_OMP_TEAMS, OMP_TEAMS_CLAUSES);
9012 : }
9013 :
9014 :
9015 : match
9016 22 : gfc_match_omp_teams_distribute (void)
9017 : {
9018 22 : return match_omp (EXEC_OMP_TEAMS_DISTRIBUTE,
9019 22 : OMP_TEAMS_CLAUSES | OMP_DISTRIBUTE_CLAUSES);
9020 : }
9021 :
9022 :
9023 : match
9024 41 : gfc_match_omp_teams_distribute_parallel_do (void)
9025 : {
9026 41 : return match_omp (EXEC_OMP_TEAMS_DISTRIBUTE_PARALLEL_DO,
9027 41 : (OMP_TEAMS_CLAUSES | OMP_DISTRIBUTE_CLAUSES
9028 41 : | OMP_PARALLEL_CLAUSES | OMP_DO_CLAUSES)
9029 41 : & ~(omp_mask (OMP_CLAUSE_ORDERED)
9030 41 : | OMP_CLAUSE_LINEAR | OMP_CLAUSE_NOWAIT));
9031 : }
9032 :
9033 :
9034 : match
9035 63 : gfc_match_omp_teams_distribute_parallel_do_simd (void)
9036 : {
9037 63 : return match_omp (EXEC_OMP_TEAMS_DISTRIBUTE_PARALLEL_DO_SIMD,
9038 63 : (OMP_TEAMS_CLAUSES | OMP_DISTRIBUTE_CLAUSES
9039 63 : | OMP_PARALLEL_CLAUSES | OMP_DO_CLAUSES
9040 63 : | OMP_SIMD_CLAUSES)
9041 63 : & ~(omp_mask (OMP_CLAUSE_ORDERED) | OMP_CLAUSE_NOWAIT));
9042 : }
9043 :
9044 :
9045 : match
9046 44 : gfc_match_omp_teams_distribute_simd (void)
9047 : {
9048 44 : return match_omp (EXEC_OMP_TEAMS_DISTRIBUTE_SIMD,
9049 44 : OMP_TEAMS_CLAUSES | OMP_DISTRIBUTE_CLAUSES
9050 44 : | OMP_SIMD_CLAUSES);
9051 : }
9052 :
9053 : match
9054 203 : gfc_match_omp_tile (void)
9055 : {
9056 203 : return match_omp (EXEC_OMP_TILE, OMP_TILE_CLAUSES);
9057 : }
9058 :
9059 : match
9060 424 : gfc_match_omp_unroll (void)
9061 : {
9062 424 : return match_omp (EXEC_OMP_UNROLL, OMP_UNROLL_CLAUSES);
9063 : }
9064 :
9065 : match
9066 39 : gfc_match_omp_workshare (void)
9067 : {
9068 39 : return match_omp (EXEC_OMP_WORKSHARE, OMP_WORKSHARE_CLAUSES);
9069 : }
9070 :
9071 :
9072 : match
9073 55 : gfc_match_omp_masked (void)
9074 : {
9075 55 : return match_omp (EXEC_OMP_MASKED, OMP_MASKED_CLAUSES);
9076 : }
9077 :
9078 : match
9079 10 : gfc_match_omp_masked_taskloop (void)
9080 : {
9081 10 : return match_omp (EXEC_OMP_MASKED_TASKLOOP,
9082 10 : OMP_MASKED_CLAUSES | OMP_TASKLOOP_CLAUSES);
9083 : }
9084 :
9085 : match
9086 16 : gfc_match_omp_masked_taskloop_simd (void)
9087 : {
9088 16 : return match_omp (EXEC_OMP_MASKED_TASKLOOP_SIMD,
9089 16 : (OMP_MASKED_CLAUSES | OMP_TASKLOOP_CLAUSES
9090 16 : | OMP_SIMD_CLAUSES));
9091 : }
9092 :
9093 : match
9094 111 : gfc_match_omp_master (void)
9095 : {
9096 111 : gfc_warning (OPT_Wdeprecated_openmp,
9097 : "%<master%> construct at %C deprecated since OpenMP 5.1, "
9098 : "use %<masked%>");
9099 111 : if (gfc_match_omp_eos () != MATCH_YES)
9100 : {
9101 1 : gfc_error ("Unexpected junk after $OMP MASTER statement at %C");
9102 1 : return MATCH_ERROR;
9103 : }
9104 110 : new_st.op = EXEC_OMP_MASTER;
9105 110 : new_st.ext.omp_clauses = NULL;
9106 110 : return MATCH_YES;
9107 : }
9108 :
9109 : match
9110 16 : gfc_match_omp_master_taskloop (void)
9111 : {
9112 16 : gfc_warning (OPT_Wdeprecated_openmp,
9113 : "%<master%> construct at %C deprecated since OpenMP 5.1, "
9114 : "use %<masked%>");
9115 16 : return match_omp (EXEC_OMP_MASTER_TASKLOOP, OMP_TASKLOOP_CLAUSES);
9116 : }
9117 :
9118 : match
9119 21 : gfc_match_omp_master_taskloop_simd (void)
9120 : {
9121 21 : gfc_warning (OPT_Wdeprecated_openmp,
9122 : "%<master%> construct at %C deprecated since OpenMP 5.1, use "
9123 : "%<masked%>");
9124 21 : return match_omp (EXEC_OMP_MASTER_TASKLOOP_SIMD,
9125 21 : OMP_TASKLOOP_CLAUSES | OMP_SIMD_CLAUSES);
9126 : }
9127 :
9128 : match
9129 239 : gfc_match_omp_ordered (void)
9130 : {
9131 239 : return match_omp (EXEC_OMP_ORDERED, OMP_ORDERED_CLAUSES);
9132 : }
9133 :
9134 : match
9135 24 : gfc_match_omp_nothing (void)
9136 : {
9137 24 : if (gfc_match_omp_eos () != MATCH_YES)
9138 : {
9139 1 : gfc_error ("Unexpected junk after $OMP NOTHING statement at %C");
9140 1 : return MATCH_ERROR;
9141 : }
9142 : /* Will use ST_NONE; therefore, no EXEC_OMP_ is needed. */
9143 : return MATCH_YES;
9144 : }
9145 :
9146 : match
9147 317 : gfc_match_omp_ordered_depend (void)
9148 : {
9149 317 : return match_omp (EXEC_OMP_ORDERED, omp_mask (OMP_CLAUSE_DOACROSS));
9150 : }
9151 :
9152 :
9153 : /* omp atomic [clause-list]
9154 : - atomic-clause: read | write | update
9155 : - capture
9156 : - memory-order-clause: seq_cst | acq_rel | release | acquire | relaxed
9157 : - hint(hint-expr)
9158 : - OpenMP 5.1: compare | fail (seq_cst | acquire | relaxed ) | weak
9159 : */
9160 :
9161 : match
9162 2188 : gfc_match_omp_atomic (void)
9163 : {
9164 2188 : gfc_omp_clauses *c;
9165 2188 : locus loc = gfc_current_locus;
9166 :
9167 2188 : if (gfc_match_omp_clauses (&c, OMP_ATOMIC_CLAUSES, false, true) != MATCH_YES)
9168 : return MATCH_ERROR;
9169 :
9170 2166 : if (c->atomic_op == GFC_OMP_ATOMIC_UNSET)
9171 1013 : c->atomic_op = GFC_OMP_ATOMIC_UPDATE;
9172 :
9173 2166 : if (c->capture && c->atomic_op != GFC_OMP_ATOMIC_UPDATE)
9174 3 : gfc_error ("!$OMP ATOMIC at %L with %s clause is incompatible with "
9175 : "READ or WRITE", &loc, "CAPTURE");
9176 2166 : if (c->compare && c->atomic_op != GFC_OMP_ATOMIC_UPDATE)
9177 3 : gfc_error ("!$OMP ATOMIC at %L with %s clause is incompatible with "
9178 : "READ or WRITE", &loc, "COMPARE");
9179 2166 : if (c->fail != OMP_MEMORDER_UNSET && c->atomic_op != GFC_OMP_ATOMIC_UPDATE)
9180 2 : gfc_error ("!$OMP ATOMIC at %L with %s clause is incompatible with "
9181 : "READ or WRITE", &loc, "FAIL");
9182 2166 : if (c->weak && !c->compare)
9183 : {
9184 5 : gfc_error ("!$OMP ATOMIC at %L with %s clause requires %s clause", &loc,
9185 : "WEAK", "COMPARE");
9186 5 : c->weak = false;
9187 : }
9188 :
9189 2166 : if (c->memorder == OMP_MEMORDER_UNSET)
9190 : {
9191 1975 : gfc_namespace *prog_unit = gfc_current_ns;
9192 1975 : while (prog_unit->parent
9193 2537 : && !(prog_unit->proc_name
9194 562 : && prog_unit->proc_name->attr.flavor == FL_MODULE))
9195 562 : prog_unit = prog_unit->parent;
9196 1975 : switch (prog_unit->omp_requires & OMP_REQ_ATOMIC_MEM_ORDER_MASK)
9197 : {
9198 1942 : case 0:
9199 1942 : case OMP_REQ_ATOMIC_MEM_ORDER_RELAXED:
9200 1942 : c->memorder = OMP_MEMORDER_RELAXED;
9201 1942 : break;
9202 7 : case OMP_REQ_ATOMIC_MEM_ORDER_SEQ_CST:
9203 7 : c->memorder = OMP_MEMORDER_SEQ_CST;
9204 7 : break;
9205 16 : case OMP_REQ_ATOMIC_MEM_ORDER_ACQ_REL:
9206 16 : if (c->capture)
9207 5 : c->memorder = OMP_MEMORDER_ACQ_REL;
9208 11 : else if (c->atomic_op == GFC_OMP_ATOMIC_READ)
9209 3 : c->memorder = OMP_MEMORDER_ACQUIRE;
9210 : else
9211 8 : c->memorder = OMP_MEMORDER_RELEASE;
9212 : break;
9213 5 : case OMP_REQ_ATOMIC_MEM_ORDER_ACQUIRE:
9214 5 : if (c->atomic_op == GFC_OMP_ATOMIC_WRITE)
9215 : {
9216 1 : gfc_error ("!$OMP ATOMIC WRITE at %L incompatible with "
9217 : "ACQUIRES clause implicitly provided by a "
9218 : "REQUIRES directive", &loc);
9219 1 : c->memorder = OMP_MEMORDER_SEQ_CST;
9220 : }
9221 : else
9222 4 : c->memorder = OMP_MEMORDER_ACQUIRE;
9223 : break;
9224 5 : case OMP_REQ_ATOMIC_MEM_ORDER_RELEASE:
9225 5 : if (c->atomic_op == GFC_OMP_ATOMIC_READ)
9226 : {
9227 1 : gfc_error ("!$OMP ATOMIC READ at %L incompatible with "
9228 : "RELEASE clause implicitly provided by a "
9229 : "REQUIRES directive", &loc);
9230 1 : c->memorder = OMP_MEMORDER_SEQ_CST;
9231 : }
9232 : else
9233 4 : c->memorder = OMP_MEMORDER_RELEASE;
9234 : break;
9235 0 : default:
9236 0 : gcc_unreachable ();
9237 : }
9238 : }
9239 : else
9240 191 : switch (c->atomic_op)
9241 : {
9242 31 : case GFC_OMP_ATOMIC_READ:
9243 31 : if (c->memorder == OMP_MEMORDER_RELEASE)
9244 : {
9245 1 : gfc_error ("!$OMP ATOMIC READ at %L incompatible with "
9246 : "RELEASE clause", &loc);
9247 1 : c->memorder = OMP_MEMORDER_SEQ_CST;
9248 : }
9249 30 : else if (c->memorder == OMP_MEMORDER_ACQ_REL)
9250 1 : c->memorder = OMP_MEMORDER_ACQUIRE;
9251 : break;
9252 37 : case GFC_OMP_ATOMIC_WRITE:
9253 37 : if (c->memorder == OMP_MEMORDER_ACQUIRE)
9254 : {
9255 1 : gfc_error ("!$OMP ATOMIC WRITE at %L incompatible with "
9256 : "ACQUIRE clause", &loc);
9257 1 : c->memorder = OMP_MEMORDER_SEQ_CST;
9258 : }
9259 36 : else if (c->memorder == OMP_MEMORDER_ACQ_REL)
9260 3 : c->memorder = OMP_MEMORDER_RELEASE;
9261 : break;
9262 : default:
9263 : break;
9264 : }
9265 2166 : gfc_error_check ();
9266 2166 : new_st.ext.omp_clauses = c;
9267 2166 : new_st.op = EXEC_OMP_ATOMIC;
9268 2166 : return MATCH_YES;
9269 : }
9270 :
9271 :
9272 : /* acc atomic [ read | write | update | capture] */
9273 :
9274 : match
9275 552 : gfc_match_oacc_atomic (void)
9276 : {
9277 552 : gfc_omp_clauses *c = gfc_get_omp_clauses ();
9278 552 : c->atomic_op = GFC_OMP_ATOMIC_UPDATE;
9279 552 : c->memorder = OMP_MEMORDER_RELAXED;
9280 552 : gfc_gobble_whitespace ();
9281 552 : if (gfc_match ("update") == MATCH_YES)
9282 : ;
9283 373 : else if (gfc_match ("read") == MATCH_YES)
9284 17 : c->atomic_op = GFC_OMP_ATOMIC_READ;
9285 356 : else if (gfc_match ("write") == MATCH_YES)
9286 13 : c->atomic_op = GFC_OMP_ATOMIC_WRITE;
9287 343 : else if (gfc_match ("capture") == MATCH_YES)
9288 319 : c->capture = true;
9289 552 : gfc_gobble_whitespace ();
9290 552 : if (gfc_match_omp_eos () != MATCH_YES)
9291 : {
9292 9 : gfc_error ("Unexpected junk after !$ACC ATOMIC statement at %C");
9293 9 : gfc_free_omp_clauses (c);
9294 9 : return MATCH_ERROR;
9295 : }
9296 543 : new_st.ext.omp_clauses = c;
9297 543 : new_st.op = EXEC_OACC_ATOMIC;
9298 543 : return MATCH_YES;
9299 : }
9300 :
9301 :
9302 : match
9303 614 : gfc_match_omp_barrier (void)
9304 : {
9305 614 : if (gfc_match_omp_eos () != MATCH_YES)
9306 : {
9307 0 : gfc_error ("Unexpected junk after $OMP BARRIER statement at %C");
9308 0 : return MATCH_ERROR;
9309 : }
9310 614 : new_st.op = EXEC_OMP_BARRIER;
9311 614 : new_st.ext.omp_clauses = NULL;
9312 614 : return MATCH_YES;
9313 : }
9314 :
9315 :
9316 : match
9317 188 : gfc_match_omp_taskgroup (void)
9318 : {
9319 188 : return match_omp (EXEC_OMP_TASKGROUP, OMP_TASKGROUP_CLAUSES);
9320 : }
9321 :
9322 :
9323 : static enum gfc_omp_cancel_kind
9324 502 : gfc_match_omp_cancel_kind (void)
9325 : {
9326 502 : if (gfc_match (" , ") != MATCH_YES
9327 502 : && gfc_match_space () != MATCH_YES)
9328 : return OMP_CANCEL_UNKNOWN;
9329 502 : if (gfc_match ("parallel") == MATCH_YES)
9330 : return OMP_CANCEL_PARALLEL;
9331 352 : if (gfc_match ("sections") == MATCH_YES)
9332 : return OMP_CANCEL_SECTIONS;
9333 253 : if (gfc_match ("do") == MATCH_YES)
9334 : return OMP_CANCEL_DO;
9335 123 : if (gfc_match ("taskgroup") == MATCH_YES)
9336 121 : return OMP_CANCEL_TASKGROUP;
9337 : return OMP_CANCEL_UNKNOWN;
9338 : }
9339 :
9340 :
9341 : match
9342 324 : gfc_match_omp_cancel (void)
9343 : {
9344 324 : gfc_omp_clauses *c;
9345 324 : enum gfc_omp_cancel_kind kind = gfc_match_omp_cancel_kind ();
9346 324 : if (kind == OMP_CANCEL_UNKNOWN)
9347 : return MATCH_ERROR;
9348 324 : if (gfc_match_omp_clauses (&c, omp_mask (OMP_CLAUSE_IF), false) != MATCH_YES)
9349 : return MATCH_ERROR;
9350 321 : c->cancel = kind;
9351 321 : new_st.op = EXEC_OMP_CANCEL;
9352 321 : new_st.ext.omp_clauses = c;
9353 321 : return MATCH_YES;
9354 : }
9355 :
9356 :
9357 : match
9358 178 : gfc_match_omp_cancellation_point (void)
9359 : {
9360 178 : gfc_omp_clauses *c;
9361 178 : enum gfc_omp_cancel_kind kind = gfc_match_omp_cancel_kind ();
9362 178 : if (kind == OMP_CANCEL_UNKNOWN)
9363 : {
9364 2 : gfc_error ("Expected construct-type PARALLEL, SECTIONS, DO or TASKGROUP "
9365 : "in $OMP CANCELLATION POINT statement at %C");
9366 2 : return MATCH_ERROR;
9367 : }
9368 176 : if (gfc_match_omp_eos () != MATCH_YES)
9369 : {
9370 0 : gfc_error ("Unexpected junk after $OMP CANCELLATION POINT statement "
9371 : "at %C");
9372 0 : return MATCH_ERROR;
9373 : }
9374 176 : c = gfc_get_omp_clauses ();
9375 176 : c->cancel = kind;
9376 176 : new_st.op = EXEC_OMP_CANCELLATION_POINT;
9377 176 : new_st.ext.omp_clauses = c;
9378 176 : return MATCH_YES;
9379 : }
9380 :
9381 :
9382 : match
9383 2736 : gfc_match_omp_end_nowait (void)
9384 : {
9385 2736 : bool nowait = false;
9386 2736 : if (gfc_match ("% nowait ") == MATCH_YES
9387 2736 : || gfc_match (" , nowait ") == MATCH_YES)
9388 : nowait = true;
9389 2736 : if (gfc_match_omp_eos () != MATCH_YES)
9390 : {
9391 4 : if (nowait)
9392 3 : gfc_error ("Unexpected junk after NOWAIT clause at %C");
9393 : else
9394 1 : gfc_error ("Unexpected junk at %C");
9395 : return MATCH_ERROR;
9396 : }
9397 2732 : new_st.op = EXEC_OMP_END_NOWAIT;
9398 2732 : new_st.ext.omp_bool = nowait;
9399 2732 : return MATCH_YES;
9400 : }
9401 :
9402 :
9403 : match
9404 570 : gfc_match_omp_end_single (void)
9405 : {
9406 570 : gfc_omp_clauses *c;
9407 570 : if (gfc_match_omp_clauses (&c, omp_mask (OMP_CLAUSE_COPYPRIVATE)
9408 : | OMP_CLAUSE_NOWAIT, false)
9409 : != MATCH_YES)
9410 : return MATCH_ERROR;
9411 570 : new_st.op = EXEC_OMP_END_SINGLE;
9412 570 : new_st.ext.omp_clauses = c;
9413 570 : return MATCH_YES;
9414 : }
9415 :
9416 :
9417 : static bool
9418 37153 : oacc_is_loop (gfc_code *code)
9419 : {
9420 37153 : return code->op == EXEC_OACC_PARALLEL_LOOP
9421 : || code->op == EXEC_OACC_KERNELS_LOOP
9422 20098 : || code->op == EXEC_OACC_SERIAL_LOOP
9423 13457 : || code->op == EXEC_OACC_LOOP;
9424 : }
9425 :
9426 : static void
9427 5987 : resolve_scalar_int_expr (gfc_expr *expr, const char *clause)
9428 : {
9429 5987 : if (!gfc_resolve_expr (expr)
9430 5987 : || expr->ts.type != BT_INTEGER
9431 11903 : || expr->rank != 0)
9432 89 : gfc_error ("%s clause at %L requires a scalar INTEGER expression",
9433 : clause, &expr->where);
9434 5987 : }
9435 :
9436 : static void
9437 4090 : resolve_positive_int_expr (gfc_expr *expr, const char *clause)
9438 : {
9439 4090 : resolve_scalar_int_expr (expr, clause);
9440 4090 : if (expr->expr_type == EXPR_CONSTANT
9441 3660 : && expr->ts.type == BT_INTEGER
9442 3627 : && mpz_sgn (expr->value.integer) <= 0)
9443 54 : gfc_warning ((flag_openmp || flag_openmp_simd) ? OPT_Wopenmp : 0,
9444 : "INTEGER expression of %s clause at %L must be positive",
9445 : clause, &expr->where);
9446 4090 : }
9447 :
9448 : static void
9449 86 : resolve_nonnegative_int_expr (gfc_expr *expr, const char *clause)
9450 : {
9451 86 : resolve_scalar_int_expr (expr, clause);
9452 86 : if (expr->expr_type == EXPR_CONSTANT
9453 13 : && expr->ts.type == BT_INTEGER
9454 11 : && mpz_sgn (expr->value.integer) < 0)
9455 6 : gfc_warning ((flag_openmp || flag_openmp_simd) ? OPT_Wopenmp : 0,
9456 : "INTEGER expression of %s clause at %L must be non-negative",
9457 : clause, &expr->where);
9458 86 : }
9459 :
9460 : /* Emits error when symbol is pointer, cray pointer or cray pointee
9461 : of derived of polymorphic type. */
9462 :
9463 : static void
9464 98 : check_symbol_not_pointer (gfc_symbol *sym, locus loc, const char *name)
9465 : {
9466 98 : if (sym->ts.type == BT_DERIVED && sym->attr.cray_pointer)
9467 0 : gfc_error ("Cray pointer object %qs of derived type in %s clause at %L",
9468 : sym->name, name, &loc);
9469 98 : if (sym->ts.type == BT_DERIVED && sym->attr.cray_pointee)
9470 0 : gfc_error ("Cray pointee object %qs of derived type in %s clause at %L",
9471 : sym->name, name, &loc);
9472 :
9473 98 : if ((sym->ts.type == BT_ASSUMED && sym->attr.pointer)
9474 98 : || (sym->ts.type == BT_CLASS && CLASS_DATA (sym)
9475 0 : && CLASS_DATA (sym)->attr.pointer))
9476 0 : gfc_error ("POINTER object %qs of polymorphic type in %s clause at %L",
9477 : sym->name, name, &loc);
9478 98 : if ((sym->ts.type == BT_ASSUMED && sym->attr.cray_pointer)
9479 98 : || (sym->ts.type == BT_CLASS && CLASS_DATA (sym)
9480 0 : && CLASS_DATA (sym)->attr.cray_pointer))
9481 0 : gfc_error ("Cray pointer object %qs of polymorphic type in %s clause at %L",
9482 : sym->name, name, &loc);
9483 98 : if ((sym->ts.type == BT_ASSUMED && sym->attr.cray_pointee)
9484 98 : || (sym->ts.type == BT_CLASS && CLASS_DATA (sym)
9485 0 : && CLASS_DATA (sym)->attr.cray_pointee))
9486 0 : gfc_error ("Cray pointee object %qs of polymorphic type in %s clause at %L",
9487 : sym->name, name, &loc);
9488 98 : }
9489 :
9490 : /* Emits error when symbol represents assumed size/rank array. */
9491 :
9492 : static void
9493 14844 : check_array_not_assumed (gfc_symbol *sym, locus loc, const char *name)
9494 : {
9495 14844 : if (sym->as && sym->as->type == AS_ASSUMED_SIZE)
9496 13 : gfc_error ("Assumed size array %qs in %s clause at %L",
9497 : sym->name, name, &loc);
9498 14844 : if (sym->as && sym->as->type == AS_ASSUMED_RANK)
9499 11 : gfc_error ("Assumed rank array %qs in %s clause at %L",
9500 : sym->name, name, &loc);
9501 14844 : }
9502 :
9503 : static void
9504 5850 : resolve_oacc_data_clauses (gfc_symbol *sym, locus loc, const char *name)
9505 : {
9506 0 : check_array_not_assumed (sym, loc, name);
9507 0 : }
9508 :
9509 : static void
9510 65 : resolve_oacc_deviceptr_clause (gfc_symbol *sym, locus loc, const char *name)
9511 : {
9512 65 : if (sym->attr.pointer
9513 64 : || (sym->ts.type == BT_CLASS && CLASS_DATA (sym)
9514 0 : && CLASS_DATA (sym)->attr.class_pointer))
9515 1 : gfc_error ("POINTER object %qs in %s clause at %L",
9516 : sym->name, name, &loc);
9517 65 : if (sym->attr.cray_pointer
9518 63 : || (sym->ts.type == BT_CLASS && CLASS_DATA (sym)
9519 0 : && CLASS_DATA (sym)->attr.cray_pointer))
9520 2 : gfc_error ("Cray pointer object %qs in %s clause at %L",
9521 : sym->name, name, &loc);
9522 65 : if (sym->attr.cray_pointee
9523 63 : || (sym->ts.type == BT_CLASS && CLASS_DATA (sym)
9524 0 : && CLASS_DATA (sym)->attr.cray_pointee))
9525 2 : gfc_error ("Cray pointee object %qs in %s clause at %L",
9526 : sym->name, name, &loc);
9527 65 : if (sym->attr.allocatable
9528 64 : || (sym->ts.type == BT_CLASS && CLASS_DATA (sym)
9529 0 : && CLASS_DATA (sym)->attr.allocatable))
9530 1 : gfc_error ("ALLOCATABLE object %qs in %s clause at %L",
9531 : sym->name, name, &loc);
9532 65 : if (sym->attr.value)
9533 1 : gfc_error ("VALUE object %qs in %s clause at %L",
9534 : sym->name, name, &loc);
9535 65 : check_array_not_assumed (sym, loc, name);
9536 65 : }
9537 :
9538 :
9539 : struct resolve_omp_udr_callback_data
9540 : {
9541 : gfc_symbol *sym1, *sym2;
9542 : };
9543 :
9544 :
9545 : static int
9546 1413 : resolve_omp_udr_callback (gfc_expr **e, int *, void *data)
9547 : {
9548 1413 : struct resolve_omp_udr_callback_data *rcd
9549 : = (struct resolve_omp_udr_callback_data *) data;
9550 1413 : if ((*e)->expr_type == EXPR_VARIABLE
9551 801 : && ((*e)->symtree->n.sym == rcd->sym1
9552 255 : || (*e)->symtree->n.sym == rcd->sym2))
9553 : {
9554 801 : gfc_ref *ref = gfc_get_ref ();
9555 801 : ref->type = REF_ARRAY;
9556 801 : ref->u.ar.where = (*e)->where;
9557 801 : ref->u.ar.as = (*e)->symtree->n.sym->as;
9558 801 : ref->u.ar.type = AR_FULL;
9559 801 : ref->u.ar.dimen = 0;
9560 801 : ref->next = (*e)->ref;
9561 801 : (*e)->ref = ref;
9562 : }
9563 1413 : return 0;
9564 : }
9565 :
9566 :
9567 : static int
9568 3008 : resolve_omp_udr_callback2 (gfc_expr **e, int *, void *)
9569 : {
9570 3008 : if ((*e)->expr_type == EXPR_FUNCTION
9571 360 : && (*e)->value.function.isym == NULL)
9572 : {
9573 174 : gfc_symbol *sym = (*e)->symtree->n.sym;
9574 174 : if (!sym->attr.intrinsic
9575 174 : && sym->attr.if_source == IFSRC_UNKNOWN)
9576 4 : gfc_error ("Implicitly declared function %s used in "
9577 : "!$OMP DECLARE REDUCTION at %L", sym->name, &(*e)->where);
9578 : }
9579 3008 : return 0;
9580 : }
9581 :
9582 :
9583 : static gfc_code *
9584 802 : resolve_omp_udr_clause (gfc_omp_namelist *n, gfc_namespace *ns,
9585 : gfc_symbol *sym1, gfc_symbol *sym2)
9586 : {
9587 802 : gfc_code *copy;
9588 802 : gfc_symbol sym1_copy, sym2_copy;
9589 :
9590 802 : if (ns->code->op == EXEC_ASSIGN)
9591 : {
9592 630 : copy = gfc_get_code (EXEC_ASSIGN);
9593 630 : copy->expr1 = gfc_copy_expr (ns->code->expr1);
9594 630 : copy->expr2 = gfc_copy_expr (ns->code->expr2);
9595 : }
9596 : else
9597 : {
9598 172 : copy = gfc_get_code (EXEC_CALL);
9599 172 : copy->symtree = ns->code->symtree;
9600 172 : copy->ext.actual = gfc_copy_actual_arglist (ns->code->ext.actual);
9601 : }
9602 802 : copy->loc = ns->code->loc;
9603 802 : sym1_copy = *sym1;
9604 802 : sym2_copy = *sym2;
9605 802 : *sym1 = *n->sym;
9606 802 : *sym2 = *n->sym;
9607 802 : sym1->name = sym1_copy.name;
9608 802 : sym2->name = sym2_copy.name;
9609 802 : ns->proc_name = ns->parent->proc_name;
9610 802 : if (n->sym->attr.dimension)
9611 : {
9612 348 : struct resolve_omp_udr_callback_data rcd;
9613 348 : rcd.sym1 = sym1;
9614 348 : rcd.sym2 = sym2;
9615 348 : gfc_code_walker (©, gfc_dummy_code_callback,
9616 : resolve_omp_udr_callback, &rcd);
9617 : }
9618 802 : gfc_resolve_code (copy, gfc_current_ns);
9619 802 : if (copy->op == EXEC_CALL && copy->resolved_isym == NULL)
9620 : {
9621 172 : gfc_symbol *sym = copy->resolved_sym;
9622 172 : if (sym
9623 170 : && !sym->attr.intrinsic
9624 170 : && sym->attr.if_source == IFSRC_UNKNOWN)
9625 4 : gfc_error ("Implicitly declared subroutine %s used in "
9626 : "!$OMP DECLARE REDUCTION at %L", sym->name,
9627 : ©->loc);
9628 : }
9629 802 : gfc_code_walker (©, gfc_dummy_code_callback,
9630 : resolve_omp_udr_callback2, NULL);
9631 802 : *sym1 = sym1_copy;
9632 802 : *sym2 = sym2_copy;
9633 802 : return copy;
9634 : }
9635 :
9636 : /* Assume that a constant expression in the range 1 (omp_default_mem_alloc)
9637 : to GOMP_OMP_PREDEF_ALLOC_MAX, or GOMP_OMPX_PREDEF_ALLOC_MIN to
9638 : GOMP_OMPX_PREDEF_ALLOC_MAX is fine. The original symbol name is already
9639 : lost during matching via gfc_match_expr. */
9640 : static bool
9641 130 : is_predefined_allocator (gfc_expr *expr)
9642 : {
9643 130 : return (gfc_resolve_expr (expr)
9644 129 : && expr->rank == 0
9645 124 : && expr->ts.type == BT_INTEGER
9646 119 : && expr->ts.kind == gfc_c_intptr_kind
9647 114 : && expr->expr_type == EXPR_CONSTANT
9648 239 : && ((mpz_sgn (expr->value.integer) > 0
9649 107 : && mpz_cmp_si (expr->value.integer,
9650 : GOMP_OMP_PREDEF_ALLOC_MAX) <= 0)
9651 4 : || (mpz_cmp_si (expr->value.integer,
9652 : GOMP_OMPX_PREDEF_ALLOC_MIN) >= 0
9653 1 : && mpz_cmp_si (expr->value.integer,
9654 130 : GOMP_OMPX_PREDEF_ALLOC_MAX) <= 0)));
9655 : }
9656 :
9657 : /* Resolve declarative ALLOCATE statement. Note: Common block vars only appear
9658 : as /block/ not individual, which is ensured during parsing. */
9659 :
9660 : void
9661 62 : gfc_resolve_omp_allocate (gfc_namespace *ns, gfc_omp_namelist *list)
9662 : {
9663 278 : for (gfc_omp_namelist *n = list; n; n = n->next)
9664 : {
9665 216 : if (n->sym->attr.result || n->sym->result == n->sym)
9666 : {
9667 1 : gfc_error ("Unexpected function-result variable %qs at %L in "
9668 : "declarative !$OMP ALLOCATE", n->sym->name, &n->where);
9669 30 : continue;
9670 : }
9671 215 : if (ns->omp_allocate->sym->attr.proc_pointer)
9672 : {
9673 0 : gfc_error ("Procedure pointer %qs not supported with !$OMP "
9674 : "ALLOCATE at %L", n->sym->name, &n->where);
9675 0 : continue;
9676 : }
9677 215 : if (n->sym->attr.flavor != FL_VARIABLE)
9678 : {
9679 3 : gfc_error ("Argument %qs at %L to declarative !$OMP ALLOCATE "
9680 : "directive must be a variable", n->sym->name,
9681 : &n->where);
9682 3 : continue;
9683 : }
9684 212 : if (ns != n->sym->ns || n->sym->attr.use_assoc || n->sym->attr.imported)
9685 : {
9686 8 : gfc_error ("Argument %qs at %L to declarative !$OMP ALLOCATE shall be"
9687 : " in the same scope as the variable declaration",
9688 : n->sym->name, &n->where);
9689 8 : continue;
9690 : }
9691 204 : if (n->sym->attr.dummy)
9692 : {
9693 3 : gfc_error ("Unexpected dummy argument %qs as argument at %L to "
9694 : "declarative !$OMP ALLOCATE", n->sym->name, &n->where);
9695 3 : continue;
9696 : }
9697 201 : if (n->sym->attr.codimension)
9698 : {
9699 0 : gfc_error ("Unexpected coarray argument %qs as argument at %L to "
9700 : "declarative !$OMP ALLOCATE", n->sym->name, &n->where);
9701 0 : continue;
9702 : }
9703 201 : if (n->sym->attr.omp_allocate)
9704 : {
9705 5 : if (n->sym->attr.in_common)
9706 : {
9707 1 : gfc_error ("Duplicated common block %</%s/%> in !$OMP ALLOCATE "
9708 1 : "at %L", n->sym->common_head->name, &n->where);
9709 3 : while (n->next && n->next->sym
9710 3 : && n->sym->common_head == n->next->sym->common_head)
9711 : n = n->next;
9712 : }
9713 : else
9714 4 : gfc_error ("Duplicated variable %qs in !$OMP ALLOCATE at %L",
9715 : n->sym->name, &n->where);
9716 5 : continue;
9717 : }
9718 : /* For 'equivalence(a,b)', a 'union_type {<type> a,b} equiv.0' is created
9719 : with a value expression for 'a' as 'equiv.0.a' (likewise for b); while
9720 : this can be handled, EQUIVALENCE is marked as obsolescent since Fortran
9721 : 2018 and also not widely used. However, it could be supported,
9722 : if needed. */
9723 196 : if (n->sym->attr.in_equivalence)
9724 : {
9725 2 : gfc_error ("Sorry, EQUIVALENCE object %qs not supported with !$OMP "
9726 : "ALLOCATE at %L", n->sym->name, &n->where);
9727 2 : continue;
9728 : }
9729 : /* Similar for Cray pointer/pointee - they could be implemented but as
9730 : common vendor extension but nowadays rarely used and requiring
9731 : -fcray-pointer, there is no need to support them. */
9732 194 : if (n->sym->attr.cray_pointer || n->sym->attr.cray_pointee)
9733 : {
9734 2 : gfc_error ("Sorry, Cray pointers and pointees such as %qs are not "
9735 : "supported with !$OMP ALLOCATE at %L",
9736 : n->sym->name, &n->where);
9737 2 : continue;
9738 : }
9739 192 : n->sym->attr.omp_allocate = 1;
9740 192 : if ((n->sym->ts.type == BT_CLASS && n->sym->attr.class_ok
9741 0 : && CLASS_DATA (n->sym)->attr.allocatable)
9742 192 : || (n->sym->ts.type != BT_CLASS && n->sym->attr.allocatable))
9743 1 : gfc_error ("Unexpected allocatable variable %qs at %L in declarative "
9744 : "!$OMP ALLOCATE directive", n->sym->name, &n->where);
9745 191 : else if ((n->sym->ts.type == BT_CLASS && n->sym->attr.class_ok
9746 0 : && CLASS_DATA (n->sym)->attr.class_pointer)
9747 191 : || (n->sym->ts.type != BT_CLASS && n->sym->attr.pointer))
9748 1 : gfc_error ("Unexpected pointer variable %qs at %L in declarative "
9749 : "!$OMP ALLOCATE directive", n->sym->name, &n->where);
9750 192 : HOST_WIDE_INT alignment = 0;
9751 198 : if (n->u.align
9752 192 : && (!gfc_resolve_expr (n->u.align)
9753 27 : || n->u.align->ts.type != BT_INTEGER
9754 26 : || n->u.align->rank != 0
9755 24 : || n->u.align->expr_type != EXPR_CONSTANT
9756 23 : || gfc_extract_hwi (n->u.align, &alignment)
9757 23 : || !pow2p_hwi (alignment)))
9758 : {
9759 6 : gfc_error ("ALIGN requires a scalar positive constant integer "
9760 : "alignment expression at %L that is a power of two",
9761 6 : &n->u.align->where);
9762 6 : while (n->sym->attr.in_common && n->next && n->next->sym
9763 6 : && n->sym->common_head == n->next->sym->common_head)
9764 : n = n->next;
9765 6 : continue;
9766 : }
9767 186 : if (n->sym->attr.in_common || n->sym->attr.save || n->sym->ns->save_all
9768 63 : || (n->sym->ns->proc_name
9769 63 : && (n->sym->ns->proc_name->attr.flavor == FL_PROGRAM
9770 55 : || n->sym->ns->proc_name->attr.flavor == FL_MODULE
9771 55 : || n->sym->ns->proc_name->attr.flavor == FL_BLOCK_DATA)))
9772 : {
9773 131 : bool com = n->sym->attr.in_common;
9774 131 : if (!n->u2.allocator)
9775 1 : gfc_error ("An ALLOCATOR clause is required as the list item "
9776 : "%<%s%s%s%> at %L has the SAVE attribute", com ? "/" : "",
9777 0 : com ? n->sym->common_head->name : n->sym->name,
9778 : com ? "/" : "", &n->where);
9779 130 : else if (!is_predefined_allocator (n->u2.allocator))
9780 24 : gfc_error ("Predefined allocator required in ALLOCATOR clause at %L"
9781 : " as the list item %<%s%s%s%> at %L has the SAVE attribute",
9782 24 : &n->u2.allocator->where, com ? "/" : "",
9783 24 : com ? n->sym->common_head->name : n->sym->name,
9784 : com ? "/" : "", &n->where);
9785 : /* Static variables may not use omp_cgroup_mem_alloc (6),
9786 : omp_pteam_mem_alloc (7), or omp_thread_mem_alloc (8). */
9787 106 : else if (mpz_cmp_si (n->u2.allocator->value.integer,
9788 : 6 /* cgroup */) >= 0
9789 34 : && mpz_cmp_si (n->u2.allocator->value.integer,
9790 : 8 /* thread */) <= 0)
9791 : {
9792 33 : STATIC_ASSERT (GOMP_OMP_PREDEF_ALLOC_CGROUP == 6);
9793 33 : STATIC_ASSERT (GOMP_OMP_PREDEF_ALLOC_PTEAM == 7);
9794 33 : STATIC_ASSERT (GOMP_OMP_PREDEF_ALLOC_THREAD == 8);
9795 33 : const char *alloc_name[] = {"omp_cgroup_mem_alloc",
9796 : "omp_pteam_mem_alloc",
9797 : "omp_thread_mem_alloc" };
9798 33 : gfc_error ("Predefined allocator %qs in ALLOCATOR clause at %L, "
9799 : "used for list item %<%s%s%s%> at %L, may not be used"
9800 : " for static variables",
9801 33 : alloc_name[mpz_get_ui (n->u2.allocator->value.integer)
9802 33 : - 6 /* cgroup */], &n->u2.allocator->where,
9803 : com ? "/" : "",
9804 33 : com ? n->sym->common_head->name : n->sym->name,
9805 : com ? "/" : "", &n->where);
9806 : }
9807 67 : while (n->sym->attr.in_common && n->next && n->next->sym
9808 186 : && n->sym->common_head == n->next->sym->common_head)
9809 : n = n->next;
9810 : }
9811 55 : else if (n->u2.allocator
9812 55 : && (!gfc_resolve_expr (n->u2.allocator)
9813 20 : || n->u2.allocator->ts.type != BT_INTEGER
9814 19 : || n->u2.allocator->rank != 0
9815 18 : || n->u2.allocator->ts.kind != gfc_c_intptr_kind))
9816 3 : gfc_error ("Expected integer expression of the "
9817 : "%<omp_allocator_handle_kind%> kind at %L",
9818 3 : &n->u2.allocator->where);
9819 : }
9820 62 : }
9821 :
9822 : /* Resolve ASSUME's and ASSUMES' assumption clauses. Note that absent/contains
9823 : is handled during parse time in omp_verify_merge_absent_contains. */
9824 :
9825 : void
9826 34 : gfc_resolve_omp_assumptions (gfc_omp_assumptions *assume)
9827 : {
9828 54 : for (gfc_expr_list *el = assume->holds; el; el = el->next)
9829 20 : if (!gfc_resolve_expr (el->expr)
9830 20 : || el->expr->ts.type != BT_LOGICAL
9831 38 : || el->expr->rank != 0)
9832 4 : gfc_error ("HOLDS expression at %L must be a scalar logical expression",
9833 4 : &el->expr->where);
9834 34 : }
9835 :
9836 :
9837 : /* Resolve the OpenMP ALLOCATE clauses. */
9838 :
9839 : static void
9840 33132 : resolve_omp_allocate_clauses (gfc_code *code, gfc_omp_clauses *omp_clauses,
9841 : gfc_namespace *ns)
9842 : {
9843 33132 : gfc_omp_namelist *n;
9844 33132 : enum gfc_omp_list_type list;
9845 :
9846 33132 : if (!omp_clauses->lists[OMP_LIST_ALLOCATE])
9847 : return;
9848 795 : for (n = omp_clauses->lists[OMP_LIST_ALLOCATE]; n; n = n->next)
9849 : {
9850 515 : if (n->u2.allocator
9851 515 : && (!gfc_resolve_expr (n->u2.allocator)
9852 290 : || n->u2.allocator->ts.type != BT_INTEGER
9853 288 : || n->u2.allocator->rank != 0
9854 287 : || n->u2.allocator->ts.kind != gfc_c_intptr_kind))
9855 : {
9856 8 : gfc_error ("Expected integer expression of the "
9857 : "%<omp_allocator_handle_kind%> kind at %L",
9858 8 : &n->u2.allocator->where);
9859 28 : break;
9860 : }
9861 507 : if (!n->u.align)
9862 399 : continue;
9863 108 : HOST_WIDE_INT alignment = 0;
9864 108 : if (!gfc_resolve_expr (n->u.align)
9865 108 : || n->u.align->ts.type != BT_INTEGER
9866 105 : || n->u.align->rank != 0
9867 102 : || n->u.align->expr_type != EXPR_CONSTANT
9868 99 : || gfc_extract_hwi (n->u.align, &alignment)
9869 99 : || alignment <= 0
9870 207 : || !pow2p_hwi (alignment))
9871 : {
9872 12 : gfc_error ("ALIGN requires a scalar positive constant integer "
9873 : "alignment expression at %L that is a power of two",
9874 12 : &n->u.align->where);
9875 12 : break;
9876 : }
9877 : }
9878 :
9879 : /* Check for 2 things here.
9880 : 1. There is no duplication of variable in allocate clause.
9881 : 2. Variable in allocate clause are also present in some
9882 : privatization clase (non-composite case). */
9883 815 : for (n = omp_clauses->lists[OMP_LIST_ALLOCATE]; n; n = n->next)
9884 515 : if (n->sym)
9885 489 : n->sym->mark = 0;
9886 :
9887 : gfc_omp_namelist *prev = NULL;
9888 815 : for (n = omp_clauses->lists[OMP_LIST_ALLOCATE]; n; )
9889 : {
9890 515 : if (n->sym == NULL)
9891 : {
9892 26 : n = n->next;
9893 26 : continue;
9894 : }
9895 489 : if (n->sym->mark == 1)
9896 : {
9897 3 : gfc_warning (OPT_Wopenmp, "%qs appears more than once in "
9898 : "%<allocate%> at %L" , n->sym->name, &n->where);
9899 : /* We have already seen this variable so it is a duplicate.
9900 : Remove it. */
9901 3 : if (prev != NULL && prev->next == n)
9902 : {
9903 3 : prev->next = n->next;
9904 3 : n->next = NULL;
9905 3 : gfc_free_omp_namelist (n, OMP_LIST_ALLOCATE);
9906 3 : n = prev->next;
9907 : }
9908 3 : continue;
9909 : }
9910 486 : n->sym->mark = 1;
9911 486 : prev = n;
9912 486 : n = n->next;
9913 : }
9914 :
9915 : /* Non-composite constructs. */
9916 300 : if (code && code->op < EXEC_OMP_DO_SIMD)
9917 : {
9918 4760 : for (list = OMP_LIST_FIRST; list < OMP_LIST_NUM;
9919 4641 : list = gfc_omp_list_type (list + 1))
9920 4641 : switch (list)
9921 : {
9922 1071 : case OMP_LIST_PRIVATE:
9923 1071 : case OMP_LIST_FIRSTPRIVATE:
9924 1071 : case OMP_LIST_LASTPRIVATE:
9925 1071 : case OMP_LIST_REDUCTION:
9926 1071 : case OMP_LIST_REDUCTION_INSCAN:
9927 1071 : case OMP_LIST_REDUCTION_TASK:
9928 1071 : case OMP_LIST_IN_REDUCTION:
9929 1071 : case OMP_LIST_TASK_REDUCTION:
9930 1071 : case OMP_LIST_LINEAR:
9931 1370 : for (n = omp_clauses->lists[list]; n; n = n->next)
9932 299 : n->sym->mark = 0;
9933 : break;
9934 : default:
9935 : break;
9936 : }
9937 :
9938 410 : for (n = omp_clauses->lists[OMP_LIST_ALLOCATE]; n; n = n->next)
9939 291 : if (n->sym->mark == 1)
9940 4 : gfc_error ("%qs specified in %<allocate%> clause at %L but not "
9941 : "in an explicit privatization clause",
9942 : n->sym->name, &n->where);
9943 : }
9944 71 : if (!(code
9945 300 : && (code->op == EXEC_OMP_ALLOCATORS || code->op == EXEC_OMP_ALLOCATE)
9946 73 : && code->block
9947 72 : && code->block->next
9948 71 : && code->block->next->op == EXEC_ALLOCATE))
9949 : return;
9950 :
9951 68 : if (code->op == EXEC_OMP_ALLOCATE)
9952 49 : gfc_warning (OPT_Wdeprecated_openmp,
9953 : "The use of one or more %<allocate%> directives with "
9954 : "an associated %<allocate%> statement at %L is "
9955 : "deprecated since OpenMP 5.2, use an %<allocators%> "
9956 : "directive", &code->loc);
9957 68 : gfc_alloc *a;
9958 68 : gfc_omp_namelist *n_null = NULL;
9959 68 : bool missing_allocator = false;
9960 68 : gfc_symbol *missing_allocator_sym = NULL;
9961 161 : for (n = omp_clauses->lists[OMP_LIST_ALLOCATE]; n; n = n->next)
9962 : {
9963 93 : if (n->u2.allocator == NULL)
9964 : {
9965 77 : if (!missing_allocator_sym)
9966 59 : missing_allocator_sym = n->sym;
9967 : missing_allocator = true;
9968 : }
9969 93 : if (n->sym == NULL)
9970 : {
9971 26 : n_null = n;
9972 26 : continue;
9973 : }
9974 67 : if (n->sym->attr.codimension)
9975 2 : gfc_error ("Unexpected coarray %qs in %<allocate%> at %L",
9976 : n->sym->name, &n->where);
9977 103 : for (a = code->block->next->ext.alloc.list; a; a = a->next)
9978 101 : if (a->expr->expr_type == EXPR_VARIABLE
9979 101 : && a->expr->symtree->n.sym == n->sym)
9980 : {
9981 65 : gfc_ref *ref;
9982 82 : for (ref = a->expr->ref; ref; ref = ref->next)
9983 17 : if (ref->type == REF_COMPONENT)
9984 : break;
9985 : if (ref == NULL)
9986 : break;
9987 : }
9988 67 : if (a == NULL)
9989 2 : gfc_error ("%qs specified in %<allocate%> at %L but not "
9990 : "in the associated ALLOCATE statement",
9991 2 : n->sym->name, &n->where);
9992 : }
9993 : /* If there is an ALLOCATE directive without list argument, a
9994 : namelist with its allocator/align clauses and n->sym = NULL is
9995 : created during parsing; here, we add all not otherwise specified
9996 : items from the Fortran allocate to that list.
9997 : For an ALLOCATORS directive, not listed items use the normal
9998 : Fortran way.
9999 : The behavior of an ALLOCATE directive that does not list all
10000 : arguments but there is no directive without list argument is not
10001 : well specified. Thus, we reject such code below. In OpenMP 5.2
10002 : the executable ALLOCATE directive is deprecated and in 6.0
10003 : deleted such that no spec clarification is to be expected. */
10004 125 : for (a = code->block->next->ext.alloc.list; a; a = a->next)
10005 89 : if (a->expr->expr_type == EXPR_VARIABLE)
10006 : {
10007 154 : for (n = omp_clauses->lists[OMP_LIST_ALLOCATE]; n; n = n->next)
10008 122 : if (a->expr->symtree->n.sym == n->sym)
10009 : {
10010 57 : gfc_ref *ref;
10011 72 : for (ref = a->expr->ref; ref; ref = ref->next)
10012 15 : if (ref->type == REF_COMPONENT)
10013 : break;
10014 : if (ref == NULL)
10015 : break;
10016 : }
10017 89 : if (n == NULL && n_null == NULL)
10018 : {
10019 : /* OK for ALLOCATORS but for ALLOCATE: Unspecified whether
10020 : that should use the default allocator of OpenMP or the
10021 : Fortran allocator. Thus, just reject it. */
10022 7 : if (code->op == EXEC_OMP_ALLOCATE)
10023 1 : gfc_error ("%qs listed in %<allocate%> statement at %L "
10024 : "but it is neither explicitly in listed in "
10025 : "the %<!$OMP ALLOCATE%> directive nor exists"
10026 : " a directive without argument list",
10027 1 : a->expr->symtree->n.sym->name,
10028 : &a->expr->where);
10029 : break;
10030 : }
10031 82 : if (n == NULL)
10032 : {
10033 25 : if (a->expr->symtree->n.sym->attr.codimension)
10034 1 : gfc_error ("Unexpected coarray %qs in %<allocate%> at "
10035 : "%L, implicitly listed in %<!$OMP ALLOCATE%>"
10036 : " at %L", a->expr->symtree->n.sym->name,
10037 : &a->expr->where, &n_null->where);
10038 : break;
10039 : }
10040 : }
10041 68 : gfc_namespace *prog_unit = ns;
10042 87 : while (prog_unit->parent)
10043 : prog_unit = prog_unit->parent;
10044 : gfc_namespace *fn_ns = ns;
10045 72 : while (fn_ns)
10046 : {
10047 70 : if (ns->proc_name
10048 70 : && (ns->proc_name->attr.subroutine
10049 6 : || ns->proc_name->attr.function))
10050 : break;
10051 4 : fn_ns = fn_ns->parent;
10052 : }
10053 68 : if (missing_allocator
10054 58 : && !(prog_unit->omp_requires & OMP_REQ_DYNAMIC_ALLOCATORS)
10055 58 : && ((fn_ns && fn_ns->proc_name->attr.omp_declare_target)
10056 55 : || omp_clauses->contained_in_target_construct))
10057 : {
10058 6 : if (code->op == EXEC_OMP_ALLOCATORS)
10059 2 : gfc_error ("ALLOCATORS directive at %L inside a target region "
10060 : "must specify an ALLOCATOR modifier for %qs",
10061 : &code->loc, missing_allocator_sym->name);
10062 4 : else if (missing_allocator_sym)
10063 2 : gfc_error ("ALLOCATE directive at %L inside a target region "
10064 : "must specify an ALLOCATOR clause for %qs",
10065 : &code->loc, missing_allocator_sym->name);
10066 : else
10067 2 : gfc_error ("ALLOCATE directive at %L inside a target region "
10068 : "must specify an ALLOCATOR clause", &code->loc);
10069 : }
10070 : }
10071 :
10072 :
10073 : /* Diagnose list items that appear multiple times in OpenMP or OpenACC clauses,
10074 : unless permitted by the specification. */
10075 :
10076 : static void
10077 33132 : check_omp_clauses_dupl_syms (gfc_code *code, gfc_omp_clauses *omp_clauses,
10078 : bool openacc)
10079 : {
10080 33132 : gfc_omp_namelist *n;
10081 33132 : enum gfc_omp_list_type list;
10082 :
10083 : /* Check that no symbol appears on multiple clauses, except that
10084 : a symbol can appear on both firstprivate and lastprivate. */
10085 1325280 : for (list = OMP_LIST_FIRST; list < OMP_LIST_NUM;
10086 1292148 : list = gfc_omp_list_type (list + 1))
10087 1338028 : for (n = omp_clauses->lists[list]; n; n = n->next)
10088 : {
10089 45880 : if (!n->sym) /* omp_all_memory. */
10090 47 : continue;
10091 45833 : n->sym->mark = 0;
10092 45833 : n->sym->comp_mark = 0;
10093 45833 : n->sym->data_mark = 0;
10094 45833 : n->sym->dev_mark = 0;
10095 45833 : n->sym->gen_mark = 0;
10096 45833 : n->sym->reduc_mark = 0;
10097 : }
10098 1325280 : for (list = OMP_LIST_FIRST; list < OMP_LIST_NUM;
10099 1292148 : list = gfc_omp_list_type (list + 1))
10100 1292148 : if (list != OMP_LIST_FIRSTPRIVATE
10101 1292148 : && list != OMP_LIST_LASTPRIVATE
10102 1292148 : && list != OMP_LIST_ALIGNED
10103 1192752 : && list != OMP_LIST_DEPEND
10104 1192752 : && list != OMP_LIST_FROM
10105 1126488 : && list != OMP_LIST_TO
10106 1126488 : && list != OMP_LIST_INTEROP
10107 1060224 : && (list != OMP_LIST_REDUCTION || !openacc)
10108 1047229 : && list != OMP_LIST_ALLOCATE)
10109 1049062 : for (n = omp_clauses->lists[list]; n; n = n->next)
10110 : {
10111 34965 : bool component_ref_p = false;
10112 :
10113 : /* Allow multiple components of the same (e.g. derived-type)
10114 : variable here. Duplicate components are detected elsewhere. */
10115 34965 : if (n->expr && n->expr->expr_type == EXPR_VARIABLE)
10116 16021 : for (gfc_ref *ref = n->expr->ref; ref; ref = ref->next)
10117 9744 : if (ref->type == REF_COMPONENT)
10118 3197 : component_ref_p = true;
10119 34965 : if ((list == OMP_LIST_IS_DEVICE_PTR
10120 34965 : || list == OMP_LIST_HAS_DEVICE_ADDR)
10121 314 : && !component_ref_p)
10122 : {
10123 314 : if (n->sym->gen_mark
10124 312 : || n->sym->dev_mark
10125 311 : || n->sym->reduc_mark
10126 311 : || n->sym->mark)
10127 5 : gfc_error ("Symbol %qs present on multiple clauses at %L",
10128 : n->sym->name, &n->where);
10129 : else
10130 309 : n->sym->dev_mark = 1;
10131 : }
10132 34651 : else if ((list == OMP_LIST_USE_DEVICE_PTR
10133 34651 : || list == OMP_LIST_USE_DEVICE_ADDR
10134 34651 : || list == OMP_LIST_PRIVATE
10135 : || list == OMP_LIST_SHARED)
10136 12861 : && !component_ref_p)
10137 : {
10138 12861 : if (n->sym->gen_mark || n->sym->dev_mark || n->sym->reduc_mark)
10139 13 : gfc_error ("Symbol %qs present on multiple clauses at %L",
10140 : n->sym->name, &n->where);
10141 : else
10142 : {
10143 12848 : n->sym->gen_mark = 1;
10144 : /* Set both generic and device bits if we have
10145 : use_device_*(x) or shared(x). This allows us to diagnose
10146 : "map(x) private(x)" below. */
10147 12848 : if (list != OMP_LIST_PRIVATE)
10148 3456 : n->sym->dev_mark = 1;
10149 : }
10150 : }
10151 21790 : else if ((list == OMP_LIST_REDUCTION
10152 21790 : || list == OMP_LIST_REDUCTION_TASK
10153 19329 : || list == OMP_LIST_REDUCTION_INSCAN
10154 19329 : || list == OMP_LIST_IN_REDUCTION
10155 19116 : || list == OMP_LIST_TASK_REDUCTION)
10156 2674 : && !component_ref_p)
10157 : {
10158 : /* Attempts to mix reduction types are diagnosed below. */
10159 2674 : if (n->sym->gen_mark || n->sym->dev_mark)
10160 2 : gfc_error ("Symbol %qs present on multiple clauses at %L",
10161 : n->sym->name, &n->where);
10162 2674 : n->sym->reduc_mark = 1;
10163 : }
10164 19116 : else if ((!component_ref_p && n->sym->comp_mark)
10165 19115 : || (component_ref_p && n->sym->mark))
10166 : {
10167 42 : if (openacc)
10168 3 : gfc_error ("Symbol %qs has mixed component and non-component "
10169 3 : "accesses at %L", n->sym->name, &n->where);
10170 : }
10171 19074 : else if ((openacc || list != OMP_LIST_MAP) && n->sym->mark)
10172 88 : gfc_error ("Symbol %qs present on multiple clauses at %L",
10173 : n->sym->name, &n->where);
10174 : else
10175 : {
10176 18986 : if (component_ref_p)
10177 2473 : n->sym->comp_mark = 1;
10178 : else
10179 16513 : n->sym->mark = 1;
10180 : }
10181 : }
10182 :
10183 : /* Detect specifically the case where we have "map(x) private(x)" and raise
10184 : an error. If we have "...simd" combined directives though, the "private"
10185 : applies to the simd part, so this is permitted though. */
10186 42532 : for (n = omp_clauses->lists[OMP_LIST_PRIVATE]; n; n = n->next)
10187 9400 : if (n->sym->mark
10188 6 : && n->sym->gen_mark
10189 6 : && !n->sym->dev_mark
10190 6 : && !n->sym->reduc_mark
10191 5 : && code->op != EXEC_OMP_TARGET_SIMD
10192 : && code->op != EXEC_OMP_TARGET_PARALLEL_DO_SIMD
10193 : && code->op != EXEC_OMP_TARGET_TEAMS_DISTRIBUTE_SIMD
10194 : && code->op != EXEC_OMP_TARGET_TEAMS_DISTRIBUTE_PARALLEL_DO_SIMD)
10195 1 : gfc_error ("Symbol %qs present on multiple clauses at %L",
10196 : n->sym->name, &n->where);
10197 :
10198 : gcc_assert (OMP_LIST_LASTPRIVATE == OMP_LIST_FIRSTPRIVATE + 1);
10199 99396 : for (list = OMP_LIST_FIRSTPRIVATE; list <= OMP_LIST_LASTPRIVATE;
10200 66264 : list = gfc_omp_list_type (list + 1))
10201 70491 : for (n = omp_clauses->lists[list]; n; n = n->next)
10202 4227 : if (n->sym->data_mark || n->sym->gen_mark || n->sym->dev_mark)
10203 : {
10204 9 : gfc_error ("Symbol %qs present on multiple clauses at %L",
10205 : n->sym->name, &n->where);
10206 9 : n->sym->data_mark = n->sym->gen_mark = n->sym->dev_mark = 0;
10207 : }
10208 4218 : else if (n->sym->mark
10209 18 : && code->op != EXEC_OMP_TARGET_TEAMS
10210 : && code->op != EXEC_OMP_TARGET_TEAMS_DISTRIBUTE
10211 : && code->op != EXEC_OMP_TARGET_TEAMS_LOOP
10212 : && code->op != EXEC_OMP_TARGET_TEAMS_DISTRIBUTE_SIMD
10213 : && code->op != EXEC_OMP_TARGET_TEAMS_DISTRIBUTE_PARALLEL_DO
10214 : && code->op != EXEC_OMP_TARGET_PARALLEL
10215 : && code->op != EXEC_OMP_TARGET_PARALLEL_DO
10216 : && code->op != EXEC_OMP_TARGET_PARALLEL_LOOP
10217 : && code->op != EXEC_OMP_TARGET_PARALLEL_DO_SIMD
10218 : && code->op != EXEC_OMP_TARGET_TEAMS_DISTRIBUTE_PARALLEL_DO_SIMD)
10219 7 : gfc_error ("Symbol %qs present on both data and map clauses "
10220 : "at %L", n->sym->name, &n->where);
10221 :
10222 35051 : for (n = omp_clauses->lists[OMP_LIST_FIRSTPRIVATE]; n; n = n->next)
10223 : {
10224 1919 : if (n->sym->data_mark || n->sym->gen_mark || n->sym->dev_mark)
10225 7 : gfc_error ("Symbol %qs present on multiple clauses at %L",
10226 : n->sym->name, &n->where);
10227 : else
10228 1912 : n->sym->data_mark = 1;
10229 : }
10230 :
10231 : /* LASTPRIVATE clauses. */
10232 35440 : for (n = omp_clauses->lists[OMP_LIST_LASTPRIVATE]; n; n = n->next)
10233 2308 : n->sym->data_mark = 0;
10234 35440 : for (n = omp_clauses->lists[OMP_LIST_LASTPRIVATE]; n; n = n->next)
10235 : {
10236 2308 : if (n->sym->data_mark || n->sym->gen_mark || n->sym->dev_mark)
10237 0 : gfc_error ("Symbol %qs present on multiple clauses at %L",
10238 : n->sym->name, &n->where);
10239 : else
10240 2308 : n->sym->data_mark = 1;
10241 : }
10242 :
10243 : /* ALIGNED clauses. */
10244 33282 : for (n = omp_clauses->lists[OMP_LIST_ALIGNED]; n; n = n->next)
10245 150 : n->sym->mark = 0;
10246 :
10247 33282 : for (n = omp_clauses->lists[OMP_LIST_ALIGNED]; n; n = n->next)
10248 : {
10249 150 : if (n->sym->mark)
10250 0 : gfc_error ("Symbol %qs present on multiple clauses at %L",
10251 : n->sym->name, &n->where);
10252 : else
10253 150 : n->sym->mark = 1;
10254 : }
10255 :
10256 : /* FROM and TO clauses. */
10257 33902 : for (n = omp_clauses->lists[OMP_LIST_TO]; n; n = n->next)
10258 770 : n->sym->mark = 0;
10259 34167 : for (n = omp_clauses->lists[OMP_LIST_FROM]; n; n = n->next)
10260 1035 : if (n->expr == NULL)
10261 1017 : n->sym->mark = 1;
10262 33902 : for (n = omp_clauses->lists[OMP_LIST_TO]; n; n = n->next)
10263 : {
10264 770 : if (n->expr == NULL && n->sym->mark)
10265 0 : gfc_error ("Symbol %qs present on both FROM and TO clauses at %L",
10266 : n->sym->name, &n->where);
10267 : else
10268 770 : n->sym->mark = 1;
10269 : }
10270 :
10271 : /* OpenACC reductions. */
10272 33132 : if (openacc)
10273 : {
10274 15131 : for (n = omp_clauses->lists[OMP_LIST_REDUCTION]; n; n = n->next)
10275 2136 : n->sym->mark = 0;
10276 15131 : for (n = omp_clauses->lists[OMP_LIST_REDUCTION]; n; n = n->next)
10277 : {
10278 2136 : if (n->sym->mark)
10279 0 : gfc_error ("Symbol %qs present on multiple clauses at %L",
10280 : n->sym->name, &n->where);
10281 : else
10282 2136 : n->sym->mark = 1;
10283 :
10284 : /* OpenACC does not support reductions on arrays. */
10285 2136 : if (n->sym->as)
10286 71 : gfc_error ("Array %qs is not permitted in reduction at %L",
10287 : n->sym->name, &n->where);
10288 : }
10289 : }
10290 33132 : }
10291 :
10292 : /* OpenMP/OpenACC: Resolve the list item of a MAP, TO, FROM, CACHE, AFFINITY
10293 : or DEPEND clause. */
10294 :
10295 : static void
10296 20963 : resolve_omp_clauses_aff_dep_map_cache (gfc_code *code,
10297 : gfc_omp_namelist *n,
10298 : const char *name,
10299 : enum gfc_omp_list_type list,
10300 : gfc_omp_clauses *omp_clauses,
10301 : bool openacc)
10302 : {
10303 20963 : gcc_checking_assert (list == OMP_LIST_AFFINITY || list == OMP_LIST_DEPEND
10304 : || list == OMP_LIST_MAP || list == OMP_LIST_TO
10305 : || list == OMP_LIST_FROM || list == OMP_LIST_CACHE);
10306 :
10307 20963 : if (list != OMP_LIST_CACHE && n->u2.ns && !n->u2.ns->resolved)
10308 : {
10309 109 : n->u2.ns->resolved = 1;
10310 109 : for (gfc_symbol *sym = n->u2.ns->omp_affinity_iterators;
10311 235 : sym; sym = sym->tlink)
10312 : {
10313 126 : gfc_constructor *c;
10314 126 : c = gfc_constructor_first (sym->value->value.constructor);
10315 126 : if (!gfc_resolve_expr (c->expr)
10316 126 : || c->expr->ts.type != BT_INTEGER
10317 250 : || c->expr->rank != 0)
10318 2 : gfc_error ("Scalar integer expression for range begin expected "
10319 2 : "at %L", &c->expr->where);
10320 126 : c = gfc_constructor_next (c);
10321 126 : if (!gfc_resolve_expr (c->expr)
10322 126 : || c->expr->ts.type != BT_INTEGER
10323 250 : || c->expr->rank != 0)
10324 2 : gfc_error ("Scalar integer expression for range end expected at %L",
10325 2 : &c->expr->where);
10326 126 : c = gfc_constructor_next (c);
10327 126 : if (c && (!gfc_resolve_expr (c->expr)
10328 16 : || c->expr->ts.type != BT_INTEGER
10329 14 : || c->expr->rank != 0))
10330 2 : gfc_error ("Scalar integer expression for range step expected "
10331 2 : "at %L", &c->expr->where);
10332 124 : else if (c
10333 14 : && c->expr->expr_type == EXPR_CONSTANT
10334 12 : && mpz_cmp_si (c->expr->value.integer, 0) == 0)
10335 2 : gfc_error ("Nonzero range step expected at %L", &c->expr->where);
10336 : }
10337 : }
10338 20862 : if (list == OMP_LIST_DEPEND)
10339 : {
10340 1964 : if (n->u.depend_doacross_op == OMP_DEPEND_SINK_FIRST
10341 : || n->u.depend_doacross_op == OMP_DOACROSS_SINK_FIRST
10342 1964 : || n->u.depend_doacross_op == OMP_DOACROSS_SINK)
10343 : {
10344 1233 : if (omp_clauses->doacross_source)
10345 : {
10346 0 : gfc_error ("Dependence-type SINK used together with SOURCE on "
10347 : "the same construct at %L", &n->where);
10348 0 : omp_clauses->doacross_source = false;
10349 : }
10350 1233 : else if (n->expr)
10351 : {
10352 571 : if (!gfc_resolve_expr (n->expr)
10353 571 : || n->expr->ts.type != BT_INTEGER
10354 1142 : || n->expr->rank != 0)
10355 0 : gfc_error ("SINK addend not a constant integer at %L",
10356 : &n->where);
10357 : }
10358 1233 : if (n->sym == NULL
10359 4 : && (n->expr == NULL
10360 3 : || mpz_cmp_si (n->expr->value.integer, -1) != 0))
10361 2 : gfc_error ("omp_cur_iteration at %L requires %<-1%> as "
10362 : "logical offset", &n->where);
10363 : return;
10364 : }
10365 731 : if (n->u.depend_doacross_op == OMP_DEPEND_DEPOBJ
10366 38 : && !n->expr
10367 22 : && (n->sym->ts.type != BT_INTEGER
10368 22 : || n->sym->ts.kind != 2 * gfc_index_integer_kind
10369 22 : || n->sym->attr.dimension))
10370 0 : gfc_error ("Locator %qs at %L in DEPEND clause of depobj type shall be "
10371 : "a scalar integer of OMP_DEPEND_KIND kind",
10372 : n->sym->name, &n->where);
10373 731 : else if (n->u.depend_doacross_op == OMP_DEPEND_DEPOBJ
10374 38 : && n->expr
10375 747 : && (!gfc_resolve_expr (n->expr)
10376 16 : || n->expr->ts.type != BT_INTEGER
10377 16 : || n->expr->ts.kind != 2 * gfc_index_integer_kind
10378 16 : || n->expr->rank != 0))
10379 0 : gfc_error ("Locator at %L in DEPEND clause of depobj type shall be a "
10380 0 : "scalar integer of OMP_DEPEND_KIND kind", &n->expr->where);
10381 : }
10382 19730 : gfc_ref *lastref = NULL, *lastslice = NULL;
10383 19730 : bool resolved = false;
10384 19730 : if (n->expr)
10385 : {
10386 6546 : lastref = n->expr->ref;
10387 6546 : resolved = gfc_resolve_expr (n->expr);
10388 :
10389 : /* Look through component refs to find last array reference. */
10390 6546 : if (resolved)
10391 : {
10392 16585 : for (gfc_ref *ref = n->expr->ref; ref; ref = ref->next)
10393 10057 : if (ref->type == REF_COMPONENT
10394 : || ref->type == REF_SUBSTRING
10395 10057 : || ref->type == REF_INQUIRY)
10396 : lastref = ref;
10397 6799 : else if (ref->type == REF_ARRAY)
10398 : {
10399 14290 : for (int i = 0; i < ref->u.ar.dimen; i++)
10400 7491 : if (ref->u.ar.dimen_type[i] == DIMEN_RANGE)
10401 6277 : lastslice = ref;
10402 : lastref = ref;
10403 : }
10404 :
10405 : /* The "!$acc cache" directive allows rectangular subarrays to be
10406 : specified, with some restrictions on the form of bounds (not
10407 : implemented). Only raise an error here if we're really sure the
10408 : array isn't contiguous. An expression such as arr(-n:n,-n:n)
10409 : could be contiguous even if it looks like it may not be. */
10410 6528 : if (code
10411 6502 : && code->op != EXEC_OACC_UPDATE
10412 5720 : && list != OMP_LIST_CACHE
10413 5720 : && list != OMP_LIST_DEPEND
10414 5398 : && !gfc_is_simply_contiguous (n->expr, false, true)
10415 1517 : && gfc_is_not_contiguous (n->expr)
10416 6541 : && !(lastslice && (lastslice->next
10417 3 : || lastslice->type != REF_ARRAY)))
10418 3 : gfc_error ("Array is not contiguous at %L", &n->where);
10419 : }
10420 : }
10421 19730 : if (list == OMP_LIST_MAP
10422 17058 : && (n->sym->attr.omp_groupprivate
10423 17057 : || n->sym->attr.omp_declare_target_local))
10424 2 : gfc_error ("%qs argument to MAP clause at %L must not be a device-local "
10425 : "variable, including GROUPPRIVATE", n->sym->name, &n->where);
10426 19730 : if (openacc
10427 19730 : && list == OMP_LIST_MAP
10428 9571 : && (n->u.map.op == OMP_MAP_ATTACH || n->u.map.op == OMP_MAP_DETACH))
10429 : {
10430 117 : symbol_attribute attr;
10431 117 : if (n->expr)
10432 99 : attr = gfc_expr_attr (n->expr);
10433 : else
10434 18 : attr = n->sym->attr;
10435 117 : if (!attr.pointer && !attr.allocatable)
10436 7 : gfc_error ("%qs clause argument must be ALLOCATABLE or a POINTER at %L",
10437 7 : (n->u.map.op == OMP_MAP_ATTACH) ? "attach" : "detach",
10438 : &n->where);
10439 : }
10440 19730 : if (lastref
10441 13196 : || (n->expr && (!resolved || n->expr->expr_type != EXPR_VARIABLE)))
10442 : {
10443 6546 : if (!lastslice && lastref && lastref->type == REF_SUBSTRING)
10444 11 : gfc_error ("Unexpected substring reference in %s clause at %L",
10445 : name, &n->where);
10446 6535 : else if (!lastslice && lastref && lastref->type == REF_INQUIRY)
10447 : {
10448 12 : gcc_assert (lastref->u.i == INQUIRY_RE || lastref->u.i == INQUIRY_IM);
10449 12 : gfc_error ("Unexpected complex-parts designator reference in %s "
10450 : "clause at %L", name, &n->where);
10451 : }
10452 6523 : else if (!resolved
10453 6505 : || n->expr->expr_type != EXPR_VARIABLE
10454 6493 : || (lastslice
10455 5615 : && (lastslice->next || lastslice->type != REF_ARRAY)))
10456 46 : gfc_error ("%qs in %s clause at %L is not a proper array section",
10457 46 : n->sym->name, name, &n->where);
10458 : else if (lastslice)
10459 : {
10460 : int i;
10461 : gfc_array_ref *ar = &lastslice->u.ar;
10462 11873 : for (i = 0; i < ar->dimen; i++)
10463 6275 : if (ar->stride[i] && code && code->op != EXEC_OACC_UPDATE)
10464 : {
10465 1 : gfc_error ("Stride should not be specified for array section "
10466 : "in %s clause at %L", name, &n->where);
10467 1 : break;
10468 : }
10469 6274 : else if (ar->dimen_type[i] != DIMEN_ELEMENT
10470 6274 : && ar->dimen_type[i] != DIMEN_RANGE)
10471 : {
10472 0 : gfc_error ("%qs in %s clause at %L is not a proper array "
10473 0 : "section", n->sym->name, name, &n->where);
10474 0 : break;
10475 : }
10476 6274 : else if ((list == OMP_LIST_DEPEND || list == OMP_LIST_AFFINITY)
10477 161 : && ar->start[i]
10478 133 : && ar->start[i]->expr_type == EXPR_CONSTANT
10479 97 : && ar->end[i]
10480 72 : && ar->end[i]->expr_type == EXPR_CONSTANT
10481 72 : && mpz_cmp (ar->start[i]->value.integer,
10482 72 : ar->end[i]->value.integer) > 0)
10483 : {
10484 0 : gfc_error ("%qs in %s clause at %L is a zero size array "
10485 0 : "section", n->sym->name,
10486 : list == OMP_LIST_DEPEND ? "DEPEND" : "AFFINITY",
10487 : &n->where);
10488 0 : break;
10489 : }
10490 : }
10491 : }
10492 13184 : else if (openacc)
10493 : {
10494 5915 : if (list == OMP_LIST_MAP && n->u.map.op == OMP_MAP_FORCE_DEVICEPTR)
10495 65 : resolve_oacc_deviceptr_clause (n->sym, n->where, name);
10496 : else
10497 5850 : resolve_oacc_data_clauses (n->sym, n->where, name);
10498 : }
10499 7269 : else if (list != OMP_LIST_DEPEND
10500 6775 : && n->sym->as
10501 3340 : && n->sym->as->type == AS_ASSUMED_SIZE)
10502 5 : gfc_error ("Assumed size array %qs in %s clause at %L",
10503 : n->sym->name, name, &n->where);
10504 19730 : if (code && list == OMP_LIST_MAP && !openacc)
10505 7442 : switch (code->op)
10506 : {
10507 6161 : case EXEC_OMP_TARGET:
10508 6161 : case EXEC_OMP_TARGET_PARALLEL:
10509 6161 : case EXEC_OMP_TARGET_PARALLEL_DO:
10510 6161 : case EXEC_OMP_TARGET_PARALLEL_DO_SIMD:
10511 6161 : case EXEC_OMP_TARGET_PARALLEL_LOOP:
10512 6161 : case EXEC_OMP_TARGET_SIMD:
10513 6161 : case EXEC_OMP_TARGET_TEAMS:
10514 6161 : case EXEC_OMP_TARGET_TEAMS_DISTRIBUTE:
10515 6161 : case EXEC_OMP_TARGET_TEAMS_DISTRIBUTE_PARALLEL_DO:
10516 6161 : case EXEC_OMP_TARGET_TEAMS_DISTRIBUTE_PARALLEL_DO_SIMD:
10517 6161 : case EXEC_OMP_TARGET_TEAMS_DISTRIBUTE_SIMD:
10518 6161 : case EXEC_OMP_TARGET_TEAMS_LOOP:
10519 6161 : case EXEC_OMP_TARGET_DATA:
10520 6161 : switch (n->u.map.op)
10521 : {
10522 : case OMP_MAP_TO:
10523 : case OMP_MAP_ALWAYS_TO:
10524 : case OMP_MAP_PRESENT_TO:
10525 : case OMP_MAP_ALWAYS_PRESENT_TO:
10526 : case OMP_MAP_FROM:
10527 : case OMP_MAP_ALWAYS_FROM:
10528 : case OMP_MAP_PRESENT_FROM:
10529 : case OMP_MAP_ALWAYS_PRESENT_FROM:
10530 : case OMP_MAP_TOFROM:
10531 : case OMP_MAP_ALWAYS_TOFROM:
10532 : case OMP_MAP_PRESENT_TOFROM:
10533 : case OMP_MAP_ALWAYS_PRESENT_TOFROM:
10534 : case OMP_MAP_ALLOC:
10535 : case OMP_MAP_PRESENT_ALLOC:
10536 : break;
10537 2 : default:
10538 2 : gfc_error ("TARGET%s with map-type other than TO, "
10539 : "FROM, TOFROM, or ALLOC on MAP clause "
10540 : "at %L",
10541 : code->op == EXEC_OMP_TARGET_DATA
10542 : ? " DATA" : "", &n->where);
10543 2 : break;
10544 : }
10545 : break;
10546 701 : case EXEC_OMP_TARGET_ENTER_DATA:
10547 701 : switch (n->u.map.op)
10548 : {
10549 : case OMP_MAP_TO:
10550 : case OMP_MAP_ALWAYS_TO:
10551 : case OMP_MAP_PRESENT_TO:
10552 : case OMP_MAP_ALWAYS_PRESENT_TO:
10553 : case OMP_MAP_ALLOC:
10554 : case OMP_MAP_PRESENT_ALLOC:
10555 : break;
10556 181 : case OMP_MAP_TOFROM:
10557 181 : n->u.map.op = OMP_MAP_TO;
10558 181 : break;
10559 3 : case OMP_MAP_ALWAYS_TOFROM:
10560 3 : n->u.map.op = OMP_MAP_ALWAYS_TO;
10561 3 : break;
10562 2 : case OMP_MAP_PRESENT_TOFROM:
10563 2 : n->u.map.op = OMP_MAP_PRESENT_TO;
10564 2 : break;
10565 2 : case OMP_MAP_ALWAYS_PRESENT_TOFROM:
10566 2 : n->u.map.op = OMP_MAP_ALWAYS_PRESENT_TO;
10567 2 : break;
10568 2 : default:
10569 2 : gfc_error ("TARGET ENTER DATA with map-type other "
10570 : "than TO, TOFROM or ALLOC on MAP clause "
10571 : "at %L", &n->where);
10572 2 : break;
10573 : }
10574 : break;
10575 580 : case EXEC_OMP_TARGET_EXIT_DATA:
10576 580 : switch (n->u.map.op)
10577 : {
10578 : case OMP_MAP_FROM:
10579 : case OMP_MAP_ALWAYS_FROM:
10580 : case OMP_MAP_PRESENT_FROM:
10581 : case OMP_MAP_ALWAYS_PRESENT_FROM:
10582 : case OMP_MAP_RELEASE:
10583 : case OMP_MAP_DELETE:
10584 : break;
10585 134 : case OMP_MAP_TOFROM:
10586 134 : n->u.map.op = OMP_MAP_FROM;
10587 134 : break;
10588 1 : case OMP_MAP_ALWAYS_TOFROM:
10589 1 : n->u.map.op = OMP_MAP_ALWAYS_FROM;
10590 1 : break;
10591 0 : case OMP_MAP_PRESENT_TOFROM:
10592 0 : n->u.map.op = OMP_MAP_PRESENT_FROM;
10593 0 : break;
10594 0 : case OMP_MAP_ALWAYS_PRESENT_TOFROM:
10595 0 : n->u.map.op = OMP_MAP_ALWAYS_PRESENT_FROM;
10596 0 : break;
10597 2 : default:
10598 2 : gfc_error ("TARGET EXIT DATA with map-type other "
10599 : "than FROM, TOFROM, RELEASE, or DELETE on "
10600 : "MAP clause at %L", &n->where);
10601 2 : break;
10602 : }
10603 : break;
10604 : default:
10605 : break;
10606 : }
10607 19730 : if (list == OMP_LIST_MAP || list == OMP_LIST_TO || list == OMP_LIST_FROM)
10608 : {
10609 18863 : gfc_typespec *ts = n->expr ? &n->expr->ts : &n->sym->ts;
10610 :
10611 18863 : if (ts->type == BT_DERIVED || ts->type == BT_CLASS)
10612 : {
10613 10 : const char *mapper_id = (n->u3.udm
10614 1002 : ? n->u3.udm->requested_mapper_id : "");
10615 1002 : gfc_omp_udm *udm = gfc_find_omp_udm (gfc_current_ns, mapper_id, ts);
10616 1002 : if (mapper_id[0] != '\0' && !udm)
10617 1 : gfc_error ("User-defined mapper %qs not found at %L",
10618 : mapper_id, &n->where);
10619 997 : else if (udm)
10620 : {
10621 27 : if (!n->u3.udm)
10622 : {
10623 18 : gcc_assert (mapper_id[0] == '\0');
10624 18 : n->u3.udm = gfc_get_omp_namelist_udm ();
10625 18 : n->u3.udm->requested_mapper_id = mapper_id;
10626 : }
10627 27 : n->u3.udm->resolved_udm = udm;
10628 : }
10629 : }
10630 : }
10631 :
10632 19730 : if (list != OMP_LIST_DEPEND)
10633 : {
10634 18999 : n->sym->attr.referenced = 1;
10635 18999 : if (n->sym->attr.threadprivate)
10636 1 : gfc_error ("THREADPRIVATE object %qs in %s clause at %L",
10637 : n->sym->name, name, &n->where);
10638 18999 : if (n->sym->attr.cray_pointee)
10639 14 : gfc_error ("Cray pointee %qs in %s clause at %L",
10640 : n->sym->name, name, &n->where);
10641 : }
10642 : }
10643 :
10644 : /* OpenMP directive resolving routines. */
10645 :
10646 : static void
10647 33132 : resolve_omp_clauses (gfc_code *code, gfc_omp_clauses *omp_clauses,
10648 : gfc_namespace *ns, bool openacc = false)
10649 : {
10650 33132 : gfc_omp_namelist *n, *last;
10651 33132 : gfc_expr_list *el;
10652 33132 : enum gfc_omp_list_type list;
10653 33132 : int ifc;
10654 33132 : bool if_without_mod = false;
10655 33132 : gfc_omp_linear_op linear_op = OMP_LINEAR_DEFAULT;
10656 33132 : static const char *clause_names[]
10657 : = { "PRIVATE", "FIRSTPRIVATE", "LASTPRIVATE", "COPYPRIVATE", "SHARED",
10658 : "COPYIN", "UNIFORM", "AFFINITY", "ALIGNED", "LINEAR", "DEPEND", "MAP",
10659 : "TO", "FROM", "INCLUSIVE", "EXCLUSIVE",
10660 : "REDUCTION", "REDUCTION" /*inscan*/, "REDUCTION" /*task*/,
10661 : "IN_REDUCTION", "TASK_REDUCTION",
10662 : "DEVICE_RESIDENT", "LINK", "LOCAL", "USE_DEVICE",
10663 : "CACHE", "IS_DEVICE_PTR", "USE_DEVICE_PTR", "USE_DEVICE_ADDR",
10664 : "NONTEMPORAL", "ALLOCATE", "HAS_DEVICE_ADDR", "ENTER",
10665 : "USES_ALLOCATORS", "INIT", "USE", "DESTROY", "INTEROP", "ADJUST_ARGS" };
10666 33132 : STATIC_ASSERT (ARRAY_SIZE (clause_names) == OMP_LIST_NUM);
10667 :
10668 33132 : if (omp_clauses == NULL)
10669 : return;
10670 :
10671 33132 : if (ns == NULL)
10672 32670 : ns = gfc_current_ns;
10673 :
10674 33132 : check_omp_clauses_dupl_syms (code, omp_clauses, openacc);
10675 :
10676 33132 : if (omp_clauses->orderedc && omp_clauses->orderedc < omp_clauses->collapse)
10677 0 : gfc_error ("ORDERED clause parameter is less than COLLAPSE at %L",
10678 : &code->loc);
10679 33132 : if (omp_clauses->order_concurrent && omp_clauses->ordered)
10680 4 : gfc_error ("ORDER clause must not be used together with ORDERED at %L",
10681 : &code->loc);
10682 33132 : if (omp_clauses->if_expr)
10683 : {
10684 1299 : gfc_expr *expr = omp_clauses->if_expr;
10685 1299 : if (!gfc_resolve_expr (expr)
10686 1299 : || expr->ts.type != BT_LOGICAL || expr->rank != 0)
10687 16 : gfc_error ("IF clause at %L requires a scalar LOGICAL expression",
10688 : &expr->where);
10689 : if_without_mod = true;
10690 : }
10691 364452 : for (ifc = 0; ifc < OMP_IF_LAST; ifc++)
10692 331320 : if (omp_clauses->if_exprs[ifc])
10693 : {
10694 141 : gfc_expr *expr = omp_clauses->if_exprs[ifc];
10695 141 : bool ok = true;
10696 141 : if (!gfc_resolve_expr (expr)
10697 141 : || expr->ts.type != BT_LOGICAL || expr->rank != 0)
10698 0 : gfc_error ("IF clause at %L requires a scalar LOGICAL expression",
10699 : &expr->where);
10700 141 : else if (if_without_mod)
10701 : {
10702 1 : gfc_error ("IF clause without modifier at %L used together with "
10703 : "IF clauses with modifiers",
10704 1 : &omp_clauses->if_expr->where);
10705 1 : if_without_mod = false;
10706 : }
10707 : else
10708 140 : switch (code->op)
10709 : {
10710 13 : case EXEC_OMP_CANCEL:
10711 13 : ok = ifc == OMP_IF_CANCEL;
10712 13 : break;
10713 :
10714 16 : case EXEC_OMP_PARALLEL:
10715 16 : case EXEC_OMP_PARALLEL_DO:
10716 16 : case EXEC_OMP_PARALLEL_LOOP:
10717 16 : case EXEC_OMP_PARALLEL_MASKED:
10718 16 : case EXEC_OMP_PARALLEL_MASTER:
10719 16 : case EXEC_OMP_PARALLEL_SECTIONS:
10720 16 : case EXEC_OMP_PARALLEL_WORKSHARE:
10721 16 : case EXEC_OMP_DISTRIBUTE_PARALLEL_DO:
10722 16 : case EXEC_OMP_TEAMS_DISTRIBUTE_PARALLEL_DO:
10723 16 : ok = ifc == OMP_IF_PARALLEL;
10724 16 : break;
10725 :
10726 28 : case EXEC_OMP_PARALLEL_DO_SIMD:
10727 28 : case EXEC_OMP_DISTRIBUTE_PARALLEL_DO_SIMD:
10728 28 : case EXEC_OMP_TEAMS_DISTRIBUTE_PARALLEL_DO_SIMD:
10729 28 : ok = ifc == OMP_IF_PARALLEL || ifc == OMP_IF_SIMD;
10730 28 : break;
10731 :
10732 8 : case EXEC_OMP_PARALLEL_MASKED_TASKLOOP:
10733 8 : case EXEC_OMP_PARALLEL_MASTER_TASKLOOP:
10734 8 : ok = ifc == OMP_IF_PARALLEL || ifc == OMP_IF_TASKLOOP;
10735 8 : break;
10736 :
10737 12 : case EXEC_OMP_PARALLEL_MASKED_TASKLOOP_SIMD:
10738 12 : case EXEC_OMP_PARALLEL_MASTER_TASKLOOP_SIMD:
10739 12 : ok = (ifc == OMP_IF_PARALLEL
10740 12 : || ifc == OMP_IF_TASKLOOP
10741 : || ifc == OMP_IF_SIMD);
10742 : break;
10743 :
10744 0 : case EXEC_OMP_SIMD:
10745 0 : case EXEC_OMP_DO_SIMD:
10746 0 : case EXEC_OMP_DISTRIBUTE_SIMD:
10747 0 : case EXEC_OMP_TEAMS_DISTRIBUTE_SIMD:
10748 0 : ok = ifc == OMP_IF_SIMD;
10749 0 : break;
10750 :
10751 1 : case EXEC_OMP_TASK:
10752 1 : ok = ifc == OMP_IF_TASK;
10753 1 : break;
10754 :
10755 5 : case EXEC_OMP_TASKLOOP:
10756 5 : case EXEC_OMP_MASKED_TASKLOOP:
10757 5 : case EXEC_OMP_MASTER_TASKLOOP:
10758 5 : ok = ifc == OMP_IF_TASKLOOP;
10759 5 : break;
10760 :
10761 20 : case EXEC_OMP_TASKLOOP_SIMD:
10762 20 : case EXEC_OMP_MASKED_TASKLOOP_SIMD:
10763 20 : case EXEC_OMP_MASTER_TASKLOOP_SIMD:
10764 20 : ok = ifc == OMP_IF_TASKLOOP || ifc == OMP_IF_SIMD;
10765 20 : break;
10766 :
10767 5 : case EXEC_OMP_TARGET:
10768 5 : case EXEC_OMP_TARGET_TEAMS:
10769 5 : case EXEC_OMP_TARGET_TEAMS_DISTRIBUTE:
10770 5 : case EXEC_OMP_TARGET_TEAMS_LOOP:
10771 5 : ok = ifc == OMP_IF_TARGET;
10772 5 : break;
10773 :
10774 4 : case EXEC_OMP_TARGET_TEAMS_DISTRIBUTE_SIMD:
10775 4 : case EXEC_OMP_TARGET_SIMD:
10776 4 : ok = ifc == OMP_IF_TARGET || ifc == OMP_IF_SIMD;
10777 4 : break;
10778 :
10779 2 : case EXEC_OMP_TARGET_DATA:
10780 2 : ok = ifc == OMP_IF_TARGET_DATA;
10781 2 : break;
10782 :
10783 2 : case EXEC_OMP_TARGET_UPDATE:
10784 2 : ok = ifc == OMP_IF_TARGET_UPDATE;
10785 2 : break;
10786 :
10787 2 : case EXEC_OMP_TARGET_ENTER_DATA:
10788 2 : ok = ifc == OMP_IF_TARGET_ENTER_DATA;
10789 2 : break;
10790 :
10791 2 : case EXEC_OMP_TARGET_EXIT_DATA:
10792 2 : ok = ifc == OMP_IF_TARGET_EXIT_DATA;
10793 2 : break;
10794 :
10795 10 : case EXEC_OMP_TARGET_TEAMS_DISTRIBUTE_PARALLEL_DO:
10796 10 : case EXEC_OMP_TARGET_PARALLEL:
10797 10 : case EXEC_OMP_TARGET_PARALLEL_DO:
10798 10 : case EXEC_OMP_TARGET_PARALLEL_LOOP:
10799 10 : ok = ifc == OMP_IF_TARGET || ifc == OMP_IF_PARALLEL;
10800 10 : break;
10801 :
10802 10 : case EXEC_OMP_TARGET_PARALLEL_DO_SIMD:
10803 10 : case EXEC_OMP_TARGET_TEAMS_DISTRIBUTE_PARALLEL_DO_SIMD:
10804 10 : ok = (ifc == OMP_IF_TARGET
10805 10 : || ifc == OMP_IF_PARALLEL
10806 : || ifc == OMP_IF_SIMD);
10807 : break;
10808 :
10809 : default:
10810 : ok = false;
10811 : break;
10812 : }
10813 119 : if (!ok)
10814 : {
10815 2 : static const char *ifs[] = {
10816 : "CANCEL",
10817 : "PARALLEL",
10818 : "SIMD",
10819 : "TASK",
10820 : "TASKLOOP",
10821 : "TARGET",
10822 : "TARGET DATA",
10823 : "TARGET UPDATE",
10824 : "TARGET ENTER DATA",
10825 : "TARGET EXIT DATA"
10826 : };
10827 2 : gfc_error ("IF clause modifier %s at %L not appropriate for "
10828 : "the current OpenMP construct", ifs[ifc], &expr->where);
10829 : }
10830 : }
10831 :
10832 33132 : if (omp_clauses->self_expr)
10833 : {
10834 177 : gfc_expr *expr = omp_clauses->self_expr;
10835 177 : if (!gfc_resolve_expr (expr)
10836 177 : || expr->ts.type != BT_LOGICAL || expr->rank != 0)
10837 6 : gfc_error ("SELF clause at %L requires a scalar LOGICAL expression",
10838 : &expr->where);
10839 : }
10840 :
10841 33132 : if (omp_clauses->final_expr)
10842 : {
10843 64 : gfc_expr *expr = omp_clauses->final_expr;
10844 64 : if (!gfc_resolve_expr (expr)
10845 64 : || expr->ts.type != BT_LOGICAL || expr->rank != 0)
10846 0 : gfc_error ("FINAL clause at %L requires a scalar LOGICAL expression",
10847 : &expr->where);
10848 : }
10849 33132 : if (omp_clauses->novariants)
10850 : {
10851 9 : gfc_expr *expr = omp_clauses->novariants;
10852 18 : if (!gfc_resolve_expr (expr) || expr->ts.type != BT_LOGICAL
10853 17 : || expr->rank != 0)
10854 1 : gfc_error (
10855 : "NOVARIANTS clause at %L requires a scalar LOGICAL expression",
10856 : &expr->where);
10857 33132 : if_without_mod = true;
10858 : }
10859 33132 : if (omp_clauses->nocontext)
10860 : {
10861 12 : gfc_expr *expr = omp_clauses->nocontext;
10862 24 : if (!gfc_resolve_expr (expr) || expr->ts.type != BT_LOGICAL
10863 23 : || expr->rank != 0)
10864 1 : gfc_error (
10865 : "NOCONTEXT clause at %L requires a scalar LOGICAL expression",
10866 : &expr->where);
10867 33132 : if_without_mod = true;
10868 : }
10869 :
10870 34148 : for (el = omp_clauses->num_threads_list; el; el = el->next)
10871 1016 : resolve_positive_int_expr (el->expr, "NUM_THREADS");
10872 :
10873 33132 : if (omp_clauses->dyn_groupprivate)
10874 10 : resolve_nonnegative_int_expr (omp_clauses->dyn_groupprivate,
10875 : "DYN_GROUPPRIVATE");
10876 33132 : if (omp_clauses->chunk_size)
10877 : {
10878 510 : gfc_expr *expr = omp_clauses->chunk_size;
10879 510 : if (!gfc_resolve_expr (expr)
10880 510 : || expr->ts.type != BT_INTEGER || expr->rank != 0)
10881 0 : gfc_error ("SCHEDULE clause's chunk_size at %L requires "
10882 : "a scalar INTEGER expression", &expr->where);
10883 510 : else if (expr->expr_type == EXPR_CONSTANT
10884 : && expr->ts.type == BT_INTEGER
10885 485 : && mpz_sgn (expr->value.integer) <= 0)
10886 2 : gfc_warning (OPT_Wopenmp, "INTEGER expression of SCHEDULE clause's "
10887 : "chunk_size at %L must be positive", &expr->where);
10888 : }
10889 33132 : if (omp_clauses->sched_kind != OMP_SCHED_NONE
10890 891 : && omp_clauses->sched_nonmonotonic)
10891 : {
10892 34 : if (omp_clauses->sched_monotonic)
10893 2 : gfc_error ("Both MONOTONIC and NONMONOTONIC schedule modifiers "
10894 : "specified at %L", &code->loc);
10895 32 : else if (omp_clauses->ordered)
10896 4 : gfc_error ("NONMONOTONIC schedule modifier specified with ORDERED "
10897 : "clause at %L", &code->loc);
10898 : }
10899 :
10900 33132 : if (omp_clauses->depobj
10901 33132 : && (!gfc_resolve_expr (omp_clauses->depobj)
10902 118 : || omp_clauses->depobj->ts.type != BT_INTEGER
10903 117 : || omp_clauses->depobj->ts.kind != 2 * gfc_index_integer_kind
10904 116 : || omp_clauses->depobj->rank != 0))
10905 4 : gfc_error ("DEPOBJ in DEPOBJ construct at %L shall be a scalar integer "
10906 4 : "of OMP_DEPEND_KIND kind", &omp_clauses->depobj->where);
10907 :
10908 : /* Check that list items are variables. */
10909 1325280 : for (list = OMP_LIST_FIRST; list < OMP_LIST_NUM;
10910 1292148 : list = gfc_omp_list_type (list + 1))
10911 1338028 : for (n = omp_clauses->lists[list]; n; n = n->next)
10912 : {
10913 45880 : if (!n->sym) /* omp_all_memory. */
10914 47 : continue;
10915 45833 : if (n->sym->attr.flavor == FL_VARIABLE
10916 277 : || n->sym->attr.proc_pointer
10917 236 : || (!code
10918 0 : && !ns->omp_udm_ns
10919 0 : && (!n->sym->attr.dummy || n->sym->ns != ns)))
10920 : {
10921 45597 : if (!code
10922 322 : && !ns->omp_udm_ns
10923 277 : && (!n->sym->attr.dummy || n->sym->ns != ns))
10924 0 : gfc_error ("Variable %qs is not a dummy argument at %L",
10925 : n->sym->name, &n->where);
10926 45597 : continue;
10927 : }
10928 236 : if (n->sym->attr.flavor == FL_PROCEDURE
10929 153 : && n->sym->result == n->sym
10930 138 : && n->sym->attr.function)
10931 : {
10932 138 : if (ns->proc_name == n->sym
10933 44 : || (ns->parent && ns->parent->proc_name == n->sym))
10934 101 : continue;
10935 37 : if (ns->proc_name->attr.entry_master)
10936 : {
10937 32 : gfc_entry_list *el = ns->entries;
10938 51 : for (; el; el = el->next)
10939 51 : if (el->sym == n->sym)
10940 : break;
10941 32 : if (el)
10942 32 : continue;
10943 : }
10944 5 : if (ns->parent
10945 3 : && ns->parent->proc_name->attr.entry_master)
10946 : {
10947 2 : gfc_entry_list *el = ns->parent->entries;
10948 3 : for (; el; el = el->next)
10949 3 : if (el->sym == n->sym)
10950 : break;
10951 2 : if (el)
10952 2 : continue;
10953 : }
10954 : }
10955 101 : if (list == OMP_LIST_MAP
10956 18 : && n->sym->attr.flavor == FL_PARAMETER)
10957 : {
10958 : /* OpenACC since 3.4 permits for Fortran named constants, but
10959 : permits removing then as optimization is not needed and such
10960 : ignore them. Likewise below for FIRSTPRIVATE. */
10961 12 : if (openacc)
10962 10 : gfc_warning (OPT_Wsurprising, "Clause for object %qs at %L is "
10963 : "ignored as parameters need not be copied",
10964 : n->sym->name, &n->where);
10965 : else
10966 2 : gfc_error ("Object %qs is not a variable at %L; parameters"
10967 : " cannot be and need not be mapped", n->sym->name,
10968 : &n->where);
10969 : }
10970 89 : else if (openacc && n->sym->attr.flavor == FL_PARAMETER)
10971 9 : gfc_warning (OPT_Wsurprising, "Clause for object %qs at %L is ignored"
10972 : " as it is a parameter", n->sym->name, &n->where);
10973 80 : else if (list != OMP_LIST_USES_ALLOCATORS)
10974 30 : gfc_error ("Object %qs is not a variable at %L", n->sym->name,
10975 : &n->where);
10976 : }
10977 :
10978 33132 : if (omp_clauses->lists[OMP_LIST_REDUCTION_INSCAN])
10979 : {
10980 69 : locus *loc = &omp_clauses->lists[OMP_LIST_REDUCTION_INSCAN]->where;
10981 69 : if (code->op != EXEC_OMP_DO
10982 : && code->op != EXEC_OMP_SIMD
10983 : && code->op != EXEC_OMP_DO_SIMD
10984 : && code->op != EXEC_OMP_PARALLEL_DO
10985 : && code->op != EXEC_OMP_PARALLEL_DO_SIMD)
10986 23 : gfc_error ("%<inscan%> REDUCTION clause on construct other than DO, "
10987 : "SIMD, DO SIMD, PARALLEL DO, PARALLEL DO SIMD at %L",
10988 : loc);
10989 69 : if (omp_clauses->ordered)
10990 2 : gfc_error ("ORDERED clause specified together with %<inscan%> "
10991 : "REDUCTION clause at %L", loc);
10992 69 : if (omp_clauses->sched_kind != OMP_SCHED_NONE)
10993 3 : gfc_error ("SCHEDULE clause specified together with %<inscan%> "
10994 : "REDUCTION clause at %L", loc);
10995 : }
10996 :
10997 33132 : if (code
10998 32873 : && code->op == EXEC_OMP_INTEROP
10999 63 : && omp_clauses->lists[OMP_LIST_DEPEND])
11000 : {
11001 12 : if (!omp_clauses->lists[OMP_LIST_INIT]
11002 5 : && !omp_clauses->lists[OMP_LIST_USE]
11003 1 : && !omp_clauses->lists[OMP_LIST_DESTROY])
11004 : {
11005 1 : gfc_error ("DEPEND clause at %L requires action clause with "
11006 : "%<targetsync%> interop-type",
11007 : &omp_clauses->lists[OMP_LIST_DEPEND]->where);
11008 : }
11009 22 : for (n = omp_clauses->lists[OMP_LIST_INIT]; n; n = n->next)
11010 12 : if (!n->u.init.targetsync)
11011 : {
11012 2 : gfc_error ("DEPEND clause at %L requires %<targetsync%> "
11013 : "interop-type, lacking it for %qs at %L",
11014 2 : &omp_clauses->lists[OMP_LIST_DEPEND]->where,
11015 2 : n->sym->name, &n->where);
11016 2 : break;
11017 : }
11018 : }
11019 32873 : if (code && (code->op == EXEC_OMP_INTEROP || code->op == EXEC_OMP_DISPATCH))
11020 1085 : for (list = OMP_LIST_INIT; list <= OMP_LIST_INTEROP;
11021 868 : list = gfc_omp_list_type (list + 1))
11022 1123 : for (n = omp_clauses->lists[list]; n; n = n->next)
11023 : {
11024 255 : if (n->sym->ts.type != BT_INTEGER
11025 252 : || n->sym->ts.kind != gfc_index_integer_kind
11026 248 : || n->sym->attr.dimension
11027 243 : || n->sym->attr.flavor != FL_VARIABLE)
11028 16 : gfc_error ("%qs at %L in %qs clause must be a scalar integer "
11029 : "variable of %<omp_interop_kind%> kind", n->sym->name,
11030 : &n->where, clause_names[list]);
11031 255 : if (list != OMP_LIST_USE && list != OMP_LIST_INTEROP
11032 109 : && n->sym->attr.intent == INTENT_IN)
11033 2 : gfc_error ("%qs at %L in %qs clause must be definable",
11034 : n->sym->name, &n->where, clause_names[list]);
11035 : }
11036 :
11037 33132 : resolve_omp_allocate_clauses (code, omp_clauses, ns);
11038 :
11039 33132 : bool has_inscan = false, has_notinscan = false;
11040 1358412 : for (enum gfc_omp_list_type list = OMP_LIST_FIRST; list < OMP_LIST_NUM;
11041 1292148 : list = gfc_omp_list_type (list + 1))
11042 1292148 : if ((n = omp_clauses->lists[list]) != NULL)
11043 : {
11044 29338 : const char *name = clause_names[list];
11045 :
11046 29338 : switch (list)
11047 : {
11048 : case OMP_LIST_COPYIN:
11049 267 : for (; n != NULL; n = n->next)
11050 : {
11051 170 : if (!n->sym->attr.threadprivate)
11052 0 : gfc_error ("Non-THREADPRIVATE object %qs in COPYIN clause"
11053 : " at %L", n->sym->name, &n->where);
11054 : }
11055 : break;
11056 83 : case OMP_LIST_COPYPRIVATE:
11057 83 : if (omp_clauses->nowait)
11058 6 : gfc_error ("NOWAIT clause must not be used with COPYPRIVATE "
11059 : "clause at %L", &n->where);
11060 376 : for (; n != NULL; n = n->next)
11061 : {
11062 293 : if (n->sym->as && n->sym->as->type == AS_ASSUMED_SIZE)
11063 0 : gfc_error ("Assumed size array %qs in COPYPRIVATE clause "
11064 : "at %L", n->sym->name, &n->where);
11065 293 : if (n->sym->attr.pointer && n->sym->attr.intent == INTENT_IN)
11066 1 : gfc_error ("INTENT(IN) POINTER %qs in COPYPRIVATE clause "
11067 : "at %L", n->sym->name, &n->where);
11068 : }
11069 : break;
11070 : case OMP_LIST_SHARED:
11071 2604 : for (; n != NULL; n = n->next)
11072 : {
11073 1642 : if (n->sym->attr.threadprivate)
11074 0 : gfc_error ("THREADPRIVATE object %qs in SHARED clause at "
11075 : "%L", n->sym->name, &n->where);
11076 1642 : if (n->sym->attr.cray_pointee)
11077 1 : gfc_error ("Cray pointee %qs in SHARED clause at %L",
11078 : n->sym->name, &n->where);
11079 1642 : if (n->sym->attr.associate_var)
11080 8 : gfc_error ("Associate name %qs in SHARED clause at %L",
11081 8 : n->sym->attr.select_type_temporary
11082 4 : ? n->sym->assoc->target->symtree->n.sym->name
11083 : : n->sym->name, &n->where);
11084 1642 : if (omp_clauses->detach
11085 1 : && n->sym == omp_clauses->detach->symtree->n.sym)
11086 1 : gfc_error ("DETACH event handle %qs in SHARED clause at %L",
11087 : n->sym->name, &n->where);
11088 : }
11089 : break;
11090 : case OMP_LIST_ALIGNED:
11091 256 : for (; n != NULL; n = n->next)
11092 : {
11093 150 : if (!n->sym->attr.pointer
11094 45 : && !n->sym->attr.allocatable
11095 30 : && !n->sym->attr.cray_pointer
11096 18 : && (n->sym->ts.type != BT_DERIVED
11097 18 : || (n->sym->ts.u.derived->from_intmod
11098 : != INTMOD_ISO_C_BINDING)
11099 18 : || (n->sym->ts.u.derived->intmod_sym_id
11100 : != ISOCBINDING_PTR)))
11101 0 : gfc_error ("%qs in ALIGNED clause must be POINTER, "
11102 : "ALLOCATABLE, Cray pointer or C_PTR at %L",
11103 : n->sym->name, &n->where);
11104 150 : else if (n->expr)
11105 : {
11106 147 : if (!gfc_resolve_expr (n->expr)
11107 147 : || n->expr->ts.type != BT_INTEGER
11108 146 : || n->expr->rank != 0
11109 146 : || n->expr->expr_type != EXPR_CONSTANT
11110 292 : || mpz_sgn (n->expr->value.integer) <= 0)
11111 4 : gfc_error ("%qs in ALIGNED clause at %L requires a scalar"
11112 : " positive constant integer alignment "
11113 4 : "expression", n->sym->name, &n->where);
11114 : }
11115 : }
11116 : break;
11117 : case OMP_LIST_AFFINITY:
11118 : case OMP_LIST_DEPEND:
11119 : case OMP_LIST_MAP:
11120 : case OMP_LIST_TO:
11121 : case OMP_LIST_FROM:
11122 : case OMP_LIST_CACHE:
11123 33236 : for (; n != NULL; n = n->next)
11124 20963 : resolve_omp_clauses_aff_dep_map_cache (code, n, name, list,
11125 : omp_clauses, openacc);
11126 : break;
11127 : case OMP_LIST_IS_DEVICE_PTR:
11128 : last = NULL;
11129 377 : for (n = omp_clauses->lists[list]; n != NULL; )
11130 : {
11131 257 : if ((n->sym->ts.type != BT_DERIVED
11132 71 : || !n->sym->ts.u.derived->ts.is_iso_c
11133 71 : || (n->sym->ts.u.derived->intmod_sym_id
11134 : != ISOCBINDING_PTR))
11135 187 : && code->op == EXEC_OMP_DISPATCH)
11136 : /* Non-TARGET (i.e. DISPATCH) requires a C_PTR. */
11137 3 : gfc_error ("List item %qs in %s clause at %L must be of "
11138 : "TYPE(C_PTR)", n->sym->name, name, &n->where);
11139 254 : else if (n->sym->ts.type != BT_DERIVED
11140 70 : || !n->sym->ts.u.derived->ts.is_iso_c
11141 70 : || (n->sym->ts.u.derived->intmod_sym_id
11142 : != ISOCBINDING_PTR))
11143 : {
11144 : /* For TARGET, non-C_PTR are deprecated and handled as
11145 : has_device_addr. */
11146 184 : gfc_warning (OPT_Wdeprecated_openmp,
11147 : "Non-C_PTR type argument at %L is deprecated, "
11148 : "use HAS_DEVICE_ADDR", &n->where);
11149 184 : gfc_omp_namelist *n2 = n;
11150 184 : n = n->next;
11151 184 : if (last)
11152 0 : last->next = n;
11153 : else
11154 184 : omp_clauses->lists[list] = n;
11155 184 : n2->next = omp_clauses->lists[OMP_LIST_HAS_DEVICE_ADDR];
11156 184 : omp_clauses->lists[OMP_LIST_HAS_DEVICE_ADDR] = n2;
11157 184 : continue;
11158 184 : }
11159 73 : last = n;
11160 73 : n = n->next;
11161 : }
11162 : break;
11163 : case OMP_LIST_HAS_DEVICE_ADDR:
11164 : case OMP_LIST_USE_DEVICE_ADDR:
11165 : break;
11166 : case OMP_LIST_USE_DEVICE_PTR:
11167 : /* Non-C_PTR are deprecated and handled as use_device_ADDR. */
11168 : last = NULL;
11169 475 : for (n = omp_clauses->lists[list]; n != NULL; )
11170 : {
11171 312 : gfc_omp_namelist *n2 = n;
11172 312 : if (n->sym->ts.type != BT_DERIVED
11173 18 : || !n->sym->ts.u.derived->ts.is_iso_c)
11174 : {
11175 294 : gfc_warning (OPT_Wdeprecated_openmp,
11176 : "Non-C_PTR type argument at %L is "
11177 : "deprecated, use USE_DEVICE_ADDR", &n->where);
11178 294 : n = n->next;
11179 294 : if (last)
11180 0 : last->next = n;
11181 : else
11182 294 : omp_clauses->lists[list] = n;
11183 294 : n2->next = omp_clauses->lists[OMP_LIST_USE_DEVICE_ADDR];
11184 294 : omp_clauses->lists[OMP_LIST_USE_DEVICE_ADDR] = n2;
11185 294 : continue;
11186 : }
11187 18 : last = n;
11188 18 : n = n->next;
11189 : }
11190 : break;
11191 65 : case OMP_LIST_USES_ALLOCATORS:
11192 65 : {
11193 65 : if (n != NULL
11194 65 : && n->u.memspace_sym
11195 20 : && (n->u.memspace_sym->attr.flavor != FL_PARAMETER
11196 18 : || n->u.memspace_sym->ts.type != BT_INTEGER
11197 18 : || n->u.memspace_sym->ts.kind != gfc_c_intptr_kind
11198 18 : || n->u.memspace_sym->attr.dimension
11199 18 : || (!startswith (n->u.memspace_sym->name, "omp_")
11200 0 : && !startswith (n->u.memspace_sym->name, "ompx_"))
11201 18 : || !endswith (n->u.memspace_sym->name, "_mem_space")))
11202 3 : gfc_error ("Memspace %qs at %L in USES_ALLOCATORS must be "
11203 : "a predefined memory space",
11204 : n->u.memspace_sym->name, &n->where);
11205 180 : for (; n != NULL; n = n->next)
11206 : {
11207 122 : if (n->sym->ts.type != BT_INTEGER
11208 121 : || n->sym->ts.kind != gfc_c_intptr_kind
11209 120 : || n->sym->attr.dimension)
11210 3 : gfc_error ("Allocator %qs at %L in USES_ALLOCATORS must "
11211 : "be a scalar integer of kind "
11212 : "%<omp_allocator_handle_kind%>", n->sym->name,
11213 : &n->where);
11214 119 : else if (n->sym->attr.flavor != FL_VARIABLE
11215 50 : && strcmp (n->sym->name, "omp_null_allocator") != 0
11216 165 : && ((!startswith (n->sym->name, "omp_")
11217 1 : && !startswith (n->sym->name, "ompx_"))
11218 45 : || !endswith (n->sym->name, "_mem_alloc")))
11219 2 : gfc_error ("Allocator %qs at %L in USES_ALLOCATORS must "
11220 : "either a variable or a predefined allocator",
11221 : n->sym->name, &n->where);
11222 117 : else if ((n->u.memspace_sym || n->u2.traits_sym)
11223 61 : && n->sym->attr.flavor != FL_VARIABLE)
11224 3 : gfc_error ("A memory space or traits array may not be "
11225 : "specified for predefined allocator %qs at %L",
11226 : n->sym->name, &n->where);
11227 122 : if (n->u2.traits_sym
11228 50 : && (n->u2.traits_sym->attr.flavor != FL_PARAMETER
11229 47 : || !n->u2.traits_sym->attr.dimension
11230 45 : || n->u2.traits_sym->as->rank != 1
11231 45 : || n->u2.traits_sym->ts.type != BT_DERIVED
11232 43 : || strcmp (n->u2.traits_sym->ts.u.derived->name,
11233 : "omp_alloctrait") != 0))
11234 : {
11235 7 : gfc_error ("Traits array %qs in USES_ALLOCATORS %L must "
11236 : "be a one-dimensional named constant array of "
11237 : "type %<omp_alloctrait%>",
11238 : n->u2.traits_sym->name, &n->where);
11239 7 : break;
11240 : }
11241 : }
11242 : break;
11243 : }
11244 : default:
11245 34818 : for (; n != NULL; n = n->next)
11246 : {
11247 20404 : if (n->sym == NULL)
11248 : {
11249 26 : gcc_assert (code->op == EXEC_OMP_ALLOCATORS
11250 : || code->op == EXEC_OMP_ALLOCATE);
11251 26 : continue;
11252 : }
11253 20378 : bool bad = false;
11254 20378 : bool is_reduction = (list == OMP_LIST_REDUCTION
11255 : || list == OMP_LIST_REDUCTION_INSCAN
11256 : || list == OMP_LIST_REDUCTION_TASK
11257 : || list == OMP_LIST_IN_REDUCTION
11258 20378 : || list == OMP_LIST_TASK_REDUCTION);
11259 20378 : if (list == OMP_LIST_REDUCTION_INSCAN)
11260 : has_inscan = true;
11261 20306 : else if (is_reduction)
11262 4738 : has_notinscan = true;
11263 20378 : if (has_inscan && has_notinscan && is_reduction)
11264 : {
11265 3 : gfc_error ("%<inscan%> and non-%<inscan%> %<reduction%> "
11266 : "clauses on the same construct at %L",
11267 : &n->where);
11268 3 : break;
11269 : }
11270 20375 : if (n->sym->attr.threadprivate)
11271 1 : gfc_error ("THREADPRIVATE object %qs in %s clause at %L",
11272 : n->sym->name, name, &n->where);
11273 20375 : if (n->sym->attr.cray_pointee)
11274 14 : gfc_error ("Cray pointee %qs in %s clause at %L",
11275 : n->sym->name, name, &n->where);
11276 20375 : if (n->sym->attr.associate_var)
11277 22 : gfc_error ("Associate name %qs in %s clause at %L",
11278 22 : n->sym->attr.select_type_temporary
11279 4 : ? n->sym->assoc->target->symtree->n.sym->name
11280 : : n->sym->name, name, &n->where);
11281 20375 : if (list != OMP_LIST_PRIVATE && is_reduction)
11282 : {
11283 4807 : if (n->sym->attr.proc_pointer)
11284 1 : gfc_error ("Procedure pointer %qs in %s clause at %L",
11285 : n->sym->name, name, &n->where);
11286 4807 : if (n->sym->attr.pointer)
11287 3 : gfc_error ("POINTER object %qs in %s clause at %L",
11288 : n->sym->name, name, &n->where);
11289 4807 : if (n->sym->attr.cray_pointer)
11290 5 : gfc_error ("Cray pointer %qs in %s clause at %L",
11291 : n->sym->name, name, &n->where);
11292 : }
11293 20375 : if (code
11294 20375 : && (oacc_is_loop (code)
11295 : || code->op == EXEC_OACC_PARALLEL
11296 : || code->op == EXEC_OACC_SERIAL))
11297 8741 : check_array_not_assumed (n->sym, n->where, name);
11298 11634 : else if (list != OMP_LIST_UNIFORM
11299 11517 : && n->sym->as && n->sym->as->type == AS_ASSUMED_SIZE)
11300 2 : gfc_error ("Assumed size array %qs in %s clause at %L",
11301 : n->sym->name, name, &n->where);
11302 20375 : if (n->sym->attr.in_namelist && !is_reduction)
11303 0 : gfc_error ("Variable %qs in %s clause is used in "
11304 : "NAMELIST statement at %L",
11305 : n->sym->name, name, &n->where);
11306 20375 : if (n->sym->attr.pointer && n->sym->attr.intent == INTENT_IN)
11307 3 : switch (list)
11308 : {
11309 3 : case OMP_LIST_PRIVATE:
11310 3 : case OMP_LIST_LASTPRIVATE:
11311 3 : case OMP_LIST_LINEAR:
11312 : /* case OMP_LIST_REDUCTION: */
11313 3 : gfc_error ("INTENT(IN) POINTER %qs in %s clause at %L",
11314 : n->sym->name, name, &n->where);
11315 3 : break;
11316 : default:
11317 : break;
11318 : }
11319 20375 : if (omp_clauses->detach
11320 3 : && (list == OMP_LIST_PRIVATE
11321 : || list == OMP_LIST_FIRSTPRIVATE
11322 : || list == OMP_LIST_LASTPRIVATE)
11323 3 : && n->sym == omp_clauses->detach->symtree->n.sym)
11324 1 : gfc_error ("DETACH event handle %qs in %s clause at %L",
11325 : n->sym->name, name, &n->where);
11326 :
11327 20375 : if (!openacc
11328 20375 : && (list == OMP_LIST_PRIVATE
11329 20375 : || list == OMP_LIST_FIRSTPRIVATE)
11330 4714 : && ((n->sym->ts.type == BT_DERIVED
11331 158 : && n->sym->ts.u.derived->attr.alloc_comp)
11332 4604 : || n->sym->ts.type == BT_CLASS))
11333 170 : switch (code->op)
11334 : {
11335 8 : case EXEC_OMP_TARGET:
11336 8 : case EXEC_OMP_TARGET_PARALLEL:
11337 8 : case EXEC_OMP_TARGET_PARALLEL_DO:
11338 8 : case EXEC_OMP_TARGET_PARALLEL_DO_SIMD:
11339 8 : case EXEC_OMP_TARGET_PARALLEL_LOOP:
11340 8 : case EXEC_OMP_TARGET_SIMD:
11341 8 : case EXEC_OMP_TARGET_TEAMS:
11342 8 : case EXEC_OMP_TARGET_TEAMS_DISTRIBUTE:
11343 8 : case EXEC_OMP_TARGET_TEAMS_DISTRIBUTE_PARALLEL_DO:
11344 8 : case EXEC_OMP_TARGET_TEAMS_DISTRIBUTE_PARALLEL_DO_SIMD:
11345 8 : case EXEC_OMP_TARGET_TEAMS_DISTRIBUTE_SIMD:
11346 8 : case EXEC_OMP_TARGET_TEAMS_LOOP:
11347 8 : if (n->sym->ts.type == BT_DERIVED
11348 2 : && n->sym->ts.u.derived->attr.alloc_comp)
11349 3 : gfc_error ("Sorry, list item %qs at %L with allocatable"
11350 : " components is not yet supported in %s "
11351 : "clause", n->sym->name, &n->where,
11352 : list == OMP_LIST_PRIVATE ? "PRIVATE"
11353 : : "FIRSTPRIVATE");
11354 : else
11355 9 : gfc_error ("Polymorphic list item %qs at %L in %s "
11356 : "clause has unspecified behavior and "
11357 : "unsupported", n->sym->name, &n->where,
11358 : list == OMP_LIST_PRIVATE ? "PRIVATE"
11359 : : "FIRSTPRIVATE");
11360 : break;
11361 : default:
11362 : break;
11363 : }
11364 :
11365 20375 : switch (list)
11366 : {
11367 104 : case OMP_LIST_REDUCTION_TASK:
11368 104 : if (code
11369 104 : && (code->op == EXEC_OMP_LOOP
11370 : || code->op == EXEC_OMP_TASKLOOP
11371 : || code->op == EXEC_OMP_TASKLOOP_SIMD
11372 : || code->op == EXEC_OMP_MASKED_TASKLOOP
11373 : || code->op == EXEC_OMP_MASKED_TASKLOOP_SIMD
11374 : || code->op == EXEC_OMP_MASTER_TASKLOOP
11375 : || code->op == EXEC_OMP_MASTER_TASKLOOP_SIMD
11376 : || code->op == EXEC_OMP_PARALLEL_LOOP
11377 : || code->op == EXEC_OMP_PARALLEL_MASKED_TASKLOOP
11378 : || code->op == EXEC_OMP_PARALLEL_MASKED_TASKLOOP_SIMD
11379 : || code->op == EXEC_OMP_PARALLEL_MASTER_TASKLOOP
11380 : || code->op == EXEC_OMP_PARALLEL_MASTER_TASKLOOP_SIMD
11381 : || code->op == EXEC_OMP_TARGET_PARALLEL_LOOP
11382 : || code->op == EXEC_OMP_TARGET_TEAMS_LOOP
11383 : || code->op == EXEC_OMP_TEAMS
11384 : || code->op == EXEC_OMP_TEAMS_DISTRIBUTE
11385 : || code->op == EXEC_OMP_TEAMS_LOOP))
11386 : {
11387 17 : gfc_error ("Only DEFAULT permitted as reduction-"
11388 : "modifier in REDUCTION clause at %L",
11389 : &n->where);
11390 17 : break;
11391 : }
11392 4790 : gcc_fallthrough ();
11393 4790 : case OMP_LIST_REDUCTION:
11394 4790 : case OMP_LIST_IN_REDUCTION:
11395 4790 : case OMP_LIST_TASK_REDUCTION:
11396 4790 : case OMP_LIST_REDUCTION_INSCAN:
11397 4790 : switch (n->u.reduction_op)
11398 : {
11399 2655 : case OMP_REDUCTION_PLUS:
11400 2655 : case OMP_REDUCTION_TIMES:
11401 2655 : case OMP_REDUCTION_MINUS:
11402 2655 : if (!gfc_numeric_ts (&n->sym->ts))
11403 : bad = true;
11404 : break;
11405 1112 : case OMP_REDUCTION_AND:
11406 1112 : case OMP_REDUCTION_OR:
11407 1112 : case OMP_REDUCTION_EQV:
11408 1112 : case OMP_REDUCTION_NEQV:
11409 1112 : if (n->sym->ts.type != BT_LOGICAL)
11410 : bad = true;
11411 : break;
11412 480 : case OMP_REDUCTION_MAX:
11413 480 : case OMP_REDUCTION_MIN:
11414 480 : if (n->sym->ts.type != BT_INTEGER
11415 212 : && n->sym->ts.type != BT_REAL)
11416 : bad = true;
11417 : break;
11418 192 : case OMP_REDUCTION_IAND:
11419 192 : case OMP_REDUCTION_IOR:
11420 192 : case OMP_REDUCTION_IEOR:
11421 192 : if (n->sym->ts.type != BT_INTEGER)
11422 : bad = true;
11423 : break;
11424 : case OMP_REDUCTION_USER:
11425 : bad = true;
11426 : break;
11427 : default:
11428 : break;
11429 : }
11430 : if (!bad)
11431 4215 : n->u2.udr = NULL;
11432 : else
11433 : {
11434 575 : const char *udr_name = NULL;
11435 575 : if (n->u2.udr)
11436 : {
11437 471 : udr_name = n->u2.udr->udr->name;
11438 471 : n->u2.udr->udr
11439 942 : = gfc_find_omp_udr (NULL, udr_name,
11440 471 : &n->sym->ts);
11441 471 : if (n->u2.udr->udr == NULL)
11442 : {
11443 0 : free (n->u2.udr);
11444 0 : n->u2.udr = NULL;
11445 : }
11446 : }
11447 575 : if (n->u2.udr == NULL)
11448 : {
11449 104 : if (udr_name == NULL)
11450 104 : switch (n->u.reduction_op)
11451 : {
11452 50 : case OMP_REDUCTION_PLUS:
11453 50 : case OMP_REDUCTION_TIMES:
11454 50 : case OMP_REDUCTION_MINUS:
11455 50 : case OMP_REDUCTION_AND:
11456 50 : case OMP_REDUCTION_OR:
11457 50 : case OMP_REDUCTION_EQV:
11458 50 : case OMP_REDUCTION_NEQV:
11459 50 : udr_name = gfc_op2string ((gfc_intrinsic_op)
11460 : n->u.reduction_op);
11461 50 : break;
11462 : case OMP_REDUCTION_MAX:
11463 : udr_name = "max";
11464 : break;
11465 9 : case OMP_REDUCTION_MIN:
11466 9 : udr_name = "min";
11467 9 : break;
11468 12 : case OMP_REDUCTION_IAND:
11469 12 : udr_name = "iand";
11470 12 : break;
11471 12 : case OMP_REDUCTION_IOR:
11472 12 : udr_name = "ior";
11473 12 : break;
11474 9 : case OMP_REDUCTION_IEOR:
11475 9 : udr_name = "ieor";
11476 9 : break;
11477 0 : default:
11478 0 : gcc_unreachable ();
11479 : }
11480 104 : gfc_error ("!$OMP DECLARE REDUCTION %s not found "
11481 : "for type %s at %L", udr_name,
11482 104 : gfc_typename (&n->sym->ts), &n->where);
11483 : }
11484 : else
11485 : {
11486 471 : gfc_omp_udr *udr = n->u2.udr->udr;
11487 471 : n->u.reduction_op = OMP_REDUCTION_USER;
11488 471 : n->u2.udr->combiner
11489 942 : = resolve_omp_udr_clause (n, udr->combiner_ns,
11490 471 : udr->omp_out,
11491 471 : udr->omp_in);
11492 471 : if (udr->initializer_ns)
11493 331 : n->u2.udr->initializer
11494 331 : = resolve_omp_udr_clause (n,
11495 : udr->initializer_ns,
11496 331 : udr->omp_priv,
11497 331 : udr->omp_orig);
11498 : }
11499 : }
11500 : break;
11501 887 : case OMP_LIST_LINEAR:
11502 887 : if (code)
11503 : {
11504 727 : bool is_worksharing_for = false;
11505 727 : switch (code->op)
11506 : {
11507 54 : case EXEC_OMP_DO:
11508 54 : case EXEC_OMP_PARALLEL_DO:
11509 54 : case EXEC_OMP_DISTRIBUTE_PARALLEL_DO:
11510 54 : case EXEC_OMP_TARGET_PARALLEL_DO:
11511 54 : case EXEC_OMP_TEAMS_DISTRIBUTE_PARALLEL_DO:
11512 54 : case EXEC_OMP_TARGET_TEAMS_DISTRIBUTE_PARALLEL_DO:
11513 54 : is_worksharing_for = true;
11514 54 : break;
11515 : default:
11516 : break;
11517 : }
11518 :
11519 54 : if (is_worksharing_for
11520 54 : && (n->sym->attr.dimension
11521 53 : || n->sym->attr.allocatable))
11522 : {
11523 1 : if (n->sym->attr.allocatable)
11524 0 : gfc_error ("Sorry, ALLOCATABLE object %qs in "
11525 : "LINEAR clause on worksharing-loop "
11526 : "construct at %L is not yet supported",
11527 : n->sym->name, &n->where);
11528 : else
11529 1 : gfc_error ("Sorry, array %qs in LINEAR clause "
11530 : "on worksharing-loop construct at %L "
11531 : "is not yet supported",
11532 : n->sym->name, &n->where);
11533 : break;
11534 : }
11535 : }
11536 :
11537 726 : if (code
11538 726 : && n->u.linear.op != OMP_LINEAR_DEFAULT
11539 23 : && n->u.linear.op != linear_op)
11540 : {
11541 23 : if (n->u.linear.old_modifier)
11542 : {
11543 9 : gfc_error ("LINEAR clause modifier used on DO or "
11544 : "SIMD construct at %L", &n->where);
11545 9 : linear_op = n->u.linear.op;
11546 : }
11547 14 : else if (n->u.linear.op != OMP_LINEAR_VAL)
11548 : {
11549 6 : gfc_error ("LINEAR clause modifier other than VAL "
11550 : "used on DO or SIMD construct at %L",
11551 : &n->where);
11552 6 : linear_op = n->u.linear.op;
11553 : }
11554 : }
11555 863 : else if (n->u.linear.op != OMP_LINEAR_REF
11556 813 : && n->sym->ts.type != BT_INTEGER)
11557 1 : gfc_error ("LINEAR variable %qs must be INTEGER "
11558 : "at %L", n->sym->name, &n->where);
11559 862 : else if ((n->u.linear.op == OMP_LINEAR_REF
11560 812 : || n->u.linear.op == OMP_LINEAR_UVAL)
11561 61 : && n->sym->attr.value)
11562 0 : gfc_error ("LINEAR dummy argument %qs with VALUE "
11563 : "attribute with %s modifier at %L",
11564 : n->sym->name,
11565 : n->u.linear.op == OMP_LINEAR_REF
11566 : ? "REF" : "UVAL", &n->where);
11567 862 : else if (n->expr)
11568 : {
11569 843 : gfc_expr *expr = n->expr;
11570 843 : if (!gfc_resolve_expr (expr)
11571 843 : || expr->ts.type != BT_INTEGER
11572 1686 : || expr->rank != 0)
11573 0 : gfc_error ("%qs in LINEAR clause at %L requires "
11574 : "a scalar integer linear-step expression",
11575 0 : n->sym->name, &n->where);
11576 843 : else if (!code && expr->expr_type != EXPR_CONSTANT)
11577 : {
11578 11 : if (expr->expr_type == EXPR_VARIABLE
11579 7 : && expr->symtree->n.sym->attr.dummy
11580 6 : && expr->symtree->n.sym->ns == ns)
11581 : {
11582 6 : gfc_omp_namelist *n2;
11583 6 : for (n2 = omp_clauses->lists[OMP_LIST_UNIFORM];
11584 6 : n2; n2 = n2->next)
11585 6 : if (n2->sym == expr->symtree->n.sym)
11586 : break;
11587 6 : if (n2)
11588 : break;
11589 : }
11590 5 : gfc_error ("%qs in LINEAR clause at %L requires "
11591 : "a constant integer linear-step "
11592 : "expression or dummy argument "
11593 : "specified in UNIFORM clause",
11594 5 : n->sym->name, &n->where);
11595 : }
11596 : }
11597 : break;
11598 : /* Workaround for PR middle-end/26316, nothing really needs
11599 : to be done here for OMP_LIST_PRIVATE. */
11600 9400 : case OMP_LIST_PRIVATE:
11601 9400 : gcc_assert (code && code->op != EXEC_NOP);
11602 : break;
11603 98 : case OMP_LIST_USE_DEVICE:
11604 98 : if (n->sym->attr.allocatable
11605 98 : || (n->sym->ts.type == BT_CLASS && CLASS_DATA (n->sym)
11606 0 : && CLASS_DATA (n->sym)->attr.allocatable))
11607 0 : gfc_error ("ALLOCATABLE object %qs in %s clause at %L",
11608 : n->sym->name, name, &n->where);
11609 98 : if (n->sym->ts.type == BT_CLASS
11610 0 : && CLASS_DATA (n->sym)
11611 0 : && CLASS_DATA (n->sym)->attr.class_pointer)
11612 0 : gfc_error ("POINTER object %qs of polymorphic type in "
11613 : "%s clause at %L", n->sym->name, name,
11614 : &n->where);
11615 98 : if (n->sym->attr.cray_pointer)
11616 2 : gfc_error ("Cray pointer object %qs in %s clause at %L",
11617 : n->sym->name, name, &n->where);
11618 96 : else if (n->sym->attr.cray_pointee)
11619 2 : gfc_error ("Cray pointee object %qs in %s clause at %L",
11620 : n->sym->name, name, &n->where);
11621 94 : else if (n->sym->attr.flavor == FL_VARIABLE
11622 93 : && !n->sym->as
11623 54 : && !n->sym->attr.pointer)
11624 13 : gfc_error ("%s clause variable %qs at %L is neither "
11625 : "a POINTER nor an array", name,
11626 : n->sym->name, &n->where);
11627 : /* FALLTHRU */
11628 98 : case OMP_LIST_DEVICE_RESIDENT:
11629 98 : check_symbol_not_pointer (n->sym, n->where, name);
11630 98 : check_array_not_assumed (n->sym, n->where, name);
11631 98 : break;
11632 : default:
11633 : break;
11634 : }
11635 : }
11636 : break;
11637 : }
11638 : }
11639 : /* OpenMP 5.1: use_device_ptr acts like use_device_addr, except for
11640 : type(c_ptr). */
11641 33132 : if (omp_clauses->lists[OMP_LIST_USE_DEVICE_PTR])
11642 : {
11643 9 : gfc_omp_namelist *n_prev, *n_next, *n_addr;
11644 9 : n_addr = omp_clauses->lists[OMP_LIST_USE_DEVICE_ADDR];
11645 28 : for (; n_addr && n_addr->next; n_addr = n_addr->next)
11646 : ;
11647 : n_prev = NULL;
11648 : n = omp_clauses->lists[OMP_LIST_USE_DEVICE_PTR];
11649 27 : while (n)
11650 : {
11651 18 : n_next = n->next;
11652 18 : if (n->sym->ts.type != BT_DERIVED
11653 18 : || n->sym->ts.u.derived->ts.f90_type != BT_VOID)
11654 : {
11655 0 : n->next = NULL;
11656 0 : if (n_addr)
11657 0 : n_addr->next = n;
11658 : else
11659 0 : omp_clauses->lists[OMP_LIST_USE_DEVICE_ADDR] = n;
11660 0 : n_addr = n;
11661 0 : if (n_prev)
11662 0 : n_prev->next = n_next;
11663 : else
11664 0 : omp_clauses->lists[OMP_LIST_USE_DEVICE_PTR] = n_next;
11665 : }
11666 : else
11667 : n_prev = n;
11668 18 : n = n_next;
11669 : }
11670 : }
11671 33132 : if (omp_clauses->safelen_expr)
11672 93 : resolve_positive_int_expr (omp_clauses->safelen_expr, "SAFELEN");
11673 33132 : if (omp_clauses->simdlen_expr)
11674 123 : resolve_positive_int_expr (omp_clauses->simdlen_expr, "SIMDLEN");
11675 33326 : for (el = omp_clauses->num_teams_list; el; el = el->next)
11676 194 : resolve_positive_int_expr (el->expr, "NUM_TEAMS");
11677 33132 : if (omp_clauses->num_teams_list
11678 153 : && omp_clauses->num_teams_list->next
11679 34 : && !omp_clauses->num_teams_dims
11680 27 : && omp_clauses->num_teams_list->expr->expr_type == EXPR_CONSTANT
11681 13 : && omp_clauses->num_teams_list->next->expr->expr_type == EXPR_CONSTANT
11682 13 : && mpz_cmp (omp_clauses->num_teams_list->expr->value.integer,
11683 13 : omp_clauses->num_teams_list->next->expr->value.integer) > 0)
11684 2 : gfc_warning (OPT_Wopenmp, "NUM_TEAMS lower bound at %L larger than upper "
11685 : "bound at %L", &omp_clauses->num_teams_list->expr->where,
11686 : &omp_clauses->num_teams_list->next->expr->where);
11687 33132 : if (omp_clauses->device)
11688 333 : resolve_scalar_int_expr (omp_clauses->device, "DEVICE");
11689 33132 : if (omp_clauses->filter)
11690 42 : resolve_nonnegative_int_expr (omp_clauses->filter, "FILTER");
11691 33132 : if (omp_clauses->hint)
11692 : {
11693 47 : resolve_scalar_int_expr (omp_clauses->hint, "HINT");
11694 47 : if (omp_clauses->hint->ts.type != BT_INTEGER
11695 45 : || omp_clauses->hint->expr_type != EXPR_CONSTANT
11696 43 : || mpz_sgn (omp_clauses->hint->value.integer) < 0)
11697 5 : gfc_error ("Value of HINT clause at %L shall be a valid "
11698 : "constant hint expression", &omp_clauses->hint->where);
11699 : }
11700 33132 : if (omp_clauses->priority)
11701 34 : resolve_nonnegative_int_expr (omp_clauses->priority, "PRIORITY");
11702 33132 : if (omp_clauses->dist_chunk_size)
11703 : {
11704 83 : gfc_expr *expr = omp_clauses->dist_chunk_size;
11705 83 : if (!gfc_resolve_expr (expr)
11706 83 : || expr->ts.type != BT_INTEGER || expr->rank != 0)
11707 0 : gfc_error ("DIST_SCHEDULE clause's chunk_size at %L requires "
11708 : "a scalar INTEGER expression", &expr->where);
11709 : }
11710 33254 : for (el = omp_clauses->thread_limit_list; el; el = el->next)
11711 122 : resolve_positive_int_expr (el->expr, "THREAD_LIMIT");
11712 33132 : if (omp_clauses->grainsize)
11713 34 : resolve_positive_int_expr (omp_clauses->grainsize, "GRAINSIZE");
11714 33132 : if (omp_clauses->num_tasks)
11715 26 : resolve_positive_int_expr (omp_clauses->num_tasks, "NUM_TASKS");
11716 33132 : if (omp_clauses->grainsize && omp_clauses->num_tasks)
11717 1 : gfc_error ("%<GRAINSIZE%> clause at %L must not be used together with "
11718 : "%<NUM_TASKS%> clause", &omp_clauses->grainsize->where);
11719 33132 : if (omp_clauses->lists[OMP_LIST_REDUCTION] && omp_clauses->nogroup)
11720 1 : gfc_error ("%<REDUCTION%> clause at %L must not be used together with "
11721 : "%<NOGROUP%> clause",
11722 : &omp_clauses->lists[OMP_LIST_REDUCTION]->where);
11723 33132 : if (omp_clauses->full && omp_clauses->partial)
11724 0 : gfc_error ("%<FULL%> clause at %C must not be used together with "
11725 : "%<PARTIAL%> clause");
11726 33132 : if (omp_clauses->async)
11727 610 : if (omp_clauses->async_expr)
11728 610 : resolve_scalar_int_expr (omp_clauses->async_expr, "ASYNC");
11729 33132 : if (omp_clauses->device_num_expr)
11730 105 : resolve_scalar_int_expr (omp_clauses->device_num_expr, "DEVICE_NUM");
11731 33132 : if (code && code->op == EXEC_OACC_SET
11732 121 : && !omp_clauses->device_num_expr
11733 52 : && !omp_clauses->oacc_device_type_present)
11734 2 : gfc_error ("At least one of the clauses %<DEVICE_TYPE%> and %<DEVICE_NUM%> "
11735 : "should be present in %<SET%> directive at %L", &code->loc);
11736 33132 : if (omp_clauses->num_gangs_expr)
11737 682 : resolve_positive_int_expr (omp_clauses->num_gangs_expr, "NUM_GANGS");
11738 33132 : if (omp_clauses->num_workers_expr)
11739 599 : resolve_positive_int_expr (omp_clauses->num_workers_expr, "NUM_WORKERS");
11740 33132 : if (omp_clauses->vector_length_expr)
11741 569 : resolve_positive_int_expr (omp_clauses->vector_length_expr,
11742 : "VECTOR_LENGTH");
11743 33132 : if (omp_clauses->gang_num_expr)
11744 114 : resolve_positive_int_expr (omp_clauses->gang_num_expr, "GANG");
11745 33132 : if (omp_clauses->gang_static_expr)
11746 94 : resolve_positive_int_expr (omp_clauses->gang_static_expr, "GANG");
11747 33132 : if (omp_clauses->worker_expr)
11748 101 : resolve_positive_int_expr (omp_clauses->worker_expr, "WORKER");
11749 33132 : if (omp_clauses->vector_expr)
11750 132 : resolve_positive_int_expr (omp_clauses->vector_expr, "VECTOR");
11751 33471 : for (el = omp_clauses->wait_list; el; el = el->next)
11752 339 : resolve_scalar_int_expr (el->expr, "WAIT");
11753 33132 : if (omp_clauses->collapse && omp_clauses->tile_list)
11754 4 : gfc_error ("Incompatible use of TILE and COLLAPSE at %L", &code->loc);
11755 33132 : if (omp_clauses->message)
11756 : {
11757 58 : gfc_expr *expr = omp_clauses->message;
11758 58 : if (!gfc_resolve_expr (expr)
11759 58 : || expr->ts.kind != gfc_default_character_kind
11760 113 : || expr->ts.type != BT_CHARACTER || expr->rank != 0)
11761 4 : gfc_error ("MESSAGE clause at %L requires a scalar default-kind "
11762 : "CHARACTER expression", &expr->where);
11763 : }
11764 33132 : if (!openacc
11765 33132 : && code
11766 19878 : && omp_clauses->lists[OMP_LIST_MAP] == NULL
11767 16081 : && omp_clauses->lists[OMP_LIST_USE_DEVICE_PTR] == NULL
11768 16078 : && omp_clauses->lists[OMP_LIST_USE_DEVICE_ADDR] == NULL)
11769 : {
11770 16055 : const char *p = NULL;
11771 16055 : switch (code->op)
11772 : {
11773 1 : case EXEC_OMP_TARGET_ENTER_DATA: p = "TARGET ENTER DATA"; break;
11774 1 : case EXEC_OMP_TARGET_EXIT_DATA: p = "TARGET EXIT DATA"; break;
11775 : default: break;
11776 : }
11777 16055 : if (code->op == EXEC_OMP_TARGET_DATA)
11778 1 : gfc_error ("TARGET DATA must contain at least one MAP, USE_DEVICE_PTR, "
11779 : "or USE_DEVICE_ADDR clause at %L", &code->loc);
11780 16054 : else if (p)
11781 2 : gfc_error ("%s must contain at least one MAP clause at %L",
11782 : p, &code->loc);
11783 : }
11784 33132 : if (omp_clauses->sizes_list)
11785 : {
11786 : gfc_expr_list *el;
11787 572 : for (el = omp_clauses->sizes_list; el; el = el->next)
11788 : {
11789 377 : resolve_scalar_int_expr (el->expr, "SIZES");
11790 377 : if (el->expr->expr_type != EXPR_CONSTANT)
11791 1 : gfc_error ("SIZES requires constant expression at %L",
11792 : &el->expr->where);
11793 376 : else if (el->expr->expr_type == EXPR_CONSTANT
11794 376 : && el->expr->ts.type == BT_INTEGER
11795 376 : && mpz_sgn (el->expr->value.integer) <= 0)
11796 2 : gfc_error ("INTEGER expression of %s clause at %L must be "
11797 : "positive", "SIZES", &el->expr->where);
11798 : }
11799 : }
11800 :
11801 33132 : if (!openacc && omp_clauses->detach)
11802 : {
11803 125 : if (!gfc_resolve_expr (omp_clauses->detach)
11804 125 : || omp_clauses->detach->ts.type != BT_INTEGER
11805 124 : || omp_clauses->detach->ts.kind != gfc_c_intptr_kind
11806 248 : || omp_clauses->detach->rank != 0)
11807 3 : gfc_error ("%qs at %L should be a scalar of type "
11808 : "integer(kind=omp_event_handle_kind)",
11809 3 : omp_clauses->detach->symtree->n.sym->name,
11810 3 : &omp_clauses->detach->where);
11811 122 : else if (omp_clauses->detach->symtree->n.sym->attr.dimension > 0)
11812 1 : gfc_error ("The event handle at %L must not be an array element",
11813 : &omp_clauses->detach->where);
11814 121 : else if (omp_clauses->detach->symtree->n.sym->ts.type == BT_DERIVED
11815 120 : || omp_clauses->detach->symtree->n.sym->ts.type == BT_CLASS)
11816 1 : gfc_error ("The event handle at %L must not be part of "
11817 : "a derived type or class", &omp_clauses->detach->where);
11818 :
11819 125 : if (omp_clauses->mergeable)
11820 2 : gfc_error ("%<DETACH%> clause at %L must not be used together with "
11821 2 : "%<MERGEABLE%> clause", &omp_clauses->detach->where);
11822 : }
11823 :
11824 : if (openacc
11825 12995 : && code->op == EXEC_OACC_HOST_DATA
11826 60 : && omp_clauses->lists[OMP_LIST_USE_DEVICE] == NULL)
11827 1 : gfc_error ("%<host_data%> construct at %L requires %<use_device%> clause",
11828 : &code->loc);
11829 :
11830 33132 : if (omp_clauses->assume)
11831 18 : gfc_resolve_omp_assumptions (omp_clauses->assume);
11832 : }
11833 :
11834 :
11835 : /* Return true if SYM is ever referenced in EXPR except in the SE node. */
11836 :
11837 : static bool
11838 5008 : expr_references_sym (gfc_expr *e, gfc_symbol *s, gfc_expr *se)
11839 : {
11840 6641 : gfc_actual_arglist *arg;
11841 6641 : if (e == NULL || e == se)
11842 : return false;
11843 5386 : switch (e->expr_type)
11844 : {
11845 3133 : case EXPR_CONSTANT:
11846 3133 : case EXPR_NULL:
11847 3133 : case EXPR_VARIABLE:
11848 3133 : case EXPR_STRUCTURE:
11849 3133 : case EXPR_ARRAY:
11850 3133 : if (e->symtree != NULL
11851 1157 : && e->symtree->n.sym == s)
11852 470 : return true;
11853 : return false;
11854 0 : case EXPR_SUBSTRING:
11855 0 : if (e->ref != NULL
11856 0 : && (expr_references_sym (e->ref->u.ss.start, s, se)
11857 0 : || expr_references_sym (e->ref->u.ss.end, s, se)))
11858 0 : return true;
11859 : return false;
11860 1742 : case EXPR_OP:
11861 1742 : if (expr_references_sym (e->value.op.op2, s, se))
11862 : return true;
11863 1633 : return expr_references_sym (e->value.op.op1, s, se);
11864 511 : case EXPR_FUNCTION:
11865 896 : for (arg = e->value.function.actual; arg; arg = arg->next)
11866 586 : if (expr_references_sym (arg->expr, s, se))
11867 : return true;
11868 : return false;
11869 0 : default:
11870 0 : gcc_unreachable ();
11871 : }
11872 : }
11873 :
11874 :
11875 : /* If EXPR is a conversion function that widens the type
11876 : if WIDENING is true or narrows the type if NARROW is true,
11877 : return the inner expression, otherwise return NULL. */
11878 :
11879 : static gfc_expr *
11880 5928 : is_conversion (gfc_expr *expr, bool narrowing, bool widening)
11881 : {
11882 5928 : gfc_typespec *ts1, *ts2;
11883 :
11884 5928 : if (expr->expr_type != EXPR_FUNCTION
11885 917 : || expr->value.function.isym == NULL
11886 894 : || expr->value.function.esym != NULL
11887 894 : || expr->value.function.isym->id != GFC_ISYM_CONVERSION
11888 388 : || (!narrowing && !widening))
11889 : return NULL;
11890 :
11891 388 : if (narrowing && widening)
11892 267 : return expr->value.function.actual->expr;
11893 :
11894 121 : if (widening)
11895 : {
11896 121 : ts1 = &expr->ts;
11897 121 : ts2 = &expr->value.function.actual->expr->ts;
11898 : }
11899 : else
11900 : {
11901 0 : ts1 = &expr->value.function.actual->expr->ts;
11902 0 : ts2 = &expr->ts;
11903 : }
11904 :
11905 121 : if (ts1->type > ts2->type
11906 49 : || (ts1->type == ts2->type && ts1->kind > ts2->kind))
11907 121 : return expr->value.function.actual->expr;
11908 :
11909 : return NULL;
11910 : }
11911 :
11912 : static bool
11913 6883 : is_scalar_intrinsic_expr (gfc_expr *expr, bool must_be_var, bool conv_ok)
11914 : {
11915 6883 : if (must_be_var
11916 4034 : && (expr->expr_type != EXPR_VARIABLE || !expr->symtree))
11917 : {
11918 37 : if (!conv_ok)
11919 : return false;
11920 37 : gfc_expr *conv = is_conversion (expr, true, true);
11921 37 : if (!conv)
11922 : return false;
11923 36 : if (conv->expr_type != EXPR_VARIABLE || !conv->symtree)
11924 : return false;
11925 : }
11926 6880 : return (expr->rank == 0
11927 6876 : && !gfc_is_coindexed (expr)
11928 13756 : && (expr->ts.type == BT_INTEGER
11929 1522 : || expr->ts.type == BT_REAL
11930 590 : || expr->ts.type == BT_COMPLEX
11931 572 : || expr->ts.type == BT_LOGICAL));
11932 : }
11933 :
11934 : static void
11935 2710 : resolve_omp_atomic (gfc_code *code)
11936 : {
11937 2710 : gfc_code *atomic_code = code->block;
11938 2710 : gfc_symbol *var;
11939 2710 : gfc_expr *stmt_expr2, *capt_expr2;
11940 2710 : gfc_omp_atomic_op aop
11941 2710 : = (gfc_omp_atomic_op) (atomic_code->ext.omp_clauses->atomic_op
11942 : & GFC_OMP_ATOMIC_MASK);
11943 2710 : gfc_code *stmt = NULL, *capture_stmt = NULL, *tailing_stmt = NULL;
11944 2710 : gfc_expr *comp_cond = NULL;
11945 2710 : locus *loc = NULL;
11946 :
11947 2710 : code = code->block->next;
11948 : /* resolve_blocks asserts this is initially EXEC_ASSIGN or EXEC_IF
11949 : If it changed to EXEC_NOP, assume an error has been emitted already. */
11950 2710 : if (code->op == EXEC_NOP)
11951 : return;
11952 :
11953 2709 : if (atomic_code->ext.omp_clauses->compare
11954 157 : && atomic_code->ext.omp_clauses->capture)
11955 : {
11956 : /* Must be either "if (x == e) then; x = d; else; v = x; end if"
11957 : or "v = expr" followed/preceded by
11958 : "if (x == e) then; x = d; end if" or "if (x == e) x = d". */
11959 103 : gfc_code *next = code;
11960 103 : if (code->op == EXEC_ASSIGN)
11961 : {
11962 19 : capture_stmt = code;
11963 19 : next = code->next;
11964 : }
11965 103 : if (next->op == EXEC_IF
11966 103 : && next->block
11967 103 : && next->block->op == EXEC_IF
11968 103 : && next->block->next
11969 102 : && next->block->next->op == EXEC_ASSIGN)
11970 : {
11971 102 : comp_cond = next->block->expr1;
11972 102 : stmt = next->block->next;
11973 102 : if (stmt->next)
11974 : {
11975 0 : loc = &stmt->loc;
11976 0 : goto unexpected;
11977 : }
11978 : }
11979 1 : else if (capture_stmt)
11980 : {
11981 0 : gfc_error ("Expected IF at %L in atomic compare capture",
11982 : &next->loc);
11983 0 : return;
11984 : }
11985 103 : if (stmt && !capture_stmt && next->block->block)
11986 : {
11987 64 : if (next->block->block->expr1)
11988 : {
11989 0 : gfc_error ("Expected ELSE at %L in atomic compare capture",
11990 : &next->block->block->expr1->where);
11991 0 : return;
11992 : }
11993 64 : if (!code->block->block->next
11994 64 : || code->block->block->next->op != EXEC_ASSIGN)
11995 : {
11996 0 : loc = (code->block->block->next ? &code->block->block->next->loc
11997 : : &code->block->block->loc);
11998 0 : goto unexpected;
11999 : }
12000 64 : capture_stmt = code->block->block->next;
12001 64 : if (capture_stmt->next)
12002 : {
12003 0 : loc = &capture_stmt->next->loc;
12004 0 : goto unexpected;
12005 : }
12006 : }
12007 103 : if (stmt && !capture_stmt && next->next->op == EXEC_ASSIGN)
12008 : capture_stmt = next->next;
12009 84 : else if (!capture_stmt)
12010 : {
12011 1 : loc = &code->loc;
12012 1 : goto unexpected;
12013 : }
12014 : }
12015 2606 : else if (atomic_code->ext.omp_clauses->compare)
12016 : {
12017 : /* Must be: "if (x == e) then; x = d; end if" or "if (x == e) x = d". */
12018 54 : if (code->op == EXEC_IF
12019 54 : && code->block
12020 54 : && code->block->op == EXEC_IF
12021 54 : && code->block->next
12022 52 : && code->block->next->op == EXEC_ASSIGN)
12023 : {
12024 52 : comp_cond = code->block->expr1;
12025 52 : stmt = code->block->next;
12026 52 : if (stmt->next || code->block->block)
12027 : {
12028 0 : loc = stmt->next ? &stmt->next->loc : &code->block->block->loc;
12029 0 : goto unexpected;
12030 : }
12031 : }
12032 : else
12033 : {
12034 2 : loc = &code->loc;
12035 2 : goto unexpected;
12036 : }
12037 : }
12038 2552 : else if (atomic_code->ext.omp_clauses->capture)
12039 : {
12040 : /* Must be: "v = x" followed/preceded by "x = ...". */
12041 489 : if (code->op != EXEC_ASSIGN)
12042 0 : goto unexpected;
12043 489 : if (code->next->op != EXEC_ASSIGN)
12044 : {
12045 0 : loc = &code->next->loc;
12046 0 : goto unexpected;
12047 : }
12048 489 : gfc_expr *expr2, *expr2_next;
12049 489 : expr2 = is_conversion (code->expr2, true, true);
12050 489 : if (expr2 == NULL)
12051 447 : expr2 = code->expr2;
12052 489 : expr2_next = is_conversion (code->next->expr2, true, true);
12053 489 : if (expr2_next == NULL)
12054 478 : expr2_next = code->next->expr2;
12055 489 : if (code->expr1->expr_type == EXPR_VARIABLE
12056 489 : && code->next->expr1->expr_type == EXPR_VARIABLE
12057 489 : && expr2->expr_type == EXPR_VARIABLE
12058 243 : && expr2_next->expr_type == EXPR_VARIABLE)
12059 : {
12060 1 : if (code->expr1->symtree->n.sym == expr2_next->symtree->n.sym)
12061 : {
12062 : stmt = code;
12063 : capture_stmt = code->next;
12064 : }
12065 : else
12066 : {
12067 489 : capture_stmt = code;
12068 489 : stmt = code->next;
12069 : }
12070 : }
12071 488 : else if (expr2->expr_type == EXPR_VARIABLE)
12072 : {
12073 : capture_stmt = code;
12074 : stmt = code->next;
12075 : }
12076 : else
12077 : {
12078 247 : stmt = code;
12079 247 : capture_stmt = code->next;
12080 : }
12081 : /* Shall be NULL but can happen for invalid code. */
12082 489 : tailing_stmt = code->next->next;
12083 : }
12084 : else
12085 : {
12086 : /* x = ... */
12087 2063 : stmt = code;
12088 2063 : if (!atomic_code->ext.omp_clauses->compare && stmt->op != EXEC_ASSIGN)
12089 1 : goto unexpected;
12090 : /* Shall be NULL but can happen for invalid code. */
12091 2062 : tailing_stmt = code->next;
12092 : }
12093 :
12094 2705 : if (comp_cond)
12095 : {
12096 154 : if (comp_cond->expr_type != EXPR_OP
12097 154 : || (comp_cond->value.op.op != INTRINSIC_EQ
12098 : && comp_cond->value.op.op != INTRINSIC_EQ_OS
12099 : && comp_cond->value.op.op != INTRINSIC_EQV))
12100 : {
12101 0 : gfc_error ("Expected %<==%>, %<.EQ.%> or %<.EQV.%> atomic comparison "
12102 : "expression at %L", &comp_cond->where);
12103 0 : return;
12104 : }
12105 154 : if (!is_scalar_intrinsic_expr (comp_cond->value.op.op1, true, true))
12106 : {
12107 1 : gfc_error ("Expected scalar intrinsic variable at %L in atomic "
12108 1 : "comparison", &comp_cond->value.op.op1->where);
12109 1 : return;
12110 : }
12111 153 : if (!gfc_resolve_expr (comp_cond->value.op.op2))
12112 : return;
12113 153 : if (!is_scalar_intrinsic_expr (comp_cond->value.op.op2, false, false))
12114 : {
12115 0 : gfc_error ("Expected scalar intrinsic expression at %L in atomic "
12116 0 : "comparison", &comp_cond->value.op.op1->where);
12117 0 : return;
12118 : }
12119 : }
12120 :
12121 2704 : if (!is_scalar_intrinsic_expr (stmt->expr1, true, false))
12122 : {
12123 4 : gfc_error ("!$OMP ATOMIC statement must set a scalar variable of "
12124 4 : "intrinsic type at %L", &stmt->expr1->where);
12125 4 : return;
12126 : }
12127 :
12128 2700 : if (!gfc_resolve_expr (stmt->expr2))
12129 : return;
12130 2696 : if (!is_scalar_intrinsic_expr (stmt->expr2, false, false))
12131 : {
12132 0 : gfc_error ("!$OMP ATOMIC statement must assign an expression of "
12133 0 : "intrinsic type at %L", &stmt->expr2->where);
12134 0 : return;
12135 : }
12136 :
12137 2696 : if (gfc_expr_attr (stmt->expr1).allocatable)
12138 : {
12139 0 : gfc_error ("!$OMP ATOMIC with ALLOCATABLE variable at %L",
12140 0 : &stmt->expr1->where);
12141 0 : return;
12142 : }
12143 :
12144 : /* Should be diagnosed above already. */
12145 2696 : gcc_assert (tailing_stmt == NULL);
12146 :
12147 2696 : var = stmt->expr1->symtree->n.sym;
12148 2696 : stmt_expr2 = is_conversion (stmt->expr2, true, true);
12149 2696 : if (stmt_expr2 == NULL)
12150 2540 : stmt_expr2 = stmt->expr2;
12151 :
12152 2696 : switch (aop)
12153 : {
12154 506 : case GFC_OMP_ATOMIC_READ:
12155 506 : if (stmt_expr2->expr_type != EXPR_VARIABLE)
12156 0 : gfc_error ("!$OMP ATOMIC READ statement must read from a scalar "
12157 : "variable of intrinsic type at %L", &stmt_expr2->where);
12158 : return;
12159 426 : case GFC_OMP_ATOMIC_WRITE:
12160 426 : if (expr_references_sym (stmt_expr2, var, NULL))
12161 0 : gfc_error ("expr in !$OMP ATOMIC WRITE assignment var = expr "
12162 : "must be scalar and cannot reference var at %L",
12163 : &stmt_expr2->where);
12164 : return;
12165 1764 : default:
12166 1764 : break;
12167 : }
12168 :
12169 1764 : if (atomic_code->ext.omp_clauses->capture)
12170 : {
12171 588 : if (!is_scalar_intrinsic_expr (capture_stmt->expr1, true, false))
12172 : {
12173 0 : gfc_error ("!$OMP ATOMIC capture-statement must set a scalar "
12174 : "variable of intrinsic type at %L",
12175 0 : &capture_stmt->expr1->where);
12176 0 : return;
12177 : }
12178 :
12179 588 : if (!is_scalar_intrinsic_expr (capture_stmt->expr2, true, true))
12180 : {
12181 2 : gfc_error ("!$OMP ATOMIC capture-statement requires a scalar variable"
12182 2 : " of intrinsic type at %L", &capture_stmt->expr2->where);
12183 2 : return;
12184 : }
12185 586 : capt_expr2 = is_conversion (capture_stmt->expr2, true, true);
12186 586 : if (capt_expr2 == NULL)
12187 564 : capt_expr2 = capture_stmt->expr2;
12188 :
12189 586 : if (capt_expr2->symtree->n.sym != var)
12190 : {
12191 1 : gfc_error ("!$OMP ATOMIC CAPTURE capture statement reads from "
12192 : "different variable than update statement writes "
12193 : "into at %L", &capture_stmt->expr2->where);
12194 1 : return;
12195 : }
12196 : }
12197 :
12198 1761 : if (atomic_code->ext.omp_clauses->compare)
12199 : {
12200 150 : gfc_expr *var_expr;
12201 150 : if (comp_cond->value.op.op1->expr_type == EXPR_VARIABLE)
12202 : var_expr = comp_cond->value.op.op1;
12203 : else
12204 12 : var_expr = comp_cond->value.op.op1->value.function.actual->expr;
12205 150 : if (var_expr->symtree->n.sym != var)
12206 : {
12207 2 : gfc_error ("For !$OMP ATOMIC COMPARE, the first operand in comparison"
12208 : " at %L must be the variable %qs that the update statement"
12209 : " writes into at %L", &var_expr->where, var->name,
12210 2 : &stmt->expr1->where);
12211 2 : return;
12212 : }
12213 148 : if (stmt_expr2->rank != 0 || expr_references_sym (stmt_expr2, var, NULL))
12214 : {
12215 1 : gfc_error ("expr in !$OMP ATOMIC COMPARE assignment var = expr "
12216 : "must be scalar and cannot reference var at %L",
12217 : &stmt_expr2->where);
12218 1 : return;
12219 : }
12220 : }
12221 1611 : else if (atomic_code->ext.omp_clauses->capture
12222 1611 : && !expr_references_sym (stmt_expr2, var, NULL))
12223 22 : atomic_code->ext.omp_clauses->atomic_op
12224 22 : = (gfc_omp_atomic_op) (atomic_code->ext.omp_clauses->atomic_op
12225 : | GFC_OMP_ATOMIC_SWAP);
12226 1589 : else if (stmt_expr2->expr_type == EXPR_OP)
12227 : {
12228 1233 : gfc_expr *v = NULL, *e, *c;
12229 1233 : gfc_intrinsic_op op = stmt_expr2->value.op.op;
12230 1233 : gfc_intrinsic_op alt_op = INTRINSIC_NONE;
12231 :
12232 1233 : if (atomic_code->ext.omp_clauses->fail != OMP_MEMORDER_UNSET)
12233 3 : gfc_error ("!$OMP ATOMIC UPDATE at %L with FAIL clause requires either"
12234 : " the COMPARE clause or using the intrinsic MIN/MAX "
12235 : "procedure", &atomic_code->loc);
12236 1233 : switch (op)
12237 : {
12238 746 : case INTRINSIC_PLUS:
12239 746 : alt_op = INTRINSIC_MINUS;
12240 746 : break;
12241 94 : case INTRINSIC_TIMES:
12242 94 : alt_op = INTRINSIC_DIVIDE;
12243 94 : break;
12244 120 : case INTRINSIC_MINUS:
12245 120 : alt_op = INTRINSIC_PLUS;
12246 120 : break;
12247 94 : case INTRINSIC_DIVIDE:
12248 94 : alt_op = INTRINSIC_TIMES;
12249 94 : break;
12250 : case INTRINSIC_AND:
12251 : case INTRINSIC_OR:
12252 : break;
12253 43 : case INTRINSIC_EQV:
12254 43 : alt_op = INTRINSIC_NEQV;
12255 43 : break;
12256 43 : case INTRINSIC_NEQV:
12257 43 : alt_op = INTRINSIC_EQV;
12258 43 : break;
12259 1 : default:
12260 1 : gfc_error ("!$OMP ATOMIC assignment operator must be binary "
12261 : "+, *, -, /, .AND., .OR., .EQV. or .NEQV. at %L",
12262 : &stmt_expr2->where);
12263 1 : return;
12264 : }
12265 :
12266 : /* Check for var = var op expr resp. var = expr op var where
12267 : expr doesn't reference var and var op expr is mathematically
12268 : equivalent to var op (expr) resp. expr op var equivalent to
12269 : (expr) op var. We rely here on the fact that the matcher
12270 : for x op1 y op2 z where op1 and op2 have equal precedence
12271 : returns (x op1 y) op2 z. */
12272 1232 : e = stmt_expr2->value.op.op2;
12273 1232 : if (e->expr_type == EXPR_VARIABLE
12274 288 : && e->symtree != NULL
12275 288 : && e->symtree->n.sym == var)
12276 : v = e;
12277 1003 : else if ((c = is_conversion (e, false, true)) != NULL
12278 48 : && c->expr_type == EXPR_VARIABLE
12279 48 : && c->symtree != NULL
12280 1051 : && c->symtree->n.sym == var)
12281 : v = c;
12282 : else
12283 : {
12284 955 : gfc_expr **p = NULL, **q;
12285 1053 : for (q = &stmt_expr2->value.op.op1; (e = *q) != NULL; )
12286 1053 : if (e->expr_type == EXPR_VARIABLE
12287 952 : && e->symtree != NULL
12288 952 : && e->symtree->n.sym == var)
12289 : {
12290 : v = e;
12291 : break;
12292 : }
12293 101 : else if ((c = is_conversion (e, false, true)) != NULL)
12294 60 : q = &e->value.function.actual->expr;
12295 41 : else if (e->expr_type != EXPR_OP
12296 41 : || (e->value.op.op != op
12297 15 : && e->value.op.op != alt_op)
12298 38 : || e->rank != 0)
12299 : break;
12300 : else
12301 : {
12302 38 : p = q;
12303 38 : q = &e->value.op.op1;
12304 : }
12305 :
12306 955 : if (v == NULL)
12307 : {
12308 3 : gfc_error ("!$OMP ATOMIC assignment must be var = var op expr "
12309 : "or var = expr op var at %L", &stmt_expr2->where);
12310 3 : return;
12311 : }
12312 :
12313 952 : if (p != NULL)
12314 : {
12315 38 : e = *p;
12316 38 : switch (e->value.op.op)
12317 : {
12318 8 : case INTRINSIC_MINUS:
12319 8 : case INTRINSIC_DIVIDE:
12320 8 : case INTRINSIC_EQV:
12321 8 : case INTRINSIC_NEQV:
12322 8 : gfc_error ("!$OMP ATOMIC var = var op expr not "
12323 : "mathematically equivalent to var = var op "
12324 : "(expr) at %L", &stmt_expr2->where);
12325 8 : break;
12326 : default:
12327 : break;
12328 : }
12329 :
12330 : /* Canonicalize into var = var op (expr). */
12331 38 : *p = e->value.op.op2;
12332 38 : e->value.op.op2 = stmt_expr2;
12333 38 : e->ts = stmt_expr2->ts;
12334 38 : if (stmt->expr2 == stmt_expr2)
12335 26 : stmt->expr2 = stmt_expr2 = e;
12336 : else
12337 12 : stmt->expr2->value.function.actual->expr = stmt_expr2 = e;
12338 :
12339 38 : if (!gfc_compare_types (&stmt_expr2->value.op.op1->ts,
12340 : &stmt_expr2->ts))
12341 : {
12342 24 : for (p = &stmt_expr2->value.op.op1; *p != v;
12343 12 : p = &(*p)->value.function.actual->expr)
12344 : ;
12345 12 : *p = NULL;
12346 12 : gfc_free_expr (stmt_expr2->value.op.op1);
12347 12 : stmt_expr2->value.op.op1 = v;
12348 12 : gfc_convert_type (v, &stmt_expr2->ts, 2);
12349 : }
12350 : }
12351 : }
12352 :
12353 1229 : if (e->rank != 0 || expr_references_sym (stmt->expr2, var, v))
12354 : {
12355 1 : gfc_error ("expr in !$OMP ATOMIC assignment var = var op expr "
12356 : "must be scalar and cannot reference var at %L",
12357 : &stmt_expr2->where);
12358 1 : return;
12359 : }
12360 : }
12361 356 : else if (stmt_expr2->expr_type == EXPR_FUNCTION
12362 355 : && stmt_expr2->value.function.isym != NULL
12363 355 : && stmt_expr2->value.function.esym == NULL
12364 355 : && stmt_expr2->value.function.actual != NULL
12365 355 : && stmt_expr2->value.function.actual->next != NULL)
12366 : {
12367 355 : gfc_actual_arglist *arg, *var_arg;
12368 :
12369 355 : switch (stmt_expr2->value.function.isym->id)
12370 : {
12371 : case GFC_ISYM_MIN:
12372 : case GFC_ISYM_MAX:
12373 : break;
12374 147 : case GFC_ISYM_IAND:
12375 147 : case GFC_ISYM_IOR:
12376 147 : case GFC_ISYM_IEOR:
12377 147 : if (stmt_expr2->value.function.actual->next->next != NULL)
12378 : {
12379 0 : gfc_error ("!$OMP ATOMIC assignment intrinsic IAND, IOR "
12380 : "or IEOR must have two arguments at %L",
12381 : &stmt_expr2->where);
12382 0 : return;
12383 : }
12384 : break;
12385 1 : default:
12386 1 : gfc_error ("!$OMP ATOMIC assignment intrinsic must be "
12387 : "MIN, MAX, IAND, IOR or IEOR at %L",
12388 : &stmt_expr2->where);
12389 1 : return;
12390 : }
12391 :
12392 : var_arg = NULL;
12393 1088 : for (arg = stmt_expr2->value.function.actual; arg; arg = arg->next)
12394 : {
12395 741 : gfc_expr *e = NULL;
12396 741 : if (arg == stmt_expr2->value.function.actual
12397 387 : || (var_arg == NULL && arg->next == NULL))
12398 : {
12399 527 : e = is_conversion (arg->expr, false, true);
12400 527 : if (!e)
12401 514 : e = arg->expr;
12402 527 : if (e->expr_type == EXPR_VARIABLE
12403 453 : && e->symtree != NULL
12404 453 : && e->symtree->n.sym == var)
12405 741 : var_arg = arg;
12406 : }
12407 741 : if ((!var_arg || !e) && expr_references_sym (arg->expr, var, NULL))
12408 : {
12409 7 : gfc_error ("!$OMP ATOMIC intrinsic arguments except one must "
12410 : "not reference %qs at %L",
12411 : var->name, &arg->expr->where);
12412 7 : return;
12413 : }
12414 734 : if (arg->expr->rank != 0)
12415 : {
12416 0 : gfc_error ("!$OMP ATOMIC intrinsic arguments must be scalar "
12417 : "at %L", &arg->expr->where);
12418 0 : return;
12419 : }
12420 : }
12421 :
12422 347 : if (var_arg == NULL)
12423 : {
12424 1 : gfc_error ("First or last !$OMP ATOMIC intrinsic argument must "
12425 : "be %qs at %L", var->name, &stmt_expr2->where);
12426 1 : return;
12427 : }
12428 :
12429 346 : if (var_arg != stmt_expr2->value.function.actual)
12430 : {
12431 : /* Canonicalize, so that var comes first. */
12432 172 : gcc_assert (var_arg->next == NULL);
12433 : for (arg = stmt_expr2->value.function.actual;
12434 185 : arg->next != var_arg; arg = arg->next)
12435 : ;
12436 172 : var_arg->next = stmt_expr2->value.function.actual;
12437 172 : stmt_expr2->value.function.actual = var_arg;
12438 172 : arg->next = NULL;
12439 : }
12440 : }
12441 : else
12442 1 : gfc_error ("!$OMP ATOMIC assignment must have an operator or "
12443 : "intrinsic on right hand side at %L", &stmt_expr2->where);
12444 : return;
12445 :
12446 4 : unexpected:
12447 4 : gfc_error ("unexpected !$OMP ATOMIC expression at %L",
12448 : loc ? loc : &code->loc);
12449 4 : return;
12450 : }
12451 :
12452 :
12453 : static struct fortran_omp_context
12454 : {
12455 : gfc_code *code;
12456 : hash_set<gfc_symbol *> *sharing_clauses;
12457 : hash_set<gfc_symbol *> *private_iterators;
12458 : struct fortran_omp_context *previous;
12459 : bool is_openmp;
12460 : } *omp_current_ctx;
12461 : static gfc_code *omp_current_do_code;
12462 : static int omp_current_do_collapse;
12463 :
12464 : /* Forward declaration for mutually recursive functions. */
12465 : static gfc_code *
12466 : find_nested_loop_in_block (gfc_code *block);
12467 :
12468 : /* Return the first nested DO loop in CHAIN, or NULL if there
12469 : isn't one. Does no error checking on intervening code. */
12470 :
12471 : static gfc_code *
12472 27482 : find_nested_loop_in_chain (gfc_code *chain)
12473 : {
12474 27482 : gfc_code *code;
12475 :
12476 27482 : if (!chain)
12477 : return NULL;
12478 :
12479 31643 : for (code = chain; code; code = code->next)
12480 31222 : switch (code->op)
12481 : {
12482 : case EXEC_DO:
12483 : case EXEC_OMP_TILE:
12484 : case EXEC_OMP_UNROLL:
12485 : return code;
12486 621 : case EXEC_BLOCK:
12487 621 : if (gfc_code *c = find_nested_loop_in_block (code))
12488 : return c;
12489 : break;
12490 : default:
12491 : break;
12492 : }
12493 : return NULL;
12494 : }
12495 :
12496 : /* Return the first nested DO loop in BLOCK, or NULL if there
12497 : isn't one. Does no error checking on intervening code. */
12498 : static gfc_code *
12499 939 : find_nested_loop_in_block (gfc_code *block)
12500 : {
12501 939 : gfc_namespace *ns;
12502 939 : gcc_assert (block->op == EXEC_BLOCK);
12503 939 : ns = block->ext.block.ns;
12504 939 : gcc_assert (ns);
12505 939 : return find_nested_loop_in_chain (ns->code);
12506 : }
12507 :
12508 : void
12509 5441 : gfc_resolve_omp_do_blocks (gfc_code *code, gfc_namespace *ns)
12510 : {
12511 5441 : if (code->block->next && code->block->next->op == EXEC_DO)
12512 : {
12513 5088 : int i;
12514 :
12515 5088 : omp_current_do_code = code->block->next;
12516 5088 : if (code->ext.omp_clauses->orderedc)
12517 142 : omp_current_do_collapse = code->ext.omp_clauses->orderedc;
12518 4946 : else if (code->ext.omp_clauses->collapse)
12519 1121 : omp_current_do_collapse = code->ext.omp_clauses->collapse;
12520 3825 : else if (code->ext.omp_clauses->sizes_list)
12521 175 : omp_current_do_collapse
12522 175 : = gfc_expr_list_len (code->ext.omp_clauses->sizes_list);
12523 : else
12524 3650 : omp_current_do_collapse = 1;
12525 5088 : if (code->ext.omp_clauses->lists[OMP_LIST_REDUCTION_INSCAN])
12526 : {
12527 : /* Checking that there is a matching EXEC_OMP_SCAN in the
12528 : innermost body cannot be deferred to resolve_omp_do because
12529 : we process directives nested in the loop before we get
12530 : there. */
12531 60 : locus *loc
12532 : = &code->ext.omp_clauses->lists[OMP_LIST_REDUCTION_INSCAN]->where;
12533 60 : gfc_code *c;
12534 :
12535 80 : for (i = 1, c = omp_current_do_code;
12536 80 : i < omp_current_do_collapse; i++)
12537 : {
12538 22 : c = find_nested_loop_in_chain (c->block->next);
12539 22 : if (!c || c->op != EXEC_DO || c->block == NULL)
12540 : break;
12541 : }
12542 :
12543 : /* Skip this if we don't have enough nested loops. That
12544 : problem will be diagnosed elsewhere. */
12545 60 : if (c && c->op == EXEC_DO)
12546 : {
12547 58 : gfc_code *block = c->block ? c->block->next : NULL;
12548 58 : if (block && block->op != EXEC_OMP_SCAN)
12549 54 : while (block && block->next
12550 54 : && block->next->op != EXEC_OMP_SCAN)
12551 : block = block->next;
12552 43 : if (!block
12553 46 : || (block->op != EXEC_OMP_SCAN
12554 43 : && (!block->next || block->next->op != EXEC_OMP_SCAN)))
12555 19 : gfc_error ("With INSCAN at %L, expected loop body with "
12556 : "!$OMP SCAN between two "
12557 : "structured block sequences", loc);
12558 : else
12559 : {
12560 39 : if (block->op == EXEC_OMP_SCAN)
12561 3 : gfc_warning (OPT_Wopenmp,
12562 : "!$OMP SCAN at %L with zero executable "
12563 : "statements in preceding structured block "
12564 : "sequence", &block->loc);
12565 39 : if ((block->op == EXEC_OMP_SCAN && !block->next)
12566 38 : || (block->next && block->next->op == EXEC_OMP_SCAN
12567 36 : && !block->next->next))
12568 3 : gfc_warning (OPT_Wopenmp,
12569 : "!$OMP SCAN at %L with zero executable "
12570 : "statements in succeeding structured block "
12571 : "sequence", block->op == EXEC_OMP_SCAN
12572 1 : ? &block->loc : &block->next->loc);
12573 : }
12574 58 : if (block && block->op != EXEC_OMP_SCAN)
12575 43 : block = block->next;
12576 46 : if (block && block->op == EXEC_OMP_SCAN)
12577 : /* Mark 'omp scan' as checked; flag will be unset later. */
12578 39 : block->ext.omp_clauses->if_present = true;
12579 : }
12580 : }
12581 : }
12582 5441 : gfc_resolve_blocks (code->block, ns);
12583 5441 : omp_current_do_collapse = 0;
12584 5441 : omp_current_do_code = NULL;
12585 5441 : }
12586 :
12587 :
12588 : void
12589 6114 : gfc_resolve_omp_parallel_blocks (gfc_code *code, gfc_namespace *ns)
12590 : {
12591 6114 : struct fortran_omp_context ctx;
12592 6114 : gfc_omp_clauses *omp_clauses = code->ext.omp_clauses;
12593 6114 : gfc_omp_namelist *n;
12594 :
12595 6114 : ctx.code = code;
12596 6114 : ctx.sharing_clauses = new hash_set<gfc_symbol *>;
12597 6114 : ctx.private_iterators = new hash_set<gfc_symbol *>;
12598 6114 : ctx.previous = omp_current_ctx;
12599 6114 : ctx.is_openmp = true;
12600 6114 : omp_current_ctx = &ctx;
12601 :
12602 244560 : for (enum gfc_omp_list_type list = OMP_LIST_FIRST; list < OMP_LIST_NUM;
12603 238446 : list = gfc_omp_list_type (list + 1))
12604 238446 : switch (list)
12605 : {
12606 61140 : case OMP_LIST_SHARED:
12607 61140 : case OMP_LIST_PRIVATE:
12608 61140 : case OMP_LIST_FIRSTPRIVATE:
12609 61140 : case OMP_LIST_LASTPRIVATE:
12610 61140 : case OMP_LIST_REDUCTION:
12611 61140 : case OMP_LIST_REDUCTION_INSCAN:
12612 61140 : case OMP_LIST_REDUCTION_TASK:
12613 61140 : case OMP_LIST_IN_REDUCTION:
12614 61140 : case OMP_LIST_TASK_REDUCTION:
12615 61140 : case OMP_LIST_LINEAR:
12616 70135 : for (n = omp_clauses->lists[list]; n; n = n->next)
12617 8995 : ctx.sharing_clauses->add (n->sym);
12618 : break;
12619 : default:
12620 : break;
12621 : }
12622 :
12623 6114 : switch (code->op)
12624 : {
12625 2368 : case EXEC_OMP_DISTRIBUTE_PARALLEL_DO:
12626 2368 : case EXEC_OMP_DISTRIBUTE_PARALLEL_DO_SIMD:
12627 2368 : case EXEC_OMP_MASKED_TASKLOOP:
12628 2368 : case EXEC_OMP_MASKED_TASKLOOP_SIMD:
12629 2368 : case EXEC_OMP_MASTER_TASKLOOP:
12630 2368 : case EXEC_OMP_MASTER_TASKLOOP_SIMD:
12631 2368 : case EXEC_OMP_PARALLEL_DO:
12632 2368 : case EXEC_OMP_PARALLEL_DO_SIMD:
12633 2368 : case EXEC_OMP_PARALLEL_LOOP:
12634 2368 : case EXEC_OMP_PARALLEL_MASKED_TASKLOOP:
12635 2368 : case EXEC_OMP_PARALLEL_MASKED_TASKLOOP_SIMD:
12636 2368 : case EXEC_OMP_PARALLEL_MASTER_TASKLOOP:
12637 2368 : case EXEC_OMP_PARALLEL_MASTER_TASKLOOP_SIMD:
12638 2368 : case EXEC_OMP_TARGET_PARALLEL_DO:
12639 2368 : case EXEC_OMP_TARGET_PARALLEL_DO_SIMD:
12640 2368 : case EXEC_OMP_TARGET_PARALLEL_LOOP:
12641 2368 : case EXEC_OMP_TARGET_TEAMS_DISTRIBUTE:
12642 2368 : case EXEC_OMP_TARGET_TEAMS_DISTRIBUTE_PARALLEL_DO:
12643 2368 : case EXEC_OMP_TARGET_TEAMS_DISTRIBUTE_PARALLEL_DO_SIMD:
12644 2368 : case EXEC_OMP_TARGET_TEAMS_DISTRIBUTE_SIMD:
12645 2368 : case EXEC_OMP_TARGET_TEAMS_LOOP:
12646 2368 : case EXEC_OMP_TASKLOOP:
12647 2368 : case EXEC_OMP_TASKLOOP_SIMD:
12648 2368 : case EXEC_OMP_TEAMS_DISTRIBUTE:
12649 2368 : case EXEC_OMP_TEAMS_DISTRIBUTE_PARALLEL_DO:
12650 2368 : case EXEC_OMP_TEAMS_DISTRIBUTE_PARALLEL_DO_SIMD:
12651 2368 : case EXEC_OMP_TEAMS_DISTRIBUTE_SIMD:
12652 2368 : case EXEC_OMP_TEAMS_LOOP:
12653 2368 : gfc_resolve_omp_do_blocks (code, ns);
12654 2368 : break;
12655 3746 : default:
12656 3746 : gfc_resolve_blocks (code->block, ns);
12657 : }
12658 :
12659 6114 : omp_current_ctx = ctx.previous;
12660 12228 : delete ctx.sharing_clauses;
12661 12228 : delete ctx.private_iterators;
12662 6114 : }
12663 :
12664 :
12665 : /* Save and clear openmp.cc private state. */
12666 :
12667 : void
12668 302800 : gfc_omp_save_and_clear_state (struct gfc_omp_saved_state *state)
12669 : {
12670 302800 : state->ptrs[0] = omp_current_ctx;
12671 302800 : state->ptrs[1] = omp_current_do_code;
12672 302800 : state->ints[0] = omp_current_do_collapse;
12673 302800 : omp_current_ctx = NULL;
12674 302800 : omp_current_do_code = NULL;
12675 302800 : omp_current_do_collapse = 0;
12676 302800 : }
12677 :
12678 :
12679 : /* Restore openmp.cc private state from the saved state. */
12680 :
12681 : void
12682 302799 : gfc_omp_restore_state (struct gfc_omp_saved_state *state)
12683 : {
12684 302799 : omp_current_ctx = (struct fortran_omp_context *) state->ptrs[0];
12685 302799 : omp_current_do_code = (gfc_code *) state->ptrs[1];
12686 302799 : omp_current_do_collapse = state->ints[0];
12687 302799 : }
12688 :
12689 :
12690 : /* Note a DO iterator variable. This is special in !$omp parallel
12691 : construct, where they are predetermined private. */
12692 :
12693 : void
12694 33424 : gfc_resolve_do_iterator (gfc_code *code, gfc_symbol *sym, bool add_clause)
12695 : {
12696 33424 : if (omp_current_ctx == NULL)
12697 : return;
12698 :
12699 13113 : int i = omp_current_do_collapse;
12700 13113 : gfc_code *c = omp_current_do_code;
12701 :
12702 13113 : if (sym->attr.threadprivate)
12703 : return;
12704 :
12705 : /* !$omp do and !$omp parallel do iteration variable is predetermined
12706 : private just in the !$omp do resp. !$omp parallel do construct,
12707 : with no implications for the outer parallel constructs. */
12708 :
12709 17948 : while (i-- >= 1 && c)
12710 : {
12711 9502 : if (code == c)
12712 : return;
12713 4835 : c = find_nested_loop_in_chain (c->block->next);
12714 4835 : if (c && (c->op == EXEC_OMP_TILE || c->op == EXEC_OMP_UNROLL))
12715 : return;
12716 : }
12717 :
12718 : /* An openacc context may represent a data clause. Abort if so. */
12719 8446 : if (!omp_current_ctx->is_openmp && !oacc_is_loop (omp_current_ctx->code))
12720 : return;
12721 :
12722 7468 : if (omp_current_ctx->sharing_clauses->contains (sym))
12723 : return;
12724 :
12725 6466 : if (! omp_current_ctx->private_iterators->add (sym) && add_clause)
12726 : {
12727 6276 : gfc_omp_clauses *omp_clauses = omp_current_ctx->code->ext.omp_clauses;
12728 6276 : gfc_omp_namelist *p;
12729 :
12730 6276 : p = gfc_get_omp_namelist ();
12731 6276 : p->sym = sym;
12732 6276 : p->where = omp_current_ctx->code->loc;
12733 6276 : p->next = omp_clauses->lists[OMP_LIST_PRIVATE];
12734 6276 : omp_clauses->lists[OMP_LIST_PRIVATE] = p;
12735 : }
12736 : }
12737 :
12738 : static void
12739 775 : handle_local_var (gfc_symbol *sym)
12740 : {
12741 775 : if (sym->attr.flavor != FL_VARIABLE
12742 180 : || sym->as != NULL
12743 139 : || (sym->ts.type != BT_INTEGER && sym->ts.type != BT_REAL))
12744 : return;
12745 72 : gfc_resolve_do_iterator (sym->ns->code, sym, false);
12746 : }
12747 :
12748 : void
12749 350685 : gfc_resolve_omp_local_vars (gfc_namespace *ns)
12750 : {
12751 350685 : if (omp_current_ctx)
12752 469 : gfc_traverse_ns (ns, handle_local_var);
12753 350685 : }
12754 :
12755 :
12756 : /* Error checking on intervening code uses a code walker. */
12757 :
12758 : struct icode_error_state
12759 : {
12760 : const char *name;
12761 : bool errorp;
12762 : gfc_code *nested;
12763 : gfc_code *next;
12764 : };
12765 :
12766 : static int
12767 944 : icode_code_error_callback (gfc_code **codep,
12768 : int *walk_subtrees ATTRIBUTE_UNUSED, void *opaque)
12769 : {
12770 944 : gfc_code *code = *codep;
12771 944 : icode_error_state *state = (icode_error_state *)opaque;
12772 :
12773 : /* gfc_code_walker walks down CODE's next chain as well as
12774 : walking things that are actually nested in CODE. We need to
12775 : special-case traversal of outer blocks, so stop immediately if we
12776 : are heading down such a next chain. */
12777 944 : if (code == state->next)
12778 : return 1;
12779 :
12780 647 : switch (code->op)
12781 : {
12782 1 : case EXEC_DO:
12783 1 : case EXEC_DO_WHILE:
12784 1 : case EXEC_DO_CONCURRENT:
12785 1 : gfc_error ("%s cannot contain loop in intervening code at %L",
12786 : state->name, &code->loc);
12787 1 : state->errorp = true;
12788 1 : break;
12789 0 : case EXEC_CYCLE:
12790 0 : case EXEC_EXIT:
12791 : /* Errors have already been diagnosed in match_exit_cycle. */
12792 0 : state->errorp = true;
12793 0 : break;
12794 : case EXEC_OMP_ASSUME:
12795 : case EXEC_OMP_METADIRECTIVE:
12796 : /* Per OpenMP 6.0, some non-executable directives are allowed in
12797 : intervening code. */
12798 : break;
12799 477 : case EXEC_CALL:
12800 : /* Per OpenMP 5.2, the "omp_" prefix is reserved, so we don't have to
12801 : consider the possibility that some locally-bound definition
12802 : overrides the runtime routine. */
12803 477 : if (code->resolved_sym
12804 477 : && omp_runtime_api_procname (code->resolved_sym->name))
12805 : {
12806 1 : gfc_error ("%s cannot contain OpenMP API call in intervening code "
12807 : "at %L",
12808 : state->name, &code->loc);
12809 1 : state->errorp = true;
12810 : }
12811 : break;
12812 168 : default:
12813 168 : if (code->op >= EXEC_OMP_FIRST_OPENMP_EXEC
12814 168 : && code->op <= EXEC_OMP_LAST_OPENMP_EXEC)
12815 : {
12816 2 : gfc_error ("%s cannot contain OpenMP directive in intervening code "
12817 : "at %L",
12818 : state->name, &code->loc);
12819 2 : state->errorp = true;
12820 : }
12821 : }
12822 : return 0;
12823 : }
12824 :
12825 : static int
12826 1081 : icode_expr_error_callback (gfc_expr **expr,
12827 : int *walk_subtrees ATTRIBUTE_UNUSED, void *opaque)
12828 : {
12829 1081 : icode_error_state *state = (icode_error_state *)opaque;
12830 :
12831 1081 : switch ((*expr)->expr_type)
12832 : {
12833 : /* As for EXPR_CALL with "omp_"-prefixed symbols. */
12834 2 : case EXPR_FUNCTION:
12835 2 : {
12836 2 : gfc_symbol *sym = (*expr)->value.function.esym;
12837 2 : if (sym && omp_runtime_api_procname (sym->name))
12838 : {
12839 1 : gfc_error ("%s cannot contain OpenMP API call in intervening code "
12840 : "at %L",
12841 1 : state->name, &((*expr)->where));
12842 1 : state->errorp = true;
12843 : }
12844 : }
12845 :
12846 : break;
12847 : default:
12848 : break;
12849 : }
12850 :
12851 : /* FIXME: The description of canonical loop form in the OpenMP standard
12852 : also says "array expressions" are not permitted in intervening code.
12853 : That term is not defined in either the OpenMP spec or the Fortran
12854 : standard, although the latter uses it informally to refer to any
12855 : expression that is not scalar-valued. It is also apparently not the
12856 : thing GCC internally calls EXPR_ARRAY. It seems the intent of the
12857 : OpenMP restriction is to disallow elemental operations/intrinsics
12858 : (including things that are not expressions, like assignment
12859 : statements) that generate implicit loops over array operands
12860 : (even if the result is a scalar), but even if the spec said
12861 : that there is no list of all the cases that would be forbidden.
12862 : This is OpenMP issue 3326. */
12863 :
12864 1081 : return 0;
12865 : }
12866 :
12867 : static void
12868 267 : diagnose_intervening_code_errors_1 (gfc_code *chain,
12869 : struct icode_error_state *state)
12870 : {
12871 267 : gfc_code *code;
12872 1080 : for (code = chain; code; code = code->next)
12873 : {
12874 813 : if (code == state->nested)
12875 : /* Do not walk the nested loop or its body, we are only
12876 : interested in intervening code. */
12877 : ;
12878 636 : else if (code->op == EXEC_BLOCK
12879 636 : && find_nested_loop_in_block (code) == state->nested)
12880 : /* This block contains the nested loop, recurse on its
12881 : statements. */
12882 : {
12883 90 : gfc_namespace* ns = code->ext.block.ns;
12884 90 : diagnose_intervening_code_errors_1 (ns->code, state);
12885 : }
12886 : else
12887 : /* Treat the whole statement as a unit. */
12888 : {
12889 546 : gfc_code *temp = state->next;
12890 546 : state->next = code->next;
12891 546 : gfc_code_walker (&code, icode_code_error_callback,
12892 : icode_expr_error_callback, state);
12893 546 : state->next = temp;
12894 : }
12895 : }
12896 267 : }
12897 :
12898 : /* Diagnose intervening code errors in BLOCK with nested loop NESTED.
12899 : NAME is the user-friendly name of the OMP directive, used for error
12900 : messages. Returns true if any error was found. */
12901 : static bool
12902 177 : diagnose_intervening_code_errors (gfc_code *chain, const char *name,
12903 : gfc_code *nested)
12904 : {
12905 177 : struct icode_error_state state;
12906 177 : state.name = name;
12907 177 : state.errorp = false;
12908 177 : state.nested = nested;
12909 177 : state.next = NULL;
12910 0 : diagnose_intervening_code_errors_1 (chain, &state);
12911 177 : return state.errorp;
12912 : }
12913 :
12914 : /* Helper function for restructure_intervening_code: wrap CHAIN in
12915 : a marker to indicate that it is a structured block sequence. That
12916 : information will be used later on (in omp-low.cc) for error checking. */
12917 : static gfc_code *
12918 461 : make_structured_block (gfc_code *chain)
12919 : {
12920 461 : gcc_assert (chain);
12921 461 : gfc_namespace *ns = gfc_build_block_ns (gfc_current_ns);
12922 461 : gfc_code *result = gfc_get_code (EXEC_BLOCK);
12923 461 : result->op = EXEC_BLOCK;
12924 461 : result->ext.block.ns = ns;
12925 461 : result->ext.block.assoc = NULL;
12926 461 : result->loc = chain->loc;
12927 461 : ns->omp_structured_block = 1;
12928 461 : ns->code = chain;
12929 461 : return result;
12930 : }
12931 :
12932 : /* Push intervening code surrounding a loop, including nested scopes,
12933 : into the body of the loop. CHAINP is the pointer to the head of
12934 : the next-chain to scan, OUTER_LOOP is the EXEC_DO for the next outer
12935 : loop level, and COLLAPSE is the number of nested loops we need to
12936 : process.
12937 : Note that CHAINP may point at outer_loop->block->next when we
12938 : are scanning the body of a loop, but if there is an intervening block
12939 : CHAINP points into the block's chain rather than its enclosing outer
12940 : loop. This is why OUTER_LOOP is passed separately. */
12941 : static gfc_code *
12942 7191 : restructure_intervening_code (gfc_code **chainp, gfc_code *outer_loop,
12943 : int count)
12944 : {
12945 7191 : gfc_code *code;
12946 7191 : gfc_code *head = *chainp;
12947 7191 : gfc_code *tail = NULL;
12948 7191 : gfc_code *innermost_loop = NULL;
12949 :
12950 7455 : for (code = *chainp; code; code = code->next, chainp = &(*chainp)->next)
12951 : {
12952 7455 : if (code->op == EXEC_DO)
12953 : {
12954 : /* Cut CODE free from its chain, leaving the ends dangling. */
12955 7107 : *chainp = NULL;
12956 7107 : tail = code->next;
12957 7107 : code->next = NULL;
12958 :
12959 7107 : if (count == 1)
12960 : innermost_loop = code;
12961 : else
12962 2090 : innermost_loop
12963 2090 : = restructure_intervening_code (&code->block->next,
12964 : code, count - 1);
12965 : break;
12966 : }
12967 348 : else if (code->op == EXEC_BLOCK
12968 348 : && find_nested_loop_in_block (code))
12969 : {
12970 84 : gfc_namespace *ns = code->ext.block.ns;
12971 :
12972 : /* Cut CODE free from its chain, leaving the ends dangling. */
12973 84 : *chainp = NULL;
12974 84 : tail = code->next;
12975 84 : code->next = NULL;
12976 :
12977 84 : innermost_loop
12978 84 : = restructure_intervening_code (&ns->code, outer_loop,
12979 : count);
12980 :
12981 : /* At this point we have already pulled out the nested loop and
12982 : pointed outer_loop at it, and moved the intervening code that
12983 : was previously in the block into the body of innermost_loop.
12984 : Now we want to move the BLOCK itself so it wraps the entire
12985 : current body of innermost_loop. */
12986 84 : ns->code = innermost_loop->block->next;
12987 84 : innermost_loop->block->next = code;
12988 84 : break;
12989 : }
12990 : }
12991 :
12992 2174 : gcc_assert (innermost_loop);
12993 :
12994 : /* Now we have split the intervening code into two parts:
12995 : head is the start of the part before the loop/block, terminating
12996 : at *chainp, and tail is the part after it. Mark each part as
12997 : a structured block sequence, and splice the two parts around the
12998 : existing body of the innermost loop. */
12999 7191 : if (head != code)
13000 : {
13001 222 : gfc_code *block = make_structured_block (head);
13002 222 : if (innermost_loop->block->next)
13003 221 : gfc_append_code (block, innermost_loop->block->next);
13004 222 : innermost_loop->block->next = block;
13005 : }
13006 7191 : if (tail)
13007 : {
13008 239 : gfc_code *block = make_structured_block (tail);
13009 239 : if (innermost_loop->block->next)
13010 237 : gfc_append_code (innermost_loop->block->next, block);
13011 : else
13012 2 : innermost_loop->block->next = block;
13013 : }
13014 :
13015 : /* For loops, finally splice CODE into OUTER_LOOP. We already handled
13016 : relinking EXEC_BLOCK above. */
13017 7191 : if (code->op == EXEC_DO && outer_loop)
13018 7107 : outer_loop->block->next = code;
13019 :
13020 7191 : return innermost_loop;
13021 : }
13022 :
13023 : /* CODE is an OMP loop construct. Return true if VAR matches an iteration
13024 : variable outer to level DEPTH. */
13025 : static bool
13026 8104 : is_outer_iteration_variable (gfc_code *code, int depth, gfc_symbol *var)
13027 : {
13028 8104 : int i;
13029 8104 : gfc_code *do_code = code;
13030 :
13031 12631 : for (i = 1; i < depth; i++)
13032 : {
13033 5028 : do_code = find_nested_loop_in_chain (do_code->block->next);
13034 5028 : gcc_assert (do_code);
13035 5028 : if (do_code->op == EXEC_OMP_TILE || do_code->op == EXEC_OMP_UNROLL)
13036 : {
13037 51 : --i;
13038 51 : continue;
13039 : }
13040 4977 : gfc_symbol *ivar = do_code->ext.iterator->var->symtree->n.sym;
13041 4977 : if (var == ivar)
13042 : return true;
13043 : }
13044 : return false;
13045 : }
13046 :
13047 : /* Forward declaration for recursive functions. */
13048 : static gfc_code *
13049 : check_nested_loop_in_block (gfc_code *block, gfc_expr *expr, gfc_symbol *sym,
13050 : bool *bad);
13051 :
13052 : /* Like find_nested_loop_in_chain, but additionally check that EXPR
13053 : does not reference any variables bound in intervening EXEC_BLOCKs
13054 : and that SYM is not bound in such intervening blocks. Either EXPR or SYM
13055 : may be null. Sets *BAD to true if either test fails. */
13056 : static gfc_code *
13057 48249 : check_nested_loop_in_chain (gfc_code *chain, gfc_expr *expr, gfc_symbol *sym,
13058 : bool *bad)
13059 : {
13060 51853 : for (gfc_code *code = chain; code; code = code->next)
13061 : {
13062 51565 : if (code->op == EXEC_DO)
13063 : return code;
13064 4123 : else if (code->op == EXEC_OMP_TILE || code->op == EXEC_OMP_UNROLL)
13065 1682 : return check_nested_loop_in_chain (code->block->next, expr, sym, bad);
13066 2441 : else if (code->op == EXEC_BLOCK)
13067 : {
13068 807 : gfc_code *c = check_nested_loop_in_block (code, expr, sym, bad);
13069 807 : if (c)
13070 : return c;
13071 : }
13072 : }
13073 : return NULL;
13074 : }
13075 :
13076 : /* Code walker for block symtrees. It doesn't take any kind of state
13077 : argument, so use a static variable. */
13078 : static struct check_nested_loop_in_block_state_t {
13079 : gfc_expr *expr;
13080 : gfc_symbol *sym;
13081 : bool *bad;
13082 : } check_nested_loop_in_block_state;
13083 :
13084 : static void
13085 766 : check_nested_loop_in_block_symbol (gfc_symbol *sym)
13086 : {
13087 766 : if (sym == check_nested_loop_in_block_state.sym
13088 766 : || (check_nested_loop_in_block_state.expr
13089 567 : && gfc_find_sym_in_expr (sym,
13090 : check_nested_loop_in_block_state.expr)))
13091 5 : *check_nested_loop_in_block_state.bad = true;
13092 766 : }
13093 :
13094 : /* Return the first nested DO loop in BLOCK, or NULL if there
13095 : isn't one. Set *BAD to true if EXPR references any variables in BLOCK, or
13096 : SYM is bound in BLOCK. Either EXPR or SYM may be null. */
13097 : static gfc_code *
13098 807 : check_nested_loop_in_block (gfc_code *block, gfc_expr *expr,
13099 : gfc_symbol *sym, bool *bad)
13100 : {
13101 807 : gfc_namespace *ns;
13102 807 : gcc_assert (block->op == EXEC_BLOCK);
13103 807 : ns = block->ext.block.ns;
13104 807 : gcc_assert (ns);
13105 :
13106 : /* Skip the check if this block doesn't contain the nested loop, or
13107 : if we already know it's bad. */
13108 807 : gfc_code *result = check_nested_loop_in_chain (ns->code, expr, sym, bad);
13109 807 : if (result && !*bad)
13110 : {
13111 519 : check_nested_loop_in_block_state.expr = expr;
13112 519 : check_nested_loop_in_block_state.sym = sym;
13113 519 : check_nested_loop_in_block_state.bad = bad;
13114 519 : gfc_traverse_ns (ns, check_nested_loop_in_block_symbol);
13115 519 : check_nested_loop_in_block_state.expr = NULL;
13116 519 : check_nested_loop_in_block_state.sym = NULL;
13117 519 : check_nested_loop_in_block_state.bad = NULL;
13118 : }
13119 807 : return result;
13120 : }
13121 :
13122 : /* CODE is an OMP loop construct. Return true if EXPR references
13123 : any variables bound in intervening code, to level DEPTH. */
13124 : static bool
13125 22780 : expr_uses_intervening_var (gfc_code *code, int depth, gfc_expr *expr)
13126 : {
13127 22780 : int i;
13128 22780 : gfc_code *do_code = code;
13129 :
13130 58339 : for (i = 0; i < depth; i++)
13131 : {
13132 35562 : bool bad = false;
13133 35562 : do_code = check_nested_loop_in_chain (do_code->block->next,
13134 : expr, NULL, &bad);
13135 35562 : if (bad)
13136 3 : return true;
13137 : }
13138 : return false;
13139 : }
13140 :
13141 : /* CODE is an OMP loop construct. Return true if SYM is bound in
13142 : intervening code, to level DEPTH. */
13143 : static bool
13144 7603 : is_intervening_var (gfc_code *code, int depth, gfc_symbol *sym)
13145 : {
13146 7603 : int i;
13147 7603 : gfc_code *do_code = code;
13148 :
13149 19481 : for (i = 0; i < depth; i++)
13150 : {
13151 11880 : bool bad = false;
13152 11880 : do_code = check_nested_loop_in_chain (do_code->block->next,
13153 : NULL, sym, &bad);
13154 11880 : if (bad)
13155 2 : return true;
13156 : }
13157 : return false;
13158 : }
13159 :
13160 : /* CODE is an OMP loop construct. Return true if EXPR does not reference
13161 : any iteration variables outer to level DEPTH. */
13162 : static bool
13163 23859 : expr_is_invariant (gfc_code *code, int depth, gfc_expr *expr)
13164 : {
13165 23859 : int i;
13166 23859 : gfc_code *do_code = code;
13167 :
13168 37181 : for (i = 1; i < depth; i++)
13169 : {
13170 14388 : do_code = find_nested_loop_in_chain (do_code->block->next);
13171 14388 : gcc_assert (do_code);
13172 14388 : if (do_code->op == EXEC_OMP_TILE || do_code->op == EXEC_OMP_UNROLL)
13173 : {
13174 136 : --i;
13175 136 : continue;
13176 : }
13177 14252 : gfc_symbol *ivar = do_code->ext.iterator->var->symtree->n.sym;
13178 14252 : if (gfc_find_sym_in_expr (ivar, expr))
13179 : return false;
13180 : }
13181 : return true;
13182 : }
13183 :
13184 : /* CODE is an OMP loop construct. Return true if EXPR matches one of the
13185 : canonical forms for a bound expression. It may include references to
13186 : an iteration variable outer to level DEPTH; set OUTER_VARP if so. */
13187 : static bool
13188 15197 : bound_expr_is_canonical (gfc_code *code, int depth, gfc_expr *expr,
13189 : gfc_symbol **outer_varp)
13190 : {
13191 15197 : gfc_expr *expr2 = NULL;
13192 :
13193 : /* Rectangular case. */
13194 15197 : if (depth == 0 || expr_is_invariant (code, depth, expr))
13195 : return true;
13196 :
13197 : /* Any simple variable that didn't pass expr_is_invariant must be
13198 : an outer_var. */
13199 568 : if (expr->expr_type == EXPR_VARIABLE && expr->rank == 0)
13200 : {
13201 63 : *outer_varp = expr->symtree->n.sym;
13202 63 : return true;
13203 : }
13204 :
13205 : /* All other permitted forms are binary operators. */
13206 505 : if (expr->expr_type != EXPR_OP)
13207 : return false;
13208 :
13209 : /* Check for plus/minus a loop invariant expr. */
13210 503 : if (expr->value.op.op == INTRINSIC_PLUS
13211 503 : || expr->value.op.op == INTRINSIC_MINUS)
13212 : {
13213 483 : if (expr_is_invariant (code, depth, expr->value.op.op1))
13214 48 : expr2 = expr->value.op.op2;
13215 435 : else if (expr_is_invariant (code, depth, expr->value.op.op2))
13216 434 : expr2 = expr->value.op.op1;
13217 : else
13218 : return false;
13219 : }
13220 : else
13221 : expr2 = expr;
13222 :
13223 : /* Check for a product with a loop-invariant expr. */
13224 502 : if (expr2->expr_type == EXPR_OP
13225 96 : && expr2->value.op.op == INTRINSIC_TIMES)
13226 : {
13227 96 : if (expr_is_invariant (code, depth, expr2->value.op.op1))
13228 40 : expr2 = expr2->value.op.op2;
13229 56 : else if (expr_is_invariant (code, depth, expr2->value.op.op2))
13230 53 : expr2 = expr2->value.op.op1;
13231 : else
13232 : return false;
13233 : }
13234 :
13235 : /* What's left must be a reference to an outer loop variable. */
13236 499 : if (expr2->expr_type == EXPR_VARIABLE
13237 499 : && expr2->rank == 0
13238 998 : && is_outer_iteration_variable (code, depth, expr2->symtree->n.sym))
13239 : {
13240 499 : *outer_varp = expr2->symtree->n.sym;
13241 499 : return true;
13242 : }
13243 :
13244 : return false;
13245 : }
13246 :
13247 : static void
13248 5441 : resolve_omp_do (gfc_code *code)
13249 : {
13250 5441 : gfc_code *do_code, *next;
13251 5441 : int i, count, non_generated_count;
13252 5441 : gfc_omp_namelist *n;
13253 5441 : gfc_symbol *dovar;
13254 5441 : const char *name;
13255 5441 : bool is_simd = false;
13256 5441 : bool errorp = false;
13257 5441 : bool perfect_nesting_errorp = false;
13258 5441 : bool imperfect = false;
13259 :
13260 5441 : switch (code->op)
13261 : {
13262 : case EXEC_OMP_DISTRIBUTE: name = "!$OMP DISTRIBUTE"; break;
13263 49 : case EXEC_OMP_DISTRIBUTE_PARALLEL_DO:
13264 49 : name = "!$OMP DISTRIBUTE PARALLEL DO";
13265 49 : break;
13266 32 : case EXEC_OMP_DISTRIBUTE_PARALLEL_DO_SIMD:
13267 32 : name = "!$OMP DISTRIBUTE PARALLEL DO SIMD";
13268 32 : is_simd = true;
13269 32 : break;
13270 50 : case EXEC_OMP_DISTRIBUTE_SIMD:
13271 50 : name = "!$OMP DISTRIBUTE SIMD";
13272 50 : is_simd = true;
13273 50 : break;
13274 1338 : case EXEC_OMP_DO: name = "!$OMP DO"; break;
13275 136 : case EXEC_OMP_DO_SIMD: name = "!$OMP DO SIMD"; is_simd = true; break;
13276 64 : case EXEC_OMP_LOOP: name = "!$OMP LOOP"; break;
13277 1220 : case EXEC_OMP_PARALLEL_DO: name = "!$OMP PARALLEL DO"; break;
13278 304 : case EXEC_OMP_PARALLEL_DO_SIMD:
13279 304 : name = "!$OMP PARALLEL DO SIMD";
13280 304 : is_simd = true;
13281 304 : break;
13282 46 : case EXEC_OMP_PARALLEL_LOOP: name = "!$OMP PARALLEL LOOP"; break;
13283 7 : case EXEC_OMP_PARALLEL_MASKED_TASKLOOP:
13284 7 : name = "!$OMP PARALLEL MASKED TASKLOOP";
13285 7 : break;
13286 10 : case EXEC_OMP_PARALLEL_MASKED_TASKLOOP_SIMD:
13287 10 : name = "!$OMP PARALLEL MASKED TASKLOOP SIMD";
13288 10 : is_simd = true;
13289 10 : break;
13290 12 : case EXEC_OMP_PARALLEL_MASTER_TASKLOOP:
13291 12 : name = "!$OMP PARALLEL MASTER TASKLOOP";
13292 12 : break;
13293 18 : case EXEC_OMP_PARALLEL_MASTER_TASKLOOP_SIMD:
13294 18 : name = "!$OMP PARALLEL MASTER TASKLOOP SIMD";
13295 18 : is_simd = true;
13296 18 : break;
13297 8 : case EXEC_OMP_MASKED_TASKLOOP: name = "!$OMP MASKED TASKLOOP"; break;
13298 14 : case EXEC_OMP_MASKED_TASKLOOP_SIMD:
13299 14 : name = "!$OMP MASKED TASKLOOP SIMD";
13300 14 : is_simd = true;
13301 14 : break;
13302 14 : case EXEC_OMP_MASTER_TASKLOOP: name = "!$OMP MASTER TASKLOOP"; break;
13303 19 : case EXEC_OMP_MASTER_TASKLOOP_SIMD:
13304 19 : name = "!$OMP MASTER TASKLOOP SIMD";
13305 19 : is_simd = true;
13306 19 : break;
13307 786 : case EXEC_OMP_SIMD: name = "!$OMP SIMD"; is_simd = true; break;
13308 88 : case EXEC_OMP_TARGET_PARALLEL_DO: name = "!$OMP TARGET PARALLEL DO"; break;
13309 20 : case EXEC_OMP_TARGET_PARALLEL_DO_SIMD:
13310 20 : name = "!$OMP TARGET PARALLEL DO SIMD";
13311 20 : is_simd = true;
13312 20 : break;
13313 16 : case EXEC_OMP_TARGET_PARALLEL_LOOP:
13314 16 : name = "!$OMP TARGET PARALLEL LOOP";
13315 16 : break;
13316 33 : case EXEC_OMP_TARGET_SIMD:
13317 33 : name = "!$OMP TARGET SIMD";
13318 33 : is_simd = true;
13319 33 : break;
13320 20 : case EXEC_OMP_TARGET_TEAMS_DISTRIBUTE:
13321 20 : name = "!$OMP TARGET TEAMS DISTRIBUTE";
13322 20 : break;
13323 77 : case EXEC_OMP_TARGET_TEAMS_DISTRIBUTE_PARALLEL_DO:
13324 77 : name = "!$OMP TARGET TEAMS DISTRIBUTE PARALLEL DO";
13325 77 : break;
13326 38 : case EXEC_OMP_TARGET_TEAMS_DISTRIBUTE_PARALLEL_DO_SIMD:
13327 38 : name = "!$OMP TARGET TEAMS DISTRIBUTE PARALLEL DO SIMD";
13328 38 : is_simd = true;
13329 38 : break;
13330 20 : case EXEC_OMP_TARGET_TEAMS_DISTRIBUTE_SIMD:
13331 20 : name = "!$OMP TARGET TEAMS DISTRIBUTE SIMD";
13332 20 : is_simd = true;
13333 20 : break;
13334 19 : case EXEC_OMP_TARGET_TEAMS_LOOP: name = "!$OMP TARGET TEAMS LOOP"; break;
13335 69 : case EXEC_OMP_TASKLOOP: name = "!$OMP TASKLOOP"; break;
13336 38 : case EXEC_OMP_TASKLOOP_SIMD:
13337 38 : name = "!$OMP TASKLOOP SIMD";
13338 38 : is_simd = true;
13339 38 : break;
13340 20 : case EXEC_OMP_TEAMS_DISTRIBUTE: name = "!$OMP TEAMS DISTRIBUTE"; break;
13341 39 : case EXEC_OMP_TEAMS_DISTRIBUTE_PARALLEL_DO:
13342 39 : name = "!$OMP TEAMS DISTRIBUTE PARALLEL DO";
13343 39 : break;
13344 61 : case EXEC_OMP_TEAMS_DISTRIBUTE_PARALLEL_DO_SIMD:
13345 61 : name = "!$OMP TEAMS DISTRIBUTE PARALLEL DO SIMD";
13346 61 : is_simd = true;
13347 61 : break;
13348 42 : case EXEC_OMP_TEAMS_DISTRIBUTE_SIMD:
13349 42 : name = "!$OMP TEAMS DISTRIBUTE SIMD";
13350 42 : is_simd = true;
13351 42 : break;
13352 48 : case EXEC_OMP_TEAMS_LOOP: name = "!$OMP TEAMS LOOP"; break;
13353 195 : case EXEC_OMP_TILE: name = "!$OMP TILE"; break;
13354 417 : case EXEC_OMP_UNROLL: name = "!$OMP UNROLL"; break;
13355 0 : default: gcc_unreachable ();
13356 : }
13357 :
13358 5441 : if (code->ext.omp_clauses)
13359 5441 : resolve_omp_clauses (code, code->ext.omp_clauses, NULL);
13360 :
13361 5441 : if (code->op == EXEC_OMP_TILE && code->ext.omp_clauses->sizes_list == NULL)
13362 0 : gfc_error ("SIZES clause is required on !$OMP TILE construct at %L",
13363 : &code->loc);
13364 :
13365 5441 : do_code = code->block->next;
13366 5441 : if (code->ext.omp_clauses->orderedc)
13367 : count = code->ext.omp_clauses->orderedc;
13368 5297 : else if (code->ext.omp_clauses->sizes_list)
13369 195 : count = gfc_expr_list_len (code->ext.omp_clauses->sizes_list);
13370 : else
13371 : {
13372 5102 : count = code->ext.omp_clauses->collapse;
13373 5102 : if (count <= 0)
13374 : count = 1;
13375 : }
13376 :
13377 5441 : non_generated_count = count;
13378 : /* While the spec defines the loop nest depth independently of the COLLAPSE
13379 : clause, in practice the middle end only pays attention to the COLLAPSE
13380 : depth and treats any further inner loops as the final-loop-body. So
13381 : here we also check canonical loop nest form only for the number of
13382 : outer loops specified by the COLLAPSE clause too. */
13383 8081 : for (i = 1; i <= count; i++)
13384 : {
13385 8081 : gfc_symbol *start_var = NULL, *end_var = NULL;
13386 : /* Parse errors are not recoverable. */
13387 8081 : if (do_code->op == EXEC_DO_WHILE)
13388 : {
13389 6 : gfc_error ("%s cannot be a DO WHILE or DO without loop control "
13390 : "at %L", name, &do_code->loc);
13391 106 : goto fail;
13392 : }
13393 8075 : if (do_code->op == EXEC_DO_CONCURRENT)
13394 : {
13395 4 : gfc_error ("%s cannot be a DO CONCURRENT loop at %L", name,
13396 : &do_code->loc);
13397 4 : goto fail;
13398 : }
13399 8071 : if (do_code->op == EXEC_OMP_TILE || do_code->op == EXEC_OMP_UNROLL)
13400 : {
13401 466 : if (do_code->op == EXEC_OMP_UNROLL)
13402 : {
13403 308 : if (!do_code->ext.omp_clauses->partial)
13404 : {
13405 53 : gfc_error ("Generated loop of UNROLL construct at %L "
13406 : "without PARTIAL clause does not have "
13407 : "canonical form", &do_code->loc);
13408 53 : goto fail;
13409 : }
13410 255 : else if (i != count)
13411 : {
13412 5 : gfc_error ("UNROLL construct at %L with PARTIAL clause "
13413 : "generates just one loop with canonical form "
13414 : "but %d loops are needed",
13415 5 : &do_code->loc, count - i + 1);
13416 5 : goto fail;
13417 : }
13418 : }
13419 158 : else if (do_code->op == EXEC_OMP_TILE)
13420 : {
13421 158 : if (do_code->ext.omp_clauses->sizes_list == NULL)
13422 : /* This should have been diagnosed earlier already. */
13423 0 : return;
13424 158 : int l = gfc_expr_list_len (do_code->ext.omp_clauses->sizes_list);
13425 158 : if (count - i + 1 > l)
13426 : {
13427 14 : gfc_error ("TILE construct at %L generates %d loops "
13428 : "with canonical form but %d loops are needed",
13429 : &do_code->loc, l, count - i + 1);
13430 14 : goto fail;
13431 : }
13432 : }
13433 394 : if (do_code->ext.omp_clauses && do_code->ext.omp_clauses->erroneous)
13434 17 : goto fail;
13435 377 : if (imperfect && !perfect_nesting_errorp)
13436 : {
13437 4 : sorry_at (gfc_get_location (&do_code->loc),
13438 : "Imperfectly nested loop using generated loops");
13439 4 : errorp = true;
13440 : }
13441 377 : if (non_generated_count == count)
13442 329 : non_generated_count = i - 1;
13443 377 : --i;
13444 377 : do_code = do_code->block->next;
13445 377 : continue;
13446 377 : }
13447 7605 : gcc_assert (do_code->op == EXEC_DO);
13448 7605 : if (do_code->ext.iterator->var->ts.type != BT_INTEGER)
13449 : {
13450 3 : gfc_error ("%s iteration variable must be of type integer at %L",
13451 : name, &do_code->loc);
13452 3 : errorp = true;
13453 : }
13454 7605 : dovar = do_code->ext.iterator->var->symtree->n.sym;
13455 7605 : if (dovar->attr.threadprivate)
13456 : {
13457 0 : gfc_error ("%s iteration variable must not be THREADPRIVATE "
13458 : "at %L", name, &do_code->loc);
13459 0 : errorp = true;
13460 : }
13461 7605 : if (code->ext.omp_clauses)
13462 304200 : for (enum gfc_omp_list_type list = OMP_LIST_FIRST; list < OMP_LIST_NUM;
13463 296595 : list = gfc_omp_list_type (list + 1))
13464 97773 : if (!is_simd || code->ext.omp_clauses->collapse > 1
13465 296595 : ? (list != OMP_LIST_PRIVATE && list != OMP_LIST_LASTPRIVATE
13466 255177 : && list != OMP_LIST_ALLOCATE)
13467 41418 : : (list != OMP_LIST_PRIVATE && list != OMP_LIST_LASTPRIVATE
13468 41418 : && list != OMP_LIST_ALLOCATE && list != OMP_LIST_LINEAR))
13469 277104 : for (n = code->ext.omp_clauses->lists[list]; n; n = n->next)
13470 4386 : if (dovar == n->sym)
13471 : {
13472 5 : if (!is_simd || code->ext.omp_clauses->collapse > 1)
13473 4 : gfc_error ("%s iteration variable present on clause "
13474 : "other than PRIVATE, LASTPRIVATE or "
13475 : "ALLOCATE at %L", name, &do_code->loc);
13476 : else
13477 1 : gfc_error ("%s iteration variable present on clause "
13478 : "other than PRIVATE, LASTPRIVATE, ALLOCATE or "
13479 : "LINEAR at %L", name, &do_code->loc);
13480 : errorp = true;
13481 : }
13482 7605 : if (is_outer_iteration_variable (code, i, dovar))
13483 : {
13484 2 : gfc_error ("%s iteration variable used in more than one loop at %L",
13485 : name, &do_code->loc);
13486 2 : errorp = true;
13487 : }
13488 7603 : else if (is_intervening_var (code, i, dovar))
13489 : {
13490 2 : gfc_error ("%s iteration variable at %L is bound in "
13491 : "intervening code",
13492 : name, &do_code->loc);
13493 2 : errorp = true;
13494 : }
13495 7601 : else if (!bound_expr_is_canonical (code, i,
13496 7601 : do_code->ext.iterator->start,
13497 : &start_var))
13498 : {
13499 4 : gfc_error ("%s loop start expression not in canonical form at %L",
13500 : name, &do_code->loc);
13501 4 : errorp = true;
13502 : }
13503 7597 : else if (expr_uses_intervening_var (code, i,
13504 7597 : do_code->ext.iterator->start))
13505 : {
13506 1 : gfc_error ("%s loop start expression at %L uses variable bound in "
13507 : "intervening code",
13508 : name, &do_code->loc);
13509 1 : errorp = true;
13510 : }
13511 7596 : else if (!bound_expr_is_canonical (code, i,
13512 7596 : do_code->ext.iterator->end,
13513 : &end_var))
13514 : {
13515 2 : gfc_error ("%s loop end expression not in canonical form at %L",
13516 : name, &do_code->loc);
13517 2 : errorp = true;
13518 : }
13519 7594 : else if (expr_uses_intervening_var (code, i,
13520 7594 : do_code->ext.iterator->end))
13521 : {
13522 1 : gfc_error ("%s loop end expression at %L uses variable bound in "
13523 : "intervening code",
13524 : name, &do_code->loc);
13525 1 : errorp = true;
13526 : }
13527 7593 : else if (start_var && end_var && start_var != end_var)
13528 : {
13529 1 : gfc_error ("%s loop bounds reference different "
13530 : "iteration variables at %L", name, &do_code->loc);
13531 1 : errorp = true;
13532 : }
13533 7592 : else if (!expr_is_invariant (code, i, do_code->ext.iterator->step))
13534 : {
13535 3 : gfc_error ("%s loop increment not in canonical form at %L",
13536 : name, &do_code->loc);
13537 3 : errorp = true;
13538 : }
13539 7589 : else if (expr_uses_intervening_var (code, i,
13540 7589 : do_code->ext.iterator->step))
13541 : {
13542 1 : gfc_error ("%s loop increment expression at %L uses variable "
13543 : "bound in intervening code",
13544 : name, &do_code->loc);
13545 1 : errorp = true;
13546 : }
13547 7605 : if (start_var || end_var)
13548 : {
13549 528 : code->ext.omp_clauses->non_rectangular = 1;
13550 528 : if (i > non_generated_count)
13551 : {
13552 3 : sorry_at (gfc_get_location (&do_code->loc),
13553 : "Non-rectangular loops from generated loops "
13554 : "unsupported");
13555 3 : errorp = true;
13556 : }
13557 : }
13558 :
13559 : /* Only parse loop body into nested loop and intervening code if
13560 : there are supposed to be more loops in the nest to collapse. */
13561 7605 : if (i == count)
13562 : break;
13563 :
13564 2270 : next = find_nested_loop_in_chain (do_code->block->next);
13565 :
13566 2270 : if (!next)
13567 : {
13568 : /* Parse error, can't recover from this. */
13569 7 : gfc_error ("not enough DO loops for collapsed %s (level %d) at %L",
13570 : name, i, &code->loc);
13571 7 : goto fail;
13572 : }
13573 2263 : else if (next != do_code->block->next
13574 2103 : || (next->next && next->next->op != EXEC_CONTINUE))
13575 : /* Imperfectly nested loop found. */
13576 : {
13577 : /* Only diagnose violation of imperfect nesting constraints once. */
13578 177 : if (!perfect_nesting_errorp)
13579 : {
13580 176 : if (code->ext.omp_clauses->orderedc)
13581 : {
13582 3 : gfc_error ("%s inner loops must be perfectly nested with "
13583 : "ORDERED clause at %L",
13584 : name, &code->loc);
13585 3 : perfect_nesting_errorp = true;
13586 : }
13587 173 : else if (code->ext.omp_clauses->lists[OMP_LIST_REDUCTION_INSCAN])
13588 : {
13589 2 : gfc_error ("%s inner loops must be perfectly nested with "
13590 : "REDUCTION INSCAN clause at %L",
13591 : name, &code->loc);
13592 2 : perfect_nesting_errorp = true;
13593 : }
13594 171 : else if (code->op == EXEC_OMP_TILE)
13595 : {
13596 8 : gfc_error ("%s inner loops must be perfectly nested at %L",
13597 : name, &code->loc);
13598 8 : perfect_nesting_errorp = true;
13599 : }
13600 13 : if (perfect_nesting_errorp)
13601 : errorp = true;
13602 : }
13603 177 : if (diagnose_intervening_code_errors (do_code->block->next,
13604 : name, next))
13605 5 : errorp = true;
13606 : imperfect = true;
13607 : }
13608 2263 : do_code = next;
13609 : }
13610 :
13611 : /* Give up now if we found any constraint violations. */
13612 5335 : if (errorp)
13613 : {
13614 48 : fail:
13615 154 : if (code->ext.omp_clauses)
13616 154 : code->ext.omp_clauses->erroneous = 1;
13617 : return;
13618 : }
13619 :
13620 5287 : if (non_generated_count)
13621 5017 : restructure_intervening_code (&code->block->next, code,
13622 : non_generated_count);
13623 : }
13624 :
13625 : /* Resolve the context selector. In particular, SKIP_P is set to true,
13626 : the context can never be matched. */
13627 :
13628 : static void
13629 785 : gfc_resolve_omp_context_selector (gfc_omp_set_selector *oss,
13630 : bool is_metadirective, bool *skip_p)
13631 : {
13632 785 : if (skip_p)
13633 324 : *skip_p = false;
13634 1488 : for (gfc_omp_set_selector *set_selector = oss; set_selector;
13635 703 : set_selector = set_selector->next)
13636 1514 : for (gfc_omp_selector *os = set_selector->trait_selectors; os; os = os->next)
13637 : {
13638 829 : if (os->score)
13639 : {
13640 52 : if (!gfc_resolve_expr (os->score)
13641 52 : || os->score->ts.type != BT_INTEGER
13642 104 : || os->score->rank != 0)
13643 : {
13644 0 : gfc_error ("%<score%> argument must be constant integer "
13645 0 : "expression at %L", &os->score->where);
13646 0 : gfc_free_expr (os->score);
13647 0 : os->score = nullptr;
13648 : }
13649 52 : else if (os->score->expr_type == EXPR_CONSTANT
13650 52 : && mpz_sgn (os->score->value.integer) < 0)
13651 : {
13652 1 : gfc_error ("%<score%> argument must be non-negative at %L",
13653 : &os->score->where);
13654 1 : gfc_free_expr (os->score);
13655 1 : os->score = nullptr;
13656 : }
13657 : }
13658 :
13659 829 : if (os->code == OMP_TRAIT_INVALID)
13660 : break;
13661 811 : enum omp_tp_type property_kind = omp_ts_map[os->code].tp_type;
13662 811 : gfc_omp_trait_property *otp = os->properties;
13663 :
13664 811 : if (!otp)
13665 415 : continue;
13666 396 : switch (property_kind)
13667 : {
13668 148 : case OMP_TRAIT_PROPERTY_DEV_NUM_EXPR:
13669 148 : case OMP_TRAIT_PROPERTY_BOOL_EXPR:
13670 148 : if (!gfc_resolve_expr (otp->expr)
13671 147 : || (property_kind == OMP_TRAIT_PROPERTY_BOOL_EXPR
13672 133 : && otp->expr->ts.type != BT_LOGICAL)
13673 146 : || (property_kind == OMP_TRAIT_PROPERTY_DEV_NUM_EXPR
13674 14 : && otp->expr->ts.type != BT_INTEGER)
13675 146 : || otp->expr->rank != 0
13676 294 : || (!is_metadirective && otp->expr->expr_type != EXPR_CONSTANT))
13677 : {
13678 3 : if (is_metadirective)
13679 : {
13680 0 : if (property_kind == OMP_TRAIT_PROPERTY_BOOL_EXPR)
13681 0 : gfc_error ("property must be a "
13682 : "logical expression at %L",
13683 0 : &otp->expr->where);
13684 : else
13685 0 : gfc_error ("property must be an "
13686 : "integer expression at %L",
13687 0 : &otp->expr->where);
13688 : }
13689 : else
13690 : {
13691 3 : if (property_kind == OMP_TRAIT_PROPERTY_BOOL_EXPR)
13692 2 : gfc_error ("property must be a constant "
13693 : "logical expression at %L",
13694 2 : &otp->expr->where);
13695 : else
13696 1 : gfc_error ("property must be a constant "
13697 : "integer expression at %L",
13698 1 : &otp->expr->where);
13699 : }
13700 : /* Prevent later ICEs. */
13701 3 : gfc_expr *e;
13702 3 : if (property_kind == OMP_TRAIT_PROPERTY_BOOL_EXPR)
13703 2 : e = gfc_get_logical_expr (gfc_default_logical_kind,
13704 2 : &otp->expr->where, true);
13705 : else
13706 1 : e = gfc_get_int_expr (gfc_default_integer_kind,
13707 1 : &otp->expr->where, 0);
13708 3 : gfc_free_expr (otp->expr);
13709 3 : otp->expr = e;
13710 3 : continue;
13711 3 : }
13712 : /* Device number must be conforming, which includes
13713 : omp_initial_device (-1), omp_invalid_device (-4),
13714 : and omp_default_device (-5). */
13715 145 : if (property_kind == OMP_TRAIT_PROPERTY_DEV_NUM_EXPR
13716 14 : && otp->expr->expr_type == EXPR_CONSTANT
13717 5 : && mpz_sgn (otp->expr->value.integer) < 0
13718 3 : && mpz_cmp_si (otp->expr->value.integer, -1) != 0
13719 2 : && mpz_cmp_si (otp->expr->value.integer, -4) != 0
13720 1 : && mpz_cmp_si (otp->expr->value.integer, -5) != 0)
13721 1 : gfc_error ("property must be a conforming device number at %L",
13722 : &otp->expr->where);
13723 : break;
13724 : default:
13725 : break;
13726 : }
13727 : /* This only handles one specific case: User condition.
13728 : FIXME: Handle more cases by calling omp_context_selector_matches;
13729 : unfortunately, we cannot generate the tree here as, e.g., PARM_DECL
13730 : backend decl are not available at this stage - but might be used in,
13731 : e.g. user conditions. See PR122361. */
13732 393 : if (skip_p && otp
13733 145 : && os->code == OMP_TRAIT_USER_CONDITION
13734 88 : && otp->expr->expr_type == EXPR_CONSTANT
13735 14 : && otp->expr->value.logical == false)
13736 12 : *skip_p = true;
13737 : }
13738 785 : }
13739 :
13740 :
13741 : static void
13742 145 : resolve_omp_metadirective (gfc_code *code, gfc_namespace *ns)
13743 : {
13744 145 : gfc_omp_variant *variant = code->ext.omp_variants;
13745 145 : gfc_omp_variant *prev_variant = variant;
13746 :
13747 469 : while (variant)
13748 : {
13749 324 : bool skip;
13750 324 : gfc_resolve_omp_context_selector (variant->selectors, true, &skip);
13751 324 : gfc_code *variant_code = variant->code;
13752 324 : gfc_resolve_code (variant_code, ns);
13753 324 : if (skip)
13754 : {
13755 : /* The following should only be true if an error occurred
13756 : as the 'otherwise' clause should always match. */
13757 12 : if (variant == code->ext.omp_variants && !variant->next)
13758 : break;
13759 12 : gfc_omp_variant *tmp = variant;
13760 12 : if (variant == code->ext.omp_variants)
13761 11 : variant = prev_variant = code->ext.omp_variants = variant->next;
13762 : else
13763 1 : variant = prev_variant->next = variant->next;
13764 12 : gfc_free_omp_set_selector_list (tmp->selectors);
13765 12 : free (tmp);
13766 : }
13767 : else
13768 : {
13769 312 : prev_variant = variant;
13770 312 : variant = variant->next;
13771 : }
13772 : }
13773 : /* Replace metadirective by its body if only 'nothing' remains. */
13774 145 : if (!code->ext.omp_variants->next && code->ext.omp_variants->stmt == ST_NONE)
13775 : {
13776 11 : gfc_code *next = code->next;
13777 11 : gfc_code *inner = code->ext.omp_variants->code;
13778 11 : gfc_free_omp_set_selector_list (code->ext.omp_variants->selectors);
13779 11 : free (code->ext.omp_variants);
13780 11 : *code = *inner;
13781 11 : free (inner);
13782 11 : while (code->next)
13783 : code = code->next;
13784 11 : code->next = next;
13785 : }
13786 145 : }
13787 :
13788 :
13789 : static gfc_statement
13790 63 : omp_code_to_statement (gfc_code *code)
13791 : {
13792 63 : switch (code->op)
13793 : {
13794 : case EXEC_OMP_PARALLEL:
13795 : return ST_OMP_PARALLEL;
13796 0 : case EXEC_OMP_PARALLEL_MASKED:
13797 0 : return ST_OMP_PARALLEL_MASKED;
13798 0 : case EXEC_OMP_PARALLEL_MASKED_TASKLOOP:
13799 0 : return ST_OMP_PARALLEL_MASKED_TASKLOOP;
13800 0 : case EXEC_OMP_PARALLEL_MASKED_TASKLOOP_SIMD:
13801 0 : return ST_OMP_PARALLEL_MASKED_TASKLOOP_SIMD;
13802 0 : case EXEC_OMP_PARALLEL_MASTER:
13803 0 : return ST_OMP_PARALLEL_MASTER;
13804 0 : case EXEC_OMP_PARALLEL_MASTER_TASKLOOP:
13805 0 : return ST_OMP_PARALLEL_MASTER_TASKLOOP;
13806 0 : case EXEC_OMP_PARALLEL_MASTER_TASKLOOP_SIMD:
13807 0 : return ST_OMP_PARALLEL_MASTER_TASKLOOP_SIMD;
13808 1 : case EXEC_OMP_PARALLEL_SECTIONS:
13809 1 : return ST_OMP_PARALLEL_SECTIONS;
13810 1 : case EXEC_OMP_SECTIONS:
13811 1 : return ST_OMP_SECTIONS;
13812 1 : case EXEC_OMP_ORDERED:
13813 1 : return ST_OMP_ORDERED;
13814 1 : case EXEC_OMP_CRITICAL:
13815 1 : return ST_OMP_CRITICAL;
13816 0 : case EXEC_OMP_MASKED:
13817 0 : return ST_OMP_MASKED;
13818 0 : case EXEC_OMP_MASKED_TASKLOOP:
13819 0 : return ST_OMP_MASKED_TASKLOOP;
13820 0 : case EXEC_OMP_MASKED_TASKLOOP_SIMD:
13821 0 : return ST_OMP_MASKED_TASKLOOP_SIMD;
13822 1 : case EXEC_OMP_MASTER:
13823 1 : return ST_OMP_MASTER;
13824 0 : case EXEC_OMP_MASTER_TASKLOOP:
13825 0 : return ST_OMP_MASTER_TASKLOOP;
13826 0 : case EXEC_OMP_MASTER_TASKLOOP_SIMD:
13827 0 : return ST_OMP_MASTER_TASKLOOP_SIMD;
13828 1 : case EXEC_OMP_SINGLE:
13829 1 : return ST_OMP_SINGLE;
13830 1 : case EXEC_OMP_TASK:
13831 1 : return ST_OMP_TASK;
13832 1 : case EXEC_OMP_WORKSHARE:
13833 1 : return ST_OMP_WORKSHARE;
13834 1 : case EXEC_OMP_PARALLEL_WORKSHARE:
13835 1 : return ST_OMP_PARALLEL_WORKSHARE;
13836 3 : case EXEC_OMP_DO:
13837 3 : return ST_OMP_DO;
13838 0 : case EXEC_OMP_LOOP:
13839 0 : return ST_OMP_LOOP;
13840 0 : case EXEC_OMP_ALLOCATE:
13841 0 : return ST_OMP_ALLOCATE_EXEC;
13842 0 : case EXEC_OMP_ALLOCATORS:
13843 0 : return ST_OMP_ALLOCATORS;
13844 0 : case EXEC_OMP_ASSUME:
13845 0 : return ST_OMP_ASSUME;
13846 1 : case EXEC_OMP_ATOMIC:
13847 1 : return ST_OMP_ATOMIC;
13848 1 : case EXEC_OMP_BARRIER:
13849 1 : return ST_OMP_BARRIER;
13850 1 : case EXEC_OMP_CANCEL:
13851 1 : return ST_OMP_CANCEL;
13852 1 : case EXEC_OMP_CANCELLATION_POINT:
13853 1 : return ST_OMP_CANCELLATION_POINT;
13854 0 : case EXEC_OMP_ERROR:
13855 0 : return ST_OMP_ERROR;
13856 1 : case EXEC_OMP_FLUSH:
13857 1 : return ST_OMP_FLUSH;
13858 0 : case EXEC_OMP_INTEROP:
13859 0 : return ST_OMP_INTEROP;
13860 1 : case EXEC_OMP_DISTRIBUTE:
13861 1 : return ST_OMP_DISTRIBUTE;
13862 1 : case EXEC_OMP_DISTRIBUTE_PARALLEL_DO:
13863 1 : return ST_OMP_DISTRIBUTE_PARALLEL_DO;
13864 1 : case EXEC_OMP_DISTRIBUTE_PARALLEL_DO_SIMD:
13865 1 : return ST_OMP_DISTRIBUTE_PARALLEL_DO_SIMD;
13866 1 : case EXEC_OMP_DISTRIBUTE_SIMD:
13867 1 : return ST_OMP_DISTRIBUTE_SIMD;
13868 1 : case EXEC_OMP_DO_SIMD:
13869 1 : return ST_OMP_DO_SIMD;
13870 0 : case EXEC_OMP_SCAN:
13871 0 : return ST_OMP_SCAN;
13872 0 : case EXEC_OMP_SCOPE:
13873 0 : return ST_OMP_SCOPE;
13874 1 : case EXEC_OMP_SIMD:
13875 1 : return ST_OMP_SIMD;
13876 1 : case EXEC_OMP_TARGET:
13877 1 : return ST_OMP_TARGET;
13878 1 : case EXEC_OMP_TARGET_DATA:
13879 1 : return ST_OMP_TARGET_DATA;
13880 1 : case EXEC_OMP_TARGET_ENTER_DATA:
13881 1 : return ST_OMP_TARGET_ENTER_DATA;
13882 1 : case EXEC_OMP_TARGET_EXIT_DATA:
13883 1 : return ST_OMP_TARGET_EXIT_DATA;
13884 1 : case EXEC_OMP_TARGET_PARALLEL:
13885 1 : return ST_OMP_TARGET_PARALLEL;
13886 1 : case EXEC_OMP_TARGET_PARALLEL_DO:
13887 1 : return ST_OMP_TARGET_PARALLEL_DO;
13888 1 : case EXEC_OMP_TARGET_PARALLEL_DO_SIMD:
13889 1 : return ST_OMP_TARGET_PARALLEL_DO_SIMD;
13890 0 : case EXEC_OMP_TARGET_PARALLEL_LOOP:
13891 0 : return ST_OMP_TARGET_PARALLEL_LOOP;
13892 1 : case EXEC_OMP_TARGET_SIMD:
13893 1 : return ST_OMP_TARGET_SIMD;
13894 1 : case EXEC_OMP_TARGET_TEAMS:
13895 1 : return ST_OMP_TARGET_TEAMS;
13896 1 : case EXEC_OMP_TARGET_TEAMS_DISTRIBUTE:
13897 1 : return ST_OMP_TARGET_TEAMS_DISTRIBUTE;
13898 1 : case EXEC_OMP_TARGET_TEAMS_DISTRIBUTE_PARALLEL_DO:
13899 1 : return ST_OMP_TARGET_TEAMS_DISTRIBUTE_PARALLEL_DO;
13900 1 : case EXEC_OMP_TARGET_TEAMS_DISTRIBUTE_PARALLEL_DO_SIMD:
13901 1 : return ST_OMP_TARGET_TEAMS_DISTRIBUTE_PARALLEL_DO_SIMD;
13902 1 : case EXEC_OMP_TARGET_TEAMS_DISTRIBUTE_SIMD:
13903 1 : return ST_OMP_TARGET_TEAMS_DISTRIBUTE_SIMD;
13904 0 : case EXEC_OMP_TARGET_TEAMS_LOOP:
13905 0 : return ST_OMP_TARGET_TEAMS_LOOP;
13906 1 : case EXEC_OMP_TARGET_UPDATE:
13907 1 : return ST_OMP_TARGET_UPDATE;
13908 1 : case EXEC_OMP_TASKGROUP:
13909 1 : return ST_OMP_TASKGROUP;
13910 1 : case EXEC_OMP_TASKLOOP:
13911 1 : return ST_OMP_TASKLOOP;
13912 1 : case EXEC_OMP_TASKLOOP_SIMD:
13913 1 : return ST_OMP_TASKLOOP_SIMD;
13914 1 : case EXEC_OMP_TASKWAIT:
13915 1 : return ST_OMP_TASKWAIT;
13916 1 : case EXEC_OMP_TASKYIELD:
13917 1 : return ST_OMP_TASKYIELD;
13918 1 : case EXEC_OMP_TEAMS:
13919 1 : return ST_OMP_TEAMS;
13920 1 : case EXEC_OMP_TEAMS_DISTRIBUTE:
13921 1 : return ST_OMP_TEAMS_DISTRIBUTE;
13922 1 : case EXEC_OMP_TEAMS_DISTRIBUTE_PARALLEL_DO:
13923 1 : return ST_OMP_TEAMS_DISTRIBUTE_PARALLEL_DO;
13924 1 : case EXEC_OMP_TEAMS_DISTRIBUTE_PARALLEL_DO_SIMD:
13925 1 : return ST_OMP_TEAMS_DISTRIBUTE_PARALLEL_DO_SIMD;
13926 1 : case EXEC_OMP_TEAMS_DISTRIBUTE_SIMD:
13927 1 : return ST_OMP_TEAMS_DISTRIBUTE_SIMD;
13928 0 : case EXEC_OMP_TEAMS_LOOP:
13929 0 : return ST_OMP_TEAMS_LOOP;
13930 6 : case EXEC_OMP_PARALLEL_DO:
13931 6 : return ST_OMP_PARALLEL_DO;
13932 1 : case EXEC_OMP_PARALLEL_DO_SIMD:
13933 1 : return ST_OMP_PARALLEL_DO_SIMD;
13934 0 : case EXEC_OMP_PARALLEL_LOOP:
13935 0 : return ST_OMP_PARALLEL_LOOP;
13936 1 : case EXEC_OMP_DEPOBJ:
13937 1 : return ST_OMP_DEPOBJ;
13938 0 : case EXEC_OMP_TILE:
13939 0 : return ST_OMP_TILE;
13940 0 : case EXEC_OMP_UNROLL:
13941 0 : return ST_OMP_UNROLL;
13942 0 : case EXEC_OMP_DISPATCH:
13943 0 : return ST_OMP_DISPATCH;
13944 0 : default:
13945 0 : gcc_unreachable ();
13946 : }
13947 : }
13948 :
13949 : static gfc_statement
13950 63 : oacc_code_to_statement (gfc_code *code)
13951 : {
13952 63 : switch (code->op)
13953 : {
13954 : case EXEC_OACC_PARALLEL:
13955 : return ST_OACC_PARALLEL;
13956 : case EXEC_OACC_KERNELS:
13957 : return ST_OACC_KERNELS;
13958 : case EXEC_OACC_SERIAL:
13959 : return ST_OACC_SERIAL;
13960 : case EXEC_OACC_DATA:
13961 : return ST_OACC_DATA;
13962 : case EXEC_OACC_HOST_DATA:
13963 : return ST_OACC_HOST_DATA;
13964 : case EXEC_OACC_PARALLEL_LOOP:
13965 : return ST_OACC_PARALLEL_LOOP;
13966 : case EXEC_OACC_KERNELS_LOOP:
13967 : return ST_OACC_KERNELS_LOOP;
13968 : case EXEC_OACC_SERIAL_LOOP:
13969 : return ST_OACC_SERIAL_LOOP;
13970 : case EXEC_OACC_LOOP:
13971 : return ST_OACC_LOOP;
13972 : case EXEC_OACC_ATOMIC:
13973 : return ST_OACC_ATOMIC;
13974 : case EXEC_OACC_ROUTINE:
13975 : return ST_OACC_ROUTINE;
13976 : case EXEC_OACC_UPDATE:
13977 : return ST_OACC_UPDATE;
13978 : case EXEC_OACC_WAIT:
13979 : return ST_OACC_WAIT;
13980 : case EXEC_OACC_CACHE:
13981 : return ST_OACC_CACHE;
13982 : case EXEC_OACC_ENTER_DATA:
13983 : return ST_OACC_ENTER_DATA;
13984 : case EXEC_OACC_EXIT_DATA:
13985 : return ST_OACC_EXIT_DATA;
13986 : case EXEC_OACC_DECLARE:
13987 : return ST_OACC_DECLARE;
13988 : case EXEC_OACC_INIT:
13989 : return ST_OACC_INIT;
13990 : case EXEC_OACC_SHUTDOWN:
13991 : return ST_OACC_SHUTDOWN;
13992 : case EXEC_OACC_SET:
13993 : return ST_OACC_SET;
13994 0 : default:
13995 0 : gcc_unreachable ();
13996 : }
13997 : }
13998 :
13999 : static void
14000 13538 : resolve_oacc_directive_inside_omp_region (gfc_code *code)
14001 : {
14002 13538 : if (omp_current_ctx != NULL && omp_current_ctx->is_openmp)
14003 : {
14004 11 : gfc_statement st = omp_code_to_statement (omp_current_ctx->code);
14005 11 : gfc_statement oacc_st = oacc_code_to_statement (code);
14006 11 : gfc_error ("The %s directive cannot be specified within "
14007 : "a %s region at %L", gfc_ascii_statement (oacc_st),
14008 : gfc_ascii_statement (st), &code->loc);
14009 : }
14010 13538 : }
14011 :
14012 : static void
14013 21349 : resolve_omp_directive_inside_oacc_region (gfc_code *code)
14014 : {
14015 21349 : if (omp_current_ctx != NULL && !omp_current_ctx->is_openmp)
14016 : {
14017 52 : gfc_statement st = oacc_code_to_statement (omp_current_ctx->code);
14018 52 : gfc_statement omp_st = omp_code_to_statement (code);
14019 52 : gfc_error ("The %s directive cannot be specified within "
14020 : "a %s region at %L", gfc_ascii_statement (omp_st),
14021 : gfc_ascii_statement (st), &code->loc);
14022 : }
14023 21349 : }
14024 :
14025 :
14026 : static void
14027 5272 : resolve_oacc_nested_loops (gfc_code *code, gfc_code* do_code, int collapse,
14028 : const char *clause)
14029 : {
14030 5272 : gfc_symbol *dovar;
14031 5272 : gfc_code *c;
14032 5272 : int i;
14033 :
14034 5792 : for (i = 1; i <= collapse; i++)
14035 : {
14036 5792 : if (do_code->op == EXEC_DO_WHILE)
14037 : {
14038 10 : gfc_error ("!$ACC LOOP cannot be a DO WHILE or DO without loop control "
14039 : "at %L", &do_code->loc);
14040 10 : break;
14041 : }
14042 5782 : if (do_code->op == EXEC_DO_CONCURRENT)
14043 : {
14044 3 : gfc_error ("!$ACC LOOP cannot be a DO CONCURRENT loop at %L",
14045 : &do_code->loc);
14046 3 : break;
14047 : }
14048 5779 : gcc_assert (do_code->op == EXEC_DO);
14049 5779 : if (do_code->ext.iterator->var->ts.type != BT_INTEGER)
14050 6 : gfc_error ("!$ACC LOOP iteration variable must be of type integer at %L",
14051 : &do_code->loc);
14052 5779 : dovar = do_code->ext.iterator->var->symtree->n.sym;
14053 5779 : if (i > 1)
14054 : {
14055 518 : gfc_code *do_code2 = code->block->next;
14056 518 : int j;
14057 :
14058 1218 : for (j = 1; j < i; j++)
14059 : {
14060 710 : gfc_symbol *ivar = do_code2->ext.iterator->var->symtree->n.sym;
14061 710 : if (dovar == ivar
14062 710 : || gfc_find_sym_in_expr (ivar, do_code->ext.iterator->start)
14063 701 : || gfc_find_sym_in_expr (ivar, do_code->ext.iterator->end)
14064 1410 : || gfc_find_sym_in_expr (ivar, do_code->ext.iterator->step))
14065 : {
14066 10 : gfc_error ("!$ACC LOOP %s loops don't form rectangular "
14067 : "iteration space at %L", clause, &do_code->loc);
14068 10 : break;
14069 : }
14070 700 : do_code2 = do_code2->block->next;
14071 : }
14072 : }
14073 5779 : if (i == collapse)
14074 : break;
14075 577 : for (c = do_code->next; c; c = c->next)
14076 48 : if (c->op != EXEC_NOP && c->op != EXEC_CONTINUE)
14077 : {
14078 0 : gfc_error ("%s !$ACC LOOP loops not perfectly nested at %L",
14079 : clause, &c->loc);
14080 0 : break;
14081 : }
14082 529 : if (c)
14083 : break;
14084 529 : do_code = do_code->block;
14085 529 : if (do_code->op != EXEC_DO && do_code->op != EXEC_DO_WHILE
14086 0 : && do_code->op != EXEC_DO_CONCURRENT)
14087 : {
14088 0 : gfc_error ("not enough DO loops for %s !$ACC LOOP at %L",
14089 : clause, &code->loc);
14090 0 : break;
14091 : }
14092 529 : do_code = do_code->next;
14093 529 : if (do_code == NULL
14094 522 : || (do_code->op != EXEC_DO && do_code->op != EXEC_DO_WHILE
14095 2 : && do_code->op != EXEC_DO_CONCURRENT))
14096 : {
14097 9 : gfc_error ("not enough DO loops for %s !$ACC LOOP at %L",
14098 : clause, &code->loc);
14099 9 : break;
14100 : }
14101 : }
14102 5272 : }
14103 :
14104 :
14105 : static void
14106 10119 : resolve_oacc_loop_blocks (gfc_code *code)
14107 : {
14108 10119 : if (!oacc_is_loop (code))
14109 : return;
14110 :
14111 5272 : if (code->ext.omp_clauses->tile_list && code->ext.omp_clauses->gang
14112 24 : && code->ext.omp_clauses->worker && code->ext.omp_clauses->vector)
14113 0 : gfc_error ("Tiled loop cannot be parallelized across gangs, workers and "
14114 : "vectors at the same time at %L", &code->loc);
14115 :
14116 5272 : if (code->ext.omp_clauses->tile_list)
14117 : {
14118 : gfc_expr_list *el;
14119 501 : for (el = code->ext.omp_clauses->tile_list; el; el = el->next)
14120 : {
14121 304 : if (el->expr == NULL)
14122 : {
14123 : /* NULL expressions are used to represent '*' arguments.
14124 : Convert those to a 0 expressions. */
14125 113 : el->expr = gfc_get_constant_expr (BT_INTEGER,
14126 : gfc_default_integer_kind,
14127 : &code->loc);
14128 113 : mpz_set_si (el->expr->value.integer, 0);
14129 : }
14130 : else
14131 : {
14132 191 : resolve_positive_int_expr (el->expr, "TILE");
14133 191 : if (el->expr->expr_type != EXPR_CONSTANT)
14134 14 : gfc_error ("TILE requires constant expression at %L",
14135 : &code->loc);
14136 : }
14137 : }
14138 : }
14139 : }
14140 :
14141 :
14142 : void
14143 10119 : gfc_resolve_oacc_blocks (gfc_code *code, gfc_namespace *ns)
14144 : {
14145 10119 : fortran_omp_context ctx;
14146 10119 : gfc_omp_clauses *omp_clauses = code->ext.omp_clauses;
14147 10119 : gfc_omp_namelist *n;
14148 :
14149 10119 : resolve_oacc_loop_blocks (code);
14150 :
14151 10119 : ctx.code = code;
14152 10119 : ctx.sharing_clauses = new hash_set<gfc_symbol *>;
14153 10119 : ctx.private_iterators = new hash_set<gfc_symbol *>;
14154 10119 : ctx.previous = omp_current_ctx;
14155 10119 : ctx.is_openmp = false;
14156 10119 : omp_current_ctx = &ctx;
14157 :
14158 404760 : for (enum gfc_omp_list_type list = OMP_LIST_FIRST; list < OMP_LIST_NUM;
14159 394641 : list = gfc_omp_list_type (list + 1))
14160 394641 : switch (list)
14161 : {
14162 10119 : case OMP_LIST_PRIVATE:
14163 10710 : for (n = omp_clauses->lists[list]; n; n = n->next)
14164 591 : ctx.sharing_clauses->add (n->sym);
14165 : break;
14166 : default:
14167 : break;
14168 : }
14169 :
14170 10119 : gfc_resolve_blocks (code->block, ns);
14171 :
14172 10119 : omp_current_ctx = ctx.previous;
14173 20238 : delete ctx.sharing_clauses;
14174 20238 : delete ctx.private_iterators;
14175 10119 : }
14176 :
14177 :
14178 : static void
14179 5272 : resolve_oacc_loop (gfc_code *code)
14180 : {
14181 5272 : gfc_code *do_code;
14182 5272 : int collapse;
14183 :
14184 5272 : if (code->ext.omp_clauses)
14185 5272 : resolve_omp_clauses (code, code->ext.omp_clauses, NULL, true);
14186 :
14187 5272 : do_code = code->block->next;
14188 5272 : collapse = code->ext.omp_clauses->collapse;
14189 :
14190 : /* Both collapsed and tiled loops are lowered the same way, but are not
14191 : compatible. In gfc_trans_omp_do, the tile is prioritized. */
14192 5272 : if (code->ext.omp_clauses->tile_list)
14193 : {
14194 : int num = 0;
14195 : gfc_expr_list *el;
14196 501 : for (el = code->ext.omp_clauses->tile_list; el; el = el->next)
14197 304 : ++num;
14198 197 : resolve_oacc_nested_loops (code, code->block->next, num, "tiled");
14199 197 : return;
14200 : }
14201 :
14202 5075 : if (collapse <= 0)
14203 : collapse = 1;
14204 5075 : resolve_oacc_nested_loops (code, do_code, collapse, "collapsed");
14205 : }
14206 :
14207 : void
14208 350685 : gfc_resolve_oacc_declare (gfc_namespace *ns)
14209 : {
14210 350685 : enum gfc_omp_list_type list;
14211 350685 : gfc_omp_namelist *n;
14212 350685 : gfc_oacc_declare *oc;
14213 :
14214 350685 : if (ns->oacc_declare == NULL)
14215 : return;
14216 :
14217 290 : for (oc = ns->oacc_declare; oc; oc = oc->next)
14218 : {
14219 6480 : for (list = OMP_LIST_FIRST; list < OMP_LIST_NUM;
14220 6318 : list = gfc_omp_list_type (list + 1))
14221 6574 : for (n = oc->clauses->lists[list]; n; n = n->next)
14222 : {
14223 256 : n->sym->mark = 0;
14224 256 : if (n->sym->attr.flavor != FL_VARIABLE
14225 16 : && (n->sym->attr.flavor != FL_PROCEDURE
14226 8 : || n->sym->result != n->sym))
14227 : {
14228 14 : if (n->sym->attr.flavor != FL_PARAMETER)
14229 : {
14230 8 : gfc_error ("Object %qs is not a variable at %L",
14231 : n->sym->name, &oc->loc);
14232 8 : continue;
14233 : }
14234 : /* Note that OpenACC 3.4 permits name constants, but the
14235 : implementation is permitted to ignore the clause;
14236 : as semantically, device_resident kind of makes sense
14237 : (and the wording with it is a bit odd), the warning
14238 : is suppressed. */
14239 6 : if (list != OMP_LIST_DEVICE_RESIDENT)
14240 5 : gfc_warning (OPT_Wsurprising, "Object %qs at %L is ignored as"
14241 : " parameters need not be copied", n->sym->name,
14242 : &oc->loc);
14243 : }
14244 :
14245 248 : if (n->expr && n->expr->ref->type == REF_ARRAY)
14246 : {
14247 1 : gfc_error ("Array sections: %qs not allowed in"
14248 1 : " !$ACC DECLARE at %L", n->sym->name, &oc->loc);
14249 1 : continue;
14250 : }
14251 : }
14252 :
14253 252 : for (n = oc->clauses->lists[OMP_LIST_DEVICE_RESIDENT]; n; n = n->next)
14254 90 : check_array_not_assumed (n->sym, oc->loc, "DEVICE_RESIDENT");
14255 : }
14256 :
14257 290 : for (oc = ns->oacc_declare; oc; oc = oc->next)
14258 : {
14259 6480 : for (list = OMP_LIST_FIRST; list < OMP_LIST_NUM;
14260 6318 : list = gfc_omp_list_type (list + 1))
14261 6574 : for (n = oc->clauses->lists[list]; n; n = n->next)
14262 : {
14263 256 : if (n->sym->mark)
14264 : {
14265 9 : gfc_error ("Symbol %qs present on multiple clauses at %L",
14266 : n->sym->name, &oc->loc);
14267 9 : continue;
14268 : }
14269 : else
14270 247 : n->sym->mark = 1;
14271 : }
14272 : }
14273 :
14274 290 : for (oc = ns->oacc_declare; oc; oc = oc->next)
14275 : {
14276 6480 : for (list = OMP_LIST_FIRST; list < OMP_LIST_NUM;
14277 6318 : list = gfc_omp_list_type (list + 1))
14278 6574 : for (n = oc->clauses->lists[list]; n; n = n->next)
14279 256 : n->sym->mark = 0;
14280 : }
14281 : }
14282 :
14283 :
14284 : void
14285 350685 : gfc_resolve_oacc_routines (gfc_namespace *ns)
14286 : {
14287 350685 : for (gfc_oacc_routine_name *orn = ns->oacc_routine_names;
14288 350785 : orn;
14289 100 : orn = orn->next)
14290 : {
14291 100 : gfc_symbol *sym = orn->sym;
14292 100 : if (!sym->attr.external
14293 29 : && !sym->attr.function
14294 27 : && !sym->attr.subroutine)
14295 : {
14296 7 : gfc_error ("NAME %qs does not refer to a subroutine or function"
14297 : " in !$ACC ROUTINE ( NAME ) at %L", sym->name, &orn->loc);
14298 7 : continue;
14299 : }
14300 93 : if (!gfc_add_omp_declare_target (&sym->attr, sym->name, &orn->loc))
14301 : {
14302 20 : gfc_error ("NAME %qs invalid"
14303 : " in !$ACC ROUTINE ( NAME ) at %L", sym->name, &orn->loc);
14304 20 : continue;
14305 : }
14306 : }
14307 350685 : }
14308 :
14309 :
14310 : void
14311 13538 : gfc_resolve_oacc_directive (gfc_code *code, gfc_namespace *ns ATTRIBUTE_UNUSED)
14312 : {
14313 13538 : resolve_oacc_directive_inside_omp_region (code);
14314 :
14315 13538 : switch (code->op)
14316 : {
14317 7723 : case EXEC_OACC_PARALLEL:
14318 7723 : case EXEC_OACC_KERNELS:
14319 7723 : case EXEC_OACC_SERIAL:
14320 7723 : case EXEC_OACC_DATA:
14321 7723 : case EXEC_OACC_HOST_DATA:
14322 7723 : case EXEC_OACC_UPDATE:
14323 7723 : case EXEC_OACC_ENTER_DATA:
14324 7723 : case EXEC_OACC_EXIT_DATA:
14325 7723 : case EXEC_OACC_WAIT:
14326 7723 : case EXEC_OACC_CACHE:
14327 7723 : case EXEC_OACC_INIT:
14328 7723 : case EXEC_OACC_SHUTDOWN:
14329 7723 : case EXEC_OACC_SET:
14330 7723 : resolve_omp_clauses (code, code->ext.omp_clauses, NULL, true);
14331 7723 : break;
14332 5272 : case EXEC_OACC_PARALLEL_LOOP:
14333 5272 : case EXEC_OACC_KERNELS_LOOP:
14334 5272 : case EXEC_OACC_SERIAL_LOOP:
14335 5272 : case EXEC_OACC_LOOP:
14336 5272 : resolve_oacc_loop (code);
14337 5272 : break;
14338 543 : case EXEC_OACC_ATOMIC:
14339 543 : resolve_omp_atomic (code);
14340 543 : break;
14341 : default:
14342 : break;
14343 : }
14344 13538 : }
14345 :
14346 :
14347 : static void
14348 2185 : resolve_omp_target (gfc_code *code)
14349 : {
14350 : #define GFC_IS_TEAMS_CONSTRUCT(op) \
14351 : (op == EXEC_OMP_TEAMS \
14352 : || op == EXEC_OMP_TEAMS_DISTRIBUTE \
14353 : || op == EXEC_OMP_TEAMS_DISTRIBUTE_SIMD \
14354 : || op == EXEC_OMP_TEAMS_DISTRIBUTE_PARALLEL_DO \
14355 : || op == EXEC_OMP_TEAMS_DISTRIBUTE_PARALLEL_DO_SIMD \
14356 : || op == EXEC_OMP_TEAMS_LOOP)
14357 :
14358 2185 : if (!code->ext.omp_clauses->contains_teams_construct)
14359 : return;
14360 203 : gfc_code *c = code->block->next;
14361 203 : if (c->op == EXEC_BLOCK)
14362 30 : c = c->ext.block.ns->code;
14363 203 : if (code->ext.omp_clauses->target_first_st_is_teams_or_meta)
14364 : {
14365 192 : if (c->op == EXEC_OMP_METADIRECTIVE)
14366 : {
14367 15 : struct gfc_omp_variant *mc
14368 : = c->ext.omp_variants;
14369 : /* All mc->(next...->)code should be identical with regards
14370 : to the diagnostic below. */
14371 16 : do
14372 : {
14373 16 : if (mc->stmt != ST_NONE
14374 15 : && GFC_IS_TEAMS_CONSTRUCT (mc->code->op))
14375 : {
14376 14 : if (c->next == NULL && mc->code->next == NULL)
14377 : return;
14378 23 : c = mc->code;
14379 : break;
14380 : }
14381 2 : mc = mc->next;
14382 : }
14383 2 : while (mc);
14384 : }
14385 177 : else if (GFC_IS_TEAMS_CONSTRUCT (c->op) && c->next == NULL)
14386 : return;
14387 : }
14388 :
14389 31 : while (c && !GFC_IS_TEAMS_CONSTRUCT (c->op))
14390 8 : c = c->next;
14391 23 : if (c)
14392 19 : gfc_error ("!$OMP TARGET region at %L with a nested TEAMS at %L may not "
14393 : "contain any other statement, declaration or directive outside "
14394 : "of the single TEAMS construct", &c->loc, &code->loc);
14395 : else
14396 4 : gfc_error ("!$OMP TARGET region at %L with a nested TEAMS may not "
14397 : "contain any other statement, declaration or directive outside "
14398 : "of the single TEAMS construct", &code->loc);
14399 : #undef GFC_IS_TEAMS_CONSTRUCT
14400 : }
14401 :
14402 : static void
14403 154 : resolve_omp_dispatch (gfc_code *code)
14404 : {
14405 154 : gfc_code *next = code->block->next;
14406 154 : if (next == NULL)
14407 : return;
14408 :
14409 151 : gfc_exec_op op = next->op;
14410 151 : gcc_assert (op == EXEC_CALL || op == EXEC_ASSIGN);
14411 151 : if (op != EXEC_CALL
14412 74 : && (op != EXEC_ASSIGN || next->expr2->expr_type != EXPR_FUNCTION))
14413 3 : gfc_error (
14414 : "%<OMP DISPATCH%> directive at %L must be followed by a procedure "
14415 : "call with optional assignment",
14416 : &code->loc);
14417 :
14418 77 : if ((op == EXEC_CALL && next->resolved_sym != NULL
14419 76 : && next->resolved_sym->attr.proc_pointer)
14420 151 : || (op == EXEC_ASSIGN && gfc_expr_attr (next->expr2).proc_pointer))
14421 1 : gfc_error ("%<OMP DISPATCH%> directive at %L cannot be followed by a "
14422 : "procedure pointer",
14423 : &code->loc);
14424 : }
14425 :
14426 : /* Resolve OpenMP directive clauses and check various requirements
14427 : of each directive. */
14428 :
14429 : void
14430 21349 : gfc_resolve_omp_directive (gfc_code *code, gfc_namespace *ns)
14431 : {
14432 21349 : resolve_omp_directive_inside_oacc_region (code);
14433 :
14434 21349 : if (code->op != EXEC_OMP_ATOMIC)
14435 19182 : gfc_maybe_initialize_eh ();
14436 :
14437 21349 : switch (code->op)
14438 : {
14439 5441 : case EXEC_OMP_DISTRIBUTE:
14440 5441 : case EXEC_OMP_DISTRIBUTE_PARALLEL_DO:
14441 5441 : case EXEC_OMP_DISTRIBUTE_PARALLEL_DO_SIMD:
14442 5441 : case EXEC_OMP_DISTRIBUTE_SIMD:
14443 5441 : case EXEC_OMP_DO:
14444 5441 : case EXEC_OMP_DO_SIMD:
14445 5441 : case EXEC_OMP_LOOP:
14446 5441 : case EXEC_OMP_PARALLEL_DO:
14447 5441 : case EXEC_OMP_PARALLEL_DO_SIMD:
14448 5441 : case EXEC_OMP_PARALLEL_LOOP:
14449 5441 : case EXEC_OMP_PARALLEL_MASKED_TASKLOOP:
14450 5441 : case EXEC_OMP_PARALLEL_MASKED_TASKLOOP_SIMD:
14451 5441 : case EXEC_OMP_PARALLEL_MASTER_TASKLOOP:
14452 5441 : case EXEC_OMP_PARALLEL_MASTER_TASKLOOP_SIMD:
14453 5441 : case EXEC_OMP_MASKED_TASKLOOP:
14454 5441 : case EXEC_OMP_MASKED_TASKLOOP_SIMD:
14455 5441 : case EXEC_OMP_MASTER_TASKLOOP:
14456 5441 : case EXEC_OMP_MASTER_TASKLOOP_SIMD:
14457 5441 : case EXEC_OMP_SIMD:
14458 5441 : case EXEC_OMP_TARGET_PARALLEL_DO:
14459 5441 : case EXEC_OMP_TARGET_PARALLEL_DO_SIMD:
14460 5441 : case EXEC_OMP_TARGET_PARALLEL_LOOP:
14461 5441 : case EXEC_OMP_TARGET_SIMD:
14462 5441 : case EXEC_OMP_TARGET_TEAMS_DISTRIBUTE:
14463 5441 : case EXEC_OMP_TARGET_TEAMS_DISTRIBUTE_PARALLEL_DO:
14464 5441 : case EXEC_OMP_TARGET_TEAMS_DISTRIBUTE_PARALLEL_DO_SIMD:
14465 5441 : case EXEC_OMP_TARGET_TEAMS_DISTRIBUTE_SIMD:
14466 5441 : case EXEC_OMP_TARGET_TEAMS_LOOP:
14467 5441 : case EXEC_OMP_TASKLOOP:
14468 5441 : case EXEC_OMP_TASKLOOP_SIMD:
14469 5441 : case EXEC_OMP_TEAMS_DISTRIBUTE:
14470 5441 : case EXEC_OMP_TEAMS_DISTRIBUTE_PARALLEL_DO:
14471 5441 : case EXEC_OMP_TEAMS_DISTRIBUTE_PARALLEL_DO_SIMD:
14472 5441 : case EXEC_OMP_TEAMS_DISTRIBUTE_SIMD:
14473 5441 : case EXEC_OMP_TEAMS_LOOP:
14474 5441 : case EXEC_OMP_TILE:
14475 5441 : case EXEC_OMP_UNROLL:
14476 5441 : resolve_omp_do (code);
14477 5441 : break;
14478 2185 : case EXEC_OMP_TARGET:
14479 2185 : resolve_omp_target (code);
14480 10323 : gcc_fallthrough ();
14481 10323 : case EXEC_OMP_ALLOCATE:
14482 10323 : case EXEC_OMP_ALLOCATORS:
14483 10323 : case EXEC_OMP_ASSUME:
14484 10323 : case EXEC_OMP_CANCEL:
14485 10323 : case EXEC_OMP_ERROR:
14486 10323 : case EXEC_OMP_INTEROP:
14487 10323 : case EXEC_OMP_MASKED:
14488 10323 : case EXEC_OMP_ORDERED:
14489 10323 : case EXEC_OMP_PARALLEL_WORKSHARE:
14490 10323 : case EXEC_OMP_PARALLEL:
14491 10323 : case EXEC_OMP_PARALLEL_MASKED:
14492 10323 : case EXEC_OMP_PARALLEL_MASTER:
14493 10323 : case EXEC_OMP_PARALLEL_SECTIONS:
14494 10323 : case EXEC_OMP_SCOPE:
14495 10323 : case EXEC_OMP_SECTIONS:
14496 10323 : case EXEC_OMP_SINGLE:
14497 10323 : case EXEC_OMP_TARGET_DATA:
14498 10323 : case EXEC_OMP_TARGET_ENTER_DATA:
14499 10323 : case EXEC_OMP_TARGET_EXIT_DATA:
14500 10323 : case EXEC_OMP_TARGET_PARALLEL:
14501 10323 : case EXEC_OMP_TARGET_TEAMS:
14502 10323 : case EXEC_OMP_TASK:
14503 10323 : case EXEC_OMP_TASKWAIT:
14504 10323 : case EXEC_OMP_TEAMS:
14505 10323 : case EXEC_OMP_WORKSHARE:
14506 10323 : case EXEC_OMP_DEPOBJ:
14507 10323 : if (code->ext.omp_clauses)
14508 10182 : resolve_omp_clauses (code, code->ext.omp_clauses, NULL);
14509 : break;
14510 1720 : case EXEC_OMP_TARGET_UPDATE:
14511 1720 : if (code->ext.omp_clauses)
14512 1720 : resolve_omp_clauses (code, code->ext.omp_clauses, NULL);
14513 1720 : if (code->ext.omp_clauses == NULL
14514 1720 : || (code->ext.omp_clauses->lists[OMP_LIST_TO] == NULL
14515 996 : && code->ext.omp_clauses->lists[OMP_LIST_FROM] == NULL))
14516 0 : gfc_error ("OMP TARGET UPDATE at %L requires at least one TO or "
14517 : "FROM clause", &code->loc);
14518 : break;
14519 2167 : case EXEC_OMP_ATOMIC:
14520 2167 : resolve_omp_clauses (code, code->block->ext.omp_clauses, NULL);
14521 2167 : resolve_omp_atomic (code);
14522 2167 : break;
14523 165 : case EXEC_OMP_CRITICAL:
14524 165 : resolve_omp_clauses (code, code->ext.omp_clauses, NULL);
14525 165 : if (!code->ext.omp_clauses->critical_name
14526 114 : && code->ext.omp_clauses->hint
14527 5 : && code->ext.omp_clauses->hint->ts.type == BT_INTEGER
14528 5 : && code->ext.omp_clauses->hint->expr_type == EXPR_CONSTANT
14529 5 : && mpz_sgn (code->ext.omp_clauses->hint->value.integer) != 0)
14530 1 : gfc_error ("OMP CRITICAL at %L with HINT clause requires a NAME, "
14531 : "except when omp_sync_hint_none is used", &code->loc);
14532 : break;
14533 49 : case EXEC_OMP_SCAN:
14534 : /* Flag is only used to checking, hence, it is unset afterwards. */
14535 49 : if (!code->ext.omp_clauses->if_present)
14536 10 : gfc_error ("Unexpected !$OMP SCAN at %L outside loop construct with "
14537 : "%<inscan%> REDUCTION clause", &code->loc);
14538 49 : code->ext.omp_clauses->if_present = false;
14539 49 : resolve_omp_clauses (code, code->ext.omp_clauses, ns);
14540 49 : break;
14541 154 : case EXEC_OMP_DISPATCH:
14542 154 : if (code->ext.omp_clauses)
14543 154 : resolve_omp_clauses (code, code->ext.omp_clauses, ns);
14544 154 : resolve_omp_dispatch (code);
14545 154 : break;
14546 145 : case EXEC_OMP_METADIRECTIVE:
14547 145 : resolve_omp_metadirective (code, ns);
14548 145 : break;
14549 : default:
14550 : break;
14551 : }
14552 21349 : }
14553 :
14554 : /* Resolve !$omp declare {variant|simd} constructs in NS.
14555 : Note that !$omp declare target is resolved in resolve_symbol. */
14556 :
14557 : void
14558 362782 : gfc_resolve_omp_declare (gfc_namespace *ns)
14559 : {
14560 362782 : gfc_omp_declare_simd *ods;
14561 363029 : for (ods = ns->omp_declare_simd; ods; ods = ods->next)
14562 : {
14563 247 : if (ods->proc_name != NULL
14564 197 : && ods->proc_name != ns->proc_name)
14565 6 : gfc_error ("!$OMP DECLARE SIMD should refer to containing procedure "
14566 : "%qs at %L", ns->proc_name->name, &ods->where);
14567 247 : if (ods->clauses)
14568 229 : resolve_omp_clauses (NULL, ods->clauses, ns);
14569 : }
14570 :
14571 362782 : gfc_omp_declare_variant *odv;
14572 362782 : gfc_omp_namelist *range_begin = NULL;
14573 :
14574 363243 : for (odv = ns->omp_declare_variant; odv; odv = odv->next)
14575 461 : gfc_resolve_omp_context_selector (odv->set_selectors, false, nullptr);
14576 363243 : for (odv = ns->omp_declare_variant; odv; odv = odv->next)
14577 664 : for (gfc_omp_namelist *n = odv->adjust_args_list; n != NULL; n = n->next)
14578 : {
14579 203 : if ((n->expr == NULL
14580 6 : && (range_begin
14581 4 : || n->u.adj_args.range_start
14582 1 : || n->u.adj_args.omp_num_args_plus
14583 1 : || n->u.adj_args.omp_num_args_minus))
14584 198 : || n->u.adj_args.error_p)
14585 : {
14586 : }
14587 197 : else if (range_begin
14588 191 : || n->u.adj_args.range_start
14589 186 : || n->u.adj_args.omp_num_args_plus
14590 186 : || n->u.adj_args.omp_num_args_minus)
14591 : {
14592 11 : if (!n->expr
14593 11 : || !gfc_resolve_expr (n->expr)
14594 11 : || n->expr->expr_type != EXPR_CONSTANT
14595 10 : || n->expr->ts.type != BT_INTEGER
14596 10 : || n->expr->rank != 0
14597 10 : || mpz_sgn (n->expr->value.integer) < 0
14598 20 : || ((n->u.adj_args.omp_num_args_plus
14599 8 : || n->u.adj_args.omp_num_args_minus)
14600 5 : && mpz_sgn (n->expr->value.integer) == 0))
14601 : {
14602 2 : if (n->u.adj_args.omp_num_args_plus
14603 2 : || n->u.adj_args.omp_num_args_minus)
14604 0 : gfc_error ("Expected constant non-negative scalar integer "
14605 : "offset expression at %L", &n->where);
14606 : else
14607 2 : gfc_error ("For range-based %<adjust_args%>, a constant "
14608 : "positive scalar integer expression is required "
14609 : "at %L", &n->where);
14610 : }
14611 : }
14612 186 : else if (n->expr
14613 186 : && n->expr->expr_type == EXPR_CONSTANT
14614 21 : && n->expr->ts.type == BT_INTEGER
14615 20 : && mpz_sgn (n->expr->value.integer) > 0)
14616 : {
14617 : }
14618 166 : else if (!n->expr
14619 166 : || !gfc_resolve_expr (n->expr)
14620 331 : || n->expr->expr_type != EXPR_VARIABLE)
14621 2 : gfc_error ("Expected dummy parameter name or a positive integer "
14622 : "at %L", &n->where);
14623 164 : else if (n->expr->expr_type == EXPR_VARIABLE)
14624 164 : n->sym = n->expr->symtree->n.sym;
14625 :
14626 203 : range_begin = n->u.adj_args.range_start ? n : NULL;
14627 : }
14628 362782 : }
14629 :
14630 : struct omp_udr_callback_data
14631 : {
14632 : gfc_omp_udr *omp_udr;
14633 : bool is_initializer;
14634 : };
14635 :
14636 : static int
14637 3746 : omp_udr_callback (gfc_expr **e, int *walk_subtrees ATTRIBUTE_UNUSED,
14638 : void *data)
14639 : {
14640 3746 : struct omp_udr_callback_data *cd = (struct omp_udr_callback_data *) data;
14641 3746 : if ((*e)->expr_type == EXPR_VARIABLE)
14642 : {
14643 2303 : if (cd->is_initializer)
14644 : {
14645 545 : if ((*e)->symtree->n.sym != cd->omp_udr->omp_priv
14646 140 : && (*e)->symtree->n.sym != cd->omp_udr->omp_orig)
14647 4 : gfc_error ("Variable other than OMP_PRIV or OMP_ORIG used in "
14648 : "INITIALIZER clause of !$OMP DECLARE REDUCTION at %L",
14649 : &(*e)->where);
14650 : }
14651 : else
14652 : {
14653 1758 : if ((*e)->symtree->n.sym != cd->omp_udr->omp_out
14654 626 : && (*e)->symtree->n.sym != cd->omp_udr->omp_in)
14655 6 : gfc_error ("Variable other than OMP_OUT or OMP_IN used in "
14656 : "combiner of !$OMP DECLARE REDUCTION at %L",
14657 : &(*e)->where);
14658 : }
14659 : }
14660 3746 : return 0;
14661 : }
14662 :
14663 : /* Resolve !$omp declare reduction constructs. */
14664 :
14665 : static void
14666 633 : gfc_resolve_omp_udr (gfc_omp_udr *omp_udr)
14667 : {
14668 633 : gfc_actual_arglist *a;
14669 633 : const char *predef_name = NULL;
14670 :
14671 633 : switch (omp_udr->rop)
14672 : {
14673 632 : case OMP_REDUCTION_PLUS:
14674 632 : case OMP_REDUCTION_TIMES:
14675 632 : case OMP_REDUCTION_MINUS:
14676 632 : case OMP_REDUCTION_AND:
14677 632 : case OMP_REDUCTION_OR:
14678 632 : case OMP_REDUCTION_EQV:
14679 632 : case OMP_REDUCTION_NEQV:
14680 632 : case OMP_REDUCTION_MAX:
14681 632 : case OMP_REDUCTION_USER:
14682 632 : break;
14683 1 : default:
14684 1 : gfc_error ("Invalid operator for !$OMP DECLARE REDUCTION %s at %L",
14685 : omp_udr->name, &omp_udr->where);
14686 26 : return;
14687 : }
14688 :
14689 632 : if (gfc_omp_udr_predef (omp_udr->rop, omp_udr->name,
14690 : &omp_udr->ts, &predef_name))
14691 : {
14692 19 : if (predef_name)
14693 19 : gfc_error ("Redefinition of predefined %qs in "
14694 : "!$OMP DECLARE REDUCTION at %L",
14695 : predef_name, &omp_udr->where);
14696 : else
14697 0 : gfc_error ("Redefinition of predefined %qs in "
14698 : "!$OMP DECLARE REDUCTION at %L", omp_udr->name,
14699 : &omp_udr->where);
14700 : return;
14701 : }
14702 :
14703 613 : if (omp_udr->ts.type == BT_CHARACTER
14704 62 : && omp_udr->ts.u.cl->length
14705 32 : && omp_udr->ts.u.cl->length->expr_type != EXPR_CONSTANT)
14706 : {
14707 1 : gfc_error ("CHARACTER length in !$OMP DECLARE REDUCTION %qs not "
14708 : "constant at %L", omp_udr->name, &omp_udr->where);
14709 1 : return;
14710 : }
14711 :
14712 612 : struct omp_udr_callback_data cd;
14713 612 : cd.omp_udr = omp_udr;
14714 612 : cd.is_initializer = false;
14715 612 : gfc_code_walker (&omp_udr->combiner_ns->code, gfc_dummy_code_callback,
14716 : omp_udr_callback, &cd);
14717 612 : if (omp_udr->combiner_ns->code->op == EXEC_CALL)
14718 : {
14719 346 : for (a = omp_udr->combiner_ns->code->ext.actual; a; a = a->next)
14720 237 : if (a->expr == NULL)
14721 : break;
14722 110 : if (a)
14723 1 : gfc_error ("Subroutine call with alternate returns in combiner "
14724 : "of !$OMP DECLARE REDUCTION at %L",
14725 : &omp_udr->combiner_ns->code->loc);
14726 : }
14727 612 : if (omp_udr->initializer_ns)
14728 : {
14729 383 : cd.is_initializer = true;
14730 383 : gfc_code_walker (&omp_udr->initializer_ns->code, gfc_dummy_code_callback,
14731 : omp_udr_callback, &cd);
14732 383 : if (omp_udr->initializer_ns->code->op == EXEC_CALL)
14733 : {
14734 377 : for (a = omp_udr->initializer_ns->code->ext.actual; a; a = a->next)
14735 243 : if (a->expr == NULL)
14736 : break;
14737 135 : if (a)
14738 1 : gfc_error ("Subroutine call with alternate returns in "
14739 : "INITIALIZER clause of !$OMP DECLARE REDUCTION "
14740 : "at %L", &omp_udr->initializer_ns->code->loc);
14741 136 : for (a = omp_udr->initializer_ns->code->ext.actual; a; a = a->next)
14742 135 : if (a->expr
14743 135 : && a->expr->expr_type == EXPR_VARIABLE
14744 135 : && a->expr->symtree->n.sym == omp_udr->omp_priv
14745 134 : && a->expr->ref == NULL)
14746 : break;
14747 135 : if (a == NULL)
14748 1 : gfc_error ("One of actual subroutine arguments in INITIALIZER "
14749 : "clause of !$OMP DECLARE REDUCTION must be OMP_PRIV "
14750 : "at %L", &omp_udr->initializer_ns->code->loc);
14751 : }
14752 : }
14753 229 : else if (omp_udr->ts.type == BT_DERIVED
14754 229 : && !gfc_has_default_initializer (omp_udr->ts.u.derived))
14755 : {
14756 4 : gfc_error ("Missing INITIALIZER clause for !$OMP DECLARE REDUCTION "
14757 : "of derived type without default initializer at %L",
14758 : &omp_udr->where);
14759 4 : return;
14760 : }
14761 : }
14762 :
14763 : void
14764 363850 : gfc_resolve_omp_udrs (gfc_symtree *st)
14765 : {
14766 363850 : gfc_omp_udr *omp_udr;
14767 :
14768 363850 : if (st == NULL)
14769 : return;
14770 534 : gfc_resolve_omp_udrs (st->left);
14771 534 : gfc_resolve_omp_udrs (st->right);
14772 1167 : for (omp_udr = st->n.omp_udr; omp_udr; omp_udr = omp_udr->next)
14773 633 : gfc_resolve_omp_udr (omp_udr);
14774 : }
14775 :
14776 : /* Resolve !$omp declare mapper constructs. */
14777 :
14778 : static void
14779 30 : gfc_resolve_omp_udm (gfc_omp_udm *omp_udm)
14780 : {
14781 30 : resolve_omp_clauses (NULL, omp_udm->clauses, omp_udm->mapper_ns);
14782 :
14783 30 : gfc_omp_namelist *n;
14784 32 : for (n = omp_udm->clauses->lists[OMP_LIST_MAP]; n; n = n->next)
14785 30 : if (n->sym == omp_udm->var_sym)
14786 : break;
14787 30 : if (!n)
14788 2 : gfc_error ("At least one %<map%> clause in !$OMP DECLARE MAPPER at %L must "
14789 : "map %qs or an element of it",
14790 2 : &omp_udm->where, omp_udm->var_sym->name);
14791 30 : }
14792 :
14793 : void
14794 362840 : gfc_resolve_omp_udms (gfc_symtree *st)
14795 : {
14796 362840 : gfc_omp_udm *omp_udm;
14797 :
14798 362840 : if (st == NULL)
14799 : return;
14800 29 : gfc_resolve_omp_udms (st->left);
14801 29 : gfc_resolve_omp_udms (st->right);
14802 59 : for (omp_udm = st->n.omp_udm; omp_udm; omp_udm = omp_udm->next)
14803 30 : gfc_resolve_omp_udm (omp_udm);
14804 : }
|
