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 56009 : gfc_match_omp_eos (void)
146 : {
147 56009 : locus old_loc;
148 56009 : char c;
149 :
150 56009 : old_loc = gfc_current_locus;
151 56009 : gfc_gobble_whitespace ();
152 :
153 56009 : if (gfc_matching_omp_context_selector)
154 : {
155 269 : if (gfc_peek_ascii_char () == ')')
156 : return MATCH_YES;
157 : }
158 : else
159 : {
160 55740 : c = gfc_next_ascii_char ();
161 55740 : 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 1751 : gfc_current_locus = old_loc;
175 1751 : return MATCH_NO;
176 : }
177 :
178 : match
179 13209 : gfc_match_omp_eos_error (void)
180 : {
181 13209 : 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 62239 : gfc_free_omp_clauses (gfc_omp_clauses *c)
193 : {
194 62239 : if (c == NULL)
195 : return;
196 :
197 35249 : gfc_free_expr (c->if_expr);
198 422988 : for (int i = 0; i < OMP_IF_LAST; i++)
199 352490 : gfc_free_expr (c->if_exprs[i]);
200 35249 : gfc_free_expr (c->self_expr);
201 35249 : gfc_free_expr (c->final_expr);
202 35249 : gfc_free_expr (c->chunk_size);
203 35249 : gfc_free_expr (c->safelen_expr);
204 35249 : gfc_free_expr (c->simdlen_expr);
205 35249 : gfc_free_expr (c->device);
206 35249 : gfc_free_expr (c->dyn_groupprivate);
207 35249 : gfc_free_expr (c->dist_chunk_size);
208 35249 : gfc_free_expr (c->grainsize);
209 35249 : gfc_free_expr (c->hint);
210 35249 : gfc_free_expr (c->num_tasks);
211 35249 : gfc_free_expr (c->priority);
212 35249 : gfc_free_expr (c->detach);
213 35249 : gfc_free_expr (c->novariants);
214 35249 : gfc_free_expr (c->nocontext);
215 35249 : gfc_free_expr (c->async_expr);
216 35249 : gfc_free_expr (c->gang_num_expr);
217 35249 : gfc_free_expr (c->gang_static_expr);
218 35249 : gfc_free_expr (c->worker_expr);
219 35249 : gfc_free_expr (c->vector_expr);
220 35249 : gfc_free_expr (c->num_gangs_expr);
221 35249 : gfc_free_expr (c->num_workers_expr);
222 35249 : gfc_free_expr (c->vector_length_expr);
223 35249 : gfc_free_expr (c->device_num_expr);
224 1445209 : for (enum gfc_omp_list_type t = OMP_LIST_FIRST; t < OMP_LIST_NUM;
225 1374711 : t = gfc_omp_list_type (t + 1))
226 1374711 : gfc_free_omp_namelist (c->lists[t], t);
227 35249 : gfc_free_expr_list (c->num_teams_list);
228 35249 : gfc_free_expr_list (c->thread_limit_list);
229 35249 : gfc_free_expr_list (c->num_threads_list);
230 35249 : gfc_free_expr_list (c->wait_list);
231 35249 : gfc_free_expr_list (c->tile_list);
232 35249 : gfc_free_expr_list (c->sizes_list);
233 35249 : free (const_cast<char *> (c->critical_name));
234 35249 : if (c->assume)
235 : {
236 29 : free (c->assume->absent);
237 29 : free (c->assume->contains);
238 29 : gfc_free_expr_list (c->assume->holds);
239 29 : free (c->assume);
240 : }
241 35249 : 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 212735 : gfc_free_expr_list (gfc_expr_list *list)
266 : {
267 212735 : gfc_expr_list *n;
268 :
269 215523 : for (; list; list = n)
270 : {
271 2788 : n = list->next;
272 2788 : free (list);
273 : }
274 212735 : }
275 :
276 : /* Free an !$omp declare simd construct list. */
277 :
278 : void
279 237 : gfc_free_omp_declare_simd (gfc_omp_declare_simd *ods)
280 : {
281 237 : if (ods)
282 : {
283 237 : gfc_free_omp_clauses (ods->clauses);
284 237 : free (ods);
285 : }
286 237 : }
287 :
288 : void
289 547195 : gfc_free_omp_declare_simd_list (gfc_omp_declare_simd *list)
290 : {
291 547432 : while (list)
292 : {
293 237 : gfc_omp_declare_simd *current = list;
294 237 : list = list->next;
295 237 : gfc_free_omp_declare_simd (current);
296 : }
297 547195 : }
298 :
299 : static void
300 728 : gfc_free_omp_trait_property_list (gfc_omp_trait_property *list)
301 : {
302 1135 : while (list)
303 : {
304 407 : gfc_omp_trait_property *current = list;
305 407 : list = list->next;
306 407 : 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 407 : free (current);
322 : }
323 728 : }
324 :
325 : static void
326 600 : gfc_free_omp_selector_list (gfc_omp_selector *list)
327 : {
328 1328 : while (list)
329 : {
330 728 : gfc_omp_selector *current = list;
331 728 : list = list->next;
332 728 : gfc_free_omp_trait_property_list (current->properties);
333 728 : free (current);
334 : }
335 600 : }
336 :
337 : static void
338 669 : gfc_free_omp_set_selector_list (gfc_omp_set_selector *list)
339 : {
340 1269 : while (list)
341 : {
342 600 : gfc_omp_set_selector *current = list;
343 600 : list = list->next;
344 600 : gfc_free_omp_selector_list (current->trait_selectors);
345 600 : free (current);
346 : }
347 669 : }
348 :
349 : /* Free an !$omp declare variant construct list. */
350 :
351 : void
352 547195 : gfc_free_omp_declare_variant_list (gfc_omp_declare_variant *list)
353 : {
354 547650 : while (list)
355 : {
356 455 : gfc_omp_declare_variant *current = list;
357 455 : list = list->next;
358 455 : gfc_free_omp_set_selector_list (current->set_selectors);
359 455 : gfc_free_omp_namelist (current->adjust_args_list, OMP_LIST_NONE);
360 455 : free (current);
361 : }
362 547195 : }
363 :
364 : /* Free an !$omp declare reduction. */
365 :
366 : void
367 1273 : gfc_free_omp_udr (gfc_omp_udr *omp_udr)
368 : {
369 1273 : if (omp_udr)
370 : {
371 686 : gfc_free_omp_udr (omp_udr->next);
372 686 : gfc_free_namespace (omp_udr->combiner_ns);
373 686 : if (omp_udr->initializer_ns)
374 386 : gfc_free_namespace (omp_udr->initializer_ns);
375 686 : free (omp_udr);
376 : }
377 1273 : }
378 :
379 : /* Free variants of an !$omp metadirective construct. */
380 :
381 : void
382 93 : gfc_free_omp_variants (gfc_omp_variant *variant)
383 : {
384 284 : while (variant)
385 : {
386 191 : gfc_omp_variant *next_variant = variant->next;
387 191 : gfc_free_omp_set_selector_list (variant->selectors);
388 191 : free (variant);
389 191 : variant = next_variant;
390 : }
391 93 : }
392 :
393 : /* Free an !$omp declare mapper. */
394 :
395 : void
396 48 : gfc_free_omp_udm (gfc_omp_udm *omp_udm)
397 : {
398 48 : if (omp_udm)
399 : {
400 24 : gfc_free_omp_udm (omp_udm->next);
401 24 : gfc_free_namespace (omp_udm->mapper_ns);
402 24 : free (omp_udm);
403 : }
404 48 : }
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 31770 : 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 31770 : gfc_omp_namelist *head, *tail, *p;
468 31770 : locus old_loc, cur_loc;
469 31770 : char n[GFC_MAX_SYMBOL_LEN+1];
470 31770 : gfc_symbol *sym;
471 31770 : match m;
472 31770 : gfc_symtree *st;
473 :
474 31770 : head = tail = NULL;
475 :
476 31770 : old_loc = gfc_current_locus;
477 31770 : if (has_all_memory)
478 708 : *has_all_memory = false;
479 31770 : m = gfc_match (str);
480 31770 : if (m != MATCH_YES)
481 : return m;
482 :
483 38509 : for (;;)
484 : {
485 38509 : gfc_gobble_whitespace ();
486 38509 : cur_loc = gfc_current_locus;
487 :
488 38509 : m = gfc_match_name (n);
489 38509 : 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 38230 : if (m == MATCH_YES)
512 : {
513 38230 : gfc_symtree *st;
514 38230 : if ((m = gfc_get_ha_sym_tree (n, &st) ? MATCH_ERROR : MATCH_YES)
515 : == MATCH_YES)
516 38230 : sym = st->n.sym;
517 : }
518 38486 : switch (m)
519 : {
520 38230 : case MATCH_YES:
521 38230 : gfc_expr *expr;
522 38230 : expr = NULL;
523 38230 : gfc_gobble_whitespace ();
524 23541 : if ((allow_sections && gfc_peek_ascii_char () == '(')
525 57409 : || (allow_derived && gfc_peek_ascii_char () == '%'))
526 : {
527 6603 : gfc_current_locus = cur_loc;
528 6603 : m = gfc_match_variable (&expr, 0);
529 6603 : switch (m)
530 : {
531 4 : case MATCH_ERROR:
532 12 : goto cleanup;
533 0 : case MATCH_NO:
534 0 : goto syntax;
535 6599 : default:
536 6599 : break;
537 : }
538 6599 : 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 38221 : gfc_set_sym_referenced (sym);
546 38221 : p = gfc_get_omp_namelist ();
547 38221 : if (head == NULL)
548 : head = tail = p;
549 10165 : else if (reverse_order)
550 : {
551 57 : p->next = head;
552 57 : head = p;
553 : }
554 : else
555 : {
556 10108 : tail->next = p;
557 10108 : tail = tail->next;
558 : }
559 38221 : p->sym = sym;
560 38221 : p->expr = expr;
561 38221 : p->where = gfc_get_location_range (NULL, 0, &cur_loc, 1,
562 : &gfc_current_locus);
563 38221 : 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 38218 : 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 38462 : if (end_colon && gfc_match_char (':') == MATCH_YES)
618 : {
619 794 : *end_colon = true;
620 794 : break;
621 : }
622 37668 : if (gfc_match_char (')') == MATCH_YES)
623 : break;
624 10236 : if (gfc_match_char (',') != MATCH_YES)
625 21 : goto syntax;
626 : }
627 :
628 38264 : while (*list)
629 10038 : list = &(*list)->next;
630 :
631 28226 : *list = head;
632 28226 : if (headp)
633 22332 : *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 364 : gfc_match_omp_to_link (const char *str, gfc_omp_namelist **list)
650 : {
651 364 : gfc_omp_namelist *head, *tail, *p;
652 364 : locus old_loc, cur_loc;
653 364 : char n[GFC_MAX_SYMBOL_LEN+1];
654 364 : gfc_symbol *sym;
655 364 : match m;
656 364 : gfc_symtree *st;
657 :
658 364 : head = tail = NULL;
659 :
660 364 : old_loc = gfc_current_locus;
661 :
662 364 : m = gfc_match (str);
663 364 : if (m != MATCH_YES)
664 : return m;
665 :
666 550 : for (;;)
667 : {
668 550 : cur_loc = gfc_current_locus;
669 550 : m = gfc_match_symbol (&sym, 1);
670 550 : switch (m)
671 : {
672 509 : case MATCH_YES:
673 509 : p = gfc_get_omp_namelist ();
674 509 : if (head == NULL)
675 : head = tail = p;
676 : else
677 : {
678 194 : tail->next = p;
679 194 : tail = tail->next;
680 : }
681 509 : tail->sym = sym;
682 509 : tail->where = cur_loc;
683 509 : goto next_item;
684 : case MATCH_NO:
685 : break;
686 0 : case MATCH_ERROR:
687 0 : goto cleanup;
688 : }
689 :
690 41 : m = gfc_match (" / %n /", n);
691 41 : if (m == MATCH_ERROR)
692 0 : goto cleanup;
693 41 : if (m == MATCH_NO)
694 0 : goto syntax;
695 :
696 41 : st = gfc_find_symtree (gfc_current_ns->common_root, n);
697 41 : if (st == NULL)
698 : {
699 0 : gfc_error ("COMMON block /%s/ not found at %C", n);
700 0 : goto cleanup;
701 : }
702 41 : p = gfc_get_omp_namelist ();
703 41 : if (head == NULL)
704 : head = tail = p;
705 : else
706 : {
707 4 : tail->next = p;
708 4 : tail = tail->next;
709 : }
710 41 : tail->u.common = st->n.common;
711 41 : tail->where = cur_loc;
712 :
713 550 : next_item:
714 550 : if (gfc_match_char (')') == MATCH_YES)
715 : break;
716 198 : if (gfc_match_char (',') != MATCH_YES)
717 0 : goto syntax;
718 : }
719 :
720 363 : while (*list)
721 11 : list = &(*list)->next;
722 :
723 352 : *list = head;
724 352 : 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 32892 : omp_mask::omp_mask (omp_mask1 m) : mask1 (((uint64_t) 1) << m), mask2 (0)
1307 : {
1308 : }
1309 :
1310 2212 : omp_mask::omp_mask (omp_mask2 m) : mask1 (0), mask2 (((uint64_t) 1) << m)
1311 : {
1312 : }
1313 :
1314 33772 : omp_mask::omp_mask (uint64_t m1, uint64_t m2) : mask1 (m1), mask2 (m2)
1315 : {
1316 : }
1317 :
1318 : omp_mask
1319 32821 : omp_mask::operator| (omp_mask1 m) const
1320 : {
1321 32821 : return omp_mask (mask1 | (((uint64_t) 1) << m), mask2);
1322 : }
1323 :
1324 : omp_mask
1325 17268 : omp_mask::operator| (omp_mask2 m) const
1326 : {
1327 17268 : return omp_mask (mask1, mask2 | (((uint64_t) 1) << m));
1328 : }
1329 :
1330 : omp_mask
1331 4374 : omp_mask::operator| (omp_mask m) const
1332 : {
1333 4374 : return omp_mask (mask1 | m.mask1, mask2 | m.mask2);
1334 : }
1335 :
1336 : omp_mask
1337 2031 : omp_mask::operator& (const omp_inv_mask &m) const
1338 : {
1339 2031 : return omp_mask (mask1 & ~m.mask1, mask2 & ~m.mask2);
1340 : }
1341 :
1342 : bool
1343 129622 : omp_mask::operator& (omp_mask1 m) const
1344 : {
1345 129622 : return (mask1 & (((uint64_t) 1) << m)) != 0;
1346 : }
1347 :
1348 : bool
1349 92343 : omp_mask::operator& (omp_mask2 m) const
1350 : {
1351 92343 : return (mask2 & (((uint64_t) 1) << m)) != 0;
1352 : }
1353 :
1354 : omp_inv_mask
1355 2031 : omp_mask::operator~ () const
1356 : {
1357 2031 : return omp_inv_mask (*this);
1358 : }
1359 :
1360 2031 : 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 8742 : gfc_match_iterator (gfc_namespace **ns, bool permit_var)
1387 : {
1388 8742 : locus old_loc = gfc_current_locus;
1389 :
1390 8742 : 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 46 : gfc_omp_absent_contains_clause (gfc_omp_assumptions **assume, bool is_absent)
1784 : {
1785 46 : if (*assume == NULL)
1786 21 : *assume = gfc_get_omp_assumptions ();
1787 76 : do
1788 : {
1789 61 : gfc_statement st = ST_NONE;
1790 61 : gfc_gobble_whitespace ();
1791 61 : locus old_loc = gfc_current_locus;
1792 61 : char c = gfc_peek_ascii_char ();
1793 61 : enum gfc_omp_directive_kind kind
1794 : = GFC_OMP_DIR_DECLARATIVE; /* Silence warning. */
1795 2333 : for (size_t i = 0; i < ARRAY_SIZE (gfc_omp_directives); i++)
1796 : {
1797 2272 : if (gfc_omp_directives[i].name[0] > c)
1798 : break;
1799 2211 : if (gfc_omp_directives[i].name[0] != c)
1800 1635 : continue;
1801 576 : if (gfc_match (gfc_omp_directives[i].name) == MATCH_YES)
1802 : {
1803 61 : st = gfc_omp_directives[i].st;
1804 61 : kind = gfc_omp_directives[i].kind;
1805 : }
1806 : }
1807 61 : gfc_gobble_whitespace ();
1808 61 : c = gfc_peek_ascii_char ();
1809 61 : 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 61 : if (kind == GFC_OMP_DIR_DECLARATIVE
1819 61 : || 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 52 : 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 14 : int i = (*assume)->n_contains;
1842 14 : int size = ((i == 0) ? 4
1843 4 : : pow2p_hwi (i) == 1 ? i*2 : 0);
1844 4 : if (size != 0)
1845 14 : (*assume)->contains = XRESIZEVEC (gfc_statement,
1846 : (*assume)->contains, size);
1847 14 : (*assume)->contains[(*assume)->n_contains++] = st;
1848 : }
1849 52 : gfc_gobble_whitespace ();
1850 52 : if (gfc_match(",") == MATCH_YES)
1851 15 : continue;
1852 37 : 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 37 : 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 44 : omp_verify_merge_absent_contains (gfc_statement st, gfc_omp_assumptions *check,
1867 : gfc_omp_assumptions *merge, locus *loc)
1868 : {
1869 44 : if (check == NULL)
1870 : return MATCH_YES;
1871 44 : bitmap_head absent_head, contains_head;
1872 44 : bitmap_obstack_initialize (NULL);
1873 44 : bitmap_initialize (&absent_head, &bitmap_default_obstack);
1874 44 : bitmap_initialize (&contains_head, &bitmap_default_obstack);
1875 :
1876 44 : match m = MATCH_YES;
1877 82 : 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 58 : for (int i = 0; i < check->n_contains; i++)
1887 : {
1888 14 : 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 14 : 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 44 : if (m == MATCH_ERROR)
1907 : return MATCH_ERROR;
1908 38 : if (merge == NULL)
1909 : return MATCH_YES;
1910 2 : 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 1 : 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 2 : 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 2 : 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 :
2479 : /* Match with duplicate check. Matches 'name'. If expr != NULL, it
2480 : then matches '(expr)', otherwise, if open_parens is true,
2481 : it matches a ' ( ' after 'name'.
2482 : dupl_message requires '%qs %L' - and is used by
2483 : gfc_match_dupl_memorder and gfc_match_dupl_atomic. */
2484 :
2485 : static match
2486 23281 : gfc_match_dupl_check (bool not_dupl, const char *name, bool open_parens = false,
2487 : gfc_expr **expr = NULL, const char *dupl_msg = NULL)
2488 : {
2489 23281 : match m;
2490 23281 : char c;
2491 23281 : locus old_loc = gfc_current_locus;
2492 23281 : if ((m = gfc_match (name)) != MATCH_YES)
2493 : return m;
2494 : /* Ensure that no partial string is matched. */
2495 18175 : if (gfc_current_form == FORM_FREE
2496 17677 : && gfc_match_eos () != MATCH_YES
2497 31713 : && ((c = gfc_peek_ascii_char ()) == '_' || ISALNUM (c)))
2498 : {
2499 13 : gfc_current_locus = old_loc;
2500 13 : return MATCH_NO;
2501 : }
2502 18162 : if (!not_dupl)
2503 : {
2504 53 : if (dupl_msg)
2505 2 : gfc_error (dupl_msg, name, &old_loc);
2506 : else
2507 51 : gfc_error ("Duplicated %qs clause at %L", name, &old_loc);
2508 : return MATCH_ERROR;
2509 : }
2510 18109 : if (open_parens || expr)
2511 : {
2512 10112 : if (gfc_match (" ( ") != MATCH_YES)
2513 : {
2514 25 : gfc_error ("Expected %<(%> after %qs at %C", name);
2515 25 : return MATCH_ERROR;
2516 : }
2517 10087 : if (expr)
2518 : {
2519 3396 : if (gfc_match ("%e )", expr) != MATCH_YES)
2520 : {
2521 9 : gfc_error ("Invalid expression after %<%s(%> at %C", name);
2522 9 : return MATCH_ERROR;
2523 : }
2524 : }
2525 : }
2526 : return MATCH_YES;
2527 : }
2528 :
2529 : static match
2530 211 : gfc_match_dupl_memorder (bool not_dupl, const char *name)
2531 : {
2532 0 : return gfc_match_dupl_check (not_dupl, name, false, NULL,
2533 : "Duplicated memory-order clause: unexpected %s "
2534 0 : "clause at %L");
2535 : }
2536 :
2537 : static match
2538 1175 : gfc_match_dupl_atomic (bool not_dupl, const char *name)
2539 : {
2540 0 : return gfc_match_dupl_check (not_dupl, name, false, NULL,
2541 : "Duplicated atomic clause: unexpected %s "
2542 0 : "clause at %L");
2543 : }
2544 :
2545 :
2546 : /* Search upwards though namespace NS and its parents to find an
2547 : !$omp declare mapper named MAPPER_ID, for typespec TS. The default
2548 : mapper has mapper_id == "". */
2549 :
2550 : gfc_omp_udm *
2551 1002 : gfc_find_omp_udm (gfc_namespace *ns, const char *mapper_id, gfc_typespec *ts)
2552 : {
2553 1002 : gfc_symtree *st;
2554 :
2555 1002 : if (ns == NULL)
2556 0 : ns = gfc_current_ns;
2557 :
2558 1181 : do
2559 : {
2560 1181 : gfc_omp_udm *omp_udm;
2561 :
2562 1181 : st = gfc_find_symtree (ns->omp_udm_root, mapper_id);
2563 :
2564 1181 : if (st != NULL)
2565 : {
2566 29 : for (omp_udm = st->n.omp_udm; omp_udm; omp_udm = omp_udm->next)
2567 29 : if (gfc_compare_types (&omp_udm->ts, ts))
2568 : return omp_udm;
2569 : }
2570 :
2571 : /* Don't escape an interface block. */
2572 1154 : if (ns && !ns->has_import_set
2573 1154 : && ns->proc_name && ns->proc_name->attr.if_source == IFSRC_IFBODY)
2574 : break;
2575 :
2576 1154 : ns = ns->parent;
2577 : }
2578 1154 : while (ns != NULL);
2579 :
2580 : return NULL;
2581 : }
2582 :
2583 :
2584 : /* Match OpenMP and OpenACC directive clauses. MASK is a bitmask of
2585 : clauses that are allowed for a particular directive. */
2586 :
2587 : static match
2588 35104 : gfc_match_omp_clauses (gfc_omp_clauses **cp, const omp_mask mask,
2589 : bool first = true, bool needs_space = true,
2590 : bool openacc = false, bool openmp_target = false,
2591 : gfc_omp_map_op default_map_op = OMP_MAP_TOFROM)
2592 : {
2593 35104 : bool error = false;
2594 35104 : gfc_omp_clauses *c = gfc_get_omp_clauses ();
2595 35104 : locus old_loc;
2596 : /* Determine whether we're dealing with an OpenACC directive that permits
2597 : derived type member accesses. This in particular disallows
2598 : "!$acc declare" from using such accesses, because it's not clear if/how
2599 : that should work. */
2600 35104 : bool allow_derived = (openacc
2601 35104 : && ((mask & OMP_CLAUSE_ATTACH)
2602 6326 : || (mask & OMP_CLAUSE_DETACH)));
2603 :
2604 35104 : gcc_checking_assert (OMP_MASK1_LAST <= 64 && OMP_MASK2_LAST <= 64);
2605 35104 : *cp = NULL;
2606 128932 : while (1)
2607 : {
2608 82018 : match m = MATCH_NO;
2609 61080 : if ((first || (m = gfc_match_char (',')) != MATCH_YES)
2610 142742 : && (needs_space && gfc_match_space () != MATCH_YES))
2611 : break;
2612 77449 : needs_space = false;
2613 77449 : first = false;
2614 77449 : gfc_gobble_whitespace ();
2615 77449 : bool end_colon;
2616 77449 : gfc_omp_namelist **head;
2617 77449 : old_loc = gfc_current_locus;
2618 77449 : char pc = gfc_peek_ascii_char ();
2619 77449 : if (pc == '\n' && m == MATCH_YES)
2620 : {
2621 1 : gfc_error ("Clause expected at %C after trailing comma");
2622 1 : goto error;
2623 : }
2624 77448 : switch (pc)
2625 : {
2626 1318 : case 'a':
2627 1318 : end_colon = false;
2628 1318 : head = NULL;
2629 1343 : if ((mask & OMP_CLAUSE_ASSUMPTIONS)
2630 1318 : && gfc_match ("absent ( ") == MATCH_YES)
2631 : {
2632 28 : if (gfc_omp_absent_contains_clause (&c->assume, true)
2633 : != MATCH_YES)
2634 3 : goto error;
2635 25 : continue;
2636 : }
2637 1290 : if ((mask & OMP_CLAUSE_ALIGNED)
2638 1290 : && gfc_match_omp_variable_list ("aligned (",
2639 : &c->lists[OMP_LIST_ALIGNED],
2640 : false, &end_colon,
2641 : &head) == MATCH_YES)
2642 : {
2643 112 : gfc_expr *alignment = NULL;
2644 112 : gfc_omp_namelist *n;
2645 :
2646 112 : if (end_colon && gfc_match (" %e )", &alignment) != MATCH_YES)
2647 : {
2648 0 : gfc_free_omp_namelist (*head, OMP_LIST_ALIGNED);
2649 0 : gfc_current_locus = old_loc;
2650 0 : *head = NULL;
2651 0 : break;
2652 : }
2653 268 : for (n = *head; n; n = n->next)
2654 156 : if (n->next && alignment)
2655 42 : n->expr = gfc_copy_expr (alignment);
2656 : else
2657 114 : n->expr = alignment;
2658 112 : continue;
2659 112 : }
2660 1188 : if ((mask & OMP_CLAUSE_MEMORDER)
2661 1195 : && (m = gfc_match_dupl_memorder ((c->memorder
2662 17 : == OMP_MEMORDER_UNSET),
2663 : "acq_rel")) != MATCH_NO)
2664 : {
2665 10 : if (m == MATCH_ERROR)
2666 0 : goto error;
2667 10 : c->memorder = OMP_MEMORDER_ACQ_REL;
2668 10 : continue;
2669 : }
2670 1175 : if ((mask & OMP_CLAUSE_MEMORDER)
2671 1175 : && (m = gfc_match_dupl_memorder ((c->memorder
2672 7 : == OMP_MEMORDER_UNSET),
2673 : "acquire")) != MATCH_NO)
2674 : {
2675 7 : if (m == MATCH_ERROR)
2676 0 : goto error;
2677 7 : c->memorder = OMP_MEMORDER_ACQUIRE;
2678 7 : continue;
2679 : }
2680 1161 : if ((mask & OMP_CLAUSE_AFFINITY)
2681 1161 : && gfc_match ("affinity ( ") == MATCH_YES)
2682 : {
2683 41 : gfc_namespace *ns_iter = NULL, *ns_curr = gfc_current_ns;
2684 41 : m = gfc_match_iterator (&ns_iter, true);
2685 41 : if (m == MATCH_ERROR)
2686 : break;
2687 31 : if (m == MATCH_YES && gfc_match (" : ") != MATCH_YES)
2688 : {
2689 1 : gfc_error ("Expected %<:%> at %C");
2690 1 : break;
2691 : }
2692 30 : if (ns_iter)
2693 18 : gfc_current_ns = ns_iter;
2694 30 : head = NULL;
2695 30 : m = gfc_match_omp_variable_list ("", &c->lists[OMP_LIST_AFFINITY],
2696 : false, NULL, &head, true);
2697 30 : gfc_current_ns = ns_curr;
2698 30 : if (m == MATCH_ERROR)
2699 : break;
2700 27 : if (ns_iter)
2701 : {
2702 45 : for (gfc_omp_namelist *n = *head; n; n = n->next)
2703 : {
2704 27 : n->u2.ns = ns_iter;
2705 27 : ns_iter->refs++;
2706 : }
2707 : }
2708 27 : continue;
2709 27 : }
2710 1120 : if ((mask & OMP_CLAUSE_ALLOCATE)
2711 1120 : && gfc_match ("allocate ( ") == MATCH_YES)
2712 : {
2713 281 : gfc_expr *allocator = NULL;
2714 281 : gfc_expr *align = NULL;
2715 281 : old_loc = gfc_current_locus;
2716 281 : if ((m = gfc_match ("allocator ( %e )", &allocator)) == MATCH_YES)
2717 50 : gfc_match (" , align ( %e )", &align);
2718 231 : else if ((m = gfc_match ("align ( %e )", &align)) == MATCH_YES)
2719 29 : gfc_match (" , allocator ( %e )", &allocator);
2720 :
2721 79 : if (m == MATCH_YES)
2722 : {
2723 79 : if (gfc_match (" : ") != MATCH_YES)
2724 : {
2725 5 : gfc_error ("Expected %<:%> at %C");
2726 8 : goto error;
2727 : }
2728 : }
2729 : else
2730 : {
2731 202 : m = gfc_match_expr (&allocator);
2732 202 : if (m == MATCH_YES && gfc_match (" : ") != MATCH_YES)
2733 : {
2734 : /* If no ":" then there is no allocator, we backtrack
2735 : and read the variable list. */
2736 101 : gfc_free_expr (allocator);
2737 101 : allocator = NULL;
2738 101 : gfc_current_locus = old_loc;
2739 : }
2740 : }
2741 276 : gfc_omp_namelist **head = NULL;
2742 276 : m = gfc_match_omp_variable_list ("", &c->lists[OMP_LIST_ALLOCATE],
2743 : true, NULL, &head);
2744 :
2745 276 : if (m != MATCH_YES)
2746 : {
2747 3 : gfc_free_expr (allocator);
2748 3 : gfc_free_expr (align);
2749 3 : gfc_error ("Expected variable list at %C");
2750 3 : goto error;
2751 : }
2752 :
2753 729 : for (gfc_omp_namelist *n = *head; n; n = n->next)
2754 : {
2755 456 : n->u2.allocator = allocator;
2756 456 : n->u.align = (align) ? gfc_copy_expr (align) : NULL;
2757 : }
2758 273 : gfc_free_expr (align);
2759 273 : continue;
2760 273 : }
2761 899 : if ((mask & OMP_CLAUSE_AT)
2762 839 : && (m = gfc_match_dupl_check (c->at == OMP_AT_UNSET, "at", true))
2763 : != MATCH_NO)
2764 : {
2765 66 : if (m == MATCH_ERROR)
2766 2 : goto error;
2767 64 : if (gfc_match ("compilation )") == MATCH_YES)
2768 15 : c->at = OMP_AT_COMPILATION;
2769 49 : else if (gfc_match ("execution )") == MATCH_YES)
2770 45 : c->at = OMP_AT_EXECUTION;
2771 : else
2772 : {
2773 4 : gfc_error ("Expected COMPILATION or EXECUTION in AT clause "
2774 : "at %C");
2775 4 : goto error;
2776 : }
2777 60 : continue;
2778 : }
2779 1416 : if ((mask & OMP_CLAUSE_ASYNC)
2780 773 : && (m = gfc_match_dupl_check (!c->async, "async")) != MATCH_NO)
2781 : {
2782 643 : if (m == MATCH_ERROR)
2783 0 : goto error;
2784 643 : c->async = true;
2785 643 : m = gfc_match (" ( %e )", &c->async_expr);
2786 643 : if (m == MATCH_ERROR)
2787 : {
2788 0 : gfc_current_locus = old_loc;
2789 0 : break;
2790 : }
2791 643 : else if (m == MATCH_NO)
2792 : {
2793 133 : c->async_expr
2794 133 : = gfc_get_constant_expr (BT_INTEGER,
2795 : gfc_default_integer_kind,
2796 : &gfc_current_locus);
2797 133 : mpz_set_si (c->async_expr->value.integer, GOMP_ASYNC_NOVAL);
2798 : }
2799 643 : continue;
2800 : }
2801 193 : if ((mask & OMP_CLAUSE_AUTO)
2802 130 : && (m = gfc_match_dupl_check (!c->par_auto, "auto"))
2803 : != MATCH_NO)
2804 : {
2805 63 : if (m == MATCH_ERROR)
2806 0 : goto error;
2807 63 : c->par_auto = true;
2808 63 : continue;
2809 : }
2810 128 : if ((mask & OMP_CLAUSE_ATTACH)
2811 62 : && gfc_match ("attach ( ") == MATCH_YES
2812 128 : && gfc_match_omp_map_clause (&c->lists[OMP_LIST_MAP],
2813 : OMP_MAP_ATTACH, false,
2814 : allow_derived))
2815 61 : continue;
2816 : break;
2817 36 : case 'b':
2818 70 : if ((mask & OMP_CLAUSE_BIND)
2819 36 : && (m = gfc_match_dupl_check (c->bind == OMP_BIND_UNSET, "bind",
2820 : true)) != MATCH_NO)
2821 : {
2822 36 : if (m == MATCH_ERROR)
2823 1 : goto error;
2824 35 : if (gfc_match ("teams )") == MATCH_YES)
2825 11 : c->bind = OMP_BIND_TEAMS;
2826 24 : else if (gfc_match ("parallel )") == MATCH_YES)
2827 15 : c->bind = OMP_BIND_PARALLEL;
2828 9 : else if (gfc_match ("thread )") == MATCH_YES)
2829 8 : c->bind = OMP_BIND_THREAD;
2830 : else
2831 : {
2832 1 : gfc_error ("Expected TEAMS, PARALLEL or THREAD as binding in "
2833 : "BIND at %C");
2834 1 : break;
2835 : }
2836 34 : continue;
2837 : }
2838 : break;
2839 7115 : case 'c':
2840 7388 : if ((mask & OMP_CLAUSE_CAPTURE)
2841 7115 : && (m = gfc_match_dupl_check (!c->capture, "capture"))
2842 : != MATCH_NO)
2843 : {
2844 274 : if (m == MATCH_ERROR)
2845 1 : goto error;
2846 273 : c->capture = true;
2847 273 : continue;
2848 : }
2849 6841 : if (mask & OMP_CLAUSE_COLLAPSE)
2850 : {
2851 1996 : gfc_expr *cexpr = NULL;
2852 1996 : if ((m = gfc_match_dupl_check (!c->collapse, "collapse", true,
2853 : &cexpr)) != MATCH_NO)
2854 : {
2855 1506 : int collapse;
2856 1506 : if (m == MATCH_ERROR)
2857 0 : goto error;
2858 1506 : if (gfc_extract_int (cexpr, &collapse, -1))
2859 4 : collapse = 1;
2860 1502 : else if (collapse <= 0)
2861 : {
2862 8 : gfc_error_now ("COLLAPSE clause argument not constant "
2863 : "positive integer at %C");
2864 8 : collapse = 1;
2865 : }
2866 1506 : gfc_free_expr (cexpr);
2867 1506 : c->collapse = collapse;
2868 1506 : continue;
2869 1506 : }
2870 : }
2871 5501 : if ((mask & OMP_CLAUSE_COMPARE)
2872 5335 : && (m = gfc_match_dupl_check (!c->compare, "compare"))
2873 : != MATCH_NO)
2874 : {
2875 167 : if (m == MATCH_ERROR)
2876 1 : goto error;
2877 166 : c->compare = true;
2878 166 : continue;
2879 : }
2880 5180 : if ((mask & OMP_CLAUSE_ASSUMPTIONS)
2881 5168 : && gfc_match ("contains ( ") == MATCH_YES)
2882 : {
2883 18 : if (gfc_omp_absent_contains_clause (&c->assume, false)
2884 : != MATCH_YES)
2885 6 : goto error;
2886 12 : continue;
2887 : }
2888 7266 : if ((mask & OMP_CLAUSE_COPY)
2889 3723 : && gfc_match ("copy ( ") == MATCH_YES
2890 7267 : && gfc_match_omp_map_clause (&c->lists[OMP_LIST_MAP],
2891 : OMP_MAP_TOFROM, true,
2892 : allow_derived))
2893 2116 : continue;
2894 3034 : if (mask & OMP_CLAUSE_COPYIN)
2895 : {
2896 2628 : if (openacc)
2897 : {
2898 2529 : if (gfc_match ("copyin ( ") == MATCH_YES)
2899 : {
2900 1458 : bool readonly = gfc_match ("readonly : ") == MATCH_YES;
2901 1458 : head = NULL;
2902 1458 : if (gfc_match_omp_variable_list ("",
2903 : &c->lists[OMP_LIST_MAP],
2904 : true, NULL, &head, true,
2905 : allow_derived)
2906 : == MATCH_YES)
2907 : {
2908 1452 : gfc_omp_namelist *n;
2909 3349 : for (n = *head; n; n = n->next)
2910 : {
2911 1897 : n->u.map.op = OMP_MAP_TO;
2912 1897 : n->u.map.readonly = readonly;
2913 : }
2914 1452 : continue;
2915 1452 : }
2916 : }
2917 : }
2918 99 : else if (gfc_match_omp_variable_list ("copyin (",
2919 : &c->lists[OMP_LIST_COPYIN],
2920 : true) == MATCH_YES)
2921 97 : continue;
2922 : }
2923 2556 : if ((mask & OMP_CLAUSE_COPYOUT)
2924 1216 : && gfc_match ("copyout ( ") == MATCH_YES
2925 2556 : && gfc_match_omp_map_clause (&c->lists[OMP_LIST_MAP],
2926 : OMP_MAP_FROM, true, allow_derived))
2927 1071 : continue;
2928 498 : if ((mask & OMP_CLAUSE_COPYPRIVATE)
2929 414 : && gfc_match_omp_variable_list ("copyprivate (",
2930 : &c->lists[OMP_LIST_COPYPRIVATE],
2931 : true) == MATCH_YES)
2932 84 : continue;
2933 651 : if ((mask & OMP_CLAUSE_CREATE)
2934 328 : && gfc_match ("create ( ") == MATCH_YES
2935 651 : && gfc_match_omp_map_clause (&c->lists[OMP_LIST_MAP],
2936 : OMP_MAP_ALLOC, true, allow_derived))
2937 321 : continue;
2938 : break;
2939 4186 : case 'd':
2940 4186 : if ((mask & OMP_CLAUSE_DEFAULTMAP)
2941 4186 : && gfc_match ("defaultmap ( ") == MATCH_YES)
2942 : {
2943 181 : enum gfc_omp_defaultmap behavior;
2944 181 : gfc_omp_defaultmap_category category
2945 : = OMP_DEFAULTMAP_CAT_UNCATEGORIZED;
2946 181 : if (gfc_match ("alloc ") == MATCH_YES)
2947 : behavior = OMP_DEFAULTMAP_ALLOC;
2948 175 : else if (gfc_match ("tofrom ") == MATCH_YES)
2949 : behavior = OMP_DEFAULTMAP_TOFROM;
2950 143 : else if (gfc_match ("to ") == MATCH_YES)
2951 : behavior = OMP_DEFAULTMAP_TO;
2952 133 : else if (gfc_match ("from ") == MATCH_YES)
2953 : behavior = OMP_DEFAULTMAP_FROM;
2954 130 : else if (gfc_match ("firstprivate ") == MATCH_YES)
2955 : behavior = OMP_DEFAULTMAP_FIRSTPRIVATE;
2956 95 : else if (gfc_match ("present ") == MATCH_YES)
2957 : behavior = OMP_DEFAULTMAP_PRESENT;
2958 91 : else if (gfc_match ("none ") == MATCH_YES)
2959 : behavior = OMP_DEFAULTMAP_NONE;
2960 10 : else if (gfc_match ("default ") == MATCH_YES)
2961 : behavior = OMP_DEFAULTMAP_DEFAULT;
2962 : else
2963 : {
2964 1 : gfc_error ("Expected ALLOC, TO, FROM, TOFROM, FIRSTPRIVATE, "
2965 : "PRESENT, NONE or DEFAULT at %C");
2966 1 : break;
2967 : }
2968 180 : if (')' == gfc_peek_ascii_char ())
2969 : ;
2970 102 : else if (gfc_match (": ") != MATCH_YES)
2971 : break;
2972 : else
2973 : {
2974 102 : if (gfc_match ("scalar ") == MATCH_YES)
2975 : category = OMP_DEFAULTMAP_CAT_SCALAR;
2976 67 : else if (gfc_match ("aggregate ") == MATCH_YES)
2977 : category = OMP_DEFAULTMAP_CAT_AGGREGATE;
2978 43 : else if (gfc_match ("allocatable ") == MATCH_YES)
2979 : category = OMP_DEFAULTMAP_CAT_ALLOCATABLE;
2980 31 : else if (gfc_match ("pointer ") == MATCH_YES)
2981 : category = OMP_DEFAULTMAP_CAT_POINTER;
2982 14 : else if (gfc_match ("all ") == MATCH_YES)
2983 : category = OMP_DEFAULTMAP_CAT_ALL;
2984 : else
2985 : {
2986 1 : gfc_error ("Expected SCALAR, AGGREGATE, ALLOCATABLE, "
2987 : "POINTER or ALL at %C");
2988 1 : break;
2989 : }
2990 : }
2991 1200 : for (int i = 0; i < OMP_DEFAULTMAP_CAT_NUM; ++i)
2992 : {
2993 1034 : if (i != category
2994 1034 : && category != OMP_DEFAULTMAP_CAT_UNCATEGORIZED
2995 486 : && category != OMP_DEFAULTMAP_CAT_ALL
2996 486 : && i != OMP_DEFAULTMAP_CAT_UNCATEGORIZED
2997 341 : && i != OMP_DEFAULTMAP_CAT_ALL)
2998 254 : continue;
2999 780 : if (c->defaultmap[i] != OMP_DEFAULTMAP_UNSET)
3000 : {
3001 13 : const char *pcategory = NULL;
3002 13 : switch (i)
3003 : {
3004 : case OMP_DEFAULTMAP_CAT_UNCATEGORIZED: break;
3005 3 : case OMP_DEFAULTMAP_CAT_ALL: pcategory = "ALL"; break;
3006 1 : case OMP_DEFAULTMAP_CAT_SCALAR: pcategory = "SCALAR"; break;
3007 2 : case OMP_DEFAULTMAP_CAT_AGGREGATE:
3008 2 : pcategory = "AGGREGATE";
3009 2 : break;
3010 1 : case OMP_DEFAULTMAP_CAT_ALLOCATABLE:
3011 1 : pcategory = "ALLOCATABLE";
3012 1 : break;
3013 : case OMP_DEFAULTMAP_CAT_POINTER:
3014 : pcategory = "POINTER";
3015 : break;
3016 0 : default: gcc_unreachable ();
3017 : }
3018 7 : if (i == OMP_DEFAULTMAP_CAT_UNCATEGORIZED)
3019 4 : gfc_error ("DEFAULTMAP at %C but prior DEFAULTMAP with "
3020 : "unspecified category");
3021 : else
3022 9 : gfc_error ("DEFAULTMAP at %C but prior DEFAULTMAP for "
3023 : "category %s", pcategory);
3024 13 : goto error;
3025 : }
3026 : }
3027 166 : c->defaultmap[category] = behavior;
3028 166 : if (gfc_match (")") != MATCH_YES)
3029 : break;
3030 166 : continue;
3031 166 : }
3032 4972 : if ((mask & OMP_CLAUSE_DEFAULT)
3033 4005 : && (m = gfc_match_dupl_check (c->default_sharing
3034 : == OMP_DEFAULT_UNKNOWN, "default",
3035 : true)) != MATCH_NO)
3036 : {
3037 1012 : if (m == MATCH_ERROR)
3038 6 : goto error;
3039 1006 : if (gfc_match ("none") == MATCH_YES)
3040 596 : c->default_sharing = OMP_DEFAULT_NONE;
3041 410 : else if (openacc)
3042 : {
3043 225 : if (gfc_match ("present") == MATCH_YES)
3044 195 : c->default_sharing = OMP_DEFAULT_PRESENT;
3045 : }
3046 : else
3047 : {
3048 185 : if (gfc_match ("firstprivate") == MATCH_YES)
3049 8 : c->default_sharing = OMP_DEFAULT_FIRSTPRIVATE;
3050 177 : else if (gfc_match ("private") == MATCH_YES)
3051 24 : c->default_sharing = OMP_DEFAULT_PRIVATE;
3052 153 : else if (gfc_match ("shared") == MATCH_YES)
3053 153 : c->default_sharing = OMP_DEFAULT_SHARED;
3054 : }
3055 1006 : if (c->default_sharing == OMP_DEFAULT_UNKNOWN)
3056 : {
3057 30 : if (openacc)
3058 30 : gfc_error ("Expected NONE or PRESENT in DEFAULT clause "
3059 : "at %C");
3060 : else
3061 0 : gfc_error ("Expected NONE, FIRSTPRIVATE, PRIVATE or SHARED "
3062 : "in DEFAULT clause at %C");
3063 30 : goto error;
3064 : }
3065 976 : if (gfc_match (" )") != MATCH_YES)
3066 9 : goto error;
3067 967 : continue;
3068 : }
3069 3301 : if ((mask & OMP_CLAUSE_DELETE)
3070 345 : && gfc_match ("delete ( ") == MATCH_YES
3071 3301 : && gfc_match_omp_map_clause (&c->lists[OMP_LIST_MAP],
3072 : OMP_MAP_RELEASE, true,
3073 : allow_derived))
3074 308 : continue;
3075 : /* DOACROSS: match 'doacross' and 'depend' with sink/source.
3076 : DEPEND: match 'depend' but not sink/source. */
3077 2685 : m = MATCH_NO;
3078 2685 : if (((mask & OMP_CLAUSE_DOACROSS)
3079 383 : && gfc_match ("doacross ( ") == MATCH_YES)
3080 3041 : || (((mask & OMP_CLAUSE_DEPEND) || (mask & OMP_CLAUSE_DOACROSS))
3081 1600 : && (m = gfc_match ("depend ( ")) == MATCH_YES))
3082 : {
3083 1100 : bool has_omp_all_memory;
3084 1100 : bool is_depend = m == MATCH_YES;
3085 1100 : gfc_namespace *ns_iter = NULL, *ns_curr = gfc_current_ns;
3086 1100 : match m_it = MATCH_NO;
3087 1100 : if (is_depend)
3088 1073 : m_it = gfc_match_iterator (&ns_iter, false);
3089 1073 : if (m_it == MATCH_ERROR)
3090 : break;
3091 1095 : if (m_it == MATCH_YES && gfc_match (" , ") != MATCH_YES)
3092 : break;
3093 1095 : m = MATCH_YES;
3094 1095 : gfc_omp_depend_doacross_op depend_op = OMP_DEPEND_OUT;
3095 1095 : if (gfc_match ("inoutset") == MATCH_YES)
3096 : depend_op = OMP_DEPEND_INOUTSET;
3097 1083 : else if (gfc_match ("inout") == MATCH_YES)
3098 : depend_op = OMP_DEPEND_INOUT;
3099 991 : else if (gfc_match ("in") == MATCH_YES)
3100 : depend_op = OMP_DEPEND_IN;
3101 704 : else if (gfc_match ("out") == MATCH_YES)
3102 : depend_op = OMP_DEPEND_OUT;
3103 442 : else if (gfc_match ("mutexinoutset") == MATCH_YES)
3104 : depend_op = OMP_DEPEND_MUTEXINOUTSET;
3105 424 : else if (gfc_match ("depobj") == MATCH_YES)
3106 : depend_op = OMP_DEPEND_DEPOBJ;
3107 387 : else if (gfc_match ("source") == MATCH_YES)
3108 : {
3109 143 : if (m_it == MATCH_YES)
3110 : {
3111 1 : gfc_error ("ITERATOR may not be combined with SOURCE "
3112 : "at %C");
3113 17 : goto error;
3114 : }
3115 142 : if (!(mask & OMP_CLAUSE_DOACROSS))
3116 : {
3117 1 : gfc_error ("SOURCE at %C not permitted as dependence-type"
3118 : " for this directive");
3119 1 : goto error;
3120 : }
3121 141 : if (c->doacross_source)
3122 : {
3123 0 : gfc_error ("Duplicated clause with SOURCE dependence-type"
3124 : " at %C");
3125 0 : goto error;
3126 : }
3127 141 : gfc_gobble_whitespace ();
3128 141 : m = gfc_match (": ");
3129 141 : if (m != MATCH_YES && !is_depend)
3130 : {
3131 1 : gfc_error ("Expected %<:%> at %C");
3132 1 : goto error;
3133 : }
3134 140 : if (gfc_match (")") != MATCH_YES
3135 146 : && !(m == MATCH_YES
3136 6 : && gfc_match ("omp_cur_iteration )") == MATCH_YES))
3137 : {
3138 2 : gfc_error ("Expected %<)%> or %<omp_cur_iteration)%> "
3139 : "at %C");
3140 2 : goto error;
3141 : }
3142 138 : if (is_depend)
3143 130 : gfc_warning (OPT_Wdeprecated_openmp,
3144 : "%<source%> modifier with %<depend%> clause "
3145 : "at %L deprecated since OpenMP 5.2, use with "
3146 : "%<doacross%>", &old_loc);
3147 138 : c->doacross_source = true;
3148 138 : c->depend_source = is_depend;
3149 1078 : continue;
3150 : }
3151 244 : else if (gfc_match ("sink ") == MATCH_YES)
3152 : {
3153 244 : if (!(mask & OMP_CLAUSE_DOACROSS))
3154 : {
3155 2 : gfc_error ("SINK at %C not permitted as dependence-type "
3156 : "for this directive");
3157 2 : goto error;
3158 : }
3159 242 : if (gfc_match (": ") != MATCH_YES)
3160 : {
3161 1 : gfc_error ("Expected %<:%> at %C");
3162 1 : goto error;
3163 : }
3164 241 : if (m_it == MATCH_YES)
3165 : {
3166 0 : gfc_error ("ITERATOR may not be combined with SINK "
3167 : "at %C");
3168 0 : goto error;
3169 : }
3170 241 : if (is_depend)
3171 226 : gfc_warning (OPT_Wdeprecated_openmp,
3172 : "%<sink%> modifier with %<depend%> clause at "
3173 : "%L deprecated since OpenMP 5.2, use with "
3174 : "%<doacross%>", &old_loc);
3175 241 : m = gfc_match_omp_doacross_sink (&c->lists[OMP_LIST_DEPEND],
3176 : is_depend);
3177 241 : if (m == MATCH_YES)
3178 238 : continue;
3179 3 : goto error;
3180 : }
3181 : else
3182 : m = MATCH_NO;
3183 708 : if (!(mask & OMP_CLAUSE_DEPEND))
3184 : {
3185 0 : gfc_error ("Expected dependence-type SINK or SOURCE at %C");
3186 0 : goto error;
3187 : }
3188 708 : head = NULL;
3189 708 : if (ns_iter)
3190 40 : gfc_current_ns = ns_iter;
3191 708 : if (m == MATCH_YES)
3192 708 : m = gfc_match_omp_variable_list (" : ",
3193 : &c->lists[OMP_LIST_DEPEND],
3194 : false, NULL, &head, true,
3195 : false, &has_omp_all_memory);
3196 708 : if (m != MATCH_YES)
3197 2 : goto error;
3198 706 : gfc_current_ns = ns_curr;
3199 706 : if (has_omp_all_memory && depend_op != OMP_DEPEND_INOUT
3200 21 : && depend_op != OMP_DEPEND_OUT)
3201 : {
3202 4 : gfc_error ("%<omp_all_memory%> used with DEPEND kind "
3203 : "other than OUT or INOUT at %C");
3204 4 : goto error;
3205 : }
3206 702 : gfc_omp_namelist *n;
3207 1435 : for (n = *head; n; n = n->next)
3208 : {
3209 733 : n->u.depend_doacross_op = depend_op;
3210 733 : n->u2.ns = ns_iter;
3211 733 : if (ns_iter)
3212 39 : ns_iter->refs++;
3213 : }
3214 702 : continue;
3215 702 : }
3216 1606 : if ((mask & OMP_CLAUSE_DESTROY)
3217 1585 : && gfc_match_omp_variable_list ("destroy (",
3218 : &c->lists[OMP_LIST_DESTROY],
3219 : true) == MATCH_YES)
3220 21 : continue;
3221 1690 : if ((mask & OMP_CLAUSE_DETACH)
3222 164 : && !openacc
3223 127 : && !c->detach
3224 1690 : && gfc_match_omp_detach (&c->detach) == MATCH_YES)
3225 126 : continue;
3226 1475 : if ((mask & OMP_CLAUSE_DETACH)
3227 38 : && openacc
3228 37 : && gfc_match ("detach ( ") == MATCH_YES
3229 1475 : && gfc_match_omp_map_clause (&c->lists[OMP_LIST_MAP],
3230 : OMP_MAP_DETACH, false,
3231 : allow_derived))
3232 37 : continue;
3233 1437 : if ((mask & OMP_CLAUSE_DEVICEPTR)
3234 87 : && gfc_match ("deviceptr ( ") == MATCH_YES
3235 1439 : && gfc_match_omp_map_clause (&c->lists[OMP_LIST_MAP],
3236 : OMP_MAP_FORCE_DEVICEPTR, false,
3237 : allow_derived))
3238 36 : continue;
3239 820 : if ((mask & OMP_CLAUSE_DEVICE_TYPE) && openacc
3240 444 : && gfc_match_dupl_check (!c->oacc_device_type_present,
3241 : "device_type", true) == MATCH_YES
3242 1697 : && match_oacc_device_type (c) == MATCH_YES)
3243 326 : continue;
3244 494 : if ((mask & OMP_CLAUSE_DEVICE_TYPE) && !openacc
3245 1415 : && gfc_match_dupl_check (c->device_type == OMP_DEVICE_TYPE_UNSET,
3246 : "device_type", true) == MATCH_YES)
3247 : {
3248 92 : if (gfc_match ("host") == MATCH_YES)
3249 32 : c->device_type = OMP_DEVICE_TYPE_HOST;
3250 60 : else if (gfc_match ("nohost") == MATCH_YES)
3251 21 : c->device_type = OMP_DEVICE_TYPE_NOHOST;
3252 39 : else if (gfc_match ("any") == MATCH_YES)
3253 38 : c->device_type = OMP_DEVICE_TYPE_ANY;
3254 : else
3255 : {
3256 1 : gfc_error ("Expected HOST, NOHOST or ANY at %C");
3257 1 : break;
3258 : }
3259 91 : if (gfc_match (" )") != MATCH_YES)
3260 : break;
3261 91 : continue;
3262 : }
3263 1054 : if ((mask & OMP_CLAUSE_DEVICE_NUM)
3264 947 : && (m = gfc_match_dupl_check (!c->device_num_expr,
3265 : "device_num")) != MATCH_NO)
3266 : {
3267 109 : if (m == MATCH_ERROR)
3268 2 : goto error;
3269 107 : if (gfc_match ("( %e )", &c->device_num_expr) != MATCH_YES)
3270 0 : goto error;
3271 107 : continue;
3272 : }
3273 886 : if ((mask & OMP_CLAUSE_DEVICE_RESIDENT)
3274 887 : && gfc_match_omp_variable_list
3275 49 : ("device_resident (",
3276 : &c->lists[OMP_LIST_DEVICE_RESIDENT], true) == MATCH_YES)
3277 48 : continue;
3278 1102 : if ((mask & OMP_CLAUSE_DEVICE)
3279 705 : && openacc
3280 314 : && gfc_match ("device ( ") == MATCH_YES
3281 1103 : && gfc_match_omp_map_clause (&c->lists[OMP_LIST_MAP],
3282 : OMP_MAP_FORCE_TO, true,
3283 : /* allow_derived = */ true))
3284 312 : continue;
3285 478 : if ((mask & OMP_CLAUSE_DEVICE)
3286 393 : && !openacc
3287 869 : && ((m = gfc_match_dupl_check (!c->device, "device", true))
3288 : != MATCH_NO))
3289 : {
3290 351 : if (m == MATCH_ERROR)
3291 0 : goto error;
3292 351 : c->ancestor = false;
3293 351 : if (gfc_match ("device_num : ") == MATCH_YES)
3294 : {
3295 18 : if (gfc_match ("%e )", &c->device) != MATCH_YES)
3296 : {
3297 1 : gfc_error ("Expected integer expression at %C");
3298 1 : break;
3299 : }
3300 : }
3301 333 : else if (gfc_match ("ancestor : ") == MATCH_YES)
3302 : {
3303 45 : bool has_requires = false;
3304 45 : c->ancestor = true;
3305 82 : for (gfc_namespace *ns = gfc_current_ns; ns; ns = ns->parent)
3306 80 : if (ns->omp_requires & OMP_REQ_REVERSE_OFFLOAD)
3307 : {
3308 : has_requires = true;
3309 : break;
3310 : }
3311 45 : if (!has_requires)
3312 : {
3313 2 : gfc_error ("%<ancestor%> device modifier not "
3314 : "preceded by %<requires%> directive "
3315 : "with %<reverse_offload%> clause at %C");
3316 5 : break;
3317 : }
3318 43 : locus old_loc2 = gfc_current_locus;
3319 43 : if (gfc_match ("%e )", &c->device) == MATCH_YES)
3320 : {
3321 43 : int device = 0;
3322 43 : if (!gfc_extract_int (c->device, &device) && device != 1)
3323 : {
3324 1 : gfc_current_locus = old_loc2;
3325 1 : gfc_error ("the %<device%> clause expression must "
3326 : "evaluate to %<1%> at %C");
3327 1 : break;
3328 : }
3329 : }
3330 : else
3331 : {
3332 0 : gfc_error ("Expected integer expression at %C");
3333 0 : break;
3334 : }
3335 : }
3336 288 : else if (gfc_match ("%e )", &c->device) != MATCH_YES)
3337 : {
3338 13 : gfc_error ("Expected integer expression or a single device-"
3339 : "modifier %<device_num%> or %<ancestor%> at %C");
3340 13 : break;
3341 : }
3342 334 : continue;
3343 334 : }
3344 127 : if ((mask & OMP_CLAUSE_DIST_SCHEDULE)
3345 97 : && c->dist_sched_kind == OMP_SCHED_NONE
3346 224 : && gfc_match ("dist_schedule ( static") == MATCH_YES)
3347 : {
3348 97 : m = MATCH_NO;
3349 97 : c->dist_sched_kind = OMP_SCHED_STATIC;
3350 97 : m = gfc_match (" , %e )", &c->dist_chunk_size);
3351 97 : if (m != MATCH_YES)
3352 14 : m = gfc_match_char (')');
3353 14 : if (m != MATCH_YES)
3354 : {
3355 0 : c->dist_sched_kind = OMP_SCHED_NONE;
3356 0 : gfc_current_locus = old_loc;
3357 : }
3358 : else
3359 97 : continue;
3360 : }
3361 41 : if ((mask & OMP_CLAUSE_DYN_GROUPPRIVATE)
3362 30 : && gfc_match_dupl_check (!c->dyn_groupprivate,
3363 : "dyn_groupprivate", true) == MATCH_YES)
3364 : {
3365 12 : if (gfc_match ("fallback ( abort ) : ") == MATCH_YES)
3366 1 : c->fallback = OMP_FALLBACK_ABORT;
3367 11 : else if (gfc_match ("fallback ( default_mem ) : ") == MATCH_YES)
3368 1 : c->fallback = OMP_FALLBACK_DEFAULT_MEM;
3369 10 : else if (gfc_match ("fallback ( null ) : ") == MATCH_YES)
3370 1 : c->fallback = OMP_FALLBACK_NULL;
3371 12 : if (gfc_match_expr (&c->dyn_groupprivate) != MATCH_YES)
3372 0 : return MATCH_ERROR;
3373 12 : if (gfc_match (" )") != MATCH_YES)
3374 1 : goto error;
3375 11 : continue;
3376 : }
3377 : break;
3378 91 : case 'e':
3379 91 : if ((mask & OMP_CLAUSE_ENTER))
3380 : {
3381 91 : m = gfc_match_omp_to_link ("enter (", &c->lists[OMP_LIST_ENTER]);
3382 91 : if (m == MATCH_ERROR)
3383 0 : goto error;
3384 91 : if (m == MATCH_YES)
3385 91 : continue;
3386 : }
3387 : break;
3388 2311 : case 'f':
3389 2360 : if ((mask & OMP_CLAUSE_FAIL)
3390 2311 : && (m = gfc_match_dupl_check (c->fail == OMP_MEMORDER_UNSET,
3391 : "fail", true)) != MATCH_NO)
3392 : {
3393 58 : if (m == MATCH_ERROR)
3394 3 : goto error;
3395 55 : if (gfc_match ("seq_cst") == MATCH_YES)
3396 6 : c->fail = OMP_MEMORDER_SEQ_CST;
3397 49 : else if (gfc_match ("acquire") == MATCH_YES)
3398 14 : c->fail = OMP_MEMORDER_ACQUIRE;
3399 35 : else if (gfc_match ("relaxed") == MATCH_YES)
3400 30 : c->fail = OMP_MEMORDER_RELAXED;
3401 : else
3402 : {
3403 5 : gfc_error ("Expected SEQ_CST, ACQUIRE or RELAXED at %C");
3404 5 : break;
3405 : }
3406 50 : if (gfc_match (" )") != MATCH_YES)
3407 1 : goto error;
3408 49 : continue;
3409 : }
3410 2296 : if ((mask & OMP_CLAUSE_FILTER)
3411 2253 : && (m = gfc_match_dupl_check (!c->filter, "filter", true,
3412 : &c->filter)) != MATCH_NO)
3413 : {
3414 44 : if (m == MATCH_ERROR)
3415 1 : goto error;
3416 43 : continue;
3417 : }
3418 2273 : if ((mask & OMP_CLAUSE_FINAL)
3419 2209 : && (m = gfc_match_dupl_check (!c->final_expr, "final", true,
3420 : &c->final_expr)) != MATCH_NO)
3421 : {
3422 64 : if (m == MATCH_ERROR)
3423 0 : goto error;
3424 64 : continue;
3425 : }
3426 2171 : if ((mask & OMP_CLAUSE_FINALIZE)
3427 2145 : && (m = gfc_match_dupl_check (!c->finalize, "finalize"))
3428 : != MATCH_NO)
3429 : {
3430 26 : if (m == MATCH_ERROR)
3431 0 : goto error;
3432 26 : c->finalize = true;
3433 26 : continue;
3434 : }
3435 3157 : if ((mask & OMP_CLAUSE_FIRSTPRIVATE)
3436 2119 : && gfc_match_omp_variable_list ("firstprivate (",
3437 : &c->lists[OMP_LIST_FIRSTPRIVATE],
3438 : true) == MATCH_YES)
3439 1038 : continue;
3440 2084 : if ((mask & OMP_CLAUSE_FROM)
3441 1081 : && gfc_match_motion_var_list ("from (", &c->lists[OMP_LIST_FROM],
3442 : &head) == MATCH_YES)
3443 1003 : continue;
3444 143 : if ((mask & OMP_CLAUSE_FULL)
3445 78 : && (m = gfc_match_dupl_check (!c->full, "full")) != MATCH_NO)
3446 : {
3447 65 : if (m == MATCH_ERROR)
3448 0 : goto error;
3449 65 : c->full = true;
3450 65 : continue;
3451 : }
3452 : break;
3453 1231 : case 'g':
3454 2423 : if ((mask & OMP_CLAUSE_GANG)
3455 1231 : && (m = gfc_match_dupl_check (!c->gang, "gang")) != MATCH_NO)
3456 : {
3457 1197 : if (m == MATCH_ERROR)
3458 0 : goto error;
3459 1197 : c->gang = true;
3460 1197 : m = match_oacc_clause_gwv (c, GOMP_DIM_GANG);
3461 1197 : if (m == MATCH_ERROR)
3462 : {
3463 5 : gfc_current_locus = old_loc;
3464 5 : break;
3465 : }
3466 1192 : continue;
3467 : }
3468 68 : if ((mask & OMP_CLAUSE_GRAINSIZE)
3469 34 : && (m = gfc_match_dupl_check (!c->grainsize, "grainsize", true))
3470 : != MATCH_NO)
3471 : {
3472 34 : if (m == MATCH_ERROR)
3473 0 : goto error;
3474 34 : if (gfc_match ("strict : ") == MATCH_YES)
3475 1 : c->grainsize_strict = true;
3476 34 : if (gfc_match (" %e )", &c->grainsize) != MATCH_YES)
3477 0 : goto error;
3478 34 : continue;
3479 : }
3480 : break;
3481 466 : case 'h':
3482 515 : if ((mask & OMP_CLAUSE_HAS_DEVICE_ADDR)
3483 515 : && gfc_match_omp_variable_list
3484 49 : ("has_device_addr (", &c->lists[OMP_LIST_HAS_DEVICE_ADDR],
3485 : false, NULL, NULL, true) == MATCH_YES)
3486 49 : continue;
3487 460 : if ((mask & OMP_CLAUSE_HINT)
3488 417 : && (m = gfc_match_dupl_check (!c->hint, "hint", true, &c->hint))
3489 : != MATCH_NO)
3490 : {
3491 43 : if (m == MATCH_ERROR)
3492 0 : goto error;
3493 43 : continue;
3494 : }
3495 374 : if ((mask & OMP_CLAUSE_ASSUMPTIONS)
3496 374 : && gfc_match ("holds ( ") == MATCH_YES)
3497 : {
3498 19 : gfc_expr *e;
3499 19 : if (gfc_match ("%e )", &e) != MATCH_YES)
3500 0 : goto error;
3501 19 : if (c->assume == NULL)
3502 12 : c->assume = gfc_get_omp_assumptions ();
3503 19 : gfc_expr_list *el = XCNEW (gfc_expr_list);
3504 19 : el->expr = e;
3505 19 : el->next = c->assume->holds;
3506 19 : c->assume->holds = el;
3507 19 : continue;
3508 19 : }
3509 709 : if ((mask & OMP_CLAUSE_HOST)
3510 355 : && gfc_match ("host ( ") == MATCH_YES
3511 710 : && gfc_match_omp_map_clause (&c->lists[OMP_LIST_MAP],
3512 : OMP_MAP_FORCE_FROM, true,
3513 : /* allow_derived = */ true))
3514 354 : continue;
3515 : break;
3516 2247 : case 'i':
3517 2270 : if ((mask & OMP_CLAUSE_IF_PRESENT)
3518 2247 : && (m = gfc_match_dupl_check (!c->if_present, "if_present"))
3519 : != MATCH_NO)
3520 : {
3521 23 : if (m == MATCH_ERROR)
3522 0 : goto error;
3523 23 : c->if_present = true;
3524 23 : continue;
3525 : }
3526 2224 : if ((mask & OMP_CLAUSE_IF)
3527 2224 : && (m = gfc_match_dupl_check (!c->if_expr, "if", true))
3528 : != MATCH_NO)
3529 : {
3530 1470 : if (m == MATCH_ERROR)
3531 14 : goto error;
3532 1456 : if (!openacc)
3533 : {
3534 : /* This should match the enum gfc_omp_if_kind order. */
3535 : static const char *ifs[OMP_IF_LAST] = {
3536 : "cancel : %e )",
3537 : "parallel : %e )",
3538 : "simd : %e )",
3539 : "task : %e )",
3540 : "taskloop : %e )",
3541 : "target : %e )",
3542 : "target data : %e )",
3543 : "target update : %e )",
3544 : "target enter data : %e )",
3545 : "target exit data : %e )" };
3546 : static const char *ifs2[] = {
3547 : "target_data : %e )",
3548 : "target_update : %e )",
3549 : "target_enter_data : %e )",
3550 : "target_exit_data : %e )" };
3551 : int i;
3552 4951 : for (i = 0; i < OMP_IF_LAST; i++)
3553 4543 : if (c->if_exprs[i] == NULL
3554 4543 : && gfc_match (ifs[i], &c->if_exprs[i]) == MATCH_YES)
3555 : break;
3556 546 : if (i < OMP_IF_LAST)
3557 138 : continue;
3558 2030 : for (i = 0; i < (int) ARRAY_SIZE (ifs2); i++)
3559 1626 : if (c->if_exprs[OMP_IF_TARGET_DATA + i] == NULL
3560 1626 : && (gfc_match (ifs2[i],
3561 : &c->if_exprs[OMP_IF_TARGET_DATA + i])
3562 : == MATCH_YES))
3563 : break;
3564 408 : if (i < (int) ARRAY_SIZE (ifs2))
3565 4 : continue;
3566 : }
3567 1314 : if (gfc_match (" %e )", &c->if_expr) == MATCH_YES)
3568 1309 : continue;
3569 5 : goto error;
3570 : }
3571 871 : if ((mask & OMP_CLAUSE_IN_REDUCTION)
3572 754 : && gfc_match_omp_clause_reduction (pc, c, openacc, allow_derived,
3573 : openmp_target) == MATCH_YES)
3574 117 : continue;
3575 662 : if ((mask & OMP_CLAUSE_INBRANCH)
3576 637 : && (m = gfc_match_dupl_check (!c->inbranch && !c->notinbranch,
3577 : "inbranch")) != MATCH_NO)
3578 : {
3579 25 : if (m == MATCH_ERROR)
3580 0 : goto error;
3581 25 : c->inbranch = true;
3582 25 : continue;
3583 : }
3584 854 : if ((mask & OMP_CLAUSE_INDEPENDENT)
3585 612 : && (m = gfc_match_dupl_check (!c->independent, "independent"))
3586 : != MATCH_NO)
3587 : {
3588 242 : if (m == MATCH_ERROR)
3589 0 : goto error;
3590 242 : c->independent = true;
3591 242 : continue;
3592 : }
3593 370 : if ((mask & OMP_CLAUSE_INDIRECT)
3594 370 : && (m = gfc_match_dupl_check (!c->indirect, "indirect"))
3595 : != MATCH_NO)
3596 : {
3597 61 : if (m == MATCH_ERROR)
3598 5 : goto error;
3599 60 : gfc_expr *indirect_expr = NULL;
3600 60 : m = gfc_match (" ( %e )", &indirect_expr);
3601 60 : if (m == MATCH_YES)
3602 : {
3603 13 : if (!gfc_resolve_expr (indirect_expr)
3604 13 : || indirect_expr->ts.type != BT_LOGICAL
3605 23 : || indirect_expr->expr_type != EXPR_CONSTANT)
3606 : {
3607 4 : gfc_error ("INDIRECT clause at %C requires a constant "
3608 : "logical expression");
3609 4 : gfc_free_expr (indirect_expr);
3610 4 : goto error;
3611 : }
3612 9 : c->indirect = indirect_expr->value.logical;
3613 9 : gfc_free_expr (indirect_expr);
3614 : }
3615 : else
3616 47 : c->indirect = 1;
3617 56 : continue;
3618 56 : }
3619 309 : if ((mask & OMP_CLAUSE_INIT)
3620 309 : && gfc_match ("init ( ") == MATCH_YES)
3621 : {
3622 108 : m = gfc_match_omp_init (&c->lists[OMP_LIST_INIT]);
3623 108 : if (m == MATCH_YES)
3624 63 : continue;
3625 45 : goto error;
3626 : }
3627 201 : if ((mask & OMP_CLAUSE_INTEROP)
3628 201 : && (m = gfc_match_dupl_check (!c->lists[OMP_LIST_INTEROP],
3629 : "interop", true)) != MATCH_NO)
3630 : {
3631 : /* Note: the interop objects are saved in reverse order to match
3632 : the order in C/C++. */
3633 125 : if (m == MATCH_YES
3634 63 : && (gfc_match_omp_variable_list ("",
3635 : &c->lists[OMP_LIST_INTEROP],
3636 : false, NULL, NULL, false,
3637 : false, NULL, false, true)
3638 : == MATCH_YES))
3639 62 : continue;
3640 1 : goto error;
3641 : }
3642 258 : if ((mask & OMP_CLAUSE_IS_DEVICE_PTR)
3643 258 : && gfc_match_omp_variable_list
3644 120 : ("is_device_ptr (",
3645 : &c->lists[OMP_LIST_IS_DEVICE_PTR], false) == MATCH_YES)
3646 120 : continue;
3647 : break;
3648 2337 : case 'l':
3649 2337 : if ((mask & OMP_CLAUSE_LASTPRIVATE)
3650 2337 : && gfc_match ("lastprivate ( ") == MATCH_YES)
3651 : {
3652 1433 : bool conditional = gfc_match ("conditional : ") == MATCH_YES;
3653 1433 : head = NULL;
3654 1433 : if (gfc_match_omp_variable_list ("",
3655 : &c->lists[OMP_LIST_LASTPRIVATE],
3656 : false, NULL, &head) == MATCH_YES)
3657 : {
3658 1433 : gfc_omp_namelist *n;
3659 3741 : for (n = *head; n; n = n->next)
3660 2308 : n->u.lastprivate_conditional = conditional;
3661 1433 : continue;
3662 1433 : }
3663 0 : gfc_current_locus = old_loc;
3664 0 : break;
3665 : }
3666 904 : end_colon = false;
3667 904 : head = NULL;
3668 904 : if ((mask & OMP_CLAUSE_LINEAR)
3669 904 : && gfc_match ("linear (") == MATCH_YES)
3670 : {
3671 837 : bool old_linear_modifier = false;
3672 837 : gfc_omp_linear_op linear_op = OMP_LINEAR_DEFAULT;
3673 837 : gfc_expr *step = NULL;
3674 837 : locus saved_loc = gfc_current_locus;
3675 :
3676 837 : if (gfc_match_omp_variable_list (" ref (",
3677 : &c->lists[OMP_LIST_LINEAR],
3678 : false, NULL, &head)
3679 : == MATCH_YES)
3680 : {
3681 : linear_op = OMP_LINEAR_REF;
3682 : old_linear_modifier = true;
3683 : }
3684 809 : else if (gfc_match_omp_variable_list (" val (",
3685 : &c->lists[OMP_LIST_LINEAR],
3686 : false, NULL, &head)
3687 : == MATCH_YES)
3688 : {
3689 : linear_op = OMP_LINEAR_VAL;
3690 : old_linear_modifier = true;
3691 : }
3692 798 : else if (gfc_match_omp_variable_list (" uval (",
3693 : &c->lists[OMP_LIST_LINEAR],
3694 : false, NULL, &head)
3695 : == MATCH_YES)
3696 : {
3697 : linear_op = OMP_LINEAR_UVAL;
3698 : old_linear_modifier = true;
3699 : }
3700 789 : else if (gfc_match_omp_variable_list ("",
3701 : &c->lists[OMP_LIST_LINEAR],
3702 : false, &end_colon, &head)
3703 : == MATCH_YES)
3704 : linear_op = OMP_LINEAR_DEFAULT;
3705 : else
3706 : {
3707 2 : gfc_current_locus = old_loc;
3708 2 : break;
3709 : }
3710 : if (linear_op != OMP_LINEAR_DEFAULT)
3711 : {
3712 48 : if (gfc_match (" :") == MATCH_YES)
3713 31 : end_colon = true;
3714 17 : else if (gfc_match (" )") != MATCH_YES)
3715 : {
3716 0 : gfc_free_omp_namelist (*head, OMP_LIST_LINEAR);
3717 0 : gfc_current_locus = old_loc;
3718 0 : *head = NULL;
3719 0 : break;
3720 : }
3721 : }
3722 835 : gfc_gobble_whitespace ();
3723 835 : if (old_linear_modifier && end_colon)
3724 : {
3725 31 : if (gfc_match (" %e )", &step) != MATCH_YES)
3726 : {
3727 1 : gfc_free_omp_namelist (*head, OMP_LIST_LINEAR);
3728 1 : gfc_current_locus = old_loc;
3729 1 : *head = NULL;
3730 5 : goto error;
3731 : }
3732 : }
3733 47 : if (old_linear_modifier)
3734 : {
3735 47 : char var_names[512]{};
3736 47 : int count, offset = 0;
3737 106 : for (gfc_omp_namelist *n = *head; n; n = n->next)
3738 : {
3739 59 : if (!n->next)
3740 47 : count = snprintf (var_names + offset,
3741 47 : sizeof (var_names) - offset,
3742 47 : "%s", n->sym->name);
3743 : else
3744 12 : count = snprintf (var_names + offset,
3745 12 : sizeof (var_names) - offset,
3746 12 : "%s, ", n->sym->name);
3747 59 : if (count < 0 || count >= ((int)sizeof (var_names))
3748 59 : - offset)
3749 : {
3750 0 : snprintf (var_names, 512, "%s, ..., ",
3751 0 : (*head)->sym->name);
3752 0 : while (n->next)
3753 : n = n->next;
3754 0 : offset = strlen (var_names);
3755 0 : snprintf (var_names + offset,
3756 0 : sizeof (var_names) - offset,
3757 0 : "%s", n->sym->name);
3758 0 : break;
3759 : }
3760 59 : offset += count;
3761 : }
3762 47 : char *var_names_for_warn = var_names;
3763 47 : const char *op_name;
3764 47 : switch (linear_op)
3765 : {
3766 : case OMP_LINEAR_REF: op_name = "ref"; break;
3767 10 : case OMP_LINEAR_VAL: op_name = "val"; break;
3768 9 : case OMP_LINEAR_UVAL: op_name = "uval"; break;
3769 0 : default: gcc_unreachable ();
3770 : }
3771 47 : gfc_warning (OPT_Wdeprecated_openmp,
3772 : "Specification of the list items as "
3773 : "arguments to the modifiers at %L is "
3774 : "deprecated; since OpenMP 5.2, use "
3775 : "%<linear(%s : %s%s)%>", &saved_loc,
3776 : var_names_for_warn, op_name,
3777 47 : step == nullptr ? "" : ", step(...)");
3778 : }
3779 787 : else if (end_colon)
3780 : {
3781 714 : bool has_error = false;
3782 : bool has_modifiers = false;
3783 : bool has_step = false;
3784 714 : bool duplicate_step = false;
3785 714 : bool duplicate_mod = false;
3786 714 : while (true)
3787 : {
3788 714 : old_loc = gfc_current_locus;
3789 714 : bool close_paren = gfc_match ("val )") == MATCH_YES;
3790 714 : if (close_paren || gfc_match ("val , ") == MATCH_YES)
3791 : {
3792 17 : if (linear_op != OMP_LINEAR_DEFAULT)
3793 : {
3794 : duplicate_mod = true;
3795 : break;
3796 : }
3797 16 : linear_op = OMP_LINEAR_VAL;
3798 16 : has_modifiers = true;
3799 16 : if (close_paren)
3800 : break;
3801 10 : continue;
3802 : }
3803 697 : close_paren = gfc_match ("uval )") == MATCH_YES;
3804 697 : if (close_paren || gfc_match ("uval , ") == MATCH_YES)
3805 : {
3806 7 : if (linear_op != OMP_LINEAR_DEFAULT)
3807 : {
3808 : duplicate_mod = true;
3809 : break;
3810 : }
3811 7 : linear_op = OMP_LINEAR_UVAL;
3812 7 : has_modifiers = true;
3813 7 : if (close_paren)
3814 : break;
3815 2 : continue;
3816 : }
3817 690 : close_paren = gfc_match ("ref )") == MATCH_YES;
3818 690 : if (close_paren || gfc_match ("ref , ") == MATCH_YES)
3819 : {
3820 16 : if (linear_op != OMP_LINEAR_DEFAULT)
3821 : {
3822 : duplicate_mod = true;
3823 : break;
3824 : }
3825 15 : linear_op = OMP_LINEAR_REF;
3826 15 : has_modifiers = true;
3827 15 : if (close_paren)
3828 : break;
3829 7 : continue;
3830 : }
3831 674 : close_paren = (gfc_match ("step ( %e ) )", &step)
3832 : == MATCH_YES);
3833 685 : if (close_paren
3834 674 : || gfc_match ("step ( %e ) , ", &step) == MATCH_YES)
3835 : {
3836 38 : if (has_step)
3837 : {
3838 : duplicate_step = true;
3839 : break;
3840 : }
3841 37 : has_modifiers = has_step = true;
3842 37 : if (close_paren)
3843 : break;
3844 11 : continue;
3845 : }
3846 636 : if (!has_modifiers
3847 636 : && gfc_match ("%e )", &step) == MATCH_YES)
3848 : {
3849 636 : if ((step->expr_type == EXPR_FUNCTION
3850 635 : || step->expr_type == EXPR_VARIABLE)
3851 31 : && strcmp (step->symtree->name, "step") == 0)
3852 : {
3853 1 : gfc_current_locus = old_loc;
3854 1 : gfc_match ("step (");
3855 1 : has_error = true;
3856 : }
3857 : break;
3858 : }
3859 : has_error = true;
3860 : break;
3861 : }
3862 49 : if (duplicate_mod || duplicate_step)
3863 : {
3864 3 : gfc_error ("Multiple %qs modifiers specified at %C",
3865 : duplicate_mod ? "linear" : "step");
3866 3 : has_error = true;
3867 : }
3868 684 : if (has_error)
3869 : {
3870 4 : gfc_free_omp_namelist (*head, OMP_LIST_LINEAR);
3871 4 : *head = NULL;
3872 4 : goto error;
3873 : }
3874 : }
3875 830 : if (step == NULL)
3876 : {
3877 130 : step = gfc_get_constant_expr (BT_INTEGER,
3878 : gfc_default_integer_kind,
3879 : &old_loc);
3880 130 : mpz_set_si (step->value.integer, 1);
3881 : }
3882 830 : (*head)->expr = step;
3883 830 : if (linear_op != OMP_LINEAR_DEFAULT || old_linear_modifier)
3884 176 : for (gfc_omp_namelist *n = *head; n; n = n->next)
3885 : {
3886 94 : n->u.linear.op = linear_op;
3887 94 : n->u.linear.old_modifier = old_linear_modifier;
3888 : }
3889 830 : continue;
3890 830 : }
3891 71 : if ((mask & OMP_CLAUSE_LINK)
3892 67 : && openacc
3893 75 : && (gfc_match_oacc_clause_link ("link (",
3894 : &c->lists[OMP_LIST_LINK])
3895 : == MATCH_YES))
3896 4 : continue;
3897 110 : else if ((mask & OMP_CLAUSE_LINK)
3898 63 : && !openacc
3899 122 : && (gfc_match_omp_to_link ("link (",
3900 : &c->lists[OMP_LIST_LINK])
3901 : == MATCH_YES))
3902 47 : continue;
3903 28 : if ((mask & OMP_CLAUSE_LOCAL)
3904 16 : && (gfc_match_omp_to_link ("local (", &c->lists[OMP_LIST_LOCAL])
3905 : == MATCH_YES))
3906 12 : continue;
3907 : break;
3908 5953 : case 'm':
3909 5953 : if ((mask & OMP_CLAUSE_MAP)
3910 5953 : && gfc_match ("map ( ") == MATCH_YES)
3911 : {
3912 5850 : locus old_loc2 = gfc_current_locus;
3913 5850 : int always_modifier = 0;
3914 5850 : int close_modifier = 0;
3915 5850 : int present_modifier = 0;
3916 5850 : int mapper_modifier = 0;
3917 5850 : int iterator_modifier = 0;
3918 5850 : gfc_namespace *ns_iter = NULL, *ns_curr = gfc_current_ns;
3919 5850 : locus second_always_locus = old_loc2;
3920 5850 : locus second_close_locus = old_loc2;
3921 5850 : locus second_mapper_locus = old_loc2;
3922 5850 : locus second_present_locus = old_loc2;
3923 5850 : char mapper_id[GFC_MAX_SYMBOL_LEN + 1] = { '\0' };
3924 5850 : locus second_iterator_locus = old_loc2;
3925 :
3926 6518 : for (;;)
3927 : {
3928 6184 : locus current_locus = gfc_current_locus;
3929 6184 : if (gfc_match ("always ") == MATCH_YES)
3930 : {
3931 148 : if (always_modifier++ == 1)
3932 5 : second_always_locus = current_locus;
3933 : }
3934 6036 : else if (gfc_match ("close ") == MATCH_YES)
3935 : {
3936 69 : if (close_modifier++ == 1)
3937 5 : second_close_locus = current_locus;
3938 : }
3939 5967 : else if (gfc_match ("present ") == MATCH_YES)
3940 : {
3941 67 : if (present_modifier++ == 1)
3942 4 : second_present_locus = current_locus;
3943 : }
3944 5900 : else if (gfc_match ("mapper ( ") == MATCH_YES)
3945 : {
3946 8 : if (mapper_modifier++ == 1)
3947 0 : second_mapper_locus = current_locus;
3948 8 : m = gfc_match (" %n ) ", mapper_id);
3949 8 : if (m != MATCH_YES)
3950 0 : goto error;
3951 8 : if (strcmp (mapper_id, "default") == 0)
3952 3 : mapper_id[0] = '\0';
3953 : }
3954 5892 : else if (gfc_match_iterator (&ns_iter, true) == MATCH_YES)
3955 : {
3956 42 : if (iterator_modifier++ == 1)
3957 1 : second_iterator_locus = current_locus;
3958 : }
3959 : else
3960 : break;
3961 334 : if (gfc_match (", ") != MATCH_YES)
3962 62 : gfc_warning (OPT_Wdeprecated_openmp,
3963 : "The specification of modifiers without "
3964 : "comma separators for the %<map%> clause "
3965 : "at %C has been deprecated since "
3966 : "OpenMP 5.2");
3967 334 : }
3968 :
3969 5850 : gfc_omp_map_op map_op = default_map_op;
3970 5850 : int always_present_modifier
3971 5850 : = always_modifier && present_modifier;
3972 :
3973 5850 : if (gfc_match ("alloc : ") == MATCH_YES)
3974 799 : map_op = (present_modifier ? OMP_MAP_PRESENT_ALLOC
3975 : : OMP_MAP_ALLOC);
3976 5051 : else if (gfc_match ("tofrom : ") == MATCH_YES)
3977 954 : map_op = (always_present_modifier ? OMP_MAP_ALWAYS_PRESENT_TOFROM
3978 950 : : present_modifier ? OMP_MAP_PRESENT_TOFROM
3979 945 : : always_modifier ? OMP_MAP_ALWAYS_TOFROM
3980 : : OMP_MAP_TOFROM);
3981 4097 : else if (gfc_match ("to : ") == MATCH_YES)
3982 1815 : map_op = (always_present_modifier ? OMP_MAP_ALWAYS_PRESENT_TO
3983 1809 : : present_modifier ? OMP_MAP_PRESENT_TO
3984 1797 : : always_modifier ? OMP_MAP_ALWAYS_TO
3985 : : OMP_MAP_TO);
3986 2282 : else if (gfc_match ("from : ") == MATCH_YES)
3987 1656 : map_op = (always_present_modifier ? OMP_MAP_ALWAYS_PRESENT_FROM
3988 1652 : : present_modifier ? OMP_MAP_PRESENT_FROM
3989 1647 : : always_modifier ? OMP_MAP_ALWAYS_FROM
3990 : : OMP_MAP_FROM);
3991 626 : else if (gfc_match ("release : ") == MATCH_YES)
3992 : map_op = OMP_MAP_RELEASE;
3993 572 : else if (gfc_match ("delete : ") == MATCH_YES)
3994 : map_op = OMP_MAP_DELETE;
3995 : else
3996 : {
3997 495 : gfc_current_locus = old_loc2;
3998 495 : always_modifier = 0;
3999 495 : close_modifier = 0;
4000 495 : mapper_modifier = 0;
4001 : }
4002 :
4003 1573 : if (always_modifier > 1)
4004 : {
4005 5 : gfc_error ("too many %<always%> modifiers at %L",
4006 : &second_always_locus);
4007 24 : break;
4008 : }
4009 5845 : if (close_modifier > 1)
4010 : {
4011 4 : gfc_error ("too many %<close%> modifiers at %L",
4012 : &second_close_locus);
4013 4 : break;
4014 : }
4015 5841 : if (present_modifier > 1)
4016 : {
4017 4 : gfc_error ("too many %<present%> modifiers at %L",
4018 : &second_present_locus);
4019 4 : break;
4020 : }
4021 5837 : if (mapper_modifier > 1)
4022 : {
4023 0 : gfc_error ("too many %<mapper%> modifiers at %L",
4024 : &second_mapper_locus);
4025 0 : break;
4026 : }
4027 5837 : if (iterator_modifier > 1)
4028 : {
4029 1 : gfc_error ("too many %<iterator%> modifiers at %L",
4030 : &second_iterator_locus);
4031 1 : break;
4032 : }
4033 :
4034 5836 : head = NULL;
4035 5836 : if (ns_iter)
4036 40 : gfc_current_ns = ns_iter;
4037 5836 : m = gfc_match_omp_variable_list ("", &c->lists[OMP_LIST_MAP],
4038 : false, NULL, &head, true, true);
4039 5836 : gfc_current_ns = ns_curr;
4040 5836 : if (m == MATCH_YES)
4041 : {
4042 5831 : gfc_omp_namelist *n;
4043 13245 : for (n = *head; n; n = n->next)
4044 : {
4045 7414 : n->u.map.op = map_op;
4046 7414 : if (mapper_id[0] != '\0')
4047 : {
4048 5 : n->u3.udm = gfc_get_omp_namelist_udm ();
4049 5 : n->u3.udm->requested_mapper_id
4050 5 : = gfc_get_string ("%s", mapper_id);
4051 : }
4052 7414 : n->u2.ns = ns_iter;
4053 7414 : if (ns_iter)
4054 42 : ns_iter->refs++;
4055 : }
4056 5831 : continue;
4057 5831 : }
4058 5 : gfc_current_locus = old_loc;
4059 5 : break;
4060 : }
4061 137 : if ((mask & OMP_CLAUSE_MERGEABLE)
4062 103 : && (m = gfc_match_dupl_check (!c->mergeable, "mergeable"))
4063 : != MATCH_NO)
4064 : {
4065 34 : if (m == MATCH_ERROR)
4066 0 : goto error;
4067 34 : c->mergeable = true;
4068 34 : continue;
4069 : }
4070 133 : if ((mask & OMP_CLAUSE_MESSAGE)
4071 69 : && (m = gfc_match_dupl_check (!c->message, "message", true,
4072 : &c->message)) != MATCH_NO)
4073 : {
4074 69 : if (m == MATCH_ERROR)
4075 5 : goto error;
4076 64 : continue;
4077 : }
4078 : break;
4079 3013 : case 'n':
4080 3065 : if ((mask & OMP_CLAUSE_NO_CREATE)
4081 1343 : && gfc_match ("no_create ( ") == MATCH_YES
4082 3065 : && gfc_match_omp_map_clause (&c->lists[OMP_LIST_MAP],
4083 : OMP_MAP_IF_PRESENT, true,
4084 : allow_derived))
4085 52 : continue;
4086 2962 : if ((mask & OMP_CLAUSE_ASSUMPTIONS)
4087 2987 : && (m = gfc_match_dupl_check (!c->assume
4088 4 : || !c->assume->no_openmp_constructs,
4089 : "no_openmp_constructs")) != MATCH_NO)
4090 : {
4091 2 : if (m == MATCH_ERROR)
4092 1 : goto error;
4093 1 : if (c->assume == NULL)
4094 0 : c->assume = gfc_get_omp_assumptions ();
4095 1 : c->assume->no_openmp_constructs = true;
4096 1 : continue;
4097 : }
4098 2972 : if ((mask & OMP_CLAUSE_ASSUMPTIONS)
4099 2983 : && (m = gfc_match_dupl_check (!c->assume
4100 2 : || !c->assume->no_openmp_routines,
4101 : "no_openmp_routines")) != MATCH_NO)
4102 : {
4103 13 : if (m == MATCH_ERROR)
4104 0 : goto error;
4105 13 : if (c->assume == NULL)
4106 12 : c->assume = gfc_get_omp_assumptions ();
4107 13 : c->assume->no_openmp_routines = true;
4108 13 : continue;
4109 : }
4110 2950 : if ((mask & OMP_CLAUSE_ASSUMPTIONS)
4111 2956 : && (m = gfc_match_dupl_check (!c->assume || !c->assume->no_openmp,
4112 : "no_openmp")) != MATCH_NO)
4113 : {
4114 4 : if (m == MATCH_ERROR)
4115 0 : goto error;
4116 4 : if (c->assume == NULL)
4117 4 : c->assume = gfc_get_omp_assumptions ();
4118 4 : c->assume->no_openmp = true;
4119 4 : continue;
4120 : }
4121 2948 : if ((mask & OMP_CLAUSE_ASSUMPTIONS)
4122 2949 : && (m = gfc_match_dupl_check (!c->assume
4123 1 : || !c->assume->no_parallelism,
4124 : "no_parallelism")) != MATCH_NO)
4125 : {
4126 6 : if (m == MATCH_ERROR)
4127 0 : goto error;
4128 6 : if (c->assume == NULL)
4129 6 : c->assume = gfc_get_omp_assumptions ();
4130 6 : c->assume->no_parallelism = true;
4131 6 : continue;
4132 : }
4133 :
4134 2946 : if ((mask & OMP_CLAUSE_NOVARIANTS)
4135 2936 : && (m = gfc_match_dupl_check (!c->novariants, "novariants", true,
4136 : &c->novariants))
4137 : != MATCH_NO)
4138 : {
4139 12 : if (m == MATCH_ERROR)
4140 2 : goto error;
4141 10 : continue;
4142 : }
4143 2937 : if ((mask & OMP_CLAUSE_NOCONTEXT)
4144 2924 : && (m = gfc_match_dupl_check (!c->nocontext, "nocontext", true,
4145 : &c->nocontext))
4146 : != MATCH_NO)
4147 : {
4148 15 : if (m == MATCH_ERROR)
4149 2 : goto error;
4150 13 : continue;
4151 : }
4152 2923 : if ((mask & OMP_CLAUSE_NOGROUP)
4153 2909 : && (m = gfc_match_dupl_check (!c->nogroup, "nogroup"))
4154 : != MATCH_NO)
4155 : {
4156 14 : if (m == MATCH_ERROR)
4157 0 : goto error;
4158 14 : c->nogroup = true;
4159 14 : continue;
4160 : }
4161 3045 : if ((mask & OMP_CLAUSE_NOHOST)
4162 2895 : && (m = gfc_match_dupl_check (!c->nohost, "nohost")) != MATCH_NO)
4163 : {
4164 151 : if (m == MATCH_ERROR)
4165 1 : goto error;
4166 150 : c->nohost = true;
4167 150 : continue;
4168 : }
4169 2786 : if ((mask & OMP_CLAUSE_NOTEMPORAL)
4170 2744 : && gfc_match_omp_variable_list ("nontemporal (",
4171 : &c->lists[OMP_LIST_NONTEMPORAL],
4172 : true) == MATCH_YES)
4173 42 : continue;
4174 2726 : if ((mask & OMP_CLAUSE_NOTINBRANCH)
4175 2703 : && (m = gfc_match_dupl_check (!c->notinbranch && !c->inbranch,
4176 : "notinbranch")) != MATCH_NO)
4177 : {
4178 25 : if (m == MATCH_ERROR)
4179 1 : goto error;
4180 24 : c->notinbranch = true;
4181 24 : continue;
4182 : }
4183 2806 : if ((mask & OMP_CLAUSE_NOWAIT)
4184 2677 : && (m = gfc_match_dupl_check (!c->nowait, "nowait")) != MATCH_NO)
4185 : {
4186 132 : if (m == MATCH_ERROR)
4187 3 : goto error;
4188 129 : c->nowait = true;
4189 129 : continue;
4190 : }
4191 3227 : if ((mask & OMP_CLAUSE_NUM_GANGS)
4192 2545 : && (m = gfc_match_dupl_check (!c->num_gangs_expr, "num_gangs",
4193 : true)) != MATCH_NO)
4194 : {
4195 686 : if (m == MATCH_ERROR)
4196 2 : goto error;
4197 684 : if (gfc_match (" %e )", &c->num_gangs_expr) != MATCH_YES)
4198 2 : goto error;
4199 682 : continue;
4200 : }
4201 1885 : if ((mask & OMP_CLAUSE_NUM_TASKS)
4202 1859 : && (m = gfc_match_dupl_check (!c->num_tasks, "num_tasks", true))
4203 : != MATCH_NO)
4204 : {
4205 26 : if (m == MATCH_ERROR)
4206 0 : goto error;
4207 26 : if (gfc_match ("strict : ") == MATCH_YES)
4208 1 : c->num_tasks_strict = true;
4209 26 : if (gfc_match (" %e )", &c->num_tasks) != MATCH_YES)
4210 0 : goto error;
4211 26 : continue;
4212 : }
4213 1833 : if ((mask & OMP_CLAUSE_NUM_TEAMS)
4214 1833 : && (m = gfc_match_dupl_check (!c->num_teams_list,
4215 : "num_teams", true)) != MATCH_NO)
4216 : {
4217 174 : if (m == MATCH_ERROR)
4218 20 : goto error;
4219 172 : gfc_expr *expr;
4220 172 : if (gfc_match ("dims ( %e ) : ", &expr) == MATCH_YES
4221 172 : && match_omp_oacc_expr_list (NULL, &c->num_teams_list,
4222 : false, true) == MATCH_YES)
4223 : {
4224 19 : int num = 0;
4225 19 : gfc_expr_list *el;
4226 55 : for (el = c->num_teams_list; el; el = el->next)
4227 36 : ++num;
4228 19 : if (!gfc_resolve_expr (expr)
4229 19 : || expr->ts.type != BT_INTEGER
4230 18 : || expr->rank != 0
4231 17 : || expr->expr_type != EXPR_CONSTANT
4232 34 : || mpz_sgn (expr->value.integer) <= 0)
4233 : {
4234 5 : gfc_error ("DIMS must be a constant positive integer "
4235 5 : "at %L", &expr->where);
4236 5 : goto error;
4237 : }
4238 14 : if (mpz_cmp_si (expr->value.integer, num) != 0)
4239 : {
4240 1 : gfc_error ("The number of arguments (%d) must be the same"
4241 : " as specified for DIMS at %L", num,
4242 : &expr->where);
4243 1 : goto error;
4244 : }
4245 13 : c->num_teams_dims = true;
4246 154 : continue;
4247 13 : }
4248 153 : else if (gfc_match ("%e ", &expr) == MATCH_YES)
4249 : {
4250 150 : c->num_teams_list = gfc_get_expr_list();
4251 150 : c->num_teams_list->expr = expr;
4252 150 : if (gfc_peek_ascii_char () == ':')
4253 : {
4254 30 : expr = NULL;
4255 30 : if (gfc_match (": %e ", &expr) == MATCH_YES)
4256 : {
4257 29 : c->num_teams_list->next = gfc_get_expr_list();
4258 29 : c->num_teams_list->next->expr = expr;
4259 29 : if (gfc_match (") ") == MATCH_YES)
4260 27 : continue;
4261 : }
4262 : }
4263 120 : else if (gfc_match (") ") == MATCH_YES)
4264 114 : continue;
4265 : }
4266 12 : gfc_error ("Expected either %<[lower-expr : ] upper-expr%> or "
4267 : "%<dims(N): expr-list%> at %C");
4268 12 : goto error;
4269 : }
4270 1659 : if ((mask & OMP_CLAUSE_NUM_THREADS)
4271 1659 : && (m = gfc_match_dupl_check (!c->num_threads_list,
4272 : "num_threads", true, NULL))
4273 : != MATCH_NO)
4274 : {
4275 1018 : int nstrict = 0, nrelaxed = 0, ndims = 0;
4276 1018 : bool fail = false;
4277 1018 : gfc_expr *dims = NULL;
4278 1018 : locus old_loc = gfc_current_locus;
4279 :
4280 1018 : if (m == MATCH_ERROR)
4281 27 : goto error;
4282 1068 : while (true)
4283 : {
4284 1042 : if (gfc_match ("strict ") == MATCH_YES)
4285 16 : nstrict++;
4286 1026 : else if (gfc_match ("relaxed ") == MATCH_YES)
4287 21 : nrelaxed++;
4288 1005 : else if (gfc_match ("dims ") == MATCH_YES)
4289 : {
4290 32 : ndims++;
4291 32 : if (dims)
4292 3 : gfc_free_expr (dims);
4293 32 : if (gfc_match ("( %e ) ", &dims) != MATCH_YES)
4294 : break;
4295 : }
4296 : else
4297 : {
4298 : fail = true;
4299 : break;
4300 : }
4301 68 : if (gfc_match (", ") == MATCH_YES)
4302 26 : continue;
4303 : break;
4304 : }
4305 1016 : if (gfc_match (" : ") == MATCH_YES)
4306 : {
4307 40 : if (nstrict + nrelaxed + ndims == 0 || fail)
4308 : {
4309 1 : gfc_error ("Expected STRICT, RELAXED or DIMS modifier at "
4310 : "%C");
4311 1 : goto error;
4312 : }
4313 39 : else if (nstrict + nrelaxed > 1)
4314 : {
4315 8 : gfc_error ("Only one STRICT or RELAXED modifier permitted"
4316 : " at %L", &old_loc);
4317 8 : goto error;
4318 : }
4319 31 : if (ndims > 1)
4320 : {
4321 3 : gfc_error ("Duplicated DIMS expression at %L",
4322 3 : &dims->where);
4323 3 : goto error;
4324 : }
4325 28 : if (nstrict || (dims && !nrelaxed))
4326 17 : c->num_threads_strict = true;
4327 : }
4328 : else
4329 : {
4330 976 : gfc_free_expr (dims);
4331 976 : dims = NULL;
4332 976 : gfc_current_locus = old_loc;
4333 : }
4334 :
4335 1004 : m = match_omp_oacc_expr_list (NULL, &c->num_threads_list, false,
4336 : true);
4337 1004 : if (m != MATCH_YES)
4338 : {
4339 7 : gfc_error ("Expected a list of integer expressions followed "
4340 : "by a %<)%> and optionally preceded by the STRICT,"
4341 : " RELAXED, or DIMS as modifiers and a colon at %C");
4342 7 : goto error;
4343 : }
4344 997 : if (dims)
4345 : {
4346 17 : int num = 0;
4347 17 : gfc_expr_list *el;
4348 46 : for (el = c->num_threads_list; el; el = el->next)
4349 29 : ++num;
4350 17 : if (!gfc_resolve_expr (dims)
4351 17 : || dims->ts.type != BT_INTEGER
4352 16 : || dims->rank != 0
4353 15 : || dims->expr_type != EXPR_CONSTANT
4354 30 : || mpz_sgn (dims->value.integer) <= 0)
4355 : {
4356 5 : gfc_error ("DIMS must be a constant positive integer "
4357 5 : "at %L", &dims->where);
4358 5 : goto error;
4359 : }
4360 12 : if (mpz_cmp_si (dims->value.integer, num) != 0)
4361 : {
4362 1 : gfc_error ("The number of arguments (%d) must be the same"
4363 : " as specified for DIMS at %L", num,
4364 : &dims->where);
4365 1 : goto error;
4366 : }
4367 11 : c->num_threads_dims = true;
4368 : }
4369 991 : continue;
4370 991 : }
4371 1240 : if ((mask & OMP_CLAUSE_NUM_WORKERS)
4372 641 : && (m = gfc_match_dupl_check (!c->num_workers_expr, "num_workers",
4373 : true, &c->num_workers_expr))
4374 : != MATCH_NO)
4375 : {
4376 603 : if (m == MATCH_ERROR)
4377 4 : goto error;
4378 599 : continue;
4379 : }
4380 : break;
4381 591 : case 'o':
4382 591 : if ((mask & OMP_CLAUSE_ORDERED)
4383 591 : && (m = gfc_match_dupl_check (!c->ordered, "ordered"))
4384 : != MATCH_NO)
4385 : {
4386 343 : if (m == MATCH_ERROR)
4387 0 : goto error;
4388 343 : gfc_expr *cexpr = NULL;
4389 343 : m = gfc_match (" ( %e )", &cexpr);
4390 :
4391 343 : c->ordered = true;
4392 343 : if (m == MATCH_YES)
4393 : {
4394 144 : int ordered = 0;
4395 144 : if (gfc_extract_int (cexpr, &ordered, -1))
4396 0 : ordered = 0;
4397 144 : else if (ordered <= 0)
4398 : {
4399 0 : gfc_error_now ("ORDERED clause argument not"
4400 : " constant positive integer at %C");
4401 0 : ordered = 0;
4402 : }
4403 144 : c->orderedc = ordered;
4404 144 : gfc_free_expr (cexpr);
4405 144 : continue;
4406 144 : }
4407 :
4408 199 : continue;
4409 199 : }
4410 482 : if ((mask & OMP_CLAUSE_ORDER)
4411 248 : && (m = gfc_match_dupl_check (!c->order_concurrent, "order", true))
4412 : != MATCH_NO)
4413 : {
4414 247 : if (m == MATCH_ERROR)
4415 10 : goto error;
4416 237 : if (gfc_match (" reproducible : concurrent )") == MATCH_YES)
4417 55 : c->order_reproducible = true;
4418 182 : else if (gfc_match (" concurrent )") == MATCH_YES)
4419 : ;
4420 50 : else if (gfc_match (" unconstrained : concurrent )") == MATCH_YES)
4421 47 : c->order_unconstrained = true;
4422 : else
4423 : {
4424 3 : gfc_error ("Expected ORDER(CONCURRENT) at %C "
4425 : "with optional %<reproducible%> or "
4426 : "%<unconstrained%> modifier");
4427 3 : goto error;
4428 : }
4429 234 : c->order_concurrent = true;
4430 234 : continue;
4431 : }
4432 : break;
4433 3101 : case 'p':
4434 3101 : if (mask & OMP_CLAUSE_PARTIAL)
4435 : {
4436 276 : if ((m = gfc_match_dupl_check (!c->partial, "partial"))
4437 : != MATCH_NO)
4438 : {
4439 276 : int expr;
4440 276 : if (m == MATCH_ERROR)
4441 0 : goto error;
4442 :
4443 276 : c->partial = -1;
4444 :
4445 276 : gfc_expr *cexpr = NULL;
4446 276 : m = gfc_match (" ( %e )", &cexpr);
4447 276 : if (m == MATCH_NO)
4448 : ;
4449 251 : else if (m == MATCH_YES
4450 251 : && !gfc_extract_int (cexpr, &expr, -1)
4451 502 : && expr > 0)
4452 247 : c->partial = expr;
4453 : else
4454 4 : gfc_error_now ("PARTIAL clause argument not constant "
4455 : "positive integer at %C");
4456 276 : gfc_free_expr (cexpr);
4457 276 : continue;
4458 276 : }
4459 : }
4460 2894 : if ((mask & OMP_CLAUSE_COPY)
4461 877 : && gfc_match ("pcopy ( ") == MATCH_YES
4462 2895 : && gfc_match_omp_map_clause (&c->lists[OMP_LIST_MAP],
4463 : OMP_MAP_TOFROM, true, allow_derived))
4464 69 : continue;
4465 2830 : if ((mask & OMP_CLAUSE_COPYIN)
4466 1910 : && gfc_match ("pcopyin ( ") == MATCH_YES
4467 2830 : && gfc_match_omp_map_clause (&c->lists[OMP_LIST_MAP],
4468 : OMP_MAP_TO, true, allow_derived))
4469 74 : continue;
4470 2755 : if ((mask & OMP_CLAUSE_COPYOUT)
4471 735 : && gfc_match ("pcopyout ( ") == MATCH_YES
4472 2755 : && gfc_match_omp_map_clause (&c->lists[OMP_LIST_MAP],
4473 : OMP_MAP_FROM, true, allow_derived))
4474 73 : continue;
4475 2624 : if ((mask & OMP_CLAUSE_CREATE)
4476 672 : && gfc_match ("pcreate ( ") == MATCH_YES
4477 2624 : && gfc_match_omp_map_clause (&c->lists[OMP_LIST_MAP],
4478 : OMP_MAP_ALLOC, true, allow_derived))
4479 15 : continue;
4480 3010 : if ((mask & OMP_CLAUSE_PRESENT)
4481 647 : && gfc_match ("present ( ") == MATCH_YES
4482 3012 : && gfc_match_omp_map_clause (&c->lists[OMP_LIST_MAP],
4483 : OMP_MAP_FORCE_PRESENT, false,
4484 : allow_derived))
4485 416 : continue;
4486 2201 : if ((mask & OMP_CLAUSE_COPY)
4487 231 : && gfc_match ("present_or_copy ( ") == MATCH_YES
4488 2201 : && gfc_match_omp_map_clause (&c->lists[OMP_LIST_MAP],
4489 : OMP_MAP_TOFROM, true,
4490 : allow_derived))
4491 23 : continue;
4492 2195 : if ((mask & OMP_CLAUSE_COPYIN)
4493 1309 : && gfc_match ("present_or_copyin ( ") == MATCH_YES
4494 2195 : && gfc_match_omp_map_clause (&c->lists[OMP_LIST_MAP],
4495 : OMP_MAP_TO, true, allow_derived))
4496 40 : continue;
4497 2150 : if ((mask & OMP_CLAUSE_COPYOUT)
4498 173 : && gfc_match ("present_or_copyout ( ") == MATCH_YES
4499 2150 : && gfc_match_omp_map_clause (&c->lists[OMP_LIST_MAP],
4500 : OMP_MAP_FROM, true, allow_derived))
4501 35 : continue;
4502 2108 : if ((mask & OMP_CLAUSE_CREATE)
4503 143 : && gfc_match ("present_or_create ( ") == MATCH_YES
4504 2108 : && gfc_match_omp_map_clause (&c->lists[OMP_LIST_MAP],
4505 : OMP_MAP_ALLOC, true, allow_derived))
4506 28 : continue;
4507 2086 : if ((mask & OMP_CLAUSE_PRIORITY)
4508 2052 : && (m = gfc_match_dupl_check (!c->priority, "priority", true,
4509 : &c->priority)) != MATCH_NO)
4510 : {
4511 34 : if (m == MATCH_ERROR)
4512 0 : goto error;
4513 34 : continue;
4514 : }
4515 3959 : if ((mask & OMP_CLAUSE_PRIVATE)
4516 2018 : && gfc_match_omp_variable_list ("private (",
4517 : &c->lists[OMP_LIST_PRIVATE],
4518 : true) == MATCH_YES)
4519 1941 : continue;
4520 141 : if ((mask & OMP_CLAUSE_PROC_BIND)
4521 141 : && (m = gfc_match_dupl_check ((c->proc_bind
4522 64 : == OMP_PROC_BIND_UNKNOWN),
4523 : "proc_bind", true)) != MATCH_NO)
4524 : {
4525 64 : if (m == MATCH_ERROR)
4526 0 : goto error;
4527 64 : if (gfc_match ("primary )") == MATCH_YES)
4528 1 : c->proc_bind = OMP_PROC_BIND_PRIMARY;
4529 63 : else if (gfc_match ("master )") == MATCH_YES)
4530 : {
4531 9 : gfc_warning (OPT_Wdeprecated_openmp,
4532 : "%<master%> affinity policy at %C deprecated "
4533 : "since OpenMP 5.1, use %<primary%>");
4534 9 : c->proc_bind = OMP_PROC_BIND_MASTER;
4535 : }
4536 54 : else if (gfc_match ("spread )") == MATCH_YES)
4537 53 : c->proc_bind = OMP_PROC_BIND_SPREAD;
4538 1 : else if (gfc_match ("close )") == MATCH_YES)
4539 1 : c->proc_bind = OMP_PROC_BIND_CLOSE;
4540 : else
4541 0 : goto error;
4542 64 : continue;
4543 : }
4544 : break;
4545 4584 : case 'r':
4546 5074 : if ((mask & OMP_CLAUSE_ATOMIC)
4547 4584 : && (m = gfc_match_dupl_atomic ((c->atomic_op
4548 : == GFC_OMP_ATOMIC_UNSET),
4549 : "read")) != MATCH_NO)
4550 : {
4551 490 : if (m == MATCH_ERROR)
4552 0 : goto error;
4553 490 : c->atomic_op = GFC_OMP_ATOMIC_READ;
4554 490 : continue;
4555 : }
4556 8151 : if ((mask & OMP_CLAUSE_REDUCTION)
4557 4094 : && gfc_match_omp_clause_reduction (pc, c, openacc,
4558 : allow_derived) == MATCH_YES)
4559 4057 : continue;
4560 47 : if ((mask & OMP_CLAUSE_MEMORDER)
4561 65 : && (m = gfc_match_dupl_memorder ((c->memorder
4562 28 : == OMP_MEMORDER_UNSET),
4563 : "relaxed")) != MATCH_NO)
4564 : {
4565 10 : if (m == MATCH_ERROR)
4566 0 : goto error;
4567 10 : c->memorder = OMP_MEMORDER_RELAXED;
4568 10 : continue;
4569 : }
4570 44 : if ((mask & OMP_CLAUSE_MEMORDER)
4571 45 : && (m = gfc_match_dupl_memorder ((c->memorder
4572 18 : == OMP_MEMORDER_UNSET),
4573 : "release")) != MATCH_NO)
4574 : {
4575 18 : if (m == MATCH_ERROR)
4576 1 : goto error;
4577 17 : c->memorder = OMP_MEMORDER_RELEASE;
4578 17 : continue;
4579 : }
4580 : break;
4581 3048 : case 's':
4582 3141 : if ((mask & OMP_CLAUSE_SAFELEN)
4583 3048 : && (m = gfc_match_dupl_check (!c->safelen_expr, "safelen",
4584 : true, &c->safelen_expr))
4585 : != MATCH_NO)
4586 : {
4587 93 : if (m == MATCH_ERROR)
4588 0 : goto error;
4589 93 : continue;
4590 : }
4591 2955 : if ((mask & OMP_CLAUSE_SCHEDULE)
4592 2955 : && (m = gfc_match_dupl_check (c->sched_kind == OMP_SCHED_NONE,
4593 : "schedule", true)) != MATCH_NO)
4594 : {
4595 809 : if (m == MATCH_ERROR)
4596 0 : goto error;
4597 809 : int nmodifiers = 0;
4598 809 : locus old_loc2 = gfc_current_locus;
4599 827 : do
4600 : {
4601 818 : if (gfc_match ("simd") == MATCH_YES)
4602 : {
4603 18 : c->sched_simd = true;
4604 18 : nmodifiers++;
4605 : }
4606 800 : else if (gfc_match ("monotonic") == MATCH_YES)
4607 : {
4608 30 : c->sched_monotonic = true;
4609 30 : nmodifiers++;
4610 : }
4611 770 : else if (gfc_match ("nonmonotonic") == MATCH_YES)
4612 : {
4613 35 : c->sched_nonmonotonic = true;
4614 35 : nmodifiers++;
4615 : }
4616 : else
4617 : {
4618 735 : if (nmodifiers)
4619 0 : gfc_current_locus = old_loc2;
4620 : break;
4621 : }
4622 92 : if (nmodifiers == 1
4623 83 : && gfc_match (" , ") == MATCH_YES)
4624 9 : continue;
4625 74 : else if (gfc_match (" : ") == MATCH_YES)
4626 : break;
4627 0 : gfc_current_locus = old_loc2;
4628 0 : break;
4629 : }
4630 : while (1);
4631 809 : if (gfc_match ("static") == MATCH_YES)
4632 425 : c->sched_kind = OMP_SCHED_STATIC;
4633 384 : else if (gfc_match ("dynamic") == MATCH_YES)
4634 164 : c->sched_kind = OMP_SCHED_DYNAMIC;
4635 220 : else if (gfc_match ("guided") == MATCH_YES)
4636 127 : c->sched_kind = OMP_SCHED_GUIDED;
4637 93 : else if (gfc_match ("runtime") == MATCH_YES)
4638 85 : c->sched_kind = OMP_SCHED_RUNTIME;
4639 8 : else if (gfc_match ("auto") == MATCH_YES)
4640 8 : c->sched_kind = OMP_SCHED_AUTO;
4641 809 : if (c->sched_kind != OMP_SCHED_NONE)
4642 : {
4643 809 : m = MATCH_NO;
4644 809 : if (c->sched_kind != OMP_SCHED_RUNTIME
4645 724 : && c->sched_kind != OMP_SCHED_AUTO)
4646 716 : m = gfc_match (" , %e )", &c->chunk_size);
4647 716 : if (m != MATCH_YES)
4648 299 : m = gfc_match_char (')');
4649 299 : if (m != MATCH_YES)
4650 0 : c->sched_kind = OMP_SCHED_NONE;
4651 : }
4652 809 : if (c->sched_kind != OMP_SCHED_NONE)
4653 809 : continue;
4654 : else
4655 0 : gfc_current_locus = old_loc;
4656 : }
4657 2329 : if ((mask & OMP_CLAUSE_SELF)
4658 335 : && !(mask & OMP_CLAUSE_HOST) /* OpenACC compute construct */
4659 2386 : && (m = gfc_match_dupl_check (!c->self_expr, "self"))
4660 : != MATCH_NO)
4661 : {
4662 186 : if (m == MATCH_ERROR)
4663 3 : goto error;
4664 183 : m = gfc_match (" ( %e )", &c->self_expr);
4665 183 : if (m == MATCH_ERROR)
4666 : {
4667 0 : gfc_current_locus = old_loc;
4668 0 : break;
4669 : }
4670 183 : else if (m == MATCH_NO)
4671 9 : c->self_expr = gfc_get_logical_expr (gfc_default_logical_kind,
4672 : NULL, true);
4673 183 : continue;
4674 : }
4675 2054 : if ((mask & OMP_CLAUSE_SELF)
4676 149 : && (mask & OMP_CLAUSE_HOST) /* OpenACC 'update' directive */
4677 95 : && gfc_match ("self ( ") == MATCH_YES
4678 2055 : && gfc_match_omp_map_clause (&c->lists[OMP_LIST_MAP],
4679 : OMP_MAP_FORCE_FROM, true,
4680 : /* allow_derived = */ true))
4681 94 : continue;
4682 2214 : if ((mask & OMP_CLAUSE_SEQ)
4683 1866 : && (m = gfc_match_dupl_check (!c->seq, "seq")) != MATCH_NO)
4684 : {
4685 348 : if (m == MATCH_ERROR)
4686 0 : goto error;
4687 348 : c->seq = true;
4688 348 : continue;
4689 : }
4690 1659 : if ((mask & OMP_CLAUSE_MEMORDER)
4691 1659 : && (m = gfc_match_dupl_memorder ((c->memorder
4692 141 : == OMP_MEMORDER_UNSET),
4693 : "seq_cst")) != MATCH_NO)
4694 : {
4695 141 : if (m == MATCH_ERROR)
4696 0 : goto error;
4697 141 : c->memorder = OMP_MEMORDER_SEQ_CST;
4698 141 : continue;
4699 : }
4700 2352 : if ((mask & OMP_CLAUSE_SHARED)
4701 1377 : && gfc_match_omp_variable_list ("shared (",
4702 : &c->lists[OMP_LIST_SHARED],
4703 : true) == MATCH_YES)
4704 975 : continue;
4705 520 : if ((mask & OMP_CLAUSE_SIMDLEN)
4706 402 : && (m = gfc_match_dupl_check (!c->simdlen_expr, "simdlen", true,
4707 : &c->simdlen_expr)) != MATCH_NO)
4708 : {
4709 118 : if (m == MATCH_ERROR)
4710 0 : goto error;
4711 118 : continue;
4712 : }
4713 306 : if ((mask & OMP_CLAUSE_SIMD)
4714 284 : && (m = gfc_match_dupl_check (!c->simd, "simd")) != MATCH_NO)
4715 : {
4716 22 : if (m == MATCH_ERROR)
4717 0 : goto error;
4718 22 : c->simd = true;
4719 22 : continue;
4720 : }
4721 313 : if ((mask & OMP_CLAUSE_SEVERITY)
4722 262 : && (m = gfc_match_dupl_check (!c->severity, "severity", true))
4723 : != MATCH_NO)
4724 : {
4725 57 : if (m == MATCH_ERROR)
4726 2 : goto error;
4727 55 : if (gfc_match ("fatal )") == MATCH_YES)
4728 15 : c->severity = OMP_SEVERITY_FATAL;
4729 40 : else if (gfc_match ("warning )") == MATCH_YES)
4730 36 : c->severity = OMP_SEVERITY_WARNING;
4731 : else
4732 : {
4733 4 : gfc_error ("Expected FATAL or WARNING in SEVERITY clause "
4734 : "at %C");
4735 4 : goto error;
4736 : }
4737 51 : continue;
4738 : }
4739 205 : if ((mask & OMP_CLAUSE_SIZES)
4740 205 : && ((m = gfc_match_dupl_check (!c->sizes_list, "sizes"))
4741 : != MATCH_NO))
4742 : {
4743 203 : if (m == MATCH_ERROR)
4744 0 : goto error;
4745 203 : m = match_omp_oacc_expr_list (" (", &c->sizes_list, false, true);
4746 203 : if (m == MATCH_ERROR)
4747 7 : goto error;
4748 196 : if (m == MATCH_YES)
4749 195 : continue;
4750 1 : gfc_error ("Expected %<(%> after %qs at %C", "sizes");
4751 1 : goto error;
4752 : }
4753 : break;
4754 1281 : case 't':
4755 1346 : if ((mask & OMP_CLAUSE_TASK_REDUCTION)
4756 1281 : && gfc_match_omp_clause_reduction (pc, c, openacc,
4757 : allow_derived) == MATCH_YES)
4758 65 : continue;
4759 1216 : if ((mask & OMP_CLAUSE_THREAD_LIMIT)
4760 1216 : && (m = gfc_match_dupl_check (!c->thread_limit_list, "thread_limit",
4761 : true, NULL)) != MATCH_NO)
4762 : {
4763 131 : int nstrict = 0, nrelaxed = 0, ndims = 0;
4764 131 : bool fail = false;
4765 131 : gfc_expr *dims = NULL;
4766 131 : locus old_loc = gfc_current_locus;
4767 :
4768 131 : if (m == MATCH_ERROR)
4769 28 : goto error;
4770 177 : while (true)
4771 : {
4772 153 : if (gfc_match ("strict ") == MATCH_YES)
4773 15 : nstrict++;
4774 138 : else if (gfc_match ("relaxed ") == MATCH_YES)
4775 25 : nrelaxed++;
4776 113 : else if (gfc_match ("dims ") == MATCH_YES)
4777 : {
4778 31 : ndims++;
4779 31 : if (dims)
4780 3 : gfc_free_expr (dims);
4781 31 : if (gfc_match ("( %e ) ", &dims) != MATCH_YES)
4782 : break;
4783 : }
4784 : else
4785 : {
4786 : fail = true;
4787 : break;
4788 : }
4789 70 : if (gfc_match (", ") == MATCH_YES)
4790 24 : continue;
4791 : break;
4792 : }
4793 129 : if (gfc_match (" : ") == MATCH_YES)
4794 : {
4795 44 : if (nstrict + nrelaxed + ndims == 0 || fail)
4796 : {
4797 1 : gfc_error ("Expected STRICT, RELAXED or DIMS modifier at "
4798 : "%C");
4799 1 : goto error;
4800 : }
4801 43 : else if (nstrict + nrelaxed > 1)
4802 : {
4803 8 : gfc_error ("Only one STRICT or RELAXED modifier permitted"
4804 : " at %L", &old_loc);
4805 8 : goto error;
4806 : }
4807 35 : if (ndims > 1)
4808 : {
4809 3 : gfc_error ("Duplicated DIMS expression at %L",
4810 3 : &dims->where);
4811 3 : goto error;
4812 : }
4813 : }
4814 : else
4815 : {
4816 85 : gfc_free_expr (dims);
4817 85 : dims = NULL;
4818 85 : gfc_current_locus = old_loc;
4819 : }
4820 :
4821 117 : m = match_omp_oacc_expr_list (NULL, &c->thread_limit_list,
4822 : false, true);
4823 117 : if (m != MATCH_YES)
4824 : {
4825 7 : gfc_error ("Expected a list of integer expressions followed "
4826 : "by a %<)%> and optionally preceded by the STRICT,"
4827 : " RELAXED, or DIMS as modifiers and a colon at %C");
4828 7 : goto error;
4829 : }
4830 110 : c->thread_limit_strict = (nstrict != 0) || (dims && !nrelaxed);
4831 :
4832 110 : if (!dims && c->thread_limit_list->next)
4833 : {
4834 1 : gfc_error ("Without the DIM modifier, only a single integer "
4835 : "expression may be specified at %L",
4836 1 : &c->thread_limit_list->next->expr->where);
4837 1 : goto error;
4838 : }
4839 109 : else if (dims)
4840 : {
4841 16 : int num = 0;
4842 16 : gfc_expr_list *el;
4843 53 : for (el = c->thread_limit_list; el; el = el->next)
4844 37 : ++num;
4845 16 : if (!gfc_resolve_expr (dims)
4846 16 : || dims->ts.type != BT_INTEGER
4847 15 : || dims->rank != 0
4848 14 : || dims->expr_type != EXPR_CONSTANT
4849 28 : || mpz_sgn (dims->value.integer) <= 0)
4850 : {
4851 5 : gfc_error ("DIMS must be a constant positive integer "
4852 5 : "at %L", &dims->where);
4853 5 : goto error;
4854 : }
4855 11 : if (mpz_cmp_si (dims->value.integer, num) != 0)
4856 : {
4857 1 : gfc_error ("The number of arguments (%d) must be the same"
4858 : " as specified for DIMS at %L", num,
4859 : &dims->where);
4860 1 : goto error;
4861 : }
4862 10 : c->thread_limit_dims = true;
4863 : }
4864 103 : continue;
4865 103 : }
4866 1098 : if ((mask & OMP_CLAUSE_THREADS)
4867 1085 : && (m = gfc_match_dupl_check (!c->threads, "threads"))
4868 : != MATCH_NO)
4869 : {
4870 13 : if (m == MATCH_ERROR)
4871 0 : goto error;
4872 13 : c->threads = true;
4873 13 : continue;
4874 : }
4875 1269 : if ((mask & OMP_CLAUSE_TILE)
4876 221 : && !c->tile_list
4877 1293 : && match_omp_oacc_expr_list ("tile (", &c->tile_list,
4878 : true, false) == MATCH_YES)
4879 197 : continue;
4880 875 : if ((mask & OMP_CLAUSE_TO) && (mask & OMP_CLAUSE_LINK))
4881 : {
4882 : /* Declare target: 'to' is an alias for 'enter';
4883 : 'to' is deprecated since 5.2. */
4884 116 : m = gfc_match_omp_to_link ("to (", &c->lists[OMP_LIST_TO]);
4885 116 : if (m == MATCH_ERROR)
4886 0 : goto error;
4887 116 : if (m == MATCH_YES)
4888 : {
4889 116 : gfc_warning (OPT_Wdeprecated_openmp,
4890 : "%<to%> clause with %<declare target%> at %L "
4891 : "deprecated since OpenMP 5.2, use %<enter%>",
4892 : &old_loc);
4893 116 : continue;
4894 : }
4895 : }
4896 1487 : else if ((mask & OMP_CLAUSE_TO)
4897 759 : && gfc_match_motion_var_list ("to (", &c->lists[OMP_LIST_TO],
4898 : &head) == MATCH_YES)
4899 728 : continue;
4900 : break;
4901 1538 : case 'u':
4902 1596 : if ((mask & OMP_CLAUSE_UNIFORM)
4903 1538 : && gfc_match_omp_variable_list ("uniform (",
4904 : &c->lists[OMP_LIST_UNIFORM],
4905 : false) == MATCH_YES)
4906 58 : continue;
4907 1621 : if ((mask & OMP_CLAUSE_UNTIED)
4908 1480 : && (m = gfc_match_dupl_check (!c->untied, "untied")) != MATCH_NO)
4909 : {
4910 141 : if (m == MATCH_ERROR)
4911 0 : goto error;
4912 141 : c->untied = true;
4913 141 : continue;
4914 : }
4915 1583 : if ((mask & OMP_CLAUSE_ATOMIC)
4916 1339 : && (m = gfc_match_dupl_atomic ((c->atomic_op
4917 : == GFC_OMP_ATOMIC_UNSET),
4918 : "update")) != MATCH_NO)
4919 : {
4920 245 : if (m == MATCH_ERROR)
4921 1 : goto error;
4922 244 : c->atomic_op = GFC_OMP_ATOMIC_UPDATE;
4923 244 : continue;
4924 : }
4925 1116 : if ((mask & OMP_CLAUSE_USE)
4926 1094 : && gfc_match_omp_variable_list ("use (",
4927 : &c->lists[OMP_LIST_USE],
4928 : true) == MATCH_YES)
4929 22 : continue;
4930 1132 : if ((mask & OMP_CLAUSE_USE_DEVICE)
4931 1072 : && gfc_match_omp_variable_list ("use_device (",
4932 : &c->lists[OMP_LIST_USE_DEVICE],
4933 : true) == MATCH_YES)
4934 60 : continue;
4935 1175 : if ((mask & OMP_CLAUSE_USE_DEVICE_PTR)
4936 1940 : && gfc_match_omp_variable_list
4937 928 : ("use_device_ptr (",
4938 : &c->lists[OMP_LIST_USE_DEVICE_PTR], false) == MATCH_YES)
4939 163 : continue;
4940 1614 : if ((mask & OMP_CLAUSE_USE_DEVICE_ADDR)
4941 1614 : && gfc_match_omp_variable_list
4942 765 : ("use_device_addr (", &c->lists[OMP_LIST_USE_DEVICE_ADDR],
4943 : false, NULL, NULL, true) == MATCH_YES)
4944 765 : continue;
4945 153 : if ((mask & OMP_CLAUSE_USES_ALLOCATORS)
4946 84 : && (gfc_match ("uses_allocators ( ") == MATCH_YES))
4947 : {
4948 78 : if (gfc_match_omp_clause_uses_allocators (c) != MATCH_YES)
4949 9 : goto error;
4950 69 : continue;
4951 : }
4952 : break;
4953 1570 : case 'v':
4954 : /* VECTOR_LENGTH must be matched before VECTOR, because the latter
4955 : doesn't unconditionally match '('. */
4956 2139 : if ((mask & OMP_CLAUSE_VECTOR_LENGTH)
4957 1570 : && (m = gfc_match_dupl_check (!c->vector_length_expr,
4958 : "vector_length", true,
4959 : &c->vector_length_expr))
4960 : != MATCH_NO)
4961 : {
4962 573 : if (m == MATCH_ERROR)
4963 4 : goto error;
4964 569 : continue;
4965 : }
4966 1989 : if ((mask & OMP_CLAUSE_VECTOR)
4967 997 : && (m = gfc_match_dupl_check (!c->vector, "vector")) != MATCH_NO)
4968 : {
4969 995 : if (m == MATCH_ERROR)
4970 0 : goto error;
4971 995 : c->vector = true;
4972 995 : m = match_oacc_clause_gwv (c, GOMP_DIM_VECTOR);
4973 995 : if (m == MATCH_ERROR)
4974 3 : goto error;
4975 992 : continue;
4976 : }
4977 : break;
4978 1485 : case 'w':
4979 1485 : if ((mask & OMP_CLAUSE_WAIT)
4980 1485 : && gfc_match ("wait") == MATCH_YES)
4981 : {
4982 192 : m = match_omp_oacc_expr_list (" (", &c->wait_list, false, false);
4983 192 : if (m == MATCH_ERROR)
4984 9 : goto error;
4985 183 : else if (m == MATCH_NO)
4986 : {
4987 47 : gfc_expr *expr
4988 47 : = gfc_get_constant_expr (BT_INTEGER,
4989 : gfc_default_integer_kind,
4990 : &gfc_current_locus);
4991 47 : mpz_set_si (expr->value.integer, GOMP_ASYNC_NOVAL);
4992 47 : gfc_expr_list **expr_list = &c->wait_list;
4993 56 : while (*expr_list)
4994 9 : expr_list = &(*expr_list)->next;
4995 47 : *expr_list = gfc_get_expr_list ();
4996 47 : (*expr_list)->expr = expr;
4997 47 : needs_space = true;
4998 : }
4999 183 : continue;
5000 183 : }
5001 1306 : if ((mask & OMP_CLAUSE_WEAK)
5002 1293 : && (m = gfc_match_dupl_check (!c->weak, "weak"))
5003 : != MATCH_NO)
5004 : {
5005 14 : if (m == MATCH_ERROR)
5006 1 : goto error;
5007 13 : c->weak = true;
5008 13 : continue;
5009 : }
5010 2140 : if ((mask & OMP_CLAUSE_WORKER)
5011 1279 : && (m = gfc_match_dupl_check (!c->worker, "worker")) != MATCH_NO)
5012 : {
5013 864 : if (m == MATCH_ERROR)
5014 0 : goto error;
5015 864 : c->worker = true;
5016 864 : m = match_oacc_clause_gwv (c, GOMP_DIM_WORKER);
5017 864 : if (m == MATCH_ERROR)
5018 3 : goto error;
5019 861 : continue;
5020 : }
5021 827 : if ((mask & OMP_CLAUSE_ATOMIC)
5022 415 : && (m = gfc_match_dupl_atomic ((c->atomic_op
5023 : == GFC_OMP_ATOMIC_UNSET),
5024 : "write")) != MATCH_NO)
5025 : {
5026 412 : if (m == MATCH_ERROR)
5027 0 : goto error;
5028 412 : c->atomic_op = GFC_OMP_ATOMIC_WRITE;
5029 412 : continue;
5030 : }
5031 : break;
5032 : }
5033 : break;
5034 46914 : }
5035 :
5036 35104 : end:
5037 34760 : if (error || gfc_match_omp_eos () != MATCH_YES)
5038 : {
5039 641 : if (!gfc_error_flag_test ())
5040 149 : gfc_error ("Failed to match clause at %C");
5041 641 : gfc_free_omp_clauses (c);
5042 641 : return MATCH_ERROR;
5043 : }
5044 :
5045 34463 : *cp = c;
5046 34463 : return MATCH_YES;
5047 :
5048 344 : error:
5049 344 : error = true;
5050 344 : goto end;
5051 : }
5052 :
5053 :
5054 : #define OACC_PARALLEL_CLAUSES \
5055 : (omp_mask (OMP_CLAUSE_IF) | OMP_CLAUSE_ASYNC | OMP_CLAUSE_NUM_GANGS \
5056 : | OMP_CLAUSE_NUM_WORKERS | OMP_CLAUSE_VECTOR_LENGTH | OMP_CLAUSE_REDUCTION \
5057 : | OMP_CLAUSE_COPY | OMP_CLAUSE_COPYIN | OMP_CLAUSE_COPYOUT \
5058 : | OMP_CLAUSE_CREATE | OMP_CLAUSE_NO_CREATE | OMP_CLAUSE_PRESENT \
5059 : | OMP_CLAUSE_DEVICEPTR | OMP_CLAUSE_PRIVATE | OMP_CLAUSE_FIRSTPRIVATE \
5060 : | OMP_CLAUSE_DEFAULT | OMP_CLAUSE_WAIT | OMP_CLAUSE_ATTACH \
5061 : | OMP_CLAUSE_SELF)
5062 : #define OACC_KERNELS_CLAUSES \
5063 : (omp_mask (OMP_CLAUSE_IF) | OMP_CLAUSE_ASYNC | OMP_CLAUSE_NUM_GANGS \
5064 : | OMP_CLAUSE_NUM_WORKERS | OMP_CLAUSE_VECTOR_LENGTH | OMP_CLAUSE_DEVICEPTR \
5065 : | OMP_CLAUSE_COPY | OMP_CLAUSE_COPYIN | OMP_CLAUSE_COPYOUT \
5066 : | OMP_CLAUSE_CREATE | OMP_CLAUSE_NO_CREATE | OMP_CLAUSE_PRESENT \
5067 : | OMP_CLAUSE_DEFAULT | OMP_CLAUSE_WAIT | OMP_CLAUSE_ATTACH \
5068 : | OMP_CLAUSE_SELF)
5069 : #define OACC_SERIAL_CLAUSES \
5070 : (omp_mask (OMP_CLAUSE_IF) | OMP_CLAUSE_ASYNC | OMP_CLAUSE_REDUCTION \
5071 : | OMP_CLAUSE_COPY | OMP_CLAUSE_COPYIN | OMP_CLAUSE_COPYOUT \
5072 : | OMP_CLAUSE_CREATE | OMP_CLAUSE_NO_CREATE | OMP_CLAUSE_PRESENT \
5073 : | OMP_CLAUSE_DEVICEPTR | OMP_CLAUSE_PRIVATE | OMP_CLAUSE_FIRSTPRIVATE \
5074 : | OMP_CLAUSE_DEFAULT | OMP_CLAUSE_WAIT | OMP_CLAUSE_ATTACH \
5075 : | OMP_CLAUSE_SELF)
5076 : #define OACC_DATA_CLAUSES \
5077 : (omp_mask (OMP_CLAUSE_IF) | OMP_CLAUSE_DEVICEPTR | OMP_CLAUSE_COPY \
5078 : | OMP_CLAUSE_COPYIN | OMP_CLAUSE_COPYOUT | OMP_CLAUSE_CREATE \
5079 : | OMP_CLAUSE_NO_CREATE | OMP_CLAUSE_PRESENT | OMP_CLAUSE_ATTACH \
5080 : | OMP_CLAUSE_DEFAULT)
5081 : #define OACC_LOOP_CLAUSES \
5082 : (omp_mask (OMP_CLAUSE_COLLAPSE) | OMP_CLAUSE_GANG | OMP_CLAUSE_WORKER \
5083 : | OMP_CLAUSE_VECTOR | OMP_CLAUSE_SEQ | OMP_CLAUSE_INDEPENDENT \
5084 : | OMP_CLAUSE_PRIVATE | OMP_CLAUSE_REDUCTION | OMP_CLAUSE_AUTO \
5085 : | OMP_CLAUSE_TILE)
5086 : #define OACC_PARALLEL_LOOP_CLAUSES \
5087 : (OACC_LOOP_CLAUSES | OACC_PARALLEL_CLAUSES)
5088 : #define OACC_KERNELS_LOOP_CLAUSES \
5089 : (OACC_LOOP_CLAUSES | OACC_KERNELS_CLAUSES)
5090 : #define OACC_SERIAL_LOOP_CLAUSES \
5091 : (OACC_LOOP_CLAUSES | OACC_SERIAL_CLAUSES)
5092 : #define OACC_HOST_DATA_CLAUSES \
5093 : (omp_mask (OMP_CLAUSE_USE_DEVICE) \
5094 : | OMP_CLAUSE_IF \
5095 : | OMP_CLAUSE_IF_PRESENT)
5096 : #define OACC_DECLARE_CLAUSES \
5097 : (omp_mask (OMP_CLAUSE_COPY) | OMP_CLAUSE_COPYIN | OMP_CLAUSE_COPYOUT \
5098 : | OMP_CLAUSE_CREATE | OMP_CLAUSE_DEVICEPTR | OMP_CLAUSE_DEVICE_RESIDENT \
5099 : | OMP_CLAUSE_PRESENT \
5100 : | OMP_CLAUSE_LINK)
5101 : #define OACC_UPDATE_CLAUSES \
5102 : (omp_mask (OMP_CLAUSE_IF) | OMP_CLAUSE_ASYNC | OMP_CLAUSE_HOST \
5103 : | OMP_CLAUSE_DEVICE | OMP_CLAUSE_WAIT | OMP_CLAUSE_IF_PRESENT \
5104 : | OMP_CLAUSE_SELF)
5105 : #define OACC_ENTER_DATA_CLAUSES \
5106 : (omp_mask (OMP_CLAUSE_IF) | OMP_CLAUSE_ASYNC | OMP_CLAUSE_WAIT \
5107 : | OMP_CLAUSE_COPYIN | OMP_CLAUSE_CREATE | OMP_CLAUSE_ATTACH)
5108 : #define OACC_EXIT_DATA_CLAUSES \
5109 : (omp_mask (OMP_CLAUSE_IF) | OMP_CLAUSE_ASYNC | OMP_CLAUSE_WAIT \
5110 : | OMP_CLAUSE_COPYOUT | OMP_CLAUSE_DELETE | OMP_CLAUSE_FINALIZE \
5111 : | OMP_CLAUSE_DETACH)
5112 : #define OACC_WAIT_CLAUSES \
5113 : omp_mask (OMP_CLAUSE_ASYNC) | OMP_CLAUSE_IF
5114 : #define OACC_ROUTINE_CLAUSES \
5115 : (omp_mask (OMP_CLAUSE_GANG) | OMP_CLAUSE_WORKER | OMP_CLAUSE_VECTOR \
5116 : | OMP_CLAUSE_SEQ \
5117 : | OMP_CLAUSE_NOHOST)
5118 : #define OACC_INIT_CLAUSES \
5119 : (omp_mask (OMP_CLAUSE_IF) | OMP_CLAUSE_DEVICE_NUM | OMP_CLAUSE_DEVICE_TYPE)
5120 : #define OACC_SHUTDOWN_CLAUSES \
5121 : (omp_mask (OMP_CLAUSE_IF) | OMP_CLAUSE_DEVICE_NUM | OMP_CLAUSE_DEVICE_TYPE)
5122 : #define OACC_SET_CLAUSES \
5123 : (omp_mask (OMP_CLAUSE_IF) | OMP_CLAUSE_DEVICE_NUM | OMP_CLAUSE_DEVICE_TYPE)
5124 :
5125 :
5126 : static match
5127 12198 : match_acc (gfc_exec_op op, const omp_mask mask)
5128 : {
5129 12198 : gfc_omp_clauses *c;
5130 12198 : if (gfc_match_omp_clauses (&c, mask, false, false, true) != MATCH_YES)
5131 : return MATCH_ERROR;
5132 11969 : new_st.op = op;
5133 11969 : new_st.ext.omp_clauses = c;
5134 11969 : return MATCH_YES;
5135 : }
5136 :
5137 : match
5138 1378 : gfc_match_oacc_parallel_loop (void)
5139 : {
5140 1378 : return match_acc (EXEC_OACC_PARALLEL_LOOP, OACC_PARALLEL_LOOP_CLAUSES);
5141 : }
5142 :
5143 :
5144 : match
5145 2974 : gfc_match_oacc_parallel (void)
5146 : {
5147 2974 : return match_acc (EXEC_OACC_PARALLEL, OACC_PARALLEL_CLAUSES);
5148 : }
5149 :
5150 :
5151 : match
5152 129 : gfc_match_oacc_kernels_loop (void)
5153 : {
5154 129 : return match_acc (EXEC_OACC_KERNELS_LOOP, OACC_KERNELS_LOOP_CLAUSES);
5155 : }
5156 :
5157 :
5158 : match
5159 906 : gfc_match_oacc_kernels (void)
5160 : {
5161 906 : return match_acc (EXEC_OACC_KERNELS, OACC_KERNELS_CLAUSES);
5162 : }
5163 :
5164 :
5165 : match
5166 230 : gfc_match_oacc_serial_loop (void)
5167 : {
5168 230 : return match_acc (EXEC_OACC_SERIAL_LOOP, OACC_SERIAL_LOOP_CLAUSES);
5169 : }
5170 :
5171 :
5172 : match
5173 359 : gfc_match_oacc_serial (void)
5174 : {
5175 359 : return match_acc (EXEC_OACC_SERIAL, OACC_SERIAL_CLAUSES);
5176 : }
5177 :
5178 :
5179 : match
5180 689 : gfc_match_oacc_data (void)
5181 : {
5182 689 : return match_acc (EXEC_OACC_DATA, OACC_DATA_CLAUSES);
5183 : }
5184 :
5185 :
5186 : match
5187 65 : gfc_match_oacc_host_data (void)
5188 : {
5189 65 : return match_acc (EXEC_OACC_HOST_DATA, OACC_HOST_DATA_CLAUSES);
5190 : }
5191 :
5192 :
5193 : match
5194 3585 : gfc_match_oacc_loop (void)
5195 : {
5196 3585 : return match_acc (EXEC_OACC_LOOP, OACC_LOOP_CLAUSES);
5197 : }
5198 :
5199 :
5200 : match
5201 178 : gfc_match_oacc_declare (void)
5202 : {
5203 178 : gfc_omp_clauses *c;
5204 178 : gfc_omp_namelist *n;
5205 178 : gfc_namespace *ns = gfc_current_ns;
5206 178 : gfc_oacc_declare *new_oc;
5207 178 : bool module_var = false;
5208 178 : locus where = gfc_current_locus;
5209 :
5210 178 : if (gfc_match_omp_clauses (&c, OACC_DECLARE_CLAUSES, false, false, true)
5211 : != MATCH_YES)
5212 : return MATCH_ERROR;
5213 :
5214 262 : for (n = c->lists[OMP_LIST_DEVICE_RESIDENT]; n != NULL; n = n->next)
5215 90 : n->sym->attr.oacc_declare_device_resident = 1;
5216 :
5217 192 : for (n = c->lists[OMP_LIST_LINK]; n != NULL; n = n->next)
5218 20 : n->sym->attr.oacc_declare_link = 1;
5219 :
5220 318 : for (n = c->lists[OMP_LIST_MAP]; n != NULL; n = n->next)
5221 : {
5222 156 : gfc_symbol *s = n->sym;
5223 :
5224 156 : if (gfc_current_ns->proc_name
5225 156 : && gfc_current_ns->proc_name->attr.flavor == FL_MODULE)
5226 : {
5227 52 : if (n->u.map.op != OMP_MAP_ALLOC && n->u.map.op != OMP_MAP_TO)
5228 : {
5229 6 : gfc_error ("Invalid clause in module with !$ACC DECLARE at %L",
5230 : &where);
5231 6 : return MATCH_ERROR;
5232 : }
5233 :
5234 : module_var = true;
5235 : }
5236 :
5237 150 : if (s->attr.use_assoc)
5238 : {
5239 0 : gfc_error ("Variable is USE-associated with !$ACC DECLARE at %L",
5240 : &where);
5241 0 : return MATCH_ERROR;
5242 : }
5243 :
5244 150 : if ((s->result == s && s->ns->contained != gfc_current_ns)
5245 150 : || ((s->attr.flavor == FL_UNKNOWN || s->attr.flavor == FL_VARIABLE)
5246 135 : && s->ns != gfc_current_ns))
5247 : {
5248 2 : gfc_error ("Variable %qs shall be declared in the same scoping unit "
5249 : "as !$ACC DECLARE at %L", s->name, &where);
5250 2 : return MATCH_ERROR;
5251 : }
5252 :
5253 148 : if ((s->attr.dimension || s->attr.codimension)
5254 76 : && s->attr.dummy && s->as->type != AS_EXPLICIT)
5255 : {
5256 2 : gfc_error ("Assumed-size dummy array with !$ACC DECLARE at %L",
5257 : &where);
5258 2 : return MATCH_ERROR;
5259 : }
5260 :
5261 146 : switch (n->u.map.op)
5262 : {
5263 49 : case OMP_MAP_FORCE_ALLOC:
5264 49 : case OMP_MAP_ALLOC:
5265 49 : s->attr.oacc_declare_create = 1;
5266 49 : break;
5267 :
5268 63 : case OMP_MAP_FORCE_TO:
5269 63 : case OMP_MAP_TO:
5270 63 : s->attr.oacc_declare_copyin = 1;
5271 63 : break;
5272 :
5273 1 : case OMP_MAP_FORCE_DEVICEPTR:
5274 1 : s->attr.oacc_declare_deviceptr = 1;
5275 1 : break;
5276 :
5277 : default:
5278 : break;
5279 : }
5280 : }
5281 :
5282 162 : new_oc = gfc_get_oacc_declare ();
5283 162 : new_oc->next = ns->oacc_declare;
5284 162 : new_oc->module_var = module_var;
5285 162 : new_oc->clauses = c;
5286 162 : new_oc->loc = gfc_current_locus;
5287 162 : ns->oacc_declare = new_oc;
5288 :
5289 162 : return MATCH_YES;
5290 : }
5291 :
5292 :
5293 : match
5294 760 : gfc_match_oacc_update (void)
5295 : {
5296 760 : gfc_omp_clauses *c;
5297 760 : locus here = gfc_current_locus;
5298 :
5299 760 : if (gfc_match_omp_clauses (&c, OACC_UPDATE_CLAUSES, false, false, true)
5300 : != MATCH_YES)
5301 : return MATCH_ERROR;
5302 :
5303 756 : if (!c->lists[OMP_LIST_MAP])
5304 : {
5305 1 : gfc_error ("%<acc update%> must contain at least one "
5306 : "%<device%> or %<host%> or %<self%> clause at %L", &here);
5307 1 : return MATCH_ERROR;
5308 : }
5309 :
5310 755 : new_st.op = EXEC_OACC_UPDATE;
5311 755 : new_st.ext.omp_clauses = c;
5312 755 : return MATCH_YES;
5313 : }
5314 :
5315 :
5316 : match
5317 877 : gfc_match_oacc_enter_data (void)
5318 : {
5319 877 : return match_acc (EXEC_OACC_ENTER_DATA, OACC_ENTER_DATA_CLAUSES);
5320 : }
5321 :
5322 :
5323 : match
5324 612 : gfc_match_oacc_exit_data (void)
5325 : {
5326 612 : return match_acc (EXEC_OACC_EXIT_DATA, OACC_EXIT_DATA_CLAUSES);
5327 : }
5328 :
5329 :
5330 : match
5331 202 : gfc_match_oacc_wait (void)
5332 : {
5333 202 : gfc_omp_clauses *c = gfc_get_omp_clauses ();
5334 202 : gfc_expr_list *wait_list = NULL, *el;
5335 202 : bool space = true;
5336 202 : match m;
5337 :
5338 202 : m = match_omp_oacc_expr_list (" (", &wait_list, true, false);
5339 202 : if (m == MATCH_ERROR)
5340 : return m;
5341 196 : else if (m == MATCH_YES)
5342 126 : space = false;
5343 :
5344 196 : if (gfc_match_omp_clauses (&c, OACC_WAIT_CLAUSES, space, space, true)
5345 : == MATCH_ERROR)
5346 : return MATCH_ERROR;
5347 :
5348 184 : if (wait_list)
5349 261 : for (el = wait_list; el; el = el->next)
5350 : {
5351 140 : if (el->expr == NULL)
5352 : {
5353 2 : gfc_error ("Invalid argument to !$ACC WAIT at %C");
5354 2 : return MATCH_ERROR;
5355 : }
5356 :
5357 138 : if (!gfc_resolve_expr (el->expr)
5358 138 : || el->expr->ts.type != BT_INTEGER || el->expr->rank != 0)
5359 : {
5360 3 : gfc_error ("WAIT clause at %L requires a scalar INTEGER expression",
5361 3 : &el->expr->where);
5362 :
5363 3 : return MATCH_ERROR;
5364 : }
5365 : }
5366 179 : c->wait_list = wait_list;
5367 179 : new_st.op = EXEC_OACC_WAIT;
5368 179 : new_st.ext.omp_clauses = c;
5369 179 : return MATCH_YES;
5370 : }
5371 :
5372 :
5373 : match
5374 97 : gfc_match_oacc_cache (void)
5375 : {
5376 97 : bool readonly = false;
5377 97 : gfc_omp_clauses *c = gfc_get_omp_clauses ();
5378 : /* The OpenACC cache directive explicitly only allows "array elements or
5379 : subarrays", which we're currently not checking here. Either check this
5380 : after the call of gfc_match_omp_variable_list, or add something like a
5381 : only_sections variant next to its allow_sections parameter. */
5382 97 : match m = gfc_match (" ( ");
5383 97 : if (m != MATCH_YES)
5384 : {
5385 0 : gfc_free_omp_clauses(c);
5386 0 : return m;
5387 : }
5388 :
5389 97 : if (gfc_match ("readonly : ") == MATCH_YES)
5390 8 : readonly = true;
5391 :
5392 97 : gfc_omp_namelist **head = NULL;
5393 97 : m = gfc_match_omp_variable_list ("", &c->lists[OMP_LIST_CACHE], true,
5394 : NULL, &head, true);
5395 97 : if (m != MATCH_YES)
5396 : {
5397 2 : gfc_free_omp_clauses(c);
5398 2 : return m;
5399 : }
5400 :
5401 95 : if (readonly)
5402 24 : for (gfc_omp_namelist *n = *head; n; n = n->next)
5403 16 : n->u.map.readonly = true;
5404 :
5405 95 : if (gfc_current_state() != COMP_DO
5406 56 : && gfc_current_state() != COMP_DO_CONCURRENT)
5407 : {
5408 2 : gfc_error ("ACC CACHE directive must be inside of loop %C");
5409 2 : gfc_free_omp_clauses(c);
5410 2 : return MATCH_ERROR;
5411 : }
5412 :
5413 93 : new_st.op = EXEC_OACC_CACHE;
5414 93 : new_st.ext.omp_clauses = c;
5415 93 : return MATCH_YES;
5416 : }
5417 :
5418 : match
5419 134 : gfc_match_oacc_init (void)
5420 : {
5421 134 : return match_acc (EXEC_OACC_INIT, OACC_INIT_CLAUSES);
5422 : }
5423 :
5424 : match
5425 130 : gfc_match_oacc_shutdown (void)
5426 : {
5427 130 : return match_acc (EXEC_OACC_SHUTDOWN, OACC_SHUTDOWN_CLAUSES);
5428 : }
5429 :
5430 : match
5431 130 : gfc_match_oacc_set (void)
5432 : {
5433 130 : return match_acc (EXEC_OACC_SET, OACC_SET_CLAUSES);
5434 : }
5435 :
5436 : /* Determine the OpenACC 'routine' directive's level of parallelism. */
5437 :
5438 : static oacc_routine_lop
5439 734 : gfc_oacc_routine_lop (gfc_omp_clauses *clauses)
5440 : {
5441 734 : oacc_routine_lop ret = OACC_ROUTINE_LOP_SEQ;
5442 :
5443 734 : if (clauses)
5444 : {
5445 584 : unsigned n_lop_clauses = 0;
5446 :
5447 584 : if (clauses->gang)
5448 : {
5449 164 : ++n_lop_clauses;
5450 164 : ret = OACC_ROUTINE_LOP_GANG;
5451 : }
5452 584 : if (clauses->worker)
5453 : {
5454 114 : ++n_lop_clauses;
5455 114 : ret = OACC_ROUTINE_LOP_WORKER;
5456 : }
5457 584 : if (clauses->vector)
5458 : {
5459 116 : ++n_lop_clauses;
5460 116 : ret = OACC_ROUTINE_LOP_VECTOR;
5461 : }
5462 584 : if (clauses->seq)
5463 : {
5464 206 : ++n_lop_clauses;
5465 206 : ret = OACC_ROUTINE_LOP_SEQ;
5466 : }
5467 :
5468 584 : if (n_lop_clauses > 1)
5469 47 : ret = OACC_ROUTINE_LOP_ERROR;
5470 : }
5471 :
5472 734 : return ret;
5473 : }
5474 :
5475 : match
5476 698 : gfc_match_oacc_routine (void)
5477 : {
5478 698 : locus old_loc;
5479 698 : match m;
5480 698 : gfc_intrinsic_sym *isym = NULL;
5481 698 : gfc_symbol *sym = NULL;
5482 698 : gfc_omp_clauses *c = NULL;
5483 698 : gfc_oacc_routine_name *n = NULL;
5484 698 : oacc_routine_lop lop = OACC_ROUTINE_LOP_NONE;
5485 698 : bool nohost;
5486 :
5487 698 : old_loc = gfc_current_locus;
5488 :
5489 698 : m = gfc_match (" (");
5490 :
5491 698 : if (gfc_current_ns->proc_name
5492 696 : && gfc_current_ns->proc_name->attr.if_source == IFSRC_IFBODY
5493 90 : && m == MATCH_YES)
5494 : {
5495 3 : gfc_error ("Only the !$ACC ROUTINE form without "
5496 : "list is allowed in interface block at %C");
5497 3 : goto cleanup;
5498 : }
5499 :
5500 608 : if (m == MATCH_YES)
5501 : {
5502 295 : char buffer[GFC_MAX_SYMBOL_LEN + 1];
5503 :
5504 295 : m = gfc_match_name (buffer);
5505 295 : if (m == MATCH_YES)
5506 : {
5507 294 : gfc_symtree *st = NULL;
5508 :
5509 : /* First look for an intrinsic symbol. */
5510 294 : isym = gfc_find_function (buffer);
5511 294 : if (!isym)
5512 294 : isym = gfc_find_subroutine (buffer);
5513 : /* If no intrinsic symbol found, search the current namespace. */
5514 294 : if (!isym)
5515 276 : st = gfc_find_symtree (gfc_current_ns->sym_root, buffer);
5516 276 : if (st)
5517 : {
5518 270 : sym = st->n.sym;
5519 : /* If the name in a 'routine' directive refers to the containing
5520 : subroutine or function, then make sure that we'll later handle
5521 : this accordingly. */
5522 270 : if (gfc_current_ns->proc_name != NULL
5523 270 : && strcmp (sym->name, gfc_current_ns->proc_name->name) == 0)
5524 294 : sym = NULL;
5525 : }
5526 :
5527 294 : if (isym == NULL && st == NULL)
5528 : {
5529 6 : gfc_error ("Invalid NAME %qs in !$ACC ROUTINE ( NAME ) at %C",
5530 : buffer);
5531 6 : gfc_current_locus = old_loc;
5532 9 : return MATCH_ERROR;
5533 : }
5534 : }
5535 : else
5536 : {
5537 1 : gfc_error ("Syntax error in !$ACC ROUTINE ( NAME ) at %C");
5538 1 : gfc_current_locus = old_loc;
5539 1 : return MATCH_ERROR;
5540 : }
5541 :
5542 288 : if (gfc_match_char (')') != MATCH_YES)
5543 : {
5544 2 : gfc_error ("Syntax error in !$ACC ROUTINE ( NAME ) at %C, expecting"
5545 : " %<)%> after NAME");
5546 2 : gfc_current_locus = old_loc;
5547 2 : return MATCH_ERROR;
5548 : }
5549 : }
5550 :
5551 686 : if (gfc_match_omp_eos () != MATCH_YES
5552 686 : && (gfc_match_omp_clauses (&c, OACC_ROUTINE_CLAUSES, false, false, true)
5553 : != MATCH_YES))
5554 : return MATCH_ERROR;
5555 :
5556 683 : lop = gfc_oacc_routine_lop (c);
5557 683 : if (lop == OACC_ROUTINE_LOP_ERROR)
5558 : {
5559 47 : gfc_error ("Multiple loop axes specified for routine at %C");
5560 47 : goto cleanup;
5561 : }
5562 636 : nohost = c ? c->nohost : false;
5563 :
5564 636 : if (isym != NULL)
5565 : {
5566 : /* Diagnose any OpenACC 'routine' directive that doesn't match the
5567 : (implicit) one with a 'seq' clause. */
5568 16 : if (c && (c->gang || c->worker || c->vector))
5569 : {
5570 10 : gfc_error ("Intrinsic symbol specified in !$ACC ROUTINE ( NAME )"
5571 : " at %C marked with incompatible GANG, WORKER, or VECTOR"
5572 : " clause");
5573 10 : goto cleanup;
5574 : }
5575 : /* ..., and no 'nohost' clause. */
5576 6 : if (nohost)
5577 : {
5578 2 : gfc_error ("Intrinsic symbol specified in !$ACC ROUTINE ( NAME )"
5579 : " at %C marked with incompatible NOHOST clause");
5580 2 : goto cleanup;
5581 : }
5582 : }
5583 620 : else if (sym != NULL)
5584 : {
5585 151 : bool add = true;
5586 :
5587 : /* For a repeated OpenACC 'routine' directive, diagnose if it doesn't
5588 : match the first one. */
5589 151 : for (gfc_oacc_routine_name *n_p = gfc_current_ns->oacc_routine_names;
5590 346 : n_p;
5591 195 : n_p = n_p->next)
5592 235 : if (n_p->sym == sym)
5593 : {
5594 51 : add = false;
5595 51 : bool nohost_p = n_p->clauses ? n_p->clauses->nohost : false;
5596 51 : if (lop != gfc_oacc_routine_lop (n_p->clauses)
5597 51 : || nohost != nohost_p)
5598 : {
5599 40 : gfc_error ("!$ACC ROUTINE already applied at %C");
5600 40 : goto cleanup;
5601 : }
5602 : }
5603 :
5604 111 : if (add)
5605 : {
5606 100 : sym->attr.oacc_routine_lop = lop;
5607 100 : sym->attr.oacc_routine_nohost = nohost;
5608 :
5609 100 : n = gfc_get_oacc_routine_name ();
5610 100 : n->sym = sym;
5611 100 : n->clauses = c;
5612 100 : n->next = gfc_current_ns->oacc_routine_names;
5613 100 : n->loc = old_loc;
5614 100 : gfc_current_ns->oacc_routine_names = n;
5615 : }
5616 : }
5617 469 : else if (gfc_current_ns->proc_name)
5618 : {
5619 : /* For a repeated OpenACC 'routine' directive, diagnose if it doesn't
5620 : match the first one. */
5621 468 : oacc_routine_lop lop_p = gfc_current_ns->proc_name->attr.oacc_routine_lop;
5622 468 : bool nohost_p = gfc_current_ns->proc_name->attr.oacc_routine_nohost;
5623 468 : if (lop_p != OACC_ROUTINE_LOP_NONE
5624 86 : && (lop != lop_p
5625 86 : || nohost != nohost_p))
5626 : {
5627 56 : gfc_error ("!$ACC ROUTINE already applied at %C");
5628 56 : goto cleanup;
5629 : }
5630 :
5631 412 : if (!gfc_add_omp_declare_target (&gfc_current_ns->proc_name->attr,
5632 : gfc_current_ns->proc_name->name,
5633 : &old_loc))
5634 1 : goto cleanup;
5635 411 : gfc_current_ns->proc_name->attr.oacc_routine_lop = lop;
5636 411 : gfc_current_ns->proc_name->attr.oacc_routine_nohost = nohost;
5637 : }
5638 : else
5639 : /* Something has gone wrong, possibly a syntax error. */
5640 1 : goto cleanup;
5641 :
5642 526 : if (gfc_pure (NULL) && c && (c->gang || c->worker || c->vector))
5643 : {
5644 6 : gfc_error ("!$ACC ROUTINE with GANG, WORKER, or VECTOR clause is not "
5645 : "permitted in PURE procedure at %C");
5646 6 : goto cleanup;
5647 : }
5648 :
5649 :
5650 520 : if (n)
5651 100 : n->clauses = c;
5652 420 : else if (gfc_current_ns->oacc_routine)
5653 0 : gfc_current_ns->oacc_routine_clauses = c;
5654 :
5655 520 : new_st.op = EXEC_OACC_ROUTINE;
5656 520 : new_st.ext.omp_clauses = c;
5657 520 : return MATCH_YES;
5658 :
5659 166 : cleanup:
5660 166 : gfc_current_locus = old_loc;
5661 166 : return MATCH_ERROR;
5662 : }
5663 :
5664 :
5665 : #define OMP_PARALLEL_CLAUSES \
5666 : (omp_mask (OMP_CLAUSE_PRIVATE) | OMP_CLAUSE_FIRSTPRIVATE \
5667 : | OMP_CLAUSE_SHARED | OMP_CLAUSE_COPYIN | OMP_CLAUSE_REDUCTION \
5668 : | OMP_CLAUSE_IF | OMP_CLAUSE_NUM_THREADS | OMP_CLAUSE_DEFAULT \
5669 : | OMP_CLAUSE_PROC_BIND | OMP_CLAUSE_ALLOCATE | OMP_CLAUSE_MESSAGE \
5670 : | OMP_CLAUSE_SEVERITY)
5671 : #define OMP_DECLARE_SIMD_CLAUSES \
5672 : (omp_mask (OMP_CLAUSE_SIMDLEN) | OMP_CLAUSE_LINEAR \
5673 : | OMP_CLAUSE_UNIFORM | OMP_CLAUSE_ALIGNED | OMP_CLAUSE_INBRANCH \
5674 : | OMP_CLAUSE_NOTINBRANCH)
5675 : #define OMP_DO_CLAUSES \
5676 : (omp_mask (OMP_CLAUSE_PRIVATE) | OMP_CLAUSE_FIRSTPRIVATE \
5677 : | OMP_CLAUSE_LASTPRIVATE | OMP_CLAUSE_REDUCTION \
5678 : | OMP_CLAUSE_SCHEDULE | OMP_CLAUSE_ORDERED | OMP_CLAUSE_COLLAPSE \
5679 : | OMP_CLAUSE_LINEAR | OMP_CLAUSE_ORDER | OMP_CLAUSE_ALLOCATE \
5680 : | OMP_CLAUSE_NOWAIT)
5681 : #define OMP_LOOP_CLAUSES \
5682 : (omp_mask (OMP_CLAUSE_BIND) | OMP_CLAUSE_COLLAPSE | OMP_CLAUSE_ORDER \
5683 : | OMP_CLAUSE_PRIVATE | OMP_CLAUSE_LASTPRIVATE | OMP_CLAUSE_REDUCTION)
5684 :
5685 : #define OMP_SCOPE_CLAUSES \
5686 : (omp_mask (OMP_CLAUSE_PRIVATE) |OMP_CLAUSE_FIRSTPRIVATE \
5687 : | OMP_CLAUSE_REDUCTION | OMP_CLAUSE_ALLOCATE | OMP_CLAUSE_NOWAIT)
5688 : #define OMP_SECTIONS_CLAUSES \
5689 : (omp_mask (OMP_CLAUSE_PRIVATE) | OMP_CLAUSE_FIRSTPRIVATE \
5690 : | OMP_CLAUSE_LASTPRIVATE | OMP_CLAUSE_REDUCTION \
5691 : | OMP_CLAUSE_ALLOCATE | OMP_CLAUSE_NOWAIT)
5692 : #define OMP_SIMD_CLAUSES \
5693 : (omp_mask (OMP_CLAUSE_PRIVATE) | OMP_CLAUSE_LASTPRIVATE \
5694 : | OMP_CLAUSE_REDUCTION | OMP_CLAUSE_COLLAPSE | OMP_CLAUSE_SAFELEN \
5695 : | OMP_CLAUSE_LINEAR | OMP_CLAUSE_ALIGNED | OMP_CLAUSE_SIMDLEN \
5696 : | OMP_CLAUSE_IF | OMP_CLAUSE_ORDER | OMP_CLAUSE_NOTEMPORAL)
5697 : #define OMP_TASK_CLAUSES \
5698 : (omp_mask (OMP_CLAUSE_PRIVATE) | OMP_CLAUSE_FIRSTPRIVATE \
5699 : | OMP_CLAUSE_SHARED | OMP_CLAUSE_IF | OMP_CLAUSE_DEFAULT \
5700 : | OMP_CLAUSE_UNTIED | OMP_CLAUSE_FINAL | OMP_CLAUSE_MERGEABLE \
5701 : | OMP_CLAUSE_DEPEND | OMP_CLAUSE_PRIORITY | OMP_CLAUSE_IN_REDUCTION \
5702 : | OMP_CLAUSE_DETACH | OMP_CLAUSE_AFFINITY | OMP_CLAUSE_ALLOCATE)
5703 : #define OMP_TASKLOOP_CLAUSES \
5704 : (omp_mask (OMP_CLAUSE_PRIVATE) | OMP_CLAUSE_FIRSTPRIVATE \
5705 : | OMP_CLAUSE_LASTPRIVATE | OMP_CLAUSE_SHARED | OMP_CLAUSE_IF \
5706 : | OMP_CLAUSE_DEFAULT | OMP_CLAUSE_UNTIED | OMP_CLAUSE_FINAL \
5707 : | OMP_CLAUSE_MERGEABLE | OMP_CLAUSE_PRIORITY | OMP_CLAUSE_GRAINSIZE \
5708 : | OMP_CLAUSE_NUM_TASKS | OMP_CLAUSE_COLLAPSE | OMP_CLAUSE_NOGROUP \
5709 : | OMP_CLAUSE_REDUCTION | OMP_CLAUSE_IN_REDUCTION | OMP_CLAUSE_ALLOCATE)
5710 : #define OMP_TASKGROUP_CLAUSES \
5711 : (omp_mask (OMP_CLAUSE_TASK_REDUCTION) | OMP_CLAUSE_ALLOCATE)
5712 : #define OMP_TARGET_CLAUSES \
5713 : (omp_mask (OMP_CLAUSE_DEVICE) | OMP_CLAUSE_MAP | OMP_CLAUSE_IF \
5714 : | OMP_CLAUSE_DEPEND | OMP_CLAUSE_NOWAIT | OMP_CLAUSE_PRIVATE \
5715 : | OMP_CLAUSE_FIRSTPRIVATE | OMP_CLAUSE_DEFAULTMAP \
5716 : | OMP_CLAUSE_IS_DEVICE_PTR | OMP_CLAUSE_IN_REDUCTION \
5717 : | OMP_CLAUSE_THREAD_LIMIT | OMP_CLAUSE_ALLOCATE \
5718 : | OMP_CLAUSE_HAS_DEVICE_ADDR | OMP_CLAUSE_USES_ALLOCATORS \
5719 : | OMP_CLAUSE_DYN_GROUPPRIVATE | OMP_CLAUSE_DEVICE_TYPE \
5720 : | OMP_CLAUSE_MESSAGE | OMP_CLAUSE_SEVERITY)
5721 : #define OMP_TARGET_DATA_CLAUSES \
5722 : (omp_mask (OMP_CLAUSE_DEVICE) | OMP_CLAUSE_MAP | OMP_CLAUSE_IF \
5723 : | OMP_CLAUSE_USE_DEVICE_PTR | OMP_CLAUSE_USE_DEVICE_ADDR)
5724 : #define OMP_TARGET_ENTER_DATA_CLAUSES \
5725 : (omp_mask (OMP_CLAUSE_DEVICE) | OMP_CLAUSE_MAP | OMP_CLAUSE_IF \
5726 : | OMP_CLAUSE_DEPEND | OMP_CLAUSE_NOWAIT)
5727 : #define OMP_TARGET_EXIT_DATA_CLAUSES \
5728 : (omp_mask (OMP_CLAUSE_DEVICE) | OMP_CLAUSE_MAP | OMP_CLAUSE_IF \
5729 : | OMP_CLAUSE_DEPEND | OMP_CLAUSE_NOWAIT)
5730 : #define OMP_TARGET_UPDATE_CLAUSES \
5731 : (omp_mask (OMP_CLAUSE_DEVICE) | OMP_CLAUSE_IF | OMP_CLAUSE_TO \
5732 : | OMP_CLAUSE_FROM | OMP_CLAUSE_DEPEND | OMP_CLAUSE_NOWAIT)
5733 : #define OMP_TEAMS_CLAUSES \
5734 : (omp_mask (OMP_CLAUSE_NUM_TEAMS) | OMP_CLAUSE_THREAD_LIMIT \
5735 : | OMP_CLAUSE_DEFAULT | OMP_CLAUSE_PRIVATE | OMP_CLAUSE_FIRSTPRIVATE \
5736 : | OMP_CLAUSE_SHARED | OMP_CLAUSE_REDUCTION | OMP_CLAUSE_ALLOCATE \
5737 : | OMP_CLAUSE_MESSAGE | OMP_CLAUSE_SEVERITY)
5738 : #define OMP_DISTRIBUTE_CLAUSES \
5739 : (omp_mask (OMP_CLAUSE_PRIVATE) | OMP_CLAUSE_FIRSTPRIVATE \
5740 : | OMP_CLAUSE_LASTPRIVATE | OMP_CLAUSE_COLLAPSE | OMP_CLAUSE_DIST_SCHEDULE \
5741 : | OMP_CLAUSE_ORDER | OMP_CLAUSE_ALLOCATE)
5742 : #define OMP_SINGLE_CLAUSES \
5743 : (omp_mask (OMP_CLAUSE_PRIVATE) | OMP_CLAUSE_FIRSTPRIVATE \
5744 : | OMP_CLAUSE_ALLOCATE | OMP_CLAUSE_NOWAIT | OMP_CLAUSE_COPYPRIVATE)
5745 : #define OMP_ORDERED_CLAUSES \
5746 : (omp_mask (OMP_CLAUSE_THREADS) | OMP_CLAUSE_SIMD)
5747 : #define OMP_DECLARE_TARGET_CLAUSES \
5748 : (omp_mask (OMP_CLAUSE_ENTER) | OMP_CLAUSE_LINK | OMP_CLAUSE_DEVICE_TYPE \
5749 : | OMP_CLAUSE_TO | OMP_CLAUSE_INDIRECT | OMP_CLAUSE_LOCAL)
5750 : #define OMP_ATOMIC_CLAUSES \
5751 : (omp_mask (OMP_CLAUSE_ATOMIC) | OMP_CLAUSE_CAPTURE | OMP_CLAUSE_HINT \
5752 : | OMP_CLAUSE_MEMORDER | OMP_CLAUSE_COMPARE | OMP_CLAUSE_FAIL \
5753 : | OMP_CLAUSE_WEAK)
5754 : #define OMP_MASKED_CLAUSES \
5755 : (omp_mask (OMP_CLAUSE_FILTER))
5756 : #define OMP_ERROR_CLAUSES \
5757 : (omp_mask (OMP_CLAUSE_AT) | OMP_CLAUSE_MESSAGE | OMP_CLAUSE_SEVERITY)
5758 : #define OMP_WORKSHARE_CLAUSES \
5759 : omp_mask (OMP_CLAUSE_NOWAIT)
5760 : #define OMP_UNROLL_CLAUSES \
5761 : (omp_mask (OMP_CLAUSE_FULL) | OMP_CLAUSE_PARTIAL)
5762 : #define OMP_TILE_CLAUSES \
5763 : (omp_mask (OMP_CLAUSE_SIZES))
5764 : #define OMP_ALLOCATORS_CLAUSES \
5765 : omp_mask (OMP_CLAUSE_ALLOCATE)
5766 : #define OMP_INTEROP_CLAUSES \
5767 : (omp_mask (OMP_CLAUSE_DEPEND) | OMP_CLAUSE_NOWAIT | OMP_CLAUSE_DEVICE \
5768 : | OMP_CLAUSE_INIT | OMP_CLAUSE_DESTROY | OMP_CLAUSE_USE)
5769 : #define OMP_DISPATCH_CLAUSES \
5770 : (omp_mask (OMP_CLAUSE_DEVICE) | OMP_CLAUSE_DEPEND | OMP_CLAUSE_NOVARIANTS \
5771 : | OMP_CLAUSE_NOCONTEXT | OMP_CLAUSE_IS_DEVICE_PTR | OMP_CLAUSE_NOWAIT \
5772 : | OMP_CLAUSE_HAS_DEVICE_ADDR | OMP_CLAUSE_INTEROP)
5773 :
5774 :
5775 : static match
5776 17356 : match_omp (gfc_exec_op op, const omp_mask mask)
5777 : {
5778 17356 : gfc_omp_clauses *c;
5779 17356 : if (gfc_match_omp_clauses (&c, mask, true, true, false,
5780 : op == EXEC_OMP_TARGET) != MATCH_YES)
5781 : return MATCH_ERROR;
5782 17018 : new_st.op = op;
5783 17018 : new_st.ext.omp_clauses = c;
5784 17018 : return MATCH_YES;
5785 : }
5786 :
5787 : /* Handles both declarative and (deprecated) executable ALLOCATE directive;
5788 : accepts optional list (for executable) and common blocks.
5789 : If no variables have been provided, the single omp namelist has sym == NULL.
5790 :
5791 : Note that the executable ALLOCATE directive permits structure elements only
5792 : in OpenMP 5.0 and 5.1 but not longer in 5.2. See also the comment on the
5793 : 'omp allocators' directive below. The accidental change was reverted for
5794 : OpenMP TR12, permitting them again. See also gfc_match_omp_allocators.
5795 :
5796 : Hence, structure elements are rejected for now, also to make resolving
5797 : OMP_LIST_ALLOCATE simpler (check for duplicates, same symbol in
5798 : Fortran allocate stmt). TODO: Permit structure elements. */
5799 :
5800 : match
5801 274 : gfc_match_omp_allocate (void)
5802 : {
5803 274 : match m;
5804 274 : bool first = true;
5805 274 : gfc_omp_namelist *vars = NULL;
5806 274 : gfc_expr *align = NULL;
5807 274 : gfc_expr *allocator = NULL;
5808 274 : locus loc = gfc_current_locus;
5809 :
5810 274 : m = gfc_match_omp_variable_list (" (", &vars, true, NULL, NULL, true, true,
5811 : NULL, true);
5812 :
5813 274 : if (m == MATCH_ERROR)
5814 : return m;
5815 :
5816 502 : while (true)
5817 : {
5818 502 : gfc_gobble_whitespace ();
5819 502 : if (gfc_match_omp_eos () == MATCH_YES)
5820 : break;
5821 234 : if (!first)
5822 28 : gfc_match (", ");
5823 234 : first = false;
5824 234 : if ((m = gfc_match_dupl_check (!align, "align", true, &align))
5825 : != MATCH_NO)
5826 : {
5827 62 : if (m == MATCH_ERROR)
5828 1 : goto error;
5829 61 : continue;
5830 : }
5831 172 : if ((m = gfc_match_dupl_check (!allocator, "allocator",
5832 : true, &allocator)) != MATCH_NO)
5833 : {
5834 171 : if (m == MATCH_ERROR)
5835 1 : goto error;
5836 170 : continue;
5837 : }
5838 1 : gfc_error ("Expected ALIGN or ALLOCATOR clause at %C");
5839 1 : return MATCH_ERROR;
5840 : }
5841 541 : for (gfc_omp_namelist *n = vars; n; n = n->next)
5842 276 : if (n->expr)
5843 : {
5844 3 : if ((n->expr->ref && n->expr->ref->type == REF_COMPONENT)
5845 3 : || (n->expr->ref->next && n->expr->ref->type == REF_COMPONENT))
5846 1 : gfc_error ("Sorry, structure-element list item at %L in ALLOCATE "
5847 : "directive is not yet supported", &n->expr->where);
5848 : else
5849 2 : gfc_error ("Unexpected expression as list item at %L in ALLOCATE "
5850 : "directive", &n->expr->where);
5851 :
5852 3 : gfc_free_omp_namelist (vars, OMP_LIST_ALLOCATE);
5853 3 : goto error;
5854 : }
5855 :
5856 265 : new_st.op = EXEC_OMP_ALLOCATE;
5857 265 : new_st.ext.omp_clauses = gfc_get_omp_clauses ();
5858 265 : if (vars == NULL)
5859 : {
5860 27 : vars = gfc_get_omp_namelist ();
5861 27 : vars->where = loc;
5862 27 : vars->u.align = align;
5863 27 : vars->u2.allocator = allocator;
5864 27 : new_st.ext.omp_clauses->lists[OMP_LIST_ALLOCATE] = vars;
5865 : }
5866 : else
5867 : {
5868 238 : new_st.ext.omp_clauses->lists[OMP_LIST_ALLOCATE] = vars;
5869 511 : for (; vars; vars = vars->next)
5870 : {
5871 273 : vars->u.align = (align) ? gfc_copy_expr (align) : NULL;
5872 273 : vars->u2.allocator = allocator;
5873 : }
5874 238 : gfc_free_expr (align);
5875 : }
5876 : return MATCH_YES;
5877 :
5878 5 : error:
5879 5 : gfc_free_expr (align);
5880 5 : gfc_free_expr (allocator);
5881 5 : return MATCH_ERROR;
5882 : }
5883 :
5884 : /* In line with OpenMP 5.2 derived-type components are rejected.
5885 : See also comment before gfc_match_omp_allocate. */
5886 :
5887 : match
5888 26 : gfc_match_omp_allocators (void)
5889 : {
5890 26 : return match_omp (EXEC_OMP_ALLOCATORS, OMP_ALLOCATORS_CLAUSES);
5891 : }
5892 :
5893 :
5894 : match
5895 23 : gfc_match_omp_assume (void)
5896 : {
5897 23 : gfc_omp_clauses *c;
5898 23 : locus loc = gfc_current_locus;
5899 30 : if ((gfc_match_omp_clauses (&c, omp_mask (OMP_CLAUSE_ASSUMPTIONS))
5900 : != MATCH_YES)
5901 23 : || (omp_verify_merge_absent_contains (ST_OMP_ASSUME, c->assume, NULL,
5902 : &loc) != MATCH_YES))
5903 : return MATCH_ERROR;
5904 16 : new_st.op = EXEC_OMP_ASSUME;
5905 16 : new_st.ext.omp_clauses = c;
5906 16 : return MATCH_YES;
5907 : }
5908 :
5909 :
5910 : match
5911 34 : gfc_match_omp_assumes (void)
5912 : {
5913 34 : gfc_omp_clauses *c;
5914 34 : locus loc = gfc_current_locus;
5915 34 : if (!gfc_current_ns->proc_name
5916 33 : || (gfc_current_ns->proc_name->attr.flavor != FL_MODULE
5917 23 : && !gfc_current_ns->proc_name->attr.subroutine
5918 10 : && !gfc_current_ns->proc_name->attr.function))
5919 : {
5920 2 : gfc_error ("!$OMP ASSUMES at %C must be in the specification part of a "
5921 : "subprogram or module");
5922 2 : return MATCH_ERROR;
5923 : }
5924 42 : if ((gfc_match_omp_clauses (&c, omp_mask (OMP_CLAUSE_ASSUMPTIONS))
5925 : != MATCH_YES)
5926 57 : || (omp_verify_merge_absent_contains (ST_OMP_ASSUMES, c->assume,
5927 25 : gfc_current_ns->omp_assumes, &loc)
5928 : != MATCH_YES))
5929 : return MATCH_ERROR;
5930 22 : if (gfc_current_ns->omp_assumes == NULL)
5931 : {
5932 20 : gfc_current_ns->omp_assumes = c->assume;
5933 20 : c->assume = NULL;
5934 : }
5935 2 : else if (gfc_current_ns->omp_assumes && c->assume)
5936 : {
5937 2 : gfc_current_ns->omp_assumes->no_openmp |= c->assume->no_openmp;
5938 2 : gfc_current_ns->omp_assumes->no_openmp_routines
5939 2 : |= c->assume->no_openmp_routines;
5940 2 : gfc_current_ns->omp_assumes->no_openmp_constructs
5941 2 : |= c->assume->no_openmp_constructs;
5942 2 : gfc_current_ns->omp_assumes->no_parallelism |= c->assume->no_parallelism;
5943 2 : if (gfc_current_ns->omp_assumes->holds && c->assume->holds)
5944 : {
5945 : gfc_expr_list *el = gfc_current_ns->omp_assumes->holds;
5946 1 : for ( ; el->next ; el = el->next)
5947 : ;
5948 1 : el->next = c->assume->holds;
5949 1 : }
5950 1 : else if (c->assume->holds)
5951 0 : gfc_current_ns->omp_assumes->holds = c->assume->holds;
5952 2 : c->assume->holds = NULL;
5953 : }
5954 22 : gfc_free_omp_clauses (c);
5955 22 : return MATCH_YES;
5956 : }
5957 :
5958 :
5959 : match
5960 163 : gfc_match_omp_critical (void)
5961 : {
5962 163 : char n[GFC_MAX_SYMBOL_LEN+1];
5963 163 : gfc_omp_clauses *c = NULL;
5964 :
5965 163 : if (gfc_match (" ( %n )", n) != MATCH_YES)
5966 115 : n[0] = '\0';
5967 :
5968 163 : if (gfc_match_omp_clauses (&c, omp_mask (OMP_CLAUSE_HINT),
5969 163 : /* first = */ n[0] == '\0') != MATCH_YES)
5970 : return MATCH_ERROR;
5971 :
5972 161 : new_st.op = EXEC_OMP_CRITICAL;
5973 161 : new_st.ext.omp_clauses = c;
5974 161 : if (n[0])
5975 48 : c->critical_name = xstrdup (n);
5976 : return MATCH_YES;
5977 : }
5978 :
5979 :
5980 : match
5981 161 : gfc_match_omp_end_critical (void)
5982 : {
5983 161 : char n[GFC_MAX_SYMBOL_LEN+1];
5984 :
5985 161 : if (gfc_match (" ( %n )", n) != MATCH_YES)
5986 113 : n[0] = '\0';
5987 161 : if (gfc_match_omp_eos () != MATCH_YES)
5988 : {
5989 1 : gfc_error ("Unexpected junk after $OMP CRITICAL statement at %C");
5990 1 : return MATCH_ERROR;
5991 : }
5992 :
5993 160 : new_st.op = EXEC_OMP_END_CRITICAL;
5994 160 : new_st.ext.omp_name = n[0] ? xstrdup (n) : NULL;
5995 160 : return MATCH_YES;
5996 : }
5997 :
5998 : /* depobj(depobj) depend(dep-type:loc)|destroy|update(dep-type)
5999 : dep-type = in/out/inout/mutexinoutset/depobj/source/sink
6000 : depend: !source, !sink
6001 : update: !source, !sink, !depobj
6002 : locator = exactly one list item .*/
6003 : match
6004 125 : gfc_match_omp_depobj (void)
6005 : {
6006 125 : gfc_omp_clauses *c = NULL;
6007 125 : gfc_expr *depobj;
6008 :
6009 125 : if (gfc_match (" ( %v ) ", &depobj) != MATCH_YES)
6010 : {
6011 2 : gfc_error ("Expected %<( depobj )%> at %C");
6012 2 : return MATCH_ERROR;
6013 : }
6014 123 : if (gfc_match ("update ( ") == MATCH_YES)
6015 : {
6016 12 : c = gfc_get_omp_clauses ();
6017 12 : if (gfc_match ("inoutset )") == MATCH_YES)
6018 2 : c->depobj_update = OMP_DEPEND_INOUTSET;
6019 10 : else if (gfc_match ("inout )") == MATCH_YES)
6020 1 : c->depobj_update = OMP_DEPEND_INOUT;
6021 9 : else if (gfc_match ("in )") == MATCH_YES)
6022 2 : c->depobj_update = OMP_DEPEND_IN;
6023 7 : else if (gfc_match ("out )") == MATCH_YES)
6024 2 : c->depobj_update = OMP_DEPEND_OUT;
6025 5 : else if (gfc_match ("mutexinoutset )") == MATCH_YES)
6026 2 : c->depobj_update = OMP_DEPEND_MUTEXINOUTSET;
6027 : else
6028 : {
6029 3 : gfc_error ("Expected IN, OUT, INOUT, INOUTSET or MUTEXINOUTSET "
6030 : "followed by %<)%> at %C");
6031 3 : goto error;
6032 : }
6033 : }
6034 111 : else if (gfc_match ("destroy ") == MATCH_YES)
6035 : {
6036 16 : gfc_expr *destroyobj = NULL;
6037 16 : c = gfc_get_omp_clauses ();
6038 16 : c->destroy = true;
6039 :
6040 16 : if (gfc_match (" ( %v ) ", &destroyobj) == MATCH_YES)
6041 : {
6042 3 : if (destroyobj->symtree != depobj->symtree)
6043 2 : gfc_warning (OPT_Wopenmp, "The same depend object should be used as"
6044 : " DEPOBJ argument at %L and as DESTROY argument at %L",
6045 : &depobj->where, &destroyobj->where);
6046 3 : gfc_free_expr (destroyobj);
6047 : }
6048 : }
6049 95 : else if (gfc_match_omp_clauses (&c, omp_mask (OMP_CLAUSE_DEPEND), true, false)
6050 : != MATCH_YES)
6051 2 : goto error;
6052 :
6053 118 : if (c->depobj_update == OMP_DEPEND_UNSET && !c->destroy)
6054 : {
6055 93 : if (!c->doacross_source && !c->lists[OMP_LIST_DEPEND])
6056 : {
6057 1 : gfc_error ("Expected DEPEND, UPDATE, or DESTROY clause at %C");
6058 1 : goto error;
6059 : }
6060 92 : if (c->lists[OMP_LIST_DEPEND]->u.depend_doacross_op == OMP_DEPEND_DEPOBJ)
6061 : {
6062 1 : gfc_error ("DEPEND clause at %L of OMP DEPOBJ construct shall not "
6063 : "have dependence-type DEPOBJ",
6064 : c->lists[OMP_LIST_DEPEND]
6065 : ? &c->lists[OMP_LIST_DEPEND]->where : &gfc_current_locus);
6066 1 : goto error;
6067 : }
6068 91 : if (c->lists[OMP_LIST_DEPEND]->next)
6069 : {
6070 1 : gfc_error ("DEPEND clause at %L of OMP DEPOBJ construct shall have "
6071 : "only a single locator",
6072 : &c->lists[OMP_LIST_DEPEND]->next->where);
6073 1 : goto error;
6074 : }
6075 : }
6076 :
6077 115 : c->depobj = depobj;
6078 115 : new_st.op = EXEC_OMP_DEPOBJ;
6079 115 : new_st.ext.omp_clauses = c;
6080 115 : return MATCH_YES;
6081 :
6082 8 : error:
6083 8 : gfc_free_expr (depobj);
6084 8 : gfc_free_omp_clauses (c);
6085 8 : return MATCH_ERROR;
6086 : }
6087 :
6088 : match
6089 160 : gfc_match_omp_dispatch (void)
6090 : {
6091 160 : return match_omp (EXEC_OMP_DISPATCH, OMP_DISPATCH_CLAUSES);
6092 : }
6093 :
6094 : match
6095 57 : gfc_match_omp_distribute (void)
6096 : {
6097 57 : return match_omp (EXEC_OMP_DISTRIBUTE, OMP_DISTRIBUTE_CLAUSES);
6098 : }
6099 :
6100 :
6101 : match
6102 44 : gfc_match_omp_distribute_parallel_do (void)
6103 : {
6104 44 : return match_omp (EXEC_OMP_DISTRIBUTE_PARALLEL_DO,
6105 44 : (OMP_DISTRIBUTE_CLAUSES | OMP_PARALLEL_CLAUSES
6106 44 : | OMP_DO_CLAUSES)
6107 44 : & ~(omp_mask (OMP_CLAUSE_ORDERED)
6108 44 : | OMP_CLAUSE_LINEAR | OMP_CLAUSE_NOWAIT));
6109 : }
6110 :
6111 :
6112 : match
6113 34 : gfc_match_omp_distribute_parallel_do_simd (void)
6114 : {
6115 34 : return match_omp (EXEC_OMP_DISTRIBUTE_PARALLEL_DO_SIMD,
6116 34 : (OMP_DISTRIBUTE_CLAUSES | OMP_PARALLEL_CLAUSES
6117 34 : | OMP_DO_CLAUSES | OMP_SIMD_CLAUSES)
6118 34 : & ~(omp_mask (OMP_CLAUSE_ORDERED) | OMP_CLAUSE_NOWAIT));
6119 : }
6120 :
6121 :
6122 : match
6123 52 : gfc_match_omp_distribute_simd (void)
6124 : {
6125 52 : return match_omp (EXEC_OMP_DISTRIBUTE_SIMD,
6126 52 : OMP_DISTRIBUTE_CLAUSES | OMP_SIMD_CLAUSES);
6127 : }
6128 :
6129 :
6130 : match
6131 1253 : gfc_match_omp_do (void)
6132 : {
6133 1253 : return match_omp (EXEC_OMP_DO, OMP_DO_CLAUSES);
6134 : }
6135 :
6136 :
6137 : match
6138 137 : gfc_match_omp_do_simd (void)
6139 : {
6140 137 : return match_omp (EXEC_OMP_DO_SIMD, OMP_DO_CLAUSES | OMP_SIMD_CLAUSES);
6141 : }
6142 :
6143 :
6144 : match
6145 70 : gfc_match_omp_loop (void)
6146 : {
6147 70 : return match_omp (EXEC_OMP_LOOP, OMP_LOOP_CLAUSES);
6148 : }
6149 :
6150 :
6151 : match
6152 35 : gfc_match_omp_teams_loop (void)
6153 : {
6154 35 : return match_omp (EXEC_OMP_TEAMS_LOOP, OMP_TEAMS_CLAUSES | OMP_LOOP_CLAUSES);
6155 : }
6156 :
6157 :
6158 : match
6159 18 : gfc_match_omp_target_teams_loop (void)
6160 : {
6161 18 : return match_omp (EXEC_OMP_TARGET_TEAMS_LOOP,
6162 18 : OMP_TARGET_CLAUSES | OMP_TEAMS_CLAUSES | OMP_LOOP_CLAUSES);
6163 : }
6164 :
6165 :
6166 : match
6167 31 : gfc_match_omp_parallel_loop (void)
6168 : {
6169 31 : return match_omp (EXEC_OMP_PARALLEL_LOOP,
6170 31 : OMP_PARALLEL_CLAUSES | OMP_LOOP_CLAUSES);
6171 : }
6172 :
6173 :
6174 : match
6175 16 : gfc_match_omp_target_parallel_loop (void)
6176 : {
6177 16 : return match_omp (EXEC_OMP_TARGET_PARALLEL_LOOP,
6178 16 : (OMP_TARGET_CLAUSES | OMP_PARALLEL_CLAUSES
6179 16 : | OMP_LOOP_CLAUSES));
6180 : }
6181 :
6182 :
6183 : match
6184 101 : gfc_match_omp_error (void)
6185 : {
6186 101 : locus loc = gfc_current_locus;
6187 101 : match m = match_omp (EXEC_OMP_ERROR, OMP_ERROR_CLAUSES);
6188 101 : if (m != MATCH_YES)
6189 : return m;
6190 :
6191 82 : gfc_omp_clauses *c = new_st.ext.omp_clauses;
6192 82 : if (c->severity == OMP_SEVERITY_UNSET)
6193 45 : c->severity = OMP_SEVERITY_FATAL;
6194 82 : if (new_st.ext.omp_clauses->at == OMP_AT_EXECUTION)
6195 : return MATCH_YES;
6196 37 : if (c->message
6197 37 : && (!gfc_resolve_expr (c->message)
6198 16 : || c->message->ts.type != BT_CHARACTER
6199 14 : || c->message->ts.kind != gfc_default_character_kind
6200 13 : || c->message->rank != 0))
6201 : {
6202 4 : gfc_error ("MESSAGE clause at %L requires a scalar default-kind "
6203 : "CHARACTER expression",
6204 4 : &new_st.ext.omp_clauses->message->where);
6205 4 : return MATCH_ERROR;
6206 : }
6207 33 : if (c->message && !gfc_is_constant_expr (c->message))
6208 : {
6209 2 : gfc_error ("Constant character expression required in MESSAGE clause "
6210 2 : "at %L", &new_st.ext.omp_clauses->message->where);
6211 2 : return MATCH_ERROR;
6212 : }
6213 31 : if (c->message)
6214 : {
6215 10 : const char *msg = G_("$OMP ERROR encountered at %L: %s");
6216 10 : gcc_assert (c->message->expr_type == EXPR_CONSTANT);
6217 10 : gfc_charlen_t slen = c->message->value.character.length;
6218 10 : int i = gfc_validate_kind (BT_CHARACTER, gfc_default_character_kind,
6219 : false);
6220 10 : size_t size = slen * gfc_character_kinds[i].bit_size / 8;
6221 10 : unsigned char *s = XCNEWVAR (unsigned char, size + 1);
6222 10 : gfc_encode_character (gfc_default_character_kind, slen,
6223 10 : c->message->value.character.string,
6224 : (unsigned char *) s, size);
6225 10 : s[size] = '\0';
6226 10 : if (c->severity == OMP_SEVERITY_WARNING)
6227 6 : gfc_warning_now (0, msg, &loc, s);
6228 : else
6229 4 : gfc_error_now (msg, &loc, s);
6230 10 : free (s);
6231 : }
6232 : else
6233 : {
6234 21 : const char *msg = G_("$OMP ERROR encountered at %L");
6235 21 : if (c->severity == OMP_SEVERITY_WARNING)
6236 7 : gfc_warning_now (0, msg, &loc);
6237 : else
6238 14 : gfc_error_now (msg, &loc);
6239 : }
6240 : return MATCH_YES;
6241 : }
6242 :
6243 : match
6244 86 : gfc_match_omp_flush (void)
6245 : {
6246 86 : gfc_omp_namelist *list = NULL;
6247 86 : gfc_omp_clauses *c = NULL;
6248 86 : gfc_gobble_whitespace ();
6249 86 : enum gfc_omp_memorder mo = OMP_MEMORDER_UNSET;
6250 86 : if (gfc_match_omp_eos () == MATCH_NO && gfc_peek_ascii_char () != '(')
6251 : {
6252 14 : if (gfc_match ("seq_cst") == MATCH_YES)
6253 : mo = OMP_MEMORDER_SEQ_CST;
6254 11 : else if (gfc_match ("acq_rel") == MATCH_YES)
6255 : mo = OMP_MEMORDER_ACQ_REL;
6256 8 : else if (gfc_match ("release") == MATCH_YES)
6257 : mo = OMP_MEMORDER_RELEASE;
6258 5 : else if (gfc_match ("acquire") == MATCH_YES)
6259 : mo = OMP_MEMORDER_ACQUIRE;
6260 : else
6261 : {
6262 2 : gfc_error ("Expected SEQ_CST, AQC_REL, RELEASE, or ACQUIRE at %C");
6263 2 : return MATCH_ERROR;
6264 : }
6265 12 : c = gfc_get_omp_clauses ();
6266 12 : c->memorder = mo;
6267 : }
6268 84 : gfc_match_omp_variable_list (" (", &list, true);
6269 84 : if (list && mo != OMP_MEMORDER_UNSET)
6270 : {
6271 4 : gfc_error ("List specified together with memory order clause in FLUSH "
6272 : "directive at %C");
6273 4 : gfc_free_omp_namelist (list, OMP_LIST_NONE);
6274 4 : gfc_free_omp_clauses (c);
6275 4 : return MATCH_ERROR;
6276 : }
6277 80 : if (gfc_match_omp_eos () != MATCH_YES)
6278 : {
6279 0 : gfc_error ("Unexpected junk after $OMP FLUSH statement at %C");
6280 0 : gfc_free_omp_namelist (list, OMP_LIST_NONE);
6281 0 : gfc_free_omp_clauses (c);
6282 0 : return MATCH_ERROR;
6283 : }
6284 80 : new_st.op = EXEC_OMP_FLUSH;
6285 80 : new_st.ext.omp_namelist = list;
6286 80 : new_st.ext.omp_clauses = c;
6287 80 : return MATCH_YES;
6288 : }
6289 :
6290 :
6291 : match
6292 189 : gfc_match_omp_declare_simd (void)
6293 : {
6294 189 : locus where = gfc_current_locus;
6295 189 : gfc_symbol *proc_name;
6296 189 : gfc_omp_clauses *c;
6297 189 : gfc_omp_declare_simd *ods;
6298 189 : bool needs_space = false;
6299 :
6300 189 : switch (gfc_match (" ( "))
6301 : {
6302 145 : case MATCH_YES:
6303 145 : if (gfc_match_symbol (&proc_name, /* host assoc = */ true) != MATCH_YES
6304 145 : || gfc_match (" ) ") != MATCH_YES)
6305 : return MATCH_ERROR;
6306 : break;
6307 44 : case MATCH_NO: proc_name = NULL; needs_space = true; break;
6308 : case MATCH_ERROR: return MATCH_ERROR;
6309 : }
6310 :
6311 189 : if (gfc_match_omp_clauses (&c, OMP_DECLARE_SIMD_CLAUSES, true,
6312 : needs_space) != MATCH_YES)
6313 : return MATCH_ERROR;
6314 :
6315 184 : if (gfc_current_ns->is_block_data)
6316 : {
6317 1 : gfc_free_omp_clauses (c);
6318 1 : return MATCH_YES;
6319 : }
6320 :
6321 183 : ods = gfc_get_omp_declare_simd ();
6322 183 : ods->where = where;
6323 183 : ods->proc_name = proc_name;
6324 183 : ods->clauses = c;
6325 183 : ods->next = gfc_current_ns->omp_declare_simd;
6326 183 : gfc_current_ns->omp_declare_simd = ods;
6327 183 : return MATCH_YES;
6328 : }
6329 :
6330 :
6331 : /* Find a matching "!$omp declare mapper" for typespec TS in symtree ST. */
6332 :
6333 : gfc_omp_udm *
6334 31 : gfc_omp_udm_find (gfc_symtree *st, gfc_typespec *ts)
6335 : {
6336 31 : gfc_omp_udm *omp_udm;
6337 :
6338 31 : if (st == NULL)
6339 : return NULL;
6340 :
6341 14 : gfc_symbol *dt = (ts->type == BT_CLASS
6342 0 : ? CLASS_DATA (ts->u.derived)->ts.u.derived
6343 : : ts->u.derived);
6344 15 : for (omp_udm = st->n.omp_udm; omp_udm; omp_udm = omp_udm->next)
6345 : {
6346 5 : if (dt == omp_udm->ts.u.derived)
6347 : return omp_udm;
6348 : /* Special case for comparing derived types across namespaces. If the
6349 : true names and module names are the same and the module name is
6350 : nonnull, then they are equal. */
6351 1 : if (dt->module && omp_udm->ts.u.derived->module
6352 1 : && strcmp (dt->name, omp_udm->ts.u.derived->name) == 0
6353 1 : && strcmp (dt->module, omp_udm->ts.u.derived->module) == 0)
6354 : return omp_udm;
6355 : }
6356 :
6357 : return NULL;
6358 : }
6359 :
6360 :
6361 : /* Match !$omp declare mapper([ mapper-identifier : ] type :: var) clauses-list */
6362 :
6363 : match
6364 29 : gfc_match_omp_declare_mapper (void)
6365 : {
6366 29 : match m;
6367 29 : gfc_typespec ts;
6368 29 : char mapper_id[GFC_MAX_SYMBOL_LEN + 1];
6369 29 : char var[GFC_MAX_SYMBOL_LEN + 1];
6370 29 : gfc_namespace *mapper_ns = NULL;
6371 29 : gfc_symtree *var_st;
6372 29 : gfc_symtree *st;
6373 29 : gfc_omp_udm *omp_udm = NULL, *prev_udm = NULL;
6374 29 : locus where = gfc_current_locus;
6375 :
6376 29 : if (gfc_match_char ('(') != MATCH_YES)
6377 : {
6378 1 : gfc_error ("Expected %<(%> at %C");
6379 1 : return MATCH_ERROR;
6380 : }
6381 :
6382 28 : locus old_locus = gfc_current_locus;
6383 :
6384 28 : m = gfc_match (" %n : ", mapper_id);
6385 :
6386 28 : if (m == MATCH_ERROR)
6387 : return MATCH_ERROR;
6388 :
6389 : /* As a special case, a mapper named "default" and an unnamed mapper are
6390 : both the default mapper for a given type. */
6391 28 : if (strcmp (mapper_id, "default") == 0)
6392 0 : mapper_id[0] = '\0';
6393 :
6394 28 : if (gfc_peek_ascii_char () == ':')
6395 : {
6396 : /* If we see '::', the user did not name the mapper, and instead we just
6397 : saw the type. So backtrack and try parsing as a type instead. */
6398 14 : mapper_id[0] = '\0';
6399 14 : gfc_current_locus = old_locus;
6400 : }
6401 28 : old_locus = gfc_current_locus;
6402 :
6403 28 : m = gfc_match_type_spec (&ts);
6404 28 : if (m != MATCH_YES)
6405 : {
6406 4 : gfc_error ("Expected either a type name at %L or a map-type "
6407 : "identifier, a colon, or a type name", &old_locus);
6408 4 : return MATCH_ERROR;
6409 : }
6410 :
6411 24 : if (ts.type != BT_DERIVED)
6412 : {
6413 1 : gfc_error ("!$OMP DECLARE MAPPER with non-derived type at %L", &old_locus);
6414 1 : return MATCH_ERROR;
6415 : }
6416 :
6417 23 : if (gfc_match (" :: ") != MATCH_YES)
6418 : {
6419 0 : gfc_error ("Expected %<::%> at %C");
6420 0 : return MATCH_ERROR;
6421 : }
6422 :
6423 23 : if (gfc_match_name (var) != MATCH_YES)
6424 : {
6425 1 : gfc_error ("Expected variable name at %C");
6426 1 : return MATCH_ERROR;
6427 : }
6428 :
6429 22 : if (gfc_match_char (')') != MATCH_YES)
6430 : {
6431 2 : gfc_error ("Expected %<)%> at %C");
6432 2 : return MATCH_ERROR;
6433 : }
6434 :
6435 20 : st = gfc_find_symtree (gfc_current_ns->omp_udm_root, mapper_id);
6436 :
6437 : /* Now we need to set up a new namespace, and create a new sym_tree for our
6438 : dummy variable so we can use it in the following list of mapping
6439 : clauses. */
6440 :
6441 20 : gfc_current_ns = mapper_ns = gfc_get_namespace (gfc_current_ns, 1);
6442 20 : mapper_ns->proc_name = mapper_ns->parent->proc_name;
6443 20 : mapper_ns->omp_udm_ns = 1;
6444 :
6445 20 : gfc_get_sym_tree (var, mapper_ns, &var_st, false);
6446 20 : var_st->n.sym->ts = ts;
6447 20 : var_st->n.sym->attr.omp_udm_artificial_var = 1;
6448 20 : var_st->n.sym->attr.flavor = FL_VARIABLE;
6449 20 : gfc_commit_symbols ();
6450 :
6451 20 : gfc_omp_clauses *clauses = NULL;
6452 :
6453 20 : m = gfc_match_omp_clauses (&clauses, omp_mask (OMP_CLAUSE_MAP), true, true,
6454 : false, false, OMP_MAP_UNSET);
6455 20 : if (m != MATCH_YES)
6456 1 : goto failure;
6457 :
6458 19 : omp_udm = gfc_get_omp_udm ();
6459 19 : omp_udm->next = NULL;
6460 19 : omp_udm->where = where;
6461 19 : omp_udm->mapper_id = gfc_get_string ("%s", mapper_id);
6462 19 : omp_udm->ts = ts;
6463 19 : omp_udm->var_sym = var_st->n.sym;
6464 19 : omp_udm->mapper_ns = mapper_ns;
6465 19 : omp_udm->clauses = clauses;
6466 :
6467 19 : gfc_current_ns = mapper_ns->parent;
6468 :
6469 19 : prev_udm = gfc_omp_udm_find (st, &ts);
6470 19 : if (prev_udm)
6471 : {
6472 2 : if (mapper_id[0])
6473 1 : gfc_error ("Redefinition of !$OMP DECLARE MAPPER at %L for type %qs with id %qs",
6474 : &where, gfc_typename (&ts), mapper_id);
6475 : else
6476 1 : gfc_error ("Redefinition of !$OMP DECLARE MAPPER at %L for type %qs",
6477 : &where, gfc_typename (&ts));
6478 2 : inform (gfc_get_location (&prev_udm->where),
6479 : "Previous !$OMP DECLARE MAPPER here");
6480 2 : return MATCH_ERROR;
6481 : }
6482 17 : else if (st)
6483 : {
6484 0 : omp_udm->next = st->n.omp_udm;
6485 0 : st->n.omp_udm = omp_udm;
6486 : }
6487 : else
6488 : {
6489 17 : st = gfc_new_symtree (&gfc_current_ns->omp_udm_root, mapper_id);
6490 17 : st->n.omp_udm = omp_udm;
6491 : }
6492 :
6493 : return MATCH_YES;
6494 :
6495 1 : failure:
6496 1 : if (mapper_ns)
6497 1 : gfc_current_ns = mapper_ns->parent;
6498 1 : gfc_free_omp_udm (omp_udm);
6499 :
6500 1 : return MATCH_ERROR;
6501 : }
6502 :
6503 : /* For 'declare reduction', matches either the combiner or initializer
6504 : expression, either can be an assignment of 'omp_sym1 = ...'
6505 : or a subroutine call, i.e. 'subroutine-name(argument-list)'. */
6506 :
6507 : static bool
6508 923 : match_udr_expr (gfc_symtree *omp_sym1, gfc_symtree *omp_sym2)
6509 : {
6510 923 : match m;
6511 923 : locus old_loc = gfc_current_locus;
6512 923 : char sname[GFC_MAX_SYMBOL_LEN + 1];
6513 923 : gfc_symbol *sym;
6514 923 : gfc_namespace *ns = gfc_current_ns;
6515 923 : gfc_expr *lvalue = NULL, *rvalue = NULL;
6516 923 : gfc_symtree *st;
6517 923 : gfc_actual_arglist *arglist;
6518 :
6519 923 : m = gfc_match (" %v =", &lvalue);
6520 923 : if (m != MATCH_YES)
6521 210 : gfc_current_locus = old_loc;
6522 : else
6523 : {
6524 713 : m = gfc_match (" %e )", &rvalue);
6525 713 : if (m == MATCH_YES)
6526 : {
6527 703 : ns->code = gfc_get_code (EXEC_ASSIGN);
6528 703 : ns->code->expr1 = lvalue;
6529 703 : ns->code->expr2 = rvalue;
6530 703 : ns->code->loc = old_loc;
6531 703 : return true;
6532 : }
6533 :
6534 10 : gfc_current_locus = old_loc;
6535 10 : gfc_free_expr (lvalue);
6536 : }
6537 :
6538 220 : m = gfc_match (" %n", sname);
6539 220 : if (m != MATCH_YES)
6540 4 : goto syntax;
6541 :
6542 216 : if (strcmp (sname, omp_sym1->name) == 0
6543 203 : || strcmp (sname, omp_sym2->name) == 0)
6544 14 : goto syntax;
6545 :
6546 202 : gfc_current_ns = ns->parent;
6547 202 : if (gfc_get_ha_sym_tree (sname, &st))
6548 0 : goto syntax;
6549 :
6550 202 : sym = st->n.sym;
6551 202 : if (sym->attr.flavor != FL_PROCEDURE
6552 74 : && sym->attr.flavor != FL_UNKNOWN)
6553 1 : goto syntax;
6554 :
6555 201 : if (!sym->attr.generic
6556 191 : && !sym->attr.subroutine
6557 73 : && !sym->attr.function)
6558 : {
6559 73 : if (!(sym->attr.external && !sym->attr.referenced))
6560 : {
6561 : /* ...create a symbol in this scope... */
6562 73 : if (sym->ns != gfc_current_ns
6563 73 : && gfc_get_sym_tree (sname, NULL, &st, false) == 1)
6564 0 : goto syntax;
6565 :
6566 73 : if (sym != st->n.sym)
6567 73 : sym = st->n.sym;
6568 : }
6569 :
6570 : /* ...and then to try to make the symbol into a subroutine. */
6571 73 : if (!gfc_add_subroutine (&sym->attr, sym->name, NULL))
6572 0 : goto syntax;
6573 : }
6574 :
6575 201 : gfc_set_sym_referenced (sym);
6576 201 : gfc_gobble_whitespace ();
6577 201 : if (gfc_peek_ascii_char () != '(')
6578 6 : goto syntax;
6579 :
6580 195 : gfc_current_ns = ns;
6581 195 : m = gfc_match_actual_arglist (1, &arglist);
6582 195 : if (m != MATCH_YES)
6583 0 : goto syntax;
6584 :
6585 195 : if (gfc_match_char (')') != MATCH_YES)
6586 0 : goto syntax;
6587 :
6588 195 : gfc_clear_error ();
6589 195 : ns->code = gfc_get_code (EXEC_CALL);
6590 195 : ns->code->symtree = st;
6591 195 : ns->code->ext.actual = arglist;
6592 195 : ns->code->loc = old_loc;
6593 195 : return true;
6594 25 : syntax:
6595 25 : gfc_clear_error ();
6596 25 : gfc_error ("Expected either %<%s = expr%> or %<subroutine-name(argument-list)"
6597 : "%> followed by %<)%> at %L", omp_sym1->name, &old_loc);
6598 25 : return false;
6599 : }
6600 :
6601 : static bool
6602 1205 : gfc_omp_udr_predef (gfc_omp_reduction_op rop, const char *name,
6603 : gfc_typespec *ts, const char **n)
6604 : {
6605 1205 : if (!gfc_numeric_ts (ts) && ts->type != BT_LOGICAL)
6606 : return false;
6607 :
6608 675 : switch (rop)
6609 : {
6610 19 : case OMP_REDUCTION_PLUS:
6611 19 : case OMP_REDUCTION_MINUS:
6612 19 : case OMP_REDUCTION_TIMES:
6613 19 : return ts->type != BT_LOGICAL;
6614 12 : case OMP_REDUCTION_AND:
6615 12 : case OMP_REDUCTION_OR:
6616 12 : case OMP_REDUCTION_EQV:
6617 12 : case OMP_REDUCTION_NEQV:
6618 12 : return ts->type == BT_LOGICAL;
6619 643 : case OMP_REDUCTION_USER:
6620 643 : if (name[0] != '.' && (ts->type == BT_INTEGER || ts->type == BT_REAL))
6621 : {
6622 571 : gfc_symbol *sym;
6623 :
6624 571 : gfc_find_symbol (name, NULL, 1, &sym);
6625 571 : if (sym != NULL)
6626 : {
6627 94 : if (sym->attr.intrinsic)
6628 0 : *n = sym->name;
6629 94 : else if ((sym->attr.flavor != FL_UNKNOWN
6630 82 : && sym->attr.flavor != FL_PROCEDURE)
6631 70 : || sym->attr.external
6632 55 : || sym->attr.generic
6633 55 : || sym->attr.entry
6634 55 : || sym->attr.result
6635 55 : || sym->attr.dummy
6636 55 : || sym->attr.subroutine
6637 51 : || sym->attr.pointer
6638 51 : || sym->attr.target
6639 51 : || sym->attr.cray_pointer
6640 51 : || sym->attr.cray_pointee
6641 51 : || (sym->attr.proc != PROC_UNKNOWN
6642 1 : && sym->attr.proc != PROC_INTRINSIC)
6643 50 : || sym->attr.if_source != IFSRC_UNKNOWN
6644 50 : || sym == sym->ns->proc_name)
6645 44 : *n = NULL;
6646 : else
6647 50 : *n = sym->name;
6648 : }
6649 : else
6650 477 : *n = name;
6651 571 : if (*n
6652 527 : && (strcmp (*n, "max") == 0 || strcmp (*n, "min") == 0))
6653 56 : return true;
6654 533 : else if (*n
6655 489 : && ts->type == BT_INTEGER
6656 403 : && (strcmp (*n, "iand") == 0
6657 397 : || strcmp (*n, "ior") == 0
6658 391 : || strcmp (*n, "ieor") == 0))
6659 : return true;
6660 : }
6661 : break;
6662 : default:
6663 : break;
6664 : }
6665 : return false;
6666 : }
6667 :
6668 : gfc_omp_udr *
6669 667 : gfc_omp_udr_find (gfc_symtree *st, gfc_typespec *ts)
6670 : {
6671 667 : gfc_omp_udr *omp_udr;
6672 :
6673 667 : if (st == NULL)
6674 : return NULL;
6675 :
6676 112 : gfc_symbol *dt = NULL;
6677 112 : if (ts->type == BT_DERIVED || ts->type == BT_CLASS)
6678 25 : dt = (ts->type == BT_CLASS
6679 0 : ? CLASS_DATA (ts->u.derived)->ts.u.derived : ts->u.derived);
6680 260 : for (omp_udr = st->n.omp_udr; omp_udr; omp_udr = omp_udr->next)
6681 161 : if (omp_udr->ts.type == ts->type
6682 91 : || (dt && omp_udr->ts.type == BT_DERIVED))
6683 : {
6684 70 : if (dt && omp_udr->ts.type == BT_DERIVED)
6685 : {
6686 15 : gfc_symbol *dtu = omp_udr->ts.u.derived;
6687 15 : if (dt == dtu)
6688 : return omp_udr;
6689 : /* Special case for comparing derived types across namespaces. If
6690 : the true names and module names are the same and the module name
6691 : is nonnull, then they are equal. */
6692 7 : if (dt->module && dtu->module
6693 1 : && strcmp (dt->name, dtu->name) == 0
6694 1 : && strcmp (dt->module, dtu->module) == 0)
6695 : return omp_udr;
6696 : }
6697 55 : else if (omp_udr->ts.kind == ts->kind)
6698 : {
6699 20 : if (omp_udr->ts.type == BT_CHARACTER)
6700 : {
6701 17 : if (omp_udr->ts.u.cl->length == NULL
6702 15 : || ts->u.cl->length == NULL)
6703 : return omp_udr;
6704 15 : if (omp_udr->ts.u.cl->length->expr_type != EXPR_CONSTANT)
6705 : return omp_udr;
6706 15 : if (ts->u.cl->length->expr_type != EXPR_CONSTANT)
6707 : return omp_udr;
6708 15 : if (omp_udr->ts.u.cl->length->ts.type != BT_INTEGER)
6709 : return omp_udr;
6710 15 : if (ts->u.cl->length->ts.type != BT_INTEGER)
6711 : return omp_udr;
6712 15 : if (gfc_compare_expr (omp_udr->ts.u.cl->length,
6713 : ts->u.cl->length, INTRINSIC_EQ) != 0)
6714 15 : continue;
6715 : }
6716 : return omp_udr;
6717 : }
6718 : }
6719 : return NULL;
6720 : }
6721 :
6722 : match
6723 588 : gfc_match_omp_declare_reduction (void)
6724 : {
6725 588 : match m;
6726 588 : gfc_intrinsic_op op;
6727 588 : char name[GFC_MAX_SYMBOL_LEN + 3];
6728 588 : auto_vec<gfc_typespec, 5> tss;
6729 588 : gfc_typespec ts;
6730 588 : unsigned int i;
6731 588 : gfc_symtree *st;
6732 588 : locus where = gfc_current_locus;
6733 588 : locus end_loc = gfc_current_locus;
6734 588 : bool end_loc_set = false;
6735 588 : gfc_omp_reduction_op rop = OMP_REDUCTION_NONE;
6736 :
6737 588 : if (gfc_match_char ('(') != MATCH_YES)
6738 : {
6739 4 : gfc_error ("Expected %<(%> at %C");
6740 4 : return MATCH_ERROR;
6741 : }
6742 :
6743 584 : m = gfc_match (" %o : ", &op);
6744 584 : if (m == MATCH_ERROR)
6745 : return MATCH_ERROR;
6746 584 : if (m == MATCH_YES)
6747 : {
6748 142 : snprintf (name, sizeof name, "operator %s", gfc_op2string (op));
6749 142 : rop = (gfc_omp_reduction_op) op;
6750 : }
6751 : else
6752 : {
6753 442 : m = gfc_match_defined_op_name (name + 1, 1);
6754 442 : if (m == MATCH_ERROR)
6755 : return MATCH_ERROR;
6756 441 : if (m == MATCH_YES)
6757 : {
6758 41 : name[0] = '.';
6759 41 : strcat (name, ".");
6760 41 : if (gfc_match (" : ") != MATCH_YES)
6761 : {
6762 0 : gfc_error ("Expected %<:%> at %C");
6763 0 : return MATCH_ERROR;
6764 : }
6765 : }
6766 : else
6767 : {
6768 400 : if (gfc_match (" %n : ", name) != MATCH_YES)
6769 : {
6770 4 : gfc_error ("Expected an identfifier or operator as reduction "
6771 : "identifier followed by a colon at %C");
6772 4 : return MATCH_ERROR;
6773 : }
6774 : }
6775 : rop = OMP_REDUCTION_USER;
6776 : }
6777 :
6778 579 : m = gfc_match_type_spec (&ts);
6779 579 : if (m != MATCH_YES)
6780 : {
6781 4 : gfc_error ("Expected type spec at %C");
6782 4 : return MATCH_ERROR;
6783 : }
6784 : /* Treat len=: the same as len=*. */
6785 575 : if (ts.type == BT_CHARACTER)
6786 61 : ts.deferred = false;
6787 575 : tss.safe_push (ts);
6788 :
6789 1191 : while (gfc_match_char (',') == MATCH_YES)
6790 : {
6791 42 : m = gfc_match_type_spec (&ts);
6792 42 : if (m != MATCH_YES)
6793 : {
6794 1 : gfc_error ("Expected type spec at %C");
6795 1 : return MATCH_ERROR;
6796 : }
6797 41 : tss.safe_push (ts);
6798 : }
6799 574 : if (gfc_match_char (':') != MATCH_YES)
6800 : {
6801 6 : gfc_error ("Expected %<:%> or %<,%> at %C");
6802 6 : return MATCH_ERROR;
6803 : }
6804 :
6805 568 : st = gfc_find_symtree (gfc_current_ns->omp_udr_root, name);
6806 1681 : for (i = 0; i < tss.length (); i++)
6807 : {
6808 604 : gfc_symtree *omp_out, *omp_in;
6809 604 : gfc_symtree *omp_priv = NULL, *omp_orig = NULL;
6810 604 : gfc_namespace *combiner_ns, *initializer_ns = NULL;
6811 604 : gfc_omp_udr *prev_udr, *omp_udr;
6812 604 : const char *predef_name = NULL;
6813 :
6814 604 : omp_udr = gfc_get_omp_udr ();
6815 604 : omp_udr->name = gfc_get_string ("%s", name);
6816 604 : omp_udr->rop = rop;
6817 604 : omp_udr->ts = tss[i];
6818 604 : omp_udr->where = where;
6819 :
6820 604 : gfc_current_ns = combiner_ns = gfc_get_namespace (gfc_current_ns, 1);
6821 604 : combiner_ns->proc_name = combiner_ns->parent->proc_name;
6822 :
6823 604 : gfc_get_sym_tree ("omp_out", combiner_ns, &omp_out, false);
6824 604 : gfc_get_sym_tree ("omp_in", combiner_ns, &omp_in, false);
6825 604 : combiner_ns->omp_udr_ns = 1;
6826 604 : omp_out->n.sym->ts = tss[i];
6827 604 : omp_in->n.sym->ts = tss[i];
6828 604 : omp_out->n.sym->attr.omp_udr_artificial_var = 1;
6829 604 : omp_in->n.sym->attr.omp_udr_artificial_var = 1;
6830 604 : omp_out->n.sym->attr.flavor = FL_VARIABLE;
6831 604 : omp_in->n.sym->attr.flavor = FL_VARIABLE;
6832 604 : gfc_commit_symbols ();
6833 604 : omp_udr->combiner_ns = combiner_ns;
6834 604 : omp_udr->omp_out = omp_out->n.sym;
6835 604 : omp_udr->omp_in = omp_in->n.sym;
6836 :
6837 604 : locus old_loc = gfc_current_locus;
6838 :
6839 604 : if (!match_udr_expr (omp_out, omp_in))
6840 : {
6841 19 : syntax:
6842 59 : gfc_current_ns = combiner_ns->parent;
6843 59 : gfc_undo_symbols ();
6844 59 : gfc_free_omp_udr (omp_udr);
6845 59 : return MATCH_ERROR;
6846 : }
6847 :
6848 585 : if (gfc_match (" initializer ( ") == MATCH_YES)
6849 : {
6850 319 : gfc_current_ns = combiner_ns->parent;
6851 319 : initializer_ns = gfc_get_namespace (gfc_current_ns, 1);
6852 319 : gfc_current_ns = initializer_ns;
6853 319 : initializer_ns->proc_name = initializer_ns->parent->proc_name;
6854 :
6855 319 : gfc_get_sym_tree ("omp_priv", initializer_ns, &omp_priv, false);
6856 319 : gfc_get_sym_tree ("omp_orig", initializer_ns, &omp_orig, false);
6857 319 : initializer_ns->omp_udr_ns = 1;
6858 319 : omp_priv->n.sym->ts = tss[i];
6859 319 : omp_orig->n.sym->ts = tss[i];
6860 319 : omp_priv->n.sym->attr.omp_udr_artificial_var = 1;
6861 319 : omp_orig->n.sym->attr.omp_udr_artificial_var = 1;
6862 319 : omp_priv->n.sym->attr.flavor = FL_VARIABLE;
6863 319 : omp_orig->n.sym->attr.flavor = FL_VARIABLE;
6864 319 : gfc_commit_symbols ();
6865 319 : omp_udr->initializer_ns = initializer_ns;
6866 319 : omp_udr->omp_priv = omp_priv->n.sym;
6867 319 : omp_udr->omp_orig = omp_orig->n.sym;
6868 :
6869 319 : if (!match_udr_expr (omp_priv, omp_orig))
6870 6 : goto syntax;
6871 : }
6872 :
6873 579 : gfc_current_ns = combiner_ns->parent;
6874 579 : if (!end_loc_set)
6875 : {
6876 543 : end_loc_set = true;
6877 543 : end_loc = gfc_current_locus;
6878 : }
6879 579 : gfc_current_locus = old_loc;
6880 :
6881 579 : prev_udr = gfc_omp_udr_find (st, &tss[i]);
6882 579 : if (gfc_omp_udr_predef (rop, name, &tss[i], &predef_name)
6883 : /* Don't error on !$omp declare reduction (min : integer : ...)
6884 : just yet, there could be integer :: min afterwards,
6885 : making it valid. When the UDR is resolved, we'll get
6886 : to it again. */
6887 579 : && (rop != OMP_REDUCTION_USER || name[0] == '.'))
6888 : {
6889 27 : if (predef_name)
6890 0 : gfc_error_now ("Redefinition of predefined %qs in "
6891 : "!$OMP DECLARE REDUCTION at %L",
6892 : predef_name, &where);
6893 : else
6894 27 : gfc_error_now ("Redefinition of predefined %qs in "
6895 : "!$OMP DECLARE REDUCTION at %L", name, &where);
6896 27 : goto syntax;
6897 : }
6898 552 : else if (prev_udr)
6899 : {
6900 7 : gfc_error_now ("Redefinition of %qs in !$OMP DECLARE REDUCTION at %L",
6901 : name, &where);
6902 7 : inform (gfc_get_location (&prev_udr->where),
6903 : "Previous !$OMP DECLARE REDUCTION");
6904 7 : goto syntax;
6905 : }
6906 545 : else if (st)
6907 : {
6908 98 : omp_udr->next = st->n.omp_udr;
6909 98 : st->n.omp_udr = omp_udr;
6910 : }
6911 : else
6912 : {
6913 447 : st = gfc_new_symtree (&gfc_current_ns->omp_udr_root, name);
6914 447 : st->n.omp_udr = omp_udr;
6915 : }
6916 : }
6917 :
6918 509 : if (end_loc_set)
6919 : {
6920 509 : gfc_current_locus = end_loc;
6921 509 : if (gfc_match_omp_eos () != MATCH_YES)
6922 : {
6923 4 : gfc_error ("Unexpected junk at %C");
6924 4 : return MATCH_ERROR;
6925 : }
6926 : return MATCH_YES;
6927 : }
6928 : return MATCH_ERROR;
6929 588 : }
6930 :
6931 :
6932 : match
6933 473 : gfc_match_omp_declare_target (void)
6934 : {
6935 473 : locus old_loc;
6936 473 : match m;
6937 473 : gfc_omp_clauses *c = NULL;
6938 473 : enum gfc_omp_list_type list;
6939 473 : gfc_omp_namelist *n;
6940 473 : gfc_symbol *s;
6941 :
6942 473 : old_loc = gfc_current_locus;
6943 :
6944 473 : if (gfc_current_ns->proc_name
6945 473 : && gfc_match_omp_eos () == MATCH_YES)
6946 : {
6947 138 : if (!gfc_add_omp_declare_target (&gfc_current_ns->proc_name->attr,
6948 138 : gfc_current_ns->proc_name->name,
6949 : &old_loc))
6950 0 : goto cleanup;
6951 : return MATCH_YES;
6952 : }
6953 :
6954 335 : if (gfc_current_ns->proc_name
6955 335 : && gfc_current_ns->proc_name->attr.if_source == IFSRC_IFBODY)
6956 : {
6957 2 : gfc_error ("Only the !$OMP DECLARE TARGET form without "
6958 : "clauses is allowed in interface block at %C");
6959 2 : goto cleanup;
6960 : }
6961 :
6962 333 : m = gfc_match (" (");
6963 333 : if (m == MATCH_YES)
6964 : {
6965 86 : c = gfc_get_omp_clauses ();
6966 86 : gfc_current_locus = old_loc;
6967 86 : m = gfc_match_omp_to_link (" (", &c->lists[OMP_LIST_ENTER]);
6968 86 : if (m != MATCH_YES)
6969 0 : goto syntax;
6970 86 : if (gfc_match_omp_eos () != MATCH_YES)
6971 : {
6972 0 : gfc_error ("Unexpected junk after !$OMP DECLARE TARGET at %C");
6973 0 : goto cleanup;
6974 : }
6975 : }
6976 247 : else if (gfc_match_omp_clauses (&c, OMP_DECLARE_TARGET_CLAUSES) != MATCH_YES)
6977 : return MATCH_ERROR;
6978 :
6979 327 : gfc_buffer_error (false);
6980 :
6981 327 : static const enum gfc_omp_list_type to_enter_link_lists[]
6982 : = { OMP_LIST_TO, OMP_LIST_ENTER, OMP_LIST_LINK, OMP_LIST_LOCAL };
6983 1635 : for (size_t listn = 0; listn < ARRAY_SIZE (to_enter_link_lists)
6984 1635 : && (list = to_enter_link_lists[listn], true); ++listn)
6985 1854 : for (n = c->lists[list]; n; n = n->next)
6986 546 : if (n->sym)
6987 505 : n->sym->mark = 0;
6988 41 : else if (n->u.common->head)
6989 41 : n->u.common->head->mark = 0;
6990 :
6991 327 : if (c->device_type == OMP_DEVICE_TYPE_UNSET)
6992 259 : c->device_type = OMP_DEVICE_TYPE_ANY;
6993 1635 : for (size_t listn = 0; listn < ARRAY_SIZE (to_enter_link_lists)
6994 1635 : && (list = to_enter_link_lists[listn], true); ++listn)
6995 1854 : for (n = c->lists[list]; n; n = n->next)
6996 546 : if (n->sym)
6997 : {
6998 505 : if (n->sym->attr.in_common)
6999 1 : gfc_error_now ("OMP DECLARE TARGET variable at %L is an "
7000 : "element of a COMMON block", &n->where);
7001 504 : else if (n->sym->attr.omp_groupprivate && list != OMP_LIST_LOCAL)
7002 12 : gfc_error_now ("List item %qs at %L not appear in the %qs clause "
7003 : "as it was previously specified in a GROUPPRIVATE "
7004 : "directive", n->sym->name, &n->where,
7005 : list == OMP_LIST_LINK
7006 5 : ? "link" : list == OMP_LIST_TO ? "to" : "enter");
7007 497 : else if (n->sym->mark)
7008 9 : gfc_error_now ("Variable at %L mentioned multiple times in "
7009 : "clauses of the same OMP DECLARE TARGET directive",
7010 : &n->where);
7011 488 : else if ((n->sym->attr.omp_declare_target_link
7012 483 : || n->sym->attr.omp_declare_target_local)
7013 : && list != OMP_LIST_LINK
7014 7 : && list != OMP_LIST_LOCAL)
7015 1 : gfc_error_now ("OMP DECLARE TARGET variable at %L previously "
7016 : "mentioned in %s clause and later in %s clause",
7017 : &n->where,
7018 : n->sym->attr.omp_declare_target_link ? "LINK"
7019 : : "LOCAL",
7020 : list == OMP_LIST_TO ? "TO" : "ENTER");
7021 487 : else if (n->sym->attr.omp_declare_target
7022 14 : && (list == OMP_LIST_LINK || list == OMP_LIST_LOCAL))
7023 1 : gfc_error_now ("OMP DECLARE TARGET variable at %L previously "
7024 : "mentioned in TO or ENTER clause and later in "
7025 : "%s clause", &n->where,
7026 : list == OMP_LIST_LINK ? "LINK" : "LOCAL");
7027 : else
7028 : {
7029 486 : if (list == OMP_LIST_TO || list == OMP_LIST_ENTER)
7030 447 : gfc_add_omp_declare_target (&n->sym->attr, n->sym->name,
7031 : &n->sym->declared_at);
7032 486 : if (list == OMP_LIST_LINK)
7033 30 : gfc_add_omp_declare_target_link (&n->sym->attr, n->sym->name,
7034 30 : &n->sym->declared_at);
7035 486 : if (list == OMP_LIST_LOCAL)
7036 9 : gfc_add_omp_declare_target_local (&n->sym->attr, n->sym->name,
7037 9 : &n->sym->declared_at);
7038 : }
7039 505 : if (n->sym->attr.omp_device_type != OMP_DEVICE_TYPE_UNSET
7040 36 : && n->sym->attr.omp_device_type != c->device_type)
7041 : {
7042 12 : const char *dt = "any";
7043 12 : if (n->sym->attr.omp_device_type == OMP_DEVICE_TYPE_NOHOST)
7044 : dt = "nohost";
7045 8 : else if (n->sym->attr.omp_device_type == OMP_DEVICE_TYPE_HOST)
7046 4 : dt = "host";
7047 12 : if (n->sym->attr.omp_groupprivate)
7048 1 : gfc_error_now ("List item %qs at %L set in previous OMP "
7049 : "GROUPPRIVATE directive to the different "
7050 : "DEVICE_TYPE %qs", n->sym->name, &n->where, dt);
7051 : else
7052 11 : gfc_error_now ("List item %qs at %L set in previous OMP "
7053 : "DECLARE TARGET directive to the different "
7054 : "DEVICE_TYPE %qs", n->sym->name, &n->where, dt);
7055 : }
7056 505 : n->sym->attr.omp_device_type = c->device_type;
7057 505 : if (c->indirect && c->device_type != OMP_DEVICE_TYPE_ANY)
7058 : {
7059 1 : gfc_error_now ("DEVICE_TYPE must be ANY when used with INDIRECT "
7060 : "at %L", &n->where);
7061 1 : c->indirect = 0;
7062 : }
7063 505 : n->sym->attr.omp_declare_target_indirect = c->indirect;
7064 505 : if (list == OMP_LIST_LINK && c->device_type == OMP_DEVICE_TYPE_NOHOST)
7065 3 : gfc_error_now ("List item %qs at %L set with NOHOST specified may "
7066 : "not appear in a LINK clause", n->sym->name,
7067 : &n->where);
7068 505 : n->sym->mark = 1;
7069 : }
7070 : else /* common block */
7071 : {
7072 41 : if (n->u.common->omp_groupprivate && list != OMP_LIST_LOCAL)
7073 7 : gfc_error_now ("Common block %</%s/%> at %L not appear in the %qs "
7074 : "clause as it was previously specified in a "
7075 : "GROUPPRIVATE directive",
7076 7 : n->u.common->name, &n->where,
7077 : list == OMP_LIST_LINK
7078 5 : ? "link" : list == OMP_LIST_TO ? "to" : "enter");
7079 34 : else if (n->u.common->head && n->u.common->head->mark)
7080 4 : gfc_error_now ("Common block %</%s/%> at %L mentioned multiple "
7081 : "times in clauses of the same OMP DECLARE TARGET "
7082 4 : "directive", n->u.common->name, &n->where);
7083 30 : else if ((n->u.common->omp_declare_target_link
7084 26 : || n->u.common->omp_declare_target_local)
7085 : && list != OMP_LIST_LINK
7086 6 : && list != OMP_LIST_LOCAL)
7087 2 : gfc_error_now ("Common block %</%s/%> at %L previously mentioned "
7088 : "in %s clause and later in %s clause",
7089 1 : n->u.common->name, &n->where,
7090 : n->u.common->omp_declare_target_link ? "LINK"
7091 : : "LOCAL",
7092 : list == OMP_LIST_TO ? "TO" : "ENTER");
7093 29 : else if (n->u.common->omp_declare_target
7094 4 : && (list == OMP_LIST_LINK || list == OMP_LIST_LOCAL))
7095 1 : gfc_error_now ("Common block %</%s/%> at %L previously mentioned "
7096 : "in TO or ENTER clause and later in %s clause",
7097 1 : n->u.common->name, &n->where,
7098 : list == OMP_LIST_LINK ? "LINK" : "LOCAL");
7099 41 : if (n->u.common->omp_device_type != OMP_DEVICE_TYPE_UNSET
7100 21 : && n->u.common->omp_device_type != c->device_type)
7101 : {
7102 1 : const char *dt = "any";
7103 1 : if (n->u.common->omp_device_type == OMP_DEVICE_TYPE_NOHOST)
7104 : dt = "nohost";
7105 0 : else if (n->u.common->omp_device_type == OMP_DEVICE_TYPE_HOST)
7106 0 : dt = "host";
7107 1 : if (n->u.common->omp_groupprivate)
7108 1 : gfc_error_now ("Common block %</%s/%> at %L set in previous OMP "
7109 : "GROUPPRIVATE directive to the different "
7110 1 : "DEVICE_TYPE %qs", n->u.common->name, &n->where,
7111 : dt);
7112 : else
7113 0 : gfc_error_now ("Common block %</%s/%> at %L set in previous OMP "
7114 : "DECLARE TARGET directive to the different "
7115 0 : "DEVICE_TYPE %qs", n->u.common->name, &n->where,
7116 : dt);
7117 : }
7118 41 : n->u.common->omp_device_type = c->device_type;
7119 :
7120 41 : if (c->indirect && c->device_type != OMP_DEVICE_TYPE_ANY)
7121 : {
7122 0 : gfc_error_now ("DEVICE_TYPE must be ANY when used with INDIRECT "
7123 : "at %L", &n->where);
7124 0 : c->indirect = 0;
7125 : }
7126 41 : if (list == OMP_LIST_LINK && c->device_type == OMP_DEVICE_TYPE_NOHOST)
7127 1 : gfc_error_now ("Common block %</%s/%> at %L set with NOHOST "
7128 : "specified may not appear in a LINK clause",
7129 1 : n->u.common->name, &n->where);
7130 :
7131 41 : if (list == OMP_LIST_TO || list == OMP_LIST_ENTER)
7132 21 : n->u.common->omp_declare_target = 1;
7133 41 : if (list == OMP_LIST_LINK)
7134 15 : n->u.common->omp_declare_target_link = 1;
7135 41 : if (list == OMP_LIST_LOCAL)
7136 5 : n->u.common->omp_declare_target_local = 1;
7137 :
7138 110 : for (s = n->u.common->head; s; s = s->common_next)
7139 : {
7140 69 : s->mark = 1;
7141 69 : if (list == OMP_LIST_TO || list == OMP_LIST_ENTER)
7142 33 : gfc_add_omp_declare_target (&s->attr, s->name, &n->where);
7143 69 : if (list == OMP_LIST_LINK)
7144 31 : gfc_add_omp_declare_target_link (&s->attr, s->name, &n->where);
7145 69 : if (list == OMP_LIST_LOCAL)
7146 5 : gfc_add_omp_declare_target_local (&s->attr, s->name, &n->where);
7147 69 : s->attr.omp_device_type = c->device_type;
7148 69 : s->attr.omp_declare_target_indirect = c->indirect;
7149 : }
7150 : }
7151 327 : if ((c->device_type || c->indirect)
7152 327 : && !c->lists[OMP_LIST_ENTER]
7153 151 : && !c->lists[OMP_LIST_TO]
7154 47 : && !c->lists[OMP_LIST_LINK]
7155 10 : && !c->lists[OMP_LIST_LOCAL])
7156 2 : gfc_warning_now (OPT_Wopenmp,
7157 : "OMP DECLARE TARGET directive at %L with only "
7158 : "DEVICE_TYPE or INDIRECT clauses is ignored",
7159 : &old_loc);
7160 :
7161 327 : gfc_buffer_error (true);
7162 :
7163 327 : if (c)
7164 327 : gfc_free_omp_clauses (c);
7165 : return MATCH_YES;
7166 :
7167 0 : syntax:
7168 0 : gfc_error ("Syntax error in !$OMP DECLARE TARGET list at %C");
7169 :
7170 2 : cleanup:
7171 2 : gfc_current_locus = old_loc;
7172 2 : if (c)
7173 0 : gfc_free_omp_clauses (c);
7174 : return MATCH_ERROR;
7175 : }
7176 :
7177 : /* Skip over and ignore trait-property-extensions.
7178 :
7179 : trait-property-extension :
7180 : trait-property-name
7181 : identifier (trait-property-extension[, trait-property-extension[, ...]])
7182 : constant integer expression
7183 : */
7184 :
7185 : static match gfc_ignore_trait_property_extension_list (void);
7186 :
7187 : static match
7188 7 : gfc_ignore_trait_property_extension (void)
7189 : {
7190 7 : char buf[GFC_MAX_SYMBOL_LEN + 1];
7191 7 : gfc_expr *expr;
7192 :
7193 : /* Identifier form of trait-property name, possibly followed by
7194 : a list of (recursive) trait-property-extensions. */
7195 7 : if (gfc_match_name (buf) == MATCH_YES)
7196 : {
7197 0 : if (gfc_match (" (") == MATCH_YES)
7198 0 : return gfc_ignore_trait_property_extension_list ();
7199 : return MATCH_YES;
7200 : }
7201 :
7202 : /* Literal constant. */
7203 7 : if (gfc_match_literal_constant (&expr, 0) == MATCH_YES)
7204 : return MATCH_YES;
7205 :
7206 : /* FIXME: constant integer expressions. */
7207 0 : gfc_error ("Expected trait-property-extension at %C");
7208 0 : return MATCH_ERROR;
7209 : }
7210 :
7211 : static match
7212 5 : gfc_ignore_trait_property_extension_list (void)
7213 : {
7214 9 : while (1)
7215 : {
7216 7 : if (gfc_ignore_trait_property_extension () != MATCH_YES)
7217 : return MATCH_ERROR;
7218 7 : if (gfc_match (" ,") == MATCH_YES)
7219 2 : continue;
7220 5 : if (gfc_match (" )") == MATCH_YES)
7221 : return MATCH_YES;
7222 0 : gfc_error ("expected %<)%> at %C");
7223 0 : return MATCH_ERROR;
7224 : }
7225 : }
7226 :
7227 :
7228 : match
7229 110 : gfc_match_omp_interop (void)
7230 : {
7231 110 : return match_omp (EXEC_OMP_INTEROP, OMP_INTEROP_CLAUSES);
7232 : }
7233 :
7234 :
7235 : /* OpenMP 5.0:
7236 :
7237 : trait-selector:
7238 : trait-selector-name[([trait-score:]trait-property[,trait-property[,...]])]
7239 :
7240 : trait-score:
7241 : score(score-expression) */
7242 :
7243 : static match
7244 638 : gfc_match_omp_context_selector (gfc_omp_set_selector *oss)
7245 : {
7246 776 : do
7247 : {
7248 776 : char selector[GFC_MAX_SYMBOL_LEN + 1];
7249 :
7250 776 : if (gfc_match_name (selector) != MATCH_YES)
7251 : {
7252 2 : gfc_error ("expected trait selector name at %C");
7253 39 : return MATCH_ERROR;
7254 : }
7255 :
7256 774 : gfc_omp_selector *os = gfc_get_omp_selector ();
7257 774 : if (oss->code == OMP_TRAIT_SET_CONSTRUCT
7258 336 : && !strcmp (selector, "do"))
7259 48 : os->code = OMP_TRAIT_CONSTRUCT_FOR;
7260 726 : else if (oss->code == OMP_TRAIT_SET_CONSTRUCT
7261 288 : && !strcmp (selector, "for"))
7262 1 : os->code = OMP_TRAIT_INVALID;
7263 : else
7264 725 : os->code = omp_lookup_ts_code (oss->code, selector);
7265 774 : os->next = oss->trait_selectors;
7266 774 : oss->trait_selectors = os;
7267 :
7268 774 : if (os->code == OMP_TRAIT_INVALID)
7269 : {
7270 18 : gfc_warning (OPT_Wopenmp,
7271 : "unknown selector %qs for context selector set %qs "
7272 : "at %C",
7273 18 : selector, omp_tss_map[oss->code]);
7274 18 : if (gfc_match (" (") == MATCH_YES
7275 18 : && gfc_ignore_trait_property_extension_list () != MATCH_YES)
7276 : return MATCH_ERROR;
7277 18 : if (gfc_match (" ,") == MATCH_YES)
7278 1 : continue;
7279 599 : break;
7280 : }
7281 :
7282 756 : enum omp_tp_type property_kind = omp_ts_map[os->code].tp_type;
7283 756 : bool allow_score = omp_ts_map[os->code].allow_score;
7284 :
7285 756 : if (gfc_match (" (") == MATCH_YES)
7286 : {
7287 431 : if (property_kind == OMP_TRAIT_PROPERTY_NONE)
7288 : {
7289 6 : gfc_error ("selector %qs does not accept any properties at %C",
7290 : selector);
7291 6 : return MATCH_ERROR;
7292 : }
7293 :
7294 425 : if (gfc_match (" score") == MATCH_YES)
7295 : {
7296 63 : if (!allow_score)
7297 : {
7298 10 : gfc_error ("%<score%> cannot be specified in traits "
7299 : "in the %qs trait-selector-set at %C",
7300 10 : omp_tss_map[oss->code]);
7301 10 : return MATCH_ERROR;
7302 : }
7303 53 : if (gfc_match (" (") != MATCH_YES)
7304 : {
7305 0 : gfc_error ("expected %<(%> at %C");
7306 0 : return MATCH_ERROR;
7307 : }
7308 53 : if (gfc_match_expr (&os->score) != MATCH_YES)
7309 : return MATCH_ERROR;
7310 :
7311 52 : if (gfc_match (" )") != MATCH_YES)
7312 : {
7313 0 : gfc_error ("expected %<)%> at %C");
7314 0 : return MATCH_ERROR;
7315 : }
7316 :
7317 52 : if (gfc_match (" :") != MATCH_YES)
7318 : {
7319 0 : gfc_error ("expected : at %C");
7320 0 : return MATCH_ERROR;
7321 : }
7322 : }
7323 :
7324 414 : gfc_omp_trait_property *otp = gfc_get_omp_trait_property ();
7325 414 : otp->property_kind = property_kind;
7326 414 : otp->next = os->properties;
7327 414 : os->properties = otp;
7328 :
7329 414 : switch (property_kind)
7330 : {
7331 25 : case OMP_TRAIT_PROPERTY_ID:
7332 25 : {
7333 25 : char buf[GFC_MAX_SYMBOL_LEN + 1];
7334 25 : if (gfc_match_name (buf) == MATCH_YES)
7335 : {
7336 24 : otp->name = XNEWVEC (char, strlen (buf) + 1);
7337 24 : strcpy (otp->name, buf);
7338 : }
7339 : else
7340 : {
7341 1 : gfc_error ("expected identifier at %C");
7342 1 : free (otp);
7343 1 : os->properties = nullptr;
7344 1 : return MATCH_ERROR;
7345 : }
7346 : }
7347 24 : break;
7348 290 : case OMP_TRAIT_PROPERTY_NAME_LIST:
7349 343 : do
7350 : {
7351 290 : char buf[GFC_MAX_SYMBOL_LEN + 1];
7352 290 : if (gfc_match_name (buf) == MATCH_YES)
7353 : {
7354 170 : otp->name = XNEWVEC (char, strlen (buf) + 1);
7355 170 : strcpy (otp->name, buf);
7356 170 : otp->is_name = true;
7357 : }
7358 120 : else if (gfc_match_literal_constant (&otp->expr, 0)
7359 : != MATCH_YES
7360 120 : || otp->expr->ts.type != BT_CHARACTER)
7361 : {
7362 5 : gfc_error ("expected identifier or string literal "
7363 : "at %C");
7364 5 : free (otp);
7365 5 : os->properties = nullptr;
7366 5 : return MATCH_ERROR;
7367 : }
7368 :
7369 285 : if (gfc_match (" ,") == MATCH_YES)
7370 : {
7371 53 : otp = gfc_get_omp_trait_property ();
7372 53 : otp->property_kind = property_kind;
7373 53 : otp->next = os->properties;
7374 53 : os->properties = otp;
7375 : }
7376 : else
7377 : break;
7378 53 : }
7379 : while (1);
7380 232 : break;
7381 137 : case OMP_TRAIT_PROPERTY_DEV_NUM_EXPR:
7382 137 : case OMP_TRAIT_PROPERTY_BOOL_EXPR:
7383 137 : if (gfc_match_expr (&otp->expr) != MATCH_YES)
7384 : {
7385 3 : gfc_error ("expected expression at %C");
7386 3 : free (otp);
7387 3 : os->properties = nullptr;
7388 3 : return MATCH_ERROR;
7389 : }
7390 : break;
7391 15 : case OMP_TRAIT_PROPERTY_CLAUSE_LIST:
7392 15 : {
7393 15 : if (os->code == OMP_TRAIT_CONSTRUCT_SIMD)
7394 : {
7395 15 : gfc_matching_omp_context_selector = true;
7396 15 : if (gfc_match_omp_clauses (&otp->clauses,
7397 15 : OMP_DECLARE_SIMD_CLAUSES,
7398 : true, false, false)
7399 : != MATCH_YES)
7400 : {
7401 1 : gfc_matching_omp_context_selector = false;
7402 1 : gfc_error ("expected simd clause at %C");
7403 1 : return MATCH_ERROR;
7404 : }
7405 14 : gfc_matching_omp_context_selector = false;
7406 : }
7407 0 : else if (os->code == OMP_TRAIT_IMPLEMENTATION_REQUIRES)
7408 : {
7409 : /* FIXME: The "requires" selector was added in OpenMP 5.1.
7410 : Currently only the now-deprecated syntax
7411 : from OpenMP 5.0 is supported.
7412 : TODO: When implementing, update modules.cc as well. */
7413 0 : sorry_at (gfc_get_location (&gfc_current_locus),
7414 : "%<requires%> selector is not supported yet");
7415 0 : return MATCH_ERROR;
7416 : }
7417 : else
7418 0 : gcc_unreachable ();
7419 14 : break;
7420 : }
7421 0 : default:
7422 0 : gcc_unreachable ();
7423 : }
7424 :
7425 404 : if (gfc_match (" )") != MATCH_YES)
7426 : {
7427 2 : gfc_error ("expected %<)%> at %C");
7428 2 : return MATCH_ERROR;
7429 : }
7430 : }
7431 325 : else if (property_kind != OMP_TRAIT_PROPERTY_NONE
7432 325 : && property_kind != OMP_TRAIT_PROPERTY_CLAUSE_LIST
7433 8 : && property_kind != OMP_TRAIT_PROPERTY_EXTENSION)
7434 : {
7435 8 : if (gfc_match (" (") != MATCH_YES)
7436 : {
7437 8 : gfc_error ("expected %<(%> at %C");
7438 8 : return MATCH_ERROR;
7439 : }
7440 : }
7441 :
7442 719 : if (gfc_match (" ,") != MATCH_YES)
7443 : break;
7444 : }
7445 : while (1);
7446 :
7447 599 : return MATCH_YES;
7448 : }
7449 :
7450 : /* OpenMP 5.0:
7451 :
7452 : trait-set-selector[,trait-set-selector[,...]]
7453 :
7454 : trait-set-selector:
7455 : trait-set-selector-name = { trait-selector[, trait-selector[, ...]] }
7456 :
7457 : trait-set-selector-name:
7458 : constructor
7459 : device
7460 : implementation
7461 : user */
7462 :
7463 : static match
7464 578 : gfc_match_omp_context_selector_specification (gfc_omp_set_selector **oss_head)
7465 : {
7466 714 : do
7467 : {
7468 646 : match m;
7469 646 : char buf[GFC_MAX_SYMBOL_LEN + 1];
7470 646 : enum omp_tss_code set = OMP_TRAIT_SET_INVALID;
7471 :
7472 646 : m = gfc_match_name (buf);
7473 646 : if (m == MATCH_YES)
7474 644 : set = omp_lookup_tss_code (buf);
7475 :
7476 644 : if (set == OMP_TRAIT_SET_INVALID)
7477 : {
7478 5 : gfc_error ("expected context selector set name at %C");
7479 47 : return MATCH_ERROR;
7480 : }
7481 :
7482 641 : m = gfc_match (" =");
7483 641 : if (m != MATCH_YES)
7484 : {
7485 1 : gfc_error ("expected %<=%> at %C");
7486 1 : return MATCH_ERROR;
7487 : }
7488 :
7489 640 : m = gfc_match (" {");
7490 640 : if (m != MATCH_YES)
7491 : {
7492 2 : gfc_error ("expected %<{%> at %C");
7493 2 : return MATCH_ERROR;
7494 : }
7495 :
7496 638 : gfc_omp_set_selector *oss = gfc_get_omp_set_selector ();
7497 638 : oss->next = *oss_head;
7498 638 : oss->code = set;
7499 638 : *oss_head = oss;
7500 :
7501 638 : if (gfc_match_omp_context_selector (oss) != MATCH_YES)
7502 : return MATCH_ERROR;
7503 :
7504 599 : m = gfc_match (" }");
7505 599 : if (m != MATCH_YES)
7506 : {
7507 0 : gfc_error ("expected %<}%> at %C");
7508 0 : return MATCH_ERROR;
7509 : }
7510 :
7511 599 : m = gfc_match (" ,");
7512 599 : if (m != MATCH_YES)
7513 : break;
7514 68 : }
7515 : while (1);
7516 :
7517 531 : return MATCH_YES;
7518 : }
7519 :
7520 :
7521 : match
7522 420 : gfc_match_omp_declare_variant (void)
7523 : {
7524 420 : char buf[GFC_MAX_SYMBOL_LEN + 1];
7525 :
7526 420 : if (gfc_match (" (") != MATCH_YES)
7527 : {
7528 2 : gfc_error ("expected %<(%> at %C");
7529 2 : return MATCH_ERROR;
7530 : }
7531 :
7532 418 : gfc_symtree *base_proc_st, *variant_proc_st;
7533 418 : if (gfc_match_name (buf) != MATCH_YES)
7534 : {
7535 2 : gfc_error ("expected name at %C");
7536 2 : return MATCH_ERROR;
7537 : }
7538 :
7539 416 : if (gfc_get_ha_sym_tree (buf, &base_proc_st))
7540 : return MATCH_ERROR;
7541 :
7542 416 : if (gfc_match (" :") == MATCH_YES)
7543 : {
7544 16 : if (gfc_match_name (buf) != MATCH_YES)
7545 : {
7546 0 : gfc_error ("expected variant name at %C");
7547 0 : return MATCH_ERROR;
7548 : }
7549 :
7550 16 : if (gfc_get_ha_sym_tree (buf, &variant_proc_st))
7551 : return MATCH_ERROR;
7552 : }
7553 : else
7554 : {
7555 : /* Base procedure not specified. */
7556 400 : variant_proc_st = base_proc_st;
7557 400 : base_proc_st = NULL;
7558 : }
7559 :
7560 416 : gfc_omp_declare_variant *odv;
7561 416 : odv = gfc_get_omp_declare_variant ();
7562 416 : odv->where = gfc_current_locus;
7563 416 : odv->variant_proc_symtree = variant_proc_st;
7564 416 : odv->adjust_args_list = NULL;
7565 416 : odv->base_proc_symtree = base_proc_st;
7566 416 : odv->next = NULL;
7567 416 : odv->error_p = false;
7568 :
7569 : /* Add the new declare variant to the end of the list. */
7570 416 : gfc_omp_declare_variant **prev_next = &gfc_current_ns->omp_declare_variant;
7571 556 : while (*prev_next)
7572 140 : prev_next = &((*prev_next)->next);
7573 416 : *prev_next = odv;
7574 :
7575 416 : if (gfc_match (" )") != MATCH_YES)
7576 : {
7577 1 : gfc_error ("expected %<)%> at %C");
7578 1 : return MATCH_ERROR;
7579 : }
7580 :
7581 415 : bool has_match = false, has_adjust_args = false, has_append_args = false;
7582 415 : bool error_p = false;
7583 415 : locus adjust_args_loc;
7584 415 : locus append_args_loc;
7585 :
7586 415 : gfc_gobble_whitespace ();
7587 415 : gfc_match_char (',');
7588 633 : for (;;)
7589 : {
7590 524 : gfc_gobble_whitespace ();
7591 :
7592 524 : enum clause
7593 : {
7594 : clause_match,
7595 : clause_adjust_args,
7596 : clause_append_args
7597 : } ccode;
7598 :
7599 524 : if (gfc_match ("match") == MATCH_YES)
7600 : ccode = clause_match;
7601 119 : else if (gfc_match ("adjust_args") == MATCH_YES)
7602 : {
7603 518 : ccode = clause_adjust_args;
7604 : adjust_args_loc = gfc_current_locus;
7605 : }
7606 38 : else if (gfc_match ("append_args") == MATCH_YES)
7607 : {
7608 518 : ccode = clause_append_args;
7609 : append_args_loc = gfc_current_locus;
7610 : }
7611 : else
7612 : {
7613 : error_p = true;
7614 : break;
7615 : }
7616 :
7617 518 : if (gfc_match (" ( ") != MATCH_YES)
7618 : {
7619 1 : gfc_error ("expected %<(%> at %C");
7620 1 : return MATCH_ERROR;
7621 : }
7622 :
7623 517 : if (ccode == clause_match)
7624 : {
7625 404 : if (has_match)
7626 : {
7627 1 : gfc_error ("%qs clause at %L specified more than once",
7628 : "match", &gfc_current_locus);
7629 1 : return MATCH_ERROR;
7630 : }
7631 403 : has_match = true;
7632 403 : if (gfc_match_omp_context_selector_specification (&odv->set_selectors)
7633 : != MATCH_YES)
7634 : return MATCH_ERROR;
7635 363 : if (gfc_match (" )") != MATCH_YES)
7636 : {
7637 0 : gfc_error ("expected %<)%> at %C");
7638 0 : return MATCH_ERROR;
7639 : }
7640 : }
7641 113 : else if (ccode == clause_adjust_args)
7642 : {
7643 81 : has_adjust_args = true;
7644 81 : bool need_device_ptr_p = false;
7645 81 : bool need_device_addr_p = false;
7646 81 : if (gfc_match ("nothing ") == MATCH_YES)
7647 : ;
7648 58 : else if (gfc_match ("need_device_ptr ") == MATCH_YES)
7649 : need_device_ptr_p = true;
7650 9 : else if (gfc_match ("need_device_addr ") == MATCH_YES)
7651 : need_device_addr_p = true;
7652 : else
7653 : {
7654 2 : gfc_error ("expected %<nothing%>, %<need_device_ptr%> or "
7655 : "%<need_device_addr%> at %C");
7656 2 : return MATCH_ERROR;
7657 : }
7658 79 : if (gfc_match (": ") != MATCH_YES)
7659 : {
7660 1 : gfc_error ("expected %<:%> at %C");
7661 1 : return MATCH_ERROR;
7662 : }
7663 : gfc_omp_namelist *tail = NULL;
7664 : bool need_range = false, have_range = false;
7665 125 : while (true)
7666 : {
7667 125 : gfc_omp_namelist *p = gfc_get_omp_namelist ();
7668 125 : p->where = gfc_current_locus;
7669 125 : p->u.adj_args.need_ptr = need_device_ptr_p;
7670 125 : p->u.adj_args.need_addr = need_device_addr_p;
7671 125 : if (tail)
7672 : {
7673 47 : tail->next = p;
7674 47 : tail = tail->next;
7675 : }
7676 : else
7677 : {
7678 78 : gfc_omp_namelist **q = &odv->adjust_args_list;
7679 78 : if (*q)
7680 : {
7681 50 : for (; (*q)->next; q = &(*q)->next)
7682 : ;
7683 28 : (*q)->next = p;
7684 : }
7685 : else
7686 50 : *q = p;
7687 : tail = p;
7688 : }
7689 125 : if (gfc_match (": ") == MATCH_YES)
7690 : {
7691 2 : if (have_range)
7692 : {
7693 0 : gfc_error ("unexpected %<:%> at %C");
7694 2 : return MATCH_ERROR;
7695 : }
7696 2 : p->u.adj_args.range_start = have_range = true;
7697 2 : need_range = false;
7698 47 : continue;
7699 : }
7700 123 : if (have_range && gfc_match (", ") == MATCH_YES)
7701 : {
7702 1 : have_range = false;
7703 1 : continue;
7704 : }
7705 122 : if (have_range && gfc_match (") ") == MATCH_YES)
7706 : break;
7707 121 : locus saved_loc = gfc_current_locus;
7708 :
7709 : /* Without ranges, only arg names or integer literals permitted;
7710 : handle literals here as gfc_match_expr simplifies the expr. */
7711 121 : if (gfc_match_literal_constant (&p->expr, true) == MATCH_YES)
7712 : {
7713 17 : gfc_gobble_whitespace ();
7714 17 : char c = gfc_peek_ascii_char ();
7715 17 : if (c != ')' && c != ',' && c != ':')
7716 : {
7717 1 : gfc_free_expr (p->expr);
7718 1 : p->expr = NULL;
7719 1 : gfc_current_locus = saved_loc;
7720 : }
7721 : }
7722 121 : if (!p->expr && gfc_match ("omp_num_args") == MATCH_YES)
7723 : {
7724 6 : if (!have_range)
7725 3 : p->u.adj_args.range_start = need_range = true;
7726 : else
7727 : need_range = false;
7728 :
7729 6 : locus saved_loc2 = gfc_current_locus;
7730 6 : gfc_gobble_whitespace ();
7731 6 : char c = gfc_peek_ascii_char ();
7732 6 : if (c == '+' || c == '-')
7733 : {
7734 5 : if (gfc_match ("+ %e", &p->expr) == MATCH_YES)
7735 1 : p->u.adj_args.omp_num_args_plus = true;
7736 4 : else if (gfc_match ("- %e", &p->expr) == MATCH_YES)
7737 4 : p->u.adj_args.omp_num_args_minus = true;
7738 0 : else if (!gfc_error_check ())
7739 : {
7740 0 : gfc_error ("expected constant integer expression "
7741 : "at %C");
7742 0 : p->u.adj_args.error_p = true;
7743 0 : return MATCH_ERROR;
7744 : }
7745 5 : p->where = gfc_get_location_range (&saved_loc, 1,
7746 : &saved_loc, 1,
7747 : &gfc_current_locus);
7748 : }
7749 : else
7750 : {
7751 1 : p->where = gfc_get_location_range (&saved_loc, 1,
7752 : &saved_loc, 1,
7753 : &saved_loc2);
7754 1 : p->u.adj_args.omp_num_args_plus = true;
7755 : }
7756 : }
7757 115 : else if (!p->expr)
7758 : {
7759 99 : match m = gfc_match_expr (&p->expr);
7760 99 : if (m != MATCH_YES)
7761 : {
7762 1 : gfc_error ("expected dummy parameter name, "
7763 : "%<omp_num_args%> or constant positive integer"
7764 : " at %C");
7765 1 : p->u.adj_args.error_p = true;
7766 1 : return MATCH_ERROR;
7767 : }
7768 98 : if (p->expr->expr_type == EXPR_CONSTANT && !have_range)
7769 98 : need_range = true; /* Constant expr but not literal. */
7770 98 : p->where = p->expr->where;
7771 : }
7772 : else
7773 16 : p->where = p->expr->where;
7774 120 : gfc_gobble_whitespace ();
7775 120 : match m = gfc_match (": ");
7776 120 : if (need_range && m != MATCH_YES)
7777 : {
7778 1 : gfc_error ("expected %<:%> at %C");
7779 1 : return MATCH_ERROR;
7780 : }
7781 119 : if (m == MATCH_YES)
7782 : {
7783 6 : p->u.adj_args.range_start = have_range = true;
7784 6 : need_range = false;
7785 6 : continue;
7786 : }
7787 113 : need_range = have_range = false;
7788 113 : if (gfc_match (", ") == MATCH_YES)
7789 38 : continue;
7790 75 : if (gfc_match (") ") == MATCH_YES)
7791 : break;
7792 : }
7793 : }
7794 32 : else if (ccode == clause_append_args)
7795 : {
7796 32 : if (has_append_args)
7797 : {
7798 1 : gfc_error ("%qs clause at %L specified more than once",
7799 : "append_args", &gfc_current_locus);
7800 1 : return MATCH_ERROR;
7801 : }
7802 56 : has_append_args = true;
7803 : gfc_omp_namelist *append_args_last = NULL;
7804 81 : do
7805 : {
7806 56 : gfc_gobble_whitespace ();
7807 56 : if (gfc_match ("interop ") != MATCH_YES)
7808 : {
7809 0 : gfc_error ("expected %<interop%> at %C");
7810 3 : return MATCH_ERROR;
7811 : }
7812 56 : if (gfc_match ("( ") != MATCH_YES)
7813 : {
7814 0 : gfc_error ("expected %<(%> at %C");
7815 0 : return MATCH_ERROR;
7816 : }
7817 :
7818 56 : bool target, targetsync;
7819 56 : char *type_str = NULL;
7820 56 : int type_str_len;
7821 56 : locus loc = gfc_current_locus;
7822 56 : if (gfc_parser_omp_clause_init_modifiers (target, targetsync,
7823 : &type_str, type_str_len,
7824 : false) == MATCH_ERROR)
7825 : return MATCH_ERROR;
7826 :
7827 54 : gfc_omp_namelist *n = gfc_get_omp_namelist();
7828 54 : n->where = loc;
7829 54 : n->u.init.target = target;
7830 54 : n->u.init.targetsync = targetsync;
7831 54 : n->u.init.len = type_str_len;
7832 54 : n->u2.init_interop = type_str;
7833 54 : if (odv->append_args_list)
7834 : {
7835 25 : append_args_last->next = n;
7836 25 : append_args_last = n;
7837 : }
7838 : else
7839 29 : append_args_last = odv->append_args_list = n;
7840 :
7841 54 : gfc_gobble_whitespace ();
7842 54 : if (gfc_match_char (',') == MATCH_YES)
7843 25 : continue;
7844 29 : if (gfc_match_char (')') == MATCH_YES)
7845 : break;
7846 1 : gfc_error ("Expected %<,%> or %<)%> at %C");
7847 1 : return MATCH_ERROR;
7848 25 : }
7849 : while (true);
7850 : }
7851 467 : gfc_gobble_whitespace ();
7852 467 : if (gfc_match_omp_eos () == MATCH_YES)
7853 : break;
7854 109 : gfc_match_char (',');
7855 109 : }
7856 :
7857 364 : if (error_p || (!has_match && !has_adjust_args && !has_append_args))
7858 : {
7859 6 : gfc_error ("expected %<match%>, %<adjust_args%> or %<append_args%> at %C");
7860 6 : return MATCH_ERROR;
7861 : }
7862 :
7863 358 : if (!has_match)
7864 : {
7865 3 : gfc_error ("expected %<match%> clause at %C");
7866 3 : return MATCH_ERROR;
7867 : }
7868 :
7869 : return MATCH_YES;
7870 : }
7871 :
7872 :
7873 : static match
7874 160 : match_omp_metadirective (bool begin_p)
7875 : {
7876 160 : locus old_loc = gfc_current_locus;
7877 160 : gfc_omp_variant *variants_head;
7878 160 : gfc_omp_variant **next_variant = &variants_head;
7879 160 : bool default_seen = false;
7880 :
7881 : /* Parse the context selectors. */
7882 656 : for (;;)
7883 : {
7884 408 : bool default_p = false;
7885 408 : gfc_omp_set_selector *selectors = NULL;
7886 :
7887 408 : gfc_gobble_whitespace ();
7888 408 : if (gfc_match_eos () == MATCH_YES)
7889 : break;
7890 266 : gfc_match_char (',');
7891 266 : gfc_gobble_whitespace ();
7892 :
7893 266 : locus variant_locus = gfc_current_locus;
7894 :
7895 266 : if (gfc_match ("default ( ") == MATCH_YES)
7896 : {
7897 82 : default_p = true;
7898 82 : gfc_warning (OPT_Wdeprecated_openmp,
7899 : "%<default%> clause with metadirective at %L "
7900 : "deprecated since OpenMP 5.2", &variant_locus);
7901 : }
7902 184 : else if (gfc_match ("otherwise ( ") == MATCH_YES)
7903 : default_p = true;
7904 177 : else if (gfc_match ("when ( ") != MATCH_YES)
7905 : {
7906 1 : gfc_error ("expected %<when%>, %<otherwise%>, or %<default%> at %C");
7907 1 : gfc_current_locus = old_loc;
7908 18 : return MATCH_ERROR;
7909 : }
7910 89 : if (default_p && default_seen)
7911 : {
7912 3 : gfc_error ("too many %<otherwise%> or %<default%> clauses "
7913 : "in %<metadirective%> at %C");
7914 3 : gfc_current_locus = old_loc;
7915 3 : return MATCH_ERROR;
7916 : }
7917 262 : else if (default_seen)
7918 : {
7919 1 : gfc_error ("%<otherwise%> or %<default%> clause "
7920 : "must appear last in %<metadirective%> at %C");
7921 1 : gfc_current_locus = old_loc;
7922 1 : return MATCH_ERROR;
7923 : }
7924 :
7925 261 : if (!default_p)
7926 : {
7927 175 : if (gfc_match_omp_context_selector_specification (&selectors)
7928 : != MATCH_YES)
7929 : return MATCH_ERROR;
7930 :
7931 168 : if (gfc_match (" : ") != MATCH_YES)
7932 : {
7933 1 : gfc_error ("expected %<:%> at %C");
7934 1 : gfc_current_locus = old_loc;
7935 1 : return MATCH_ERROR;
7936 : }
7937 :
7938 167 : gfc_commit_symbols ();
7939 : }
7940 :
7941 253 : gfc_matching_omp_context_selector = true;
7942 253 : gfc_statement directive = match_omp_directive ();
7943 253 : gfc_matching_omp_context_selector = false;
7944 :
7945 253 : if (is_omp_declarative_stmt (directive))
7946 0 : sorry_at (gfc_get_location (&gfc_current_locus),
7947 : "declarative directive variants are not supported");
7948 :
7949 253 : if (gfc_error_flag_test ())
7950 : {
7951 2 : gfc_current_locus = old_loc;
7952 2 : return MATCH_ERROR;
7953 : }
7954 :
7955 251 : if (gfc_match (" )") != MATCH_YES)
7956 : {
7957 0 : gfc_error ("Expected %<)%> at %C");
7958 0 : gfc_current_locus = old_loc;
7959 0 : return MATCH_ERROR;
7960 : }
7961 :
7962 251 : gfc_commit_symbols ();
7963 :
7964 251 : if (begin_p
7965 251 : && directive != ST_NONE
7966 251 : && gfc_omp_end_stmt (directive) == ST_NONE)
7967 : {
7968 3 : gfc_error ("variant directive used in OMP BEGIN METADIRECTIVE "
7969 : "at %C must have a corresponding end directive");
7970 3 : gfc_current_locus = old_loc;
7971 3 : return MATCH_ERROR;
7972 : }
7973 :
7974 248 : if (default_p)
7975 : default_seen = true;
7976 :
7977 248 : gfc_omp_variant *omv = gfc_get_omp_variant ();
7978 248 : omv->selectors = selectors;
7979 248 : omv->stmt = directive;
7980 248 : omv->where = variant_locus;
7981 :
7982 248 : if (directive == ST_NONE)
7983 : {
7984 : /* The directive was a 'nothing' directive. */
7985 15 : omv->code = gfc_get_code (EXEC_CONTINUE);
7986 15 : omv->code->ext.omp_clauses = NULL;
7987 : }
7988 : else
7989 : {
7990 233 : omv->code = gfc_get_code (new_st.op);
7991 233 : omv->code->ext.omp_clauses = new_st.ext.omp_clauses;
7992 : /* Prevent the OpenMP clauses from being freed via NEW_ST. */
7993 233 : new_st.ext.omp_clauses = NULL;
7994 : }
7995 :
7996 248 : *next_variant = omv;
7997 248 : next_variant = &omv->next;
7998 248 : }
7999 :
8000 142 : if (gfc_match_omp_eos () != MATCH_YES)
8001 : {
8002 0 : gfc_error ("Unexpected junk after OMP METADIRECTIVE at %C");
8003 0 : gfc_current_locus = old_loc;
8004 0 : return MATCH_ERROR;
8005 : }
8006 :
8007 : /* Add a 'default (nothing)' clause if no default is explicitly given. */
8008 142 : if (!default_seen)
8009 : {
8010 65 : gfc_omp_variant *omv = gfc_get_omp_variant ();
8011 65 : omv->stmt = ST_NONE;
8012 65 : omv->code = gfc_get_code (EXEC_CONTINUE);
8013 65 : omv->code->ext.omp_clauses = NULL;
8014 65 : omv->where = old_loc;
8015 65 : omv->selectors = NULL;
8016 :
8017 65 : *next_variant = omv;
8018 65 : next_variant = &omv->next;
8019 : }
8020 :
8021 142 : new_st.op = EXEC_OMP_METADIRECTIVE;
8022 142 : new_st.ext.omp_variants = variants_head;
8023 :
8024 142 : return MATCH_YES;
8025 : }
8026 :
8027 : match
8028 43 : gfc_match_omp_begin_metadirective (void)
8029 : {
8030 43 : return match_omp_metadirective (true);
8031 : }
8032 :
8033 : match
8034 117 : gfc_match_omp_metadirective (void)
8035 : {
8036 117 : return match_omp_metadirective (false);
8037 : }
8038 :
8039 : /* Match 'omp threadprivate' or 'omp groupprivate'. */
8040 : static match
8041 259 : gfc_match_omp_thread_group_private (bool is_groupprivate)
8042 : {
8043 259 : locus old_loc;
8044 259 : char n[GFC_MAX_SYMBOL_LEN+1];
8045 259 : gfc_symbol *sym;
8046 259 : match m;
8047 259 : gfc_symtree *st;
8048 259 : struct sym_loc_t { gfc_symbol *sym; gfc_common_head *com; locus loc; };
8049 259 : auto_vec<sym_loc_t> syms;
8050 :
8051 259 : old_loc = gfc_current_locus;
8052 :
8053 259 : m = gfc_match (" ( ");
8054 259 : if (m != MATCH_YES)
8055 : return m;
8056 :
8057 369 : for (;;)
8058 : {
8059 314 : locus sym_loc = gfc_current_locus;
8060 314 : m = gfc_match_symbol (&sym, 0);
8061 314 : switch (m)
8062 : {
8063 209 : case MATCH_YES:
8064 209 : if (sym->attr.in_common)
8065 0 : gfc_error_now ("%qs variable at %L is an element of a COMMON block",
8066 : is_groupprivate ? "groupprivate" : "threadprivate",
8067 : &sym_loc);
8068 209 : else if (!is_groupprivate
8069 209 : && !gfc_add_threadprivate (&sym->attr, sym->name, &sym_loc))
8070 16 : goto cleanup;
8071 207 : else if (is_groupprivate)
8072 : {
8073 30 : if (!gfc_add_omp_groupprivate (&sym->attr, sym->name, &sym_loc))
8074 4 : goto cleanup;
8075 26 : syms.safe_push ({sym, nullptr, sym_loc});
8076 : }
8077 203 : goto next_item;
8078 : case MATCH_NO:
8079 : break;
8080 0 : case MATCH_ERROR:
8081 0 : goto cleanup;
8082 : }
8083 :
8084 105 : m = gfc_match (" / %n /", n);
8085 105 : if (m == MATCH_ERROR)
8086 0 : goto cleanup;
8087 105 : if (m == MATCH_NO || n[0] == '\0')
8088 0 : goto syntax;
8089 :
8090 105 : st = gfc_find_symtree (gfc_current_ns->common_root, n);
8091 105 : if (st == NULL)
8092 : {
8093 2 : gfc_error ("COMMON block /%s/ not found at %L", n, &sym_loc);
8094 2 : goto cleanup;
8095 : }
8096 103 : syms.safe_push ({nullptr, st->n.common, sym_loc});
8097 103 : if (is_groupprivate)
8098 30 : st->n.common->omp_groupprivate = 1;
8099 : else
8100 73 : st->n.common->threadprivate = 1;
8101 236 : for (sym = st->n.common->head; sym; sym = sym->common_next)
8102 141 : if (!is_groupprivate
8103 141 : && !gfc_add_threadprivate (&sym->attr, sym->name, &sym_loc))
8104 3 : goto cleanup;
8105 138 : else if (is_groupprivate
8106 138 : && !gfc_add_omp_groupprivate (&sym->attr, sym->name, &sym_loc))
8107 5 : goto cleanup;
8108 :
8109 95 : next_item:
8110 298 : if (gfc_match_char (')') == MATCH_YES)
8111 : break;
8112 55 : if (gfc_match_char (',') != MATCH_YES)
8113 0 : goto syntax;
8114 55 : }
8115 :
8116 243 : if (is_groupprivate)
8117 : {
8118 39 : gfc_omp_clauses *c;
8119 39 : m = gfc_match_omp_clauses (&c, omp_mask (OMP_CLAUSE_DEVICE_TYPE));
8120 39 : if (m == MATCH_ERROR)
8121 0 : return MATCH_ERROR;
8122 :
8123 39 : if (c->device_type == OMP_DEVICE_TYPE_UNSET)
8124 19 : c->device_type = OMP_DEVICE_TYPE_ANY;
8125 :
8126 86 : for (size_t i = 0; i < syms.length (); i++)
8127 47 : if (syms[i].sym)
8128 : {
8129 24 : sym_loc_t &n = syms[i];
8130 24 : if (n.sym->attr.in_common)
8131 0 : gfc_error_now ("Variable %qs at %L is an element of a COMMON "
8132 : "block", n.sym->name, &n.loc);
8133 24 : else if (n.sym->attr.omp_declare_target
8134 23 : || n.sym->attr.omp_declare_target_link)
8135 2 : gfc_error_now ("List item %qs at %L implies OMP DECLARE TARGET "
8136 : "with the LOCAL clause, but it has been specified"
8137 : " with a different clause before",
8138 : n.sym->name, &n.loc);
8139 24 : if (n.sym->attr.omp_device_type != OMP_DEVICE_TYPE_UNSET
8140 5 : && n.sym->attr.omp_device_type != c->device_type)
8141 : {
8142 2 : const char *dt = "any";
8143 2 : if (n.sym->attr.omp_device_type == OMP_DEVICE_TYPE_HOST)
8144 : dt = "host";
8145 0 : else if (n.sym->attr.omp_device_type == OMP_DEVICE_TYPE_NOHOST)
8146 0 : dt = "nohost";
8147 2 : gfc_error_now ("List item %qs at %L set in previous OMP DECLARE "
8148 : "TARGET directive to the different DEVICE_TYPE %qs",
8149 : n.sym->name, &n.loc, dt);
8150 : }
8151 24 : gfc_add_omp_declare_target_local (&n.sym->attr, n.sym->name,
8152 : &n.loc);
8153 24 : n.sym->attr.omp_device_type = c->device_type;
8154 : }
8155 : else /* Common block. */
8156 : {
8157 23 : sym_loc_t &n = syms[i];
8158 23 : if (n.com->omp_declare_target
8159 22 : || n.com->omp_declare_target_link)
8160 2 : gfc_error_now ("List item %</%s/%> at %L implies OMP DECLARE "
8161 : "TARGET with the LOCAL clause, but it has been "
8162 : "specified with a different clause before",
8163 2 : n.com->name, &n.loc);
8164 23 : if (n.com->omp_device_type != OMP_DEVICE_TYPE_UNSET
8165 5 : && n.com->omp_device_type != c->device_type)
8166 : {
8167 2 : const char *dt = "any";
8168 2 : if (n.com->omp_device_type == OMP_DEVICE_TYPE_HOST)
8169 : dt = "host";
8170 0 : else if (n.com->omp_device_type == OMP_DEVICE_TYPE_NOHOST)
8171 0 : dt = "nohost";
8172 2 : gfc_error_now ("List item %qs at %L set in previous OMP DECLARE"
8173 : " TARGET directive to the different DEVICE_TYPE "
8174 2 : "%qs", n.com->name, &n.loc, dt);
8175 : }
8176 23 : n.com->omp_declare_target_local = 1;
8177 23 : n.com->omp_device_type = c->device_type;
8178 46 : for (gfc_symbol *s = n.com->head; s; s = s->common_next)
8179 : {
8180 23 : gfc_add_omp_declare_target_local (&s->attr, s->name, &n.loc);
8181 23 : s->attr.omp_device_type = c->device_type;
8182 : }
8183 : }
8184 39 : free (c);
8185 : }
8186 :
8187 243 : if (gfc_match_omp_eos () != MATCH_YES)
8188 : {
8189 0 : gfc_error ("Unexpected junk after OMP %s at %C",
8190 : is_groupprivate ? "GROUPPRIVATE" : "THREADPRIVATE");
8191 0 : goto cleanup;
8192 : }
8193 :
8194 : return MATCH_YES;
8195 :
8196 0 : syntax:
8197 0 : gfc_error ("Syntax error in !$OMP %s list at %C",
8198 : is_groupprivate ? "GROUPPRIVATE" : "THREADPRIVATE");
8199 :
8200 16 : cleanup:
8201 16 : gfc_current_locus = old_loc;
8202 16 : return MATCH_ERROR;
8203 259 : }
8204 :
8205 :
8206 : match
8207 48 : gfc_match_omp_groupprivate (void)
8208 : {
8209 48 : return gfc_match_omp_thread_group_private (true);
8210 : }
8211 :
8212 :
8213 : match
8214 211 : gfc_match_omp_threadprivate (void)
8215 : {
8216 211 : return gfc_match_omp_thread_group_private (false);
8217 : }
8218 :
8219 :
8220 : match
8221 2208 : gfc_match_omp_parallel (void)
8222 : {
8223 2208 : return match_omp (EXEC_OMP_PARALLEL, OMP_PARALLEL_CLAUSES);
8224 : }
8225 :
8226 :
8227 : match
8228 1203 : gfc_match_omp_parallel_do (void)
8229 : {
8230 1203 : return match_omp (EXEC_OMP_PARALLEL_DO,
8231 1203 : (OMP_PARALLEL_CLAUSES | OMP_DO_CLAUSES)
8232 1203 : & ~(omp_mask (OMP_CLAUSE_NOWAIT)));
8233 : }
8234 :
8235 :
8236 : match
8237 298 : gfc_match_omp_parallel_do_simd (void)
8238 : {
8239 298 : return match_omp (EXEC_OMP_PARALLEL_DO_SIMD,
8240 298 : (OMP_PARALLEL_CLAUSES | OMP_DO_CLAUSES | OMP_SIMD_CLAUSES)
8241 298 : & ~(omp_mask (OMP_CLAUSE_NOWAIT)));
8242 : }
8243 :
8244 :
8245 : match
8246 14 : gfc_match_omp_parallel_masked (void)
8247 : {
8248 14 : return match_omp (EXEC_OMP_PARALLEL_MASKED,
8249 14 : OMP_PARALLEL_CLAUSES | OMP_MASKED_CLAUSES);
8250 : }
8251 :
8252 : match
8253 10 : gfc_match_omp_parallel_masked_taskloop (void)
8254 : {
8255 10 : return match_omp (EXEC_OMP_PARALLEL_MASKED_TASKLOOP,
8256 10 : (OMP_PARALLEL_CLAUSES | OMP_MASKED_CLAUSES
8257 10 : | OMP_TASKLOOP_CLAUSES)
8258 10 : & ~(omp_mask (OMP_CLAUSE_IN_REDUCTION)));
8259 : }
8260 :
8261 : match
8262 13 : gfc_match_omp_parallel_masked_taskloop_simd (void)
8263 : {
8264 13 : return match_omp (EXEC_OMP_PARALLEL_MASKED_TASKLOOP_SIMD,
8265 13 : (OMP_PARALLEL_CLAUSES | OMP_MASKED_CLAUSES
8266 13 : | OMP_TASKLOOP_CLAUSES | OMP_SIMD_CLAUSES)
8267 13 : & ~(omp_mask (OMP_CLAUSE_IN_REDUCTION)));
8268 : }
8269 :
8270 : match
8271 14 : gfc_match_omp_parallel_master (void)
8272 : {
8273 14 : gfc_warning (OPT_Wdeprecated_openmp,
8274 : "%<master%> construct at %C deprecated since OpenMP 5.1, use "
8275 : "%<masked%>");
8276 14 : return match_omp (EXEC_OMP_PARALLEL_MASTER, OMP_PARALLEL_CLAUSES);
8277 : }
8278 :
8279 : match
8280 15 : gfc_match_omp_parallel_master_taskloop (void)
8281 : {
8282 15 : gfc_warning (OPT_Wdeprecated_openmp,
8283 : "%<master%> construct at %C deprecated since OpenMP 5.1, "
8284 : "use %<masked%>");
8285 15 : return match_omp (EXEC_OMP_PARALLEL_MASTER_TASKLOOP,
8286 15 : (OMP_PARALLEL_CLAUSES | OMP_TASKLOOP_CLAUSES)
8287 15 : & ~(omp_mask (OMP_CLAUSE_IN_REDUCTION)));
8288 : }
8289 :
8290 : match
8291 21 : gfc_match_omp_parallel_master_taskloop_simd (void)
8292 : {
8293 21 : gfc_warning (OPT_Wdeprecated_openmp,
8294 : "%<master%> construct at %C deprecated since OpenMP 5.1, "
8295 : "use %<masked%>");
8296 21 : return match_omp (EXEC_OMP_PARALLEL_MASTER_TASKLOOP_SIMD,
8297 21 : (OMP_PARALLEL_CLAUSES | OMP_TASKLOOP_CLAUSES
8298 21 : | OMP_SIMD_CLAUSES)
8299 21 : & ~(omp_mask (OMP_CLAUSE_IN_REDUCTION)));
8300 : }
8301 :
8302 : match
8303 59 : gfc_match_omp_parallel_sections (void)
8304 : {
8305 59 : return match_omp (EXEC_OMP_PARALLEL_SECTIONS,
8306 59 : (OMP_PARALLEL_CLAUSES | OMP_SECTIONS_CLAUSES)
8307 59 : & ~(omp_mask (OMP_CLAUSE_NOWAIT)));
8308 : }
8309 :
8310 :
8311 : match
8312 56 : gfc_match_omp_parallel_workshare (void)
8313 : {
8314 56 : return match_omp (EXEC_OMP_PARALLEL_WORKSHARE, OMP_PARALLEL_CLAUSES);
8315 : }
8316 :
8317 : void
8318 50336 : gfc_check_omp_requires (gfc_namespace *ns, int ref_omp_requires)
8319 : {
8320 50336 : const char *msg = G_("Program unit at %L has OpenMP device "
8321 : "constructs/routines but does not set !$OMP REQUIRES %s "
8322 : "but other program units do");
8323 50336 : if (ns->omp_target_seen
8324 1301 : && (ns->omp_requires & OMP_REQ_TARGET_MASK)
8325 1301 : != (ref_omp_requires & OMP_REQ_TARGET_MASK))
8326 : {
8327 6 : gcc_assert (ns->proc_name);
8328 6 : if ((ref_omp_requires & OMP_REQ_REVERSE_OFFLOAD)
8329 5 : && !(ns->omp_requires & OMP_REQ_REVERSE_OFFLOAD))
8330 4 : gfc_error (msg, &ns->proc_name->declared_at, "REVERSE_OFFLOAD");
8331 6 : if ((ref_omp_requires & OMP_REQ_UNIFIED_ADDRESS)
8332 1 : && !(ns->omp_requires & OMP_REQ_UNIFIED_ADDRESS))
8333 1 : gfc_error (msg, &ns->proc_name->declared_at, "UNIFIED_ADDRESS");
8334 6 : if ((ref_omp_requires & OMP_REQ_UNIFIED_SHARED_MEMORY)
8335 4 : && !(ns->omp_requires & OMP_REQ_UNIFIED_SHARED_MEMORY))
8336 2 : gfc_error (msg, &ns->proc_name->declared_at, "UNIFIED_SHARED_MEMORY");
8337 6 : if ((ref_omp_requires & OMP_REQ_SELF_MAPS)
8338 1 : && !(ns->omp_requires & OMP_REQ_UNIFIED_SHARED_MEMORY))
8339 1 : gfc_error (msg, &ns->proc_name->declared_at, "SELF_MAPS");
8340 : }
8341 50336 : }
8342 :
8343 : bool
8344 127 : gfc_omp_requires_add_clause (gfc_omp_requires_kind clause,
8345 : const char *clause_name, locus *loc,
8346 : const char *module_name)
8347 : {
8348 127 : gfc_namespace *prog_unit = gfc_current_ns;
8349 151 : while (prog_unit->parent)
8350 : {
8351 26 : if (gfc_state_stack->previous
8352 26 : && gfc_state_stack->previous->state == COMP_INTERFACE)
8353 : break;
8354 : /* A submodule namespace may have its parent set to the ancestor module
8355 : for host-association purposes. Do not escape the submodule boundary:
8356 : the submodule itself is the program unit for OMP REQUIRES purposes. */
8357 25 : if (prog_unit->proc_name
8358 25 : && prog_unit->proc_name->attr.flavor == FL_MODULE)
8359 : break;
8360 24 : prog_unit = prog_unit->parent;
8361 : }
8362 :
8363 : /* Requires added after use. */
8364 127 : if (prog_unit->omp_target_seen
8365 24 : && (clause & OMP_REQ_TARGET_MASK)
8366 24 : && !(prog_unit->omp_requires & clause))
8367 : {
8368 0 : if (module_name)
8369 0 : gfc_error ("!$OMP REQUIRES clause %qs specified via module %qs use "
8370 : "at %L comes after using a device construct/routine",
8371 : clause_name, module_name, loc);
8372 : else
8373 0 : gfc_error ("!$OMP REQUIRES clause %qs specified at %L comes after "
8374 : "using a device construct/routine", clause_name, loc);
8375 : return false;
8376 : }
8377 :
8378 : /* Overriding atomic_default_mem_order clause value. */
8379 127 : if ((clause & OMP_REQ_ATOMIC_MEM_ORDER_MASK)
8380 34 : && (prog_unit->omp_requires & OMP_REQ_ATOMIC_MEM_ORDER_MASK)
8381 6 : && (prog_unit->omp_requires & OMP_REQ_ATOMIC_MEM_ORDER_MASK)
8382 6 : != (int) clause)
8383 : {
8384 3 : const char *other;
8385 3 : switch (prog_unit->omp_requires & OMP_REQ_ATOMIC_MEM_ORDER_MASK)
8386 : {
8387 : case OMP_REQ_ATOMIC_MEM_ORDER_SEQ_CST: other = "seq_cst"; break;
8388 0 : case OMP_REQ_ATOMIC_MEM_ORDER_ACQ_REL: other = "acq_rel"; break;
8389 1 : case OMP_REQ_ATOMIC_MEM_ORDER_ACQUIRE: other = "acquire"; break;
8390 1 : case OMP_REQ_ATOMIC_MEM_ORDER_RELAXED: other = "relaxed"; break;
8391 0 : case OMP_REQ_ATOMIC_MEM_ORDER_RELEASE: other = "release"; break;
8392 0 : default: gcc_unreachable ();
8393 : }
8394 :
8395 3 : if (module_name)
8396 0 : gfc_error ("!$OMP REQUIRES clause %<atomic_default_mem_order(%s)%> "
8397 : "specified via module %qs use at %L overrides a previous "
8398 : "%<atomic_default_mem_order(%s)%> (which might be through "
8399 : "using a module)", clause_name, module_name, loc, other);
8400 : else
8401 3 : gfc_error ("!$OMP REQUIRES clause %<atomic_default_mem_order(%s)%> "
8402 : "specified at %L overrides a previous "
8403 : "%<atomic_default_mem_order(%s)%> (which might be through "
8404 : "using a module)", clause_name, loc, other);
8405 : return false;
8406 : }
8407 :
8408 : /* Requires via module not at program-unit level and not repeating clause. */
8409 124 : if (prog_unit != gfc_current_ns && !(prog_unit->omp_requires & clause))
8410 : {
8411 0 : if (clause & OMP_REQ_ATOMIC_MEM_ORDER_MASK)
8412 0 : gfc_error ("!$OMP REQUIRES clause %<atomic_default_mem_order(%s)%> "
8413 : "specified via module %qs use at %L but same clause is "
8414 : "not specified for the program unit", clause_name,
8415 : module_name, loc);
8416 : else
8417 0 : gfc_error ("!$OMP REQUIRES clause %qs specified via module %qs use at "
8418 : "%L but same clause is not specified for the program unit",
8419 : clause_name, module_name, loc);
8420 : return false;
8421 : }
8422 :
8423 124 : if (!gfc_state_stack->previous
8424 116 : || gfc_state_stack->previous->state != COMP_INTERFACE)
8425 123 : prog_unit->omp_requires |= clause;
8426 : return true;
8427 : }
8428 :
8429 : match
8430 99 : gfc_match_omp_requires (void)
8431 : {
8432 99 : static const char *clauses[] = {"reverse_offload",
8433 : "unified_address",
8434 : "unified_shared_memory",
8435 : "self_maps",
8436 : "dynamic_allocators",
8437 : "atomic_default"};
8438 99 : const char *clause = NULL;
8439 99 : int requires_clauses = 0;
8440 99 : bool first = true;
8441 99 : locus old_loc;
8442 :
8443 : /* A submodule's namespace may have its parent pointer set to the ancestor
8444 : module namespace for host-association purposes. The submodule spec part
8445 : is still a valid program-unit spec part for OMP REQUIRES. Only reject
8446 : the directive when we are genuinely nested inside a procedure. */
8447 99 : if (gfc_current_ns->parent
8448 8 : && !(gfc_current_ns->proc_name
8449 8 : && gfc_current_ns->proc_name->attr.flavor == FL_MODULE)
8450 7 : && (!gfc_state_stack->previous
8451 7 : || gfc_state_stack->previous->state != COMP_INTERFACE))
8452 : {
8453 6 : gfc_error ("!$OMP REQUIRES at %C must appear in the specification part "
8454 : "of a program unit");
8455 6 : return MATCH_ERROR;
8456 : }
8457 :
8458 279 : while (true)
8459 : {
8460 186 : old_loc = gfc_current_locus;
8461 186 : gfc_omp_requires_kind requires_clause;
8462 93 : if ((first || gfc_match_char (',') != MATCH_YES)
8463 186 : && (first && gfc_match_space () != MATCH_YES))
8464 0 : goto error;
8465 186 : first = false;
8466 186 : gfc_gobble_whitespace ();
8467 186 : old_loc = gfc_current_locus;
8468 :
8469 186 : if (gfc_match_omp_eos () != MATCH_NO)
8470 : break;
8471 104 : if (gfc_match (clauses[0]) == MATCH_YES)
8472 : {
8473 34 : clause = clauses[0];
8474 34 : requires_clause = OMP_REQ_REVERSE_OFFLOAD;
8475 34 : if (requires_clauses & OMP_REQ_REVERSE_OFFLOAD)
8476 1 : goto duplicate_clause;
8477 : }
8478 70 : else if (gfc_match (clauses[1]) == MATCH_YES)
8479 : {
8480 9 : clause = clauses[1];
8481 9 : requires_clause = OMP_REQ_UNIFIED_ADDRESS;
8482 9 : if (requires_clauses & OMP_REQ_UNIFIED_ADDRESS)
8483 1 : goto duplicate_clause;
8484 : }
8485 61 : else if (gfc_match (clauses[2]) == MATCH_YES)
8486 : {
8487 14 : clause = clauses[2];
8488 14 : requires_clause = OMP_REQ_UNIFIED_SHARED_MEMORY;
8489 14 : if (requires_clauses & OMP_REQ_UNIFIED_SHARED_MEMORY)
8490 1 : goto duplicate_clause;
8491 : }
8492 47 : else if (gfc_match (clauses[3]) == MATCH_YES)
8493 : {
8494 8 : clause = clauses[3];
8495 8 : requires_clause = OMP_REQ_SELF_MAPS;
8496 8 : if (requires_clauses & OMP_REQ_SELF_MAPS)
8497 0 : goto duplicate_clause;
8498 : }
8499 39 : else if (gfc_match (clauses[4]) == MATCH_YES)
8500 : {
8501 7 : clause = clauses[4];
8502 7 : requires_clause = OMP_REQ_DYNAMIC_ALLOCATORS;
8503 7 : if (requires_clauses & OMP_REQ_DYNAMIC_ALLOCATORS)
8504 1 : goto duplicate_clause;
8505 : }
8506 32 : else if (gfc_match ("atomic_default_mem_order (") == MATCH_YES)
8507 : {
8508 31 : clause = clauses[5];
8509 31 : if (requires_clauses & OMP_REQ_ATOMIC_MEM_ORDER_MASK)
8510 1 : goto duplicate_clause;
8511 30 : if (gfc_match (" seq_cst )") == MATCH_YES)
8512 : {
8513 : clause = "seq_cst";
8514 : requires_clause = OMP_REQ_ATOMIC_MEM_ORDER_SEQ_CST;
8515 : }
8516 18 : else if (gfc_match (" acq_rel )") == MATCH_YES)
8517 : {
8518 : clause = "acq_rel";
8519 : requires_clause = OMP_REQ_ATOMIC_MEM_ORDER_ACQ_REL;
8520 : }
8521 12 : else if (gfc_match (" acquire )") == MATCH_YES)
8522 : {
8523 : clause = "acquire";
8524 : requires_clause = OMP_REQ_ATOMIC_MEM_ORDER_ACQUIRE;
8525 : }
8526 9 : else if (gfc_match (" relaxed )") == MATCH_YES)
8527 : {
8528 : clause = "relaxed";
8529 : requires_clause = OMP_REQ_ATOMIC_MEM_ORDER_RELAXED;
8530 : }
8531 5 : else if (gfc_match (" release )") == MATCH_YES)
8532 : {
8533 : clause = "release";
8534 : requires_clause = OMP_REQ_ATOMIC_MEM_ORDER_RELEASE;
8535 : }
8536 : else
8537 : {
8538 2 : gfc_error ("Expected ACQ_REL, ACQUIRE, RELAXED, RELEASE or "
8539 : "SEQ_CST for ATOMIC_DEFAULT_MEM_ORDER clause at %C");
8540 2 : goto error;
8541 : }
8542 : }
8543 : else
8544 1 : goto error;
8545 :
8546 96 : if (!gfc_omp_requires_add_clause (requires_clause, clause, &old_loc, NULL))
8547 3 : goto error;
8548 93 : requires_clauses |= requires_clause;
8549 93 : }
8550 :
8551 82 : if (requires_clauses == 0)
8552 : {
8553 1 : if (!gfc_error_flag_test ())
8554 1 : gfc_error ("Clause expected at %C");
8555 1 : goto error;
8556 : }
8557 : return MATCH_YES;
8558 :
8559 5 : duplicate_clause:
8560 5 : gfc_error ("%qs clause at %L specified more than once", clause, &old_loc);
8561 12 : error:
8562 12 : if (!gfc_error_flag_test ())
8563 1 : gfc_error ("Expected UNIFIED_ADDRESS, UNIFIED_SHARED_MEMORY, SELF_MAPS, "
8564 : "DYNAMIC_ALLOCATORS, REVERSE_OFFLOAD, or "
8565 : "ATOMIC_DEFAULT_MEM_ORDER clause at %L", &old_loc);
8566 : return MATCH_ERROR;
8567 : }
8568 :
8569 :
8570 : match
8571 51 : gfc_match_omp_scan (void)
8572 : {
8573 51 : bool incl;
8574 51 : gfc_omp_clauses *c = gfc_get_omp_clauses ();
8575 51 : gfc_gobble_whitespace ();
8576 51 : if ((incl = (gfc_match ("inclusive") == MATCH_YES))
8577 51 : || gfc_match ("exclusive") == MATCH_YES)
8578 : {
8579 70 : if (gfc_match_omp_variable_list (" (", &c->lists[incl ? OMP_LIST_SCAN_IN
8580 : : OMP_LIST_SCAN_EX],
8581 : false) != MATCH_YES)
8582 : {
8583 0 : gfc_free_omp_clauses (c);
8584 0 : return MATCH_ERROR;
8585 : }
8586 : }
8587 : else
8588 : {
8589 1 : gfc_error ("Expected INCLUSIVE or EXCLUSIVE clause at %C");
8590 1 : gfc_free_omp_clauses (c);
8591 1 : return MATCH_ERROR;
8592 : }
8593 50 : if (gfc_match_omp_eos () != MATCH_YES)
8594 : {
8595 1 : gfc_error ("Unexpected junk after !$OMP SCAN at %C");
8596 1 : gfc_free_omp_clauses (c);
8597 1 : return MATCH_ERROR;
8598 : }
8599 :
8600 49 : new_st.op = EXEC_OMP_SCAN;
8601 49 : new_st.ext.omp_clauses = c;
8602 49 : return MATCH_YES;
8603 : }
8604 :
8605 :
8606 : match
8607 58 : gfc_match_omp_scope (void)
8608 : {
8609 58 : return match_omp (EXEC_OMP_SCOPE, OMP_SCOPE_CLAUSES);
8610 : }
8611 :
8612 :
8613 : match
8614 82 : gfc_match_omp_sections (void)
8615 : {
8616 82 : return match_omp (EXEC_OMP_SECTIONS, OMP_SECTIONS_CLAUSES);
8617 : }
8618 :
8619 :
8620 : match
8621 783 : gfc_match_omp_simd (void)
8622 : {
8623 783 : return match_omp (EXEC_OMP_SIMD, OMP_SIMD_CLAUSES);
8624 : }
8625 :
8626 :
8627 : match
8628 570 : gfc_match_omp_single (void)
8629 : {
8630 570 : return match_omp (EXEC_OMP_SINGLE, OMP_SINGLE_CLAUSES);
8631 : }
8632 :
8633 :
8634 : match
8635 2250 : gfc_match_omp_target (void)
8636 : {
8637 2250 : return match_omp (EXEC_OMP_TARGET, OMP_TARGET_CLAUSES);
8638 : }
8639 :
8640 :
8641 : match
8642 1401 : gfc_match_omp_target_data (void)
8643 : {
8644 1401 : return match_omp (EXEC_OMP_TARGET_DATA, OMP_TARGET_DATA_CLAUSES);
8645 : }
8646 :
8647 :
8648 : match
8649 472 : gfc_match_omp_target_enter_data (void)
8650 : {
8651 472 : return match_omp (EXEC_OMP_TARGET_ENTER_DATA, OMP_TARGET_ENTER_DATA_CLAUSES);
8652 : }
8653 :
8654 :
8655 : match
8656 367 : gfc_match_omp_target_exit_data (void)
8657 : {
8658 367 : return match_omp (EXEC_OMP_TARGET_EXIT_DATA, OMP_TARGET_EXIT_DATA_CLAUSES);
8659 : }
8660 :
8661 :
8662 : match
8663 27 : gfc_match_omp_target_parallel (void)
8664 : {
8665 27 : return match_omp (EXEC_OMP_TARGET_PARALLEL,
8666 27 : (OMP_TARGET_CLAUSES | OMP_PARALLEL_CLAUSES)
8667 27 : & ~(omp_mask (OMP_CLAUSE_COPYIN)));
8668 : }
8669 :
8670 :
8671 : match
8672 81 : gfc_match_omp_target_parallel_do (void)
8673 : {
8674 81 : return match_omp (EXEC_OMP_TARGET_PARALLEL_DO,
8675 81 : (OMP_TARGET_CLAUSES | OMP_PARALLEL_CLAUSES
8676 81 : | OMP_DO_CLAUSES) & ~(omp_mask (OMP_CLAUSE_COPYIN)));
8677 : }
8678 :
8679 :
8680 : match
8681 20 : gfc_match_omp_target_parallel_do_simd (void)
8682 : {
8683 20 : return match_omp (EXEC_OMP_TARGET_PARALLEL_DO_SIMD,
8684 20 : (OMP_TARGET_CLAUSES | OMP_PARALLEL_CLAUSES | OMP_DO_CLAUSES
8685 20 : | OMP_SIMD_CLAUSES) & ~(omp_mask (OMP_CLAUSE_COPYIN)));
8686 : }
8687 :
8688 :
8689 : match
8690 34 : gfc_match_omp_target_simd (void)
8691 : {
8692 34 : return match_omp (EXEC_OMP_TARGET_SIMD,
8693 34 : OMP_TARGET_CLAUSES | OMP_SIMD_CLAUSES);
8694 : }
8695 :
8696 :
8697 : match
8698 76 : gfc_match_omp_target_teams (void)
8699 : {
8700 76 : return match_omp (EXEC_OMP_TARGET_TEAMS,
8701 76 : OMP_TARGET_CLAUSES | OMP_TEAMS_CLAUSES);
8702 : }
8703 :
8704 :
8705 : match
8706 19 : gfc_match_omp_target_teams_distribute (void)
8707 : {
8708 19 : return match_omp (EXEC_OMP_TARGET_TEAMS_DISTRIBUTE,
8709 19 : OMP_TARGET_CLAUSES | OMP_TEAMS_CLAUSES
8710 19 : | OMP_DISTRIBUTE_CLAUSES);
8711 : }
8712 :
8713 :
8714 : match
8715 66 : gfc_match_omp_target_teams_distribute_parallel_do (void)
8716 : {
8717 66 : return match_omp (EXEC_OMP_TARGET_TEAMS_DISTRIBUTE_PARALLEL_DO,
8718 66 : (OMP_TARGET_CLAUSES | OMP_TEAMS_CLAUSES
8719 66 : | OMP_DISTRIBUTE_CLAUSES | OMP_PARALLEL_CLAUSES
8720 66 : | OMP_DO_CLAUSES)
8721 66 : & ~(omp_mask (OMP_CLAUSE_ORDERED))
8722 66 : & ~(omp_mask (OMP_CLAUSE_LINEAR)));
8723 : }
8724 :
8725 :
8726 : match
8727 36 : gfc_match_omp_target_teams_distribute_parallel_do_simd (void)
8728 : {
8729 36 : return match_omp (EXEC_OMP_TARGET_TEAMS_DISTRIBUTE_PARALLEL_DO_SIMD,
8730 36 : (OMP_TARGET_CLAUSES | OMP_TEAMS_CLAUSES
8731 36 : | OMP_DISTRIBUTE_CLAUSES | OMP_PARALLEL_CLAUSES
8732 36 : | OMP_DO_CLAUSES | OMP_SIMD_CLAUSES)
8733 36 : & ~(omp_mask (OMP_CLAUSE_ORDERED)));
8734 : }
8735 :
8736 :
8737 : match
8738 21 : gfc_match_omp_target_teams_distribute_simd (void)
8739 : {
8740 21 : return match_omp (EXEC_OMP_TARGET_TEAMS_DISTRIBUTE_SIMD,
8741 21 : OMP_TARGET_CLAUSES | OMP_TEAMS_CLAUSES
8742 21 : | OMP_DISTRIBUTE_CLAUSES | OMP_SIMD_CLAUSES);
8743 : }
8744 :
8745 :
8746 : match
8747 1727 : gfc_match_omp_target_update (void)
8748 : {
8749 1727 : return match_omp (EXEC_OMP_TARGET_UPDATE, OMP_TARGET_UPDATE_CLAUSES);
8750 : }
8751 :
8752 :
8753 : match
8754 1182 : gfc_match_omp_task (void)
8755 : {
8756 1182 : return match_omp (EXEC_OMP_TASK, OMP_TASK_CLAUSES);
8757 : }
8758 :
8759 :
8760 : match
8761 72 : gfc_match_omp_taskloop (void)
8762 : {
8763 72 : return match_omp (EXEC_OMP_TASKLOOP, OMP_TASKLOOP_CLAUSES);
8764 : }
8765 :
8766 :
8767 : match
8768 40 : gfc_match_omp_taskloop_simd (void)
8769 : {
8770 40 : return match_omp (EXEC_OMP_TASKLOOP_SIMD,
8771 40 : OMP_TASKLOOP_CLAUSES | OMP_SIMD_CLAUSES);
8772 : }
8773 :
8774 :
8775 : match
8776 147 : gfc_match_omp_taskwait (void)
8777 : {
8778 147 : if (gfc_match_omp_eos () == MATCH_YES)
8779 : {
8780 133 : new_st.op = EXEC_OMP_TASKWAIT;
8781 133 : new_st.ext.omp_clauses = NULL;
8782 133 : return MATCH_YES;
8783 : }
8784 14 : return match_omp (EXEC_OMP_TASKWAIT,
8785 14 : omp_mask (OMP_CLAUSE_DEPEND) | OMP_CLAUSE_NOWAIT);
8786 : }
8787 :
8788 :
8789 : match
8790 10 : gfc_match_omp_taskyield (void)
8791 : {
8792 10 : if (gfc_match_omp_eos () != MATCH_YES)
8793 : {
8794 0 : gfc_error ("Unexpected junk after TASKYIELD clause at %C");
8795 0 : return MATCH_ERROR;
8796 : }
8797 10 : new_st.op = EXEC_OMP_TASKYIELD;
8798 10 : new_st.ext.omp_clauses = NULL;
8799 10 : return MATCH_YES;
8800 : }
8801 :
8802 :
8803 : match
8804 218 : gfc_match_omp_teams (void)
8805 : {
8806 218 : return match_omp (EXEC_OMP_TEAMS, OMP_TEAMS_CLAUSES);
8807 : }
8808 :
8809 :
8810 : match
8811 22 : gfc_match_omp_teams_distribute (void)
8812 : {
8813 22 : return match_omp (EXEC_OMP_TEAMS_DISTRIBUTE,
8814 22 : OMP_TEAMS_CLAUSES | OMP_DISTRIBUTE_CLAUSES);
8815 : }
8816 :
8817 :
8818 : match
8819 41 : gfc_match_omp_teams_distribute_parallel_do (void)
8820 : {
8821 41 : return match_omp (EXEC_OMP_TEAMS_DISTRIBUTE_PARALLEL_DO,
8822 41 : (OMP_TEAMS_CLAUSES | OMP_DISTRIBUTE_CLAUSES
8823 41 : | OMP_PARALLEL_CLAUSES | OMP_DO_CLAUSES)
8824 41 : & ~(omp_mask (OMP_CLAUSE_ORDERED)
8825 41 : | OMP_CLAUSE_LINEAR | OMP_CLAUSE_NOWAIT));
8826 : }
8827 :
8828 :
8829 : match
8830 63 : gfc_match_omp_teams_distribute_parallel_do_simd (void)
8831 : {
8832 63 : return match_omp (EXEC_OMP_TEAMS_DISTRIBUTE_PARALLEL_DO_SIMD,
8833 63 : (OMP_TEAMS_CLAUSES | OMP_DISTRIBUTE_CLAUSES
8834 63 : | OMP_PARALLEL_CLAUSES | OMP_DO_CLAUSES
8835 63 : | OMP_SIMD_CLAUSES)
8836 63 : & ~(omp_mask (OMP_CLAUSE_ORDERED) | OMP_CLAUSE_NOWAIT));
8837 : }
8838 :
8839 :
8840 : match
8841 44 : gfc_match_omp_teams_distribute_simd (void)
8842 : {
8843 44 : return match_omp (EXEC_OMP_TEAMS_DISTRIBUTE_SIMD,
8844 44 : OMP_TEAMS_CLAUSES | OMP_DISTRIBUTE_CLAUSES
8845 44 : | OMP_SIMD_CLAUSES);
8846 : }
8847 :
8848 : match
8849 203 : gfc_match_omp_tile (void)
8850 : {
8851 203 : return match_omp (EXEC_OMP_TILE, OMP_TILE_CLAUSES);
8852 : }
8853 :
8854 : match
8855 415 : gfc_match_omp_unroll (void)
8856 : {
8857 415 : return match_omp (EXEC_OMP_UNROLL, OMP_UNROLL_CLAUSES);
8858 : }
8859 :
8860 : match
8861 39 : gfc_match_omp_workshare (void)
8862 : {
8863 39 : return match_omp (EXEC_OMP_WORKSHARE, OMP_WORKSHARE_CLAUSES);
8864 : }
8865 :
8866 :
8867 : match
8868 55 : gfc_match_omp_masked (void)
8869 : {
8870 55 : return match_omp (EXEC_OMP_MASKED, OMP_MASKED_CLAUSES);
8871 : }
8872 :
8873 : match
8874 10 : gfc_match_omp_masked_taskloop (void)
8875 : {
8876 10 : return match_omp (EXEC_OMP_MASKED_TASKLOOP,
8877 10 : OMP_MASKED_CLAUSES | OMP_TASKLOOP_CLAUSES);
8878 : }
8879 :
8880 : match
8881 16 : gfc_match_omp_masked_taskloop_simd (void)
8882 : {
8883 16 : return match_omp (EXEC_OMP_MASKED_TASKLOOP_SIMD,
8884 16 : (OMP_MASKED_CLAUSES | OMP_TASKLOOP_CLAUSES
8885 16 : | OMP_SIMD_CLAUSES));
8886 : }
8887 :
8888 : match
8889 111 : gfc_match_omp_master (void)
8890 : {
8891 111 : gfc_warning (OPT_Wdeprecated_openmp,
8892 : "%<master%> construct at %C deprecated since OpenMP 5.1, "
8893 : "use %<masked%>");
8894 111 : if (gfc_match_omp_eos () != MATCH_YES)
8895 : {
8896 1 : gfc_error ("Unexpected junk after $OMP MASTER statement at %C");
8897 1 : return MATCH_ERROR;
8898 : }
8899 110 : new_st.op = EXEC_OMP_MASTER;
8900 110 : new_st.ext.omp_clauses = NULL;
8901 110 : return MATCH_YES;
8902 : }
8903 :
8904 : match
8905 16 : gfc_match_omp_master_taskloop (void)
8906 : {
8907 16 : gfc_warning (OPT_Wdeprecated_openmp,
8908 : "%<master%> construct at %C deprecated since OpenMP 5.1, "
8909 : "use %<masked%>");
8910 16 : return match_omp (EXEC_OMP_MASTER_TASKLOOP, OMP_TASKLOOP_CLAUSES);
8911 : }
8912 :
8913 : match
8914 21 : gfc_match_omp_master_taskloop_simd (void)
8915 : {
8916 21 : gfc_warning (OPT_Wdeprecated_openmp,
8917 : "%<master%> construct at %C deprecated since OpenMP 5.1, use "
8918 : "%<masked%>");
8919 21 : return match_omp (EXEC_OMP_MASTER_TASKLOOP_SIMD,
8920 21 : OMP_TASKLOOP_CLAUSES | OMP_SIMD_CLAUSES);
8921 : }
8922 :
8923 : match
8924 235 : gfc_match_omp_ordered (void)
8925 : {
8926 235 : return match_omp (EXEC_OMP_ORDERED, OMP_ORDERED_CLAUSES);
8927 : }
8928 :
8929 : match
8930 24 : gfc_match_omp_nothing (void)
8931 : {
8932 24 : if (gfc_match_omp_eos () != MATCH_YES)
8933 : {
8934 1 : gfc_error ("Unexpected junk after $OMP NOTHING statement at %C");
8935 1 : return MATCH_ERROR;
8936 : }
8937 : /* Will use ST_NONE; therefore, no EXEC_OMP_ is needed. */
8938 : return MATCH_YES;
8939 : }
8940 :
8941 : match
8942 317 : gfc_match_omp_ordered_depend (void)
8943 : {
8944 317 : return match_omp (EXEC_OMP_ORDERED, omp_mask (OMP_CLAUSE_DOACROSS));
8945 : }
8946 :
8947 :
8948 : /* omp atomic [clause-list]
8949 : - atomic-clause: read | write | update
8950 : - capture
8951 : - memory-order-clause: seq_cst | acq_rel | release | acquire | relaxed
8952 : - hint(hint-expr)
8953 : - OpenMP 5.1: compare | fail (seq_cst | acquire | relaxed ) | weak
8954 : */
8955 :
8956 : match
8957 2171 : gfc_match_omp_atomic (void)
8958 : {
8959 2171 : gfc_omp_clauses *c;
8960 2171 : locus loc = gfc_current_locus;
8961 :
8962 2171 : if (gfc_match_omp_clauses (&c, OMP_ATOMIC_CLAUSES, true, true) != MATCH_YES)
8963 : return MATCH_ERROR;
8964 :
8965 2153 : if (c->atomic_op == GFC_OMP_ATOMIC_UNSET)
8966 1011 : c->atomic_op = GFC_OMP_ATOMIC_UPDATE;
8967 :
8968 2153 : if (c->capture && c->atomic_op != GFC_OMP_ATOMIC_UPDATE)
8969 3 : gfc_error ("!$OMP ATOMIC at %L with %s clause is incompatible with "
8970 : "READ or WRITE", &loc, "CAPTURE");
8971 2153 : if (c->compare && c->atomic_op != GFC_OMP_ATOMIC_UPDATE)
8972 3 : gfc_error ("!$OMP ATOMIC at %L with %s clause is incompatible with "
8973 : "READ or WRITE", &loc, "COMPARE");
8974 2153 : if (c->fail != OMP_MEMORDER_UNSET && c->atomic_op != GFC_OMP_ATOMIC_UPDATE)
8975 2 : gfc_error ("!$OMP ATOMIC at %L with %s clause is incompatible with "
8976 : "READ or WRITE", &loc, "FAIL");
8977 2153 : if (c->weak && !c->compare)
8978 : {
8979 5 : gfc_error ("!$OMP ATOMIC at %L with %s clause requires %s clause", &loc,
8980 : "WEAK", "COMPARE");
8981 5 : c->weak = false;
8982 : }
8983 :
8984 2153 : if (c->memorder == OMP_MEMORDER_UNSET)
8985 : {
8986 1969 : gfc_namespace *prog_unit = gfc_current_ns;
8987 1969 : while (prog_unit->parent
8988 2525 : && !(prog_unit->proc_name
8989 556 : && prog_unit->proc_name->attr.flavor == FL_MODULE))
8990 556 : prog_unit = prog_unit->parent;
8991 1969 : switch (prog_unit->omp_requires & OMP_REQ_ATOMIC_MEM_ORDER_MASK)
8992 : {
8993 1936 : case 0:
8994 1936 : case OMP_REQ_ATOMIC_MEM_ORDER_RELAXED:
8995 1936 : c->memorder = OMP_MEMORDER_RELAXED;
8996 1936 : break;
8997 7 : case OMP_REQ_ATOMIC_MEM_ORDER_SEQ_CST:
8998 7 : c->memorder = OMP_MEMORDER_SEQ_CST;
8999 7 : break;
9000 16 : case OMP_REQ_ATOMIC_MEM_ORDER_ACQ_REL:
9001 16 : if (c->capture)
9002 5 : c->memorder = OMP_MEMORDER_ACQ_REL;
9003 11 : else if (c->atomic_op == GFC_OMP_ATOMIC_READ)
9004 3 : c->memorder = OMP_MEMORDER_ACQUIRE;
9005 : else
9006 8 : c->memorder = OMP_MEMORDER_RELEASE;
9007 : break;
9008 5 : case OMP_REQ_ATOMIC_MEM_ORDER_ACQUIRE:
9009 5 : if (c->atomic_op == GFC_OMP_ATOMIC_WRITE)
9010 : {
9011 1 : gfc_error ("!$OMP ATOMIC WRITE at %L incompatible with "
9012 : "ACQUIRES clause implicitly provided by a "
9013 : "REQUIRES directive", &loc);
9014 1 : c->memorder = OMP_MEMORDER_SEQ_CST;
9015 : }
9016 : else
9017 4 : c->memorder = OMP_MEMORDER_ACQUIRE;
9018 : break;
9019 5 : case OMP_REQ_ATOMIC_MEM_ORDER_RELEASE:
9020 5 : if (c->atomic_op == GFC_OMP_ATOMIC_READ)
9021 : {
9022 1 : gfc_error ("!$OMP ATOMIC READ at %L incompatible with "
9023 : "RELEASE clause implicitly provided by a "
9024 : "REQUIRES directive", &loc);
9025 1 : c->memorder = OMP_MEMORDER_SEQ_CST;
9026 : }
9027 : else
9028 4 : c->memorder = OMP_MEMORDER_RELEASE;
9029 : break;
9030 0 : default:
9031 0 : gcc_unreachable ();
9032 : }
9033 : }
9034 : else
9035 184 : switch (c->atomic_op)
9036 : {
9037 29 : case GFC_OMP_ATOMIC_READ:
9038 29 : if (c->memorder == OMP_MEMORDER_RELEASE)
9039 : {
9040 1 : gfc_error ("!$OMP ATOMIC READ at %L incompatible with "
9041 : "RELEASE clause", &loc);
9042 1 : c->memorder = OMP_MEMORDER_SEQ_CST;
9043 : }
9044 28 : else if (c->memorder == OMP_MEMORDER_ACQ_REL)
9045 1 : c->memorder = OMP_MEMORDER_ACQUIRE;
9046 : break;
9047 35 : case GFC_OMP_ATOMIC_WRITE:
9048 35 : if (c->memorder == OMP_MEMORDER_ACQUIRE)
9049 : {
9050 1 : gfc_error ("!$OMP ATOMIC WRITE at %L incompatible with "
9051 : "ACQUIRE clause", &loc);
9052 1 : c->memorder = OMP_MEMORDER_SEQ_CST;
9053 : }
9054 34 : else if (c->memorder == OMP_MEMORDER_ACQ_REL)
9055 1 : c->memorder = OMP_MEMORDER_RELEASE;
9056 : break;
9057 : default:
9058 : break;
9059 : }
9060 2153 : gfc_error_check ();
9061 2153 : new_st.ext.omp_clauses = c;
9062 2153 : new_st.op = EXEC_OMP_ATOMIC;
9063 2153 : return MATCH_YES;
9064 : }
9065 :
9066 :
9067 : /* acc atomic [ read | write | update | capture] */
9068 :
9069 : match
9070 552 : gfc_match_oacc_atomic (void)
9071 : {
9072 552 : gfc_omp_clauses *c = gfc_get_omp_clauses ();
9073 552 : c->atomic_op = GFC_OMP_ATOMIC_UPDATE;
9074 552 : c->memorder = OMP_MEMORDER_RELAXED;
9075 552 : gfc_gobble_whitespace ();
9076 552 : if (gfc_match ("update") == MATCH_YES)
9077 : ;
9078 373 : else if (gfc_match ("read") == MATCH_YES)
9079 17 : c->atomic_op = GFC_OMP_ATOMIC_READ;
9080 356 : else if (gfc_match ("write") == MATCH_YES)
9081 13 : c->atomic_op = GFC_OMP_ATOMIC_WRITE;
9082 343 : else if (gfc_match ("capture") == MATCH_YES)
9083 319 : c->capture = true;
9084 552 : gfc_gobble_whitespace ();
9085 552 : if (gfc_match_omp_eos () != MATCH_YES)
9086 : {
9087 9 : gfc_error ("Unexpected junk after !$ACC ATOMIC statement at %C");
9088 9 : gfc_free_omp_clauses (c);
9089 9 : return MATCH_ERROR;
9090 : }
9091 543 : new_st.ext.omp_clauses = c;
9092 543 : new_st.op = EXEC_OACC_ATOMIC;
9093 543 : return MATCH_YES;
9094 : }
9095 :
9096 :
9097 : match
9098 614 : gfc_match_omp_barrier (void)
9099 : {
9100 614 : if (gfc_match_omp_eos () != MATCH_YES)
9101 : {
9102 0 : gfc_error ("Unexpected junk after $OMP BARRIER statement at %C");
9103 0 : return MATCH_ERROR;
9104 : }
9105 614 : new_st.op = EXEC_OMP_BARRIER;
9106 614 : new_st.ext.omp_clauses = NULL;
9107 614 : return MATCH_YES;
9108 : }
9109 :
9110 :
9111 : match
9112 188 : gfc_match_omp_taskgroup (void)
9113 : {
9114 188 : return match_omp (EXEC_OMP_TASKGROUP, OMP_TASKGROUP_CLAUSES);
9115 : }
9116 :
9117 :
9118 : static enum gfc_omp_cancel_kind
9119 494 : gfc_match_omp_cancel_kind (void)
9120 : {
9121 494 : if (gfc_match_space () != MATCH_YES)
9122 : return OMP_CANCEL_UNKNOWN;
9123 494 : if (gfc_match ("parallel") == MATCH_YES)
9124 : return OMP_CANCEL_PARALLEL;
9125 352 : if (gfc_match ("sections") == MATCH_YES)
9126 : return OMP_CANCEL_SECTIONS;
9127 253 : if (gfc_match ("do") == MATCH_YES)
9128 : return OMP_CANCEL_DO;
9129 123 : if (gfc_match ("taskgroup") == MATCH_YES)
9130 121 : return OMP_CANCEL_TASKGROUP;
9131 : return OMP_CANCEL_UNKNOWN;
9132 : }
9133 :
9134 :
9135 : match
9136 320 : gfc_match_omp_cancel (void)
9137 : {
9138 320 : gfc_omp_clauses *c;
9139 320 : enum gfc_omp_cancel_kind kind = gfc_match_omp_cancel_kind ();
9140 320 : if (kind == OMP_CANCEL_UNKNOWN)
9141 : return MATCH_ERROR;
9142 320 : if (gfc_match_omp_clauses (&c, omp_mask (OMP_CLAUSE_IF), false) != MATCH_YES)
9143 : return MATCH_ERROR;
9144 317 : c->cancel = kind;
9145 317 : new_st.op = EXEC_OMP_CANCEL;
9146 317 : new_st.ext.omp_clauses = c;
9147 317 : return MATCH_YES;
9148 : }
9149 :
9150 :
9151 : match
9152 174 : gfc_match_omp_cancellation_point (void)
9153 : {
9154 174 : gfc_omp_clauses *c;
9155 174 : enum gfc_omp_cancel_kind kind = gfc_match_omp_cancel_kind ();
9156 174 : if (kind == OMP_CANCEL_UNKNOWN)
9157 : {
9158 2 : gfc_error ("Expected construct-type PARALLEL, SECTIONS, DO or TASKGROUP "
9159 : "in $OMP CANCELLATION POINT statement at %C");
9160 2 : return MATCH_ERROR;
9161 : }
9162 172 : if (gfc_match_omp_eos () != MATCH_YES)
9163 : {
9164 0 : gfc_error ("Unexpected junk after $OMP CANCELLATION POINT statement "
9165 : "at %C");
9166 0 : return MATCH_ERROR;
9167 : }
9168 172 : c = gfc_get_omp_clauses ();
9169 172 : c->cancel = kind;
9170 172 : new_st.op = EXEC_OMP_CANCELLATION_POINT;
9171 172 : new_st.ext.omp_clauses = c;
9172 172 : return MATCH_YES;
9173 : }
9174 :
9175 :
9176 : match
9177 2734 : gfc_match_omp_end_nowait (void)
9178 : {
9179 2734 : bool nowait = false;
9180 2734 : if (gfc_match ("% nowait") == MATCH_YES)
9181 258 : nowait = true;
9182 2734 : if (gfc_match_omp_eos () != MATCH_YES)
9183 : {
9184 4 : if (nowait)
9185 3 : gfc_error ("Unexpected junk after NOWAIT clause at %C");
9186 : else
9187 1 : gfc_error ("Unexpected junk at %C");
9188 : return MATCH_ERROR;
9189 : }
9190 2730 : new_st.op = EXEC_OMP_END_NOWAIT;
9191 2730 : new_st.ext.omp_bool = nowait;
9192 2730 : return MATCH_YES;
9193 : }
9194 :
9195 :
9196 : match
9197 566 : gfc_match_omp_end_single (void)
9198 : {
9199 566 : gfc_omp_clauses *c;
9200 566 : if (gfc_match_omp_clauses (&c, omp_mask (OMP_CLAUSE_COPYPRIVATE)
9201 : | OMP_CLAUSE_NOWAIT) != MATCH_YES)
9202 : return MATCH_ERROR;
9203 566 : new_st.op = EXEC_OMP_END_SINGLE;
9204 566 : new_st.ext.omp_clauses = c;
9205 566 : return MATCH_YES;
9206 : }
9207 :
9208 :
9209 : static bool
9210 37143 : oacc_is_loop (gfc_code *code)
9211 : {
9212 37143 : return code->op == EXEC_OACC_PARALLEL_LOOP
9213 : || code->op == EXEC_OACC_KERNELS_LOOP
9214 20088 : || code->op == EXEC_OACC_SERIAL_LOOP
9215 13457 : || code->op == EXEC_OACC_LOOP;
9216 : }
9217 :
9218 : static void
9219 5982 : resolve_scalar_int_expr (gfc_expr *expr, const char *clause)
9220 : {
9221 5982 : if (!gfc_resolve_expr (expr)
9222 5982 : || expr->ts.type != BT_INTEGER
9223 11893 : || expr->rank != 0)
9224 89 : gfc_error ("%s clause at %L requires a scalar INTEGER expression",
9225 : clause, &expr->where);
9226 5982 : }
9227 :
9228 : static void
9229 4090 : resolve_positive_int_expr (gfc_expr *expr, const char *clause)
9230 : {
9231 4090 : resolve_scalar_int_expr (expr, clause);
9232 4090 : if (expr->expr_type == EXPR_CONSTANT
9233 3660 : && expr->ts.type == BT_INTEGER
9234 3627 : && mpz_sgn (expr->value.integer) <= 0)
9235 54 : gfc_warning ((flag_openmp || flag_openmp_simd) ? OPT_Wopenmp : 0,
9236 : "INTEGER expression of %s clause at %L must be positive",
9237 : clause, &expr->where);
9238 4090 : }
9239 :
9240 : static void
9241 86 : resolve_nonnegative_int_expr (gfc_expr *expr, const char *clause)
9242 : {
9243 86 : resolve_scalar_int_expr (expr, clause);
9244 86 : if (expr->expr_type == EXPR_CONSTANT
9245 13 : && expr->ts.type == BT_INTEGER
9246 11 : && mpz_sgn (expr->value.integer) < 0)
9247 6 : gfc_warning ((flag_openmp || flag_openmp_simd) ? OPT_Wopenmp : 0,
9248 : "INTEGER expression of %s clause at %L must be non-negative",
9249 : clause, &expr->where);
9250 86 : }
9251 :
9252 : /* Emits error when symbol is pointer, cray pointer or cray pointee
9253 : of derived of polymorphic type. */
9254 :
9255 : static void
9256 98 : check_symbol_not_pointer (gfc_symbol *sym, locus loc, const char *name)
9257 : {
9258 98 : if (sym->ts.type == BT_DERIVED && sym->attr.cray_pointer)
9259 0 : gfc_error ("Cray pointer object %qs of derived type in %s clause at %L",
9260 : sym->name, name, &loc);
9261 98 : if (sym->ts.type == BT_DERIVED && sym->attr.cray_pointee)
9262 0 : gfc_error ("Cray pointee object %qs of derived type in %s clause at %L",
9263 : sym->name, name, &loc);
9264 :
9265 98 : if ((sym->ts.type == BT_ASSUMED && sym->attr.pointer)
9266 98 : || (sym->ts.type == BT_CLASS && CLASS_DATA (sym)
9267 0 : && CLASS_DATA (sym)->attr.pointer))
9268 0 : gfc_error ("POINTER object %qs of polymorphic type in %s clause at %L",
9269 : sym->name, name, &loc);
9270 98 : if ((sym->ts.type == BT_ASSUMED && sym->attr.cray_pointer)
9271 98 : || (sym->ts.type == BT_CLASS && CLASS_DATA (sym)
9272 0 : && CLASS_DATA (sym)->attr.cray_pointer))
9273 0 : gfc_error ("Cray pointer object %qs of polymorphic type in %s clause at %L",
9274 : sym->name, name, &loc);
9275 98 : if ((sym->ts.type == BT_ASSUMED && sym->attr.cray_pointee)
9276 98 : || (sym->ts.type == BT_CLASS && CLASS_DATA (sym)
9277 0 : && CLASS_DATA (sym)->attr.cray_pointee))
9278 0 : gfc_error ("Cray pointee object %qs of polymorphic type in %s clause at %L",
9279 : sym->name, name, &loc);
9280 98 : }
9281 :
9282 : /* Emits error when symbol represents assumed size/rank array. */
9283 :
9284 : static void
9285 14844 : check_array_not_assumed (gfc_symbol *sym, locus loc, const char *name)
9286 : {
9287 14844 : if (sym->as && sym->as->type == AS_ASSUMED_SIZE)
9288 13 : gfc_error ("Assumed size array %qs in %s clause at %L",
9289 : sym->name, name, &loc);
9290 14844 : if (sym->as && sym->as->type == AS_ASSUMED_RANK)
9291 11 : gfc_error ("Assumed rank array %qs in %s clause at %L",
9292 : sym->name, name, &loc);
9293 14844 : }
9294 :
9295 : static void
9296 5850 : resolve_oacc_data_clauses (gfc_symbol *sym, locus loc, const char *name)
9297 : {
9298 0 : check_array_not_assumed (sym, loc, name);
9299 0 : }
9300 :
9301 : static void
9302 65 : resolve_oacc_deviceptr_clause (gfc_symbol *sym, locus loc, const char *name)
9303 : {
9304 65 : if (sym->attr.pointer
9305 64 : || (sym->ts.type == BT_CLASS && CLASS_DATA (sym)
9306 0 : && CLASS_DATA (sym)->attr.class_pointer))
9307 1 : gfc_error ("POINTER object %qs in %s clause at %L",
9308 : sym->name, name, &loc);
9309 65 : if (sym->attr.cray_pointer
9310 63 : || (sym->ts.type == BT_CLASS && CLASS_DATA (sym)
9311 0 : && CLASS_DATA (sym)->attr.cray_pointer))
9312 2 : gfc_error ("Cray pointer object %qs in %s clause at %L",
9313 : sym->name, name, &loc);
9314 65 : if (sym->attr.cray_pointee
9315 63 : || (sym->ts.type == BT_CLASS && CLASS_DATA (sym)
9316 0 : && CLASS_DATA (sym)->attr.cray_pointee))
9317 2 : gfc_error ("Cray pointee object %qs in %s clause at %L",
9318 : sym->name, name, &loc);
9319 65 : if (sym->attr.allocatable
9320 64 : || (sym->ts.type == BT_CLASS && CLASS_DATA (sym)
9321 0 : && CLASS_DATA (sym)->attr.allocatable))
9322 1 : gfc_error ("ALLOCATABLE object %qs in %s clause at %L",
9323 : sym->name, name, &loc);
9324 65 : if (sym->attr.value)
9325 1 : gfc_error ("VALUE object %qs in %s clause at %L",
9326 : sym->name, name, &loc);
9327 65 : check_array_not_assumed (sym, loc, name);
9328 65 : }
9329 :
9330 :
9331 : struct resolve_omp_udr_callback_data
9332 : {
9333 : gfc_symbol *sym1, *sym2;
9334 : };
9335 :
9336 :
9337 : static int
9338 1413 : resolve_omp_udr_callback (gfc_expr **e, int *, void *data)
9339 : {
9340 1413 : struct resolve_omp_udr_callback_data *rcd
9341 : = (struct resolve_omp_udr_callback_data *) data;
9342 1413 : if ((*e)->expr_type == EXPR_VARIABLE
9343 801 : && ((*e)->symtree->n.sym == rcd->sym1
9344 255 : || (*e)->symtree->n.sym == rcd->sym2))
9345 : {
9346 801 : gfc_ref *ref = gfc_get_ref ();
9347 801 : ref->type = REF_ARRAY;
9348 801 : ref->u.ar.where = (*e)->where;
9349 801 : ref->u.ar.as = (*e)->symtree->n.sym->as;
9350 801 : ref->u.ar.type = AR_FULL;
9351 801 : ref->u.ar.dimen = 0;
9352 801 : ref->next = (*e)->ref;
9353 801 : (*e)->ref = ref;
9354 : }
9355 1413 : return 0;
9356 : }
9357 :
9358 :
9359 : static int
9360 3008 : resolve_omp_udr_callback2 (gfc_expr **e, int *, void *)
9361 : {
9362 3008 : if ((*e)->expr_type == EXPR_FUNCTION
9363 360 : && (*e)->value.function.isym == NULL)
9364 : {
9365 174 : gfc_symbol *sym = (*e)->symtree->n.sym;
9366 174 : if (!sym->attr.intrinsic
9367 174 : && sym->attr.if_source == IFSRC_UNKNOWN)
9368 4 : gfc_error ("Implicitly declared function %s used in "
9369 : "!$OMP DECLARE REDUCTION at %L", sym->name, &(*e)->where);
9370 : }
9371 3008 : return 0;
9372 : }
9373 :
9374 :
9375 : static gfc_code *
9376 802 : resolve_omp_udr_clause (gfc_omp_namelist *n, gfc_namespace *ns,
9377 : gfc_symbol *sym1, gfc_symbol *sym2)
9378 : {
9379 802 : gfc_code *copy;
9380 802 : gfc_symbol sym1_copy, sym2_copy;
9381 :
9382 802 : if (ns->code->op == EXEC_ASSIGN)
9383 : {
9384 630 : copy = gfc_get_code (EXEC_ASSIGN);
9385 630 : copy->expr1 = gfc_copy_expr (ns->code->expr1);
9386 630 : copy->expr2 = gfc_copy_expr (ns->code->expr2);
9387 : }
9388 : else
9389 : {
9390 172 : copy = gfc_get_code (EXEC_CALL);
9391 172 : copy->symtree = ns->code->symtree;
9392 172 : copy->ext.actual = gfc_copy_actual_arglist (ns->code->ext.actual);
9393 : }
9394 802 : copy->loc = ns->code->loc;
9395 802 : sym1_copy = *sym1;
9396 802 : sym2_copy = *sym2;
9397 802 : *sym1 = *n->sym;
9398 802 : *sym2 = *n->sym;
9399 802 : sym1->name = sym1_copy.name;
9400 802 : sym2->name = sym2_copy.name;
9401 802 : ns->proc_name = ns->parent->proc_name;
9402 802 : if (n->sym->attr.dimension)
9403 : {
9404 348 : struct resolve_omp_udr_callback_data rcd;
9405 348 : rcd.sym1 = sym1;
9406 348 : rcd.sym2 = sym2;
9407 348 : gfc_code_walker (©, gfc_dummy_code_callback,
9408 : resolve_omp_udr_callback, &rcd);
9409 : }
9410 802 : gfc_resolve_code (copy, gfc_current_ns);
9411 802 : if (copy->op == EXEC_CALL && copy->resolved_isym == NULL)
9412 : {
9413 172 : gfc_symbol *sym = copy->resolved_sym;
9414 172 : if (sym
9415 170 : && !sym->attr.intrinsic
9416 170 : && sym->attr.if_source == IFSRC_UNKNOWN)
9417 4 : gfc_error ("Implicitly declared subroutine %s used in "
9418 : "!$OMP DECLARE REDUCTION at %L", sym->name,
9419 : ©->loc);
9420 : }
9421 802 : gfc_code_walker (©, gfc_dummy_code_callback,
9422 : resolve_omp_udr_callback2, NULL);
9423 802 : *sym1 = sym1_copy;
9424 802 : *sym2 = sym2_copy;
9425 802 : return copy;
9426 : }
9427 :
9428 : /* Assume that a constant expression in the range 1 (omp_default_mem_alloc)
9429 : to GOMP_OMP_PREDEF_ALLOC_MAX, or GOMP_OMPX_PREDEF_ALLOC_MIN to
9430 : GOMP_OMPX_PREDEF_ALLOC_MAX is fine. The original symbol name is already
9431 : lost during matching via gfc_match_expr. */
9432 : static bool
9433 130 : is_predefined_allocator (gfc_expr *expr)
9434 : {
9435 130 : return (gfc_resolve_expr (expr)
9436 129 : && expr->rank == 0
9437 124 : && expr->ts.type == BT_INTEGER
9438 119 : && expr->ts.kind == gfc_c_intptr_kind
9439 114 : && expr->expr_type == EXPR_CONSTANT
9440 239 : && ((mpz_sgn (expr->value.integer) > 0
9441 107 : && mpz_cmp_si (expr->value.integer,
9442 : GOMP_OMP_PREDEF_ALLOC_MAX) <= 0)
9443 4 : || (mpz_cmp_si (expr->value.integer,
9444 : GOMP_OMPX_PREDEF_ALLOC_MIN) >= 0
9445 1 : && mpz_cmp_si (expr->value.integer,
9446 130 : GOMP_OMPX_PREDEF_ALLOC_MAX) <= 0)));
9447 : }
9448 :
9449 : /* Resolve declarative ALLOCATE statement. Note: Common block vars only appear
9450 : as /block/ not individual, which is ensured during parsing. */
9451 :
9452 : void
9453 62 : gfc_resolve_omp_allocate (gfc_namespace *ns, gfc_omp_namelist *list)
9454 : {
9455 278 : for (gfc_omp_namelist *n = list; n; n = n->next)
9456 : {
9457 216 : if (n->sym->attr.result || n->sym->result == n->sym)
9458 : {
9459 1 : gfc_error ("Unexpected function-result variable %qs at %L in "
9460 : "declarative !$OMP ALLOCATE", n->sym->name, &n->where);
9461 30 : continue;
9462 : }
9463 215 : if (ns->omp_allocate->sym->attr.proc_pointer)
9464 : {
9465 0 : gfc_error ("Procedure pointer %qs not supported with !$OMP "
9466 : "ALLOCATE at %L", n->sym->name, &n->where);
9467 0 : continue;
9468 : }
9469 215 : if (n->sym->attr.flavor != FL_VARIABLE)
9470 : {
9471 3 : gfc_error ("Argument %qs at %L to declarative !$OMP ALLOCATE "
9472 : "directive must be a variable", n->sym->name,
9473 : &n->where);
9474 3 : continue;
9475 : }
9476 212 : if (ns != n->sym->ns || n->sym->attr.use_assoc || n->sym->attr.imported)
9477 : {
9478 8 : gfc_error ("Argument %qs at %L to declarative !$OMP ALLOCATE shall be"
9479 : " in the same scope as the variable declaration",
9480 : n->sym->name, &n->where);
9481 8 : continue;
9482 : }
9483 204 : if (n->sym->attr.dummy)
9484 : {
9485 3 : gfc_error ("Unexpected dummy argument %qs as argument at %L to "
9486 : "declarative !$OMP ALLOCATE", n->sym->name, &n->where);
9487 3 : continue;
9488 : }
9489 201 : if (n->sym->attr.codimension)
9490 : {
9491 0 : gfc_error ("Unexpected coarray argument %qs as argument at %L to "
9492 : "declarative !$OMP ALLOCATE", n->sym->name, &n->where);
9493 0 : continue;
9494 : }
9495 201 : if (n->sym->attr.omp_allocate)
9496 : {
9497 5 : if (n->sym->attr.in_common)
9498 : {
9499 1 : gfc_error ("Duplicated common block %</%s/%> in !$OMP ALLOCATE "
9500 1 : "at %L", n->sym->common_head->name, &n->where);
9501 3 : while (n->next && n->next->sym
9502 3 : && n->sym->common_head == n->next->sym->common_head)
9503 : n = n->next;
9504 : }
9505 : else
9506 4 : gfc_error ("Duplicated variable %qs in !$OMP ALLOCATE at %L",
9507 : n->sym->name, &n->where);
9508 5 : continue;
9509 : }
9510 : /* For 'equivalence(a,b)', a 'union_type {<type> a,b} equiv.0' is created
9511 : with a value expression for 'a' as 'equiv.0.a' (likewise for b); while
9512 : this can be handled, EQUIVALENCE is marked as obsolescent since Fortran
9513 : 2018 and also not widely used. However, it could be supported,
9514 : if needed. */
9515 196 : if (n->sym->attr.in_equivalence)
9516 : {
9517 2 : gfc_error ("Sorry, EQUIVALENCE object %qs not supported with !$OMP "
9518 : "ALLOCATE at %L", n->sym->name, &n->where);
9519 2 : continue;
9520 : }
9521 : /* Similar for Cray pointer/pointee - they could be implemented but as
9522 : common vendor extension but nowadays rarely used and requiring
9523 : -fcray-pointer, there is no need to support them. */
9524 194 : if (n->sym->attr.cray_pointer || n->sym->attr.cray_pointee)
9525 : {
9526 2 : gfc_error ("Sorry, Cray pointers and pointees such as %qs are not "
9527 : "supported with !$OMP ALLOCATE at %L",
9528 : n->sym->name, &n->where);
9529 2 : continue;
9530 : }
9531 192 : n->sym->attr.omp_allocate = 1;
9532 192 : if ((n->sym->ts.type == BT_CLASS && n->sym->attr.class_ok
9533 0 : && CLASS_DATA (n->sym)->attr.allocatable)
9534 192 : || (n->sym->ts.type != BT_CLASS && n->sym->attr.allocatable))
9535 1 : gfc_error ("Unexpected allocatable variable %qs at %L in declarative "
9536 : "!$OMP ALLOCATE directive", n->sym->name, &n->where);
9537 191 : else if ((n->sym->ts.type == BT_CLASS && n->sym->attr.class_ok
9538 0 : && CLASS_DATA (n->sym)->attr.class_pointer)
9539 191 : || (n->sym->ts.type != BT_CLASS && n->sym->attr.pointer))
9540 1 : gfc_error ("Unexpected pointer variable %qs at %L in declarative "
9541 : "!$OMP ALLOCATE directive", n->sym->name, &n->where);
9542 192 : HOST_WIDE_INT alignment = 0;
9543 198 : if (n->u.align
9544 192 : && (!gfc_resolve_expr (n->u.align)
9545 27 : || n->u.align->ts.type != BT_INTEGER
9546 26 : || n->u.align->rank != 0
9547 24 : || n->u.align->expr_type != EXPR_CONSTANT
9548 23 : || gfc_extract_hwi (n->u.align, &alignment)
9549 23 : || !pow2p_hwi (alignment)))
9550 : {
9551 6 : gfc_error ("ALIGN requires a scalar positive constant integer "
9552 : "alignment expression at %L that is a power of two",
9553 6 : &n->u.align->where);
9554 6 : while (n->sym->attr.in_common && n->next && n->next->sym
9555 6 : && n->sym->common_head == n->next->sym->common_head)
9556 : n = n->next;
9557 6 : continue;
9558 : }
9559 186 : if (n->sym->attr.in_common || n->sym->attr.save || n->sym->ns->save_all
9560 63 : || (n->sym->ns->proc_name
9561 63 : && (n->sym->ns->proc_name->attr.flavor == FL_PROGRAM
9562 55 : || n->sym->ns->proc_name->attr.flavor == FL_MODULE
9563 55 : || n->sym->ns->proc_name->attr.flavor == FL_BLOCK_DATA)))
9564 : {
9565 131 : bool com = n->sym->attr.in_common;
9566 131 : if (!n->u2.allocator)
9567 1 : gfc_error ("An ALLOCATOR clause is required as the list item "
9568 : "%<%s%s%s%> at %L has the SAVE attribute", com ? "/" : "",
9569 0 : com ? n->sym->common_head->name : n->sym->name,
9570 : com ? "/" : "", &n->where);
9571 130 : else if (!is_predefined_allocator (n->u2.allocator))
9572 24 : gfc_error ("Predefined allocator required in ALLOCATOR clause at %L"
9573 : " as the list item %<%s%s%s%> at %L has the SAVE attribute",
9574 24 : &n->u2.allocator->where, com ? "/" : "",
9575 24 : com ? n->sym->common_head->name : n->sym->name,
9576 : com ? "/" : "", &n->where);
9577 : /* Static variables may not use omp_cgroup_mem_alloc (6),
9578 : omp_pteam_mem_alloc (7), or omp_thread_mem_alloc (8). */
9579 106 : else if (mpz_cmp_si (n->u2.allocator->value.integer,
9580 : 6 /* cgroup */) >= 0
9581 34 : && mpz_cmp_si (n->u2.allocator->value.integer,
9582 : 8 /* thread */) <= 0)
9583 : {
9584 33 : STATIC_ASSERT (GOMP_OMP_PREDEF_ALLOC_CGROUP == 6);
9585 33 : STATIC_ASSERT (GOMP_OMP_PREDEF_ALLOC_PTEAM == 7);
9586 33 : STATIC_ASSERT (GOMP_OMP_PREDEF_ALLOC_THREAD == 8);
9587 33 : const char *alloc_name[] = {"omp_cgroup_mem_alloc",
9588 : "omp_pteam_mem_alloc",
9589 : "omp_thread_mem_alloc" };
9590 33 : gfc_error ("Predefined allocator %qs in ALLOCATOR clause at %L, "
9591 : "used for list item %<%s%s%s%> at %L, may not be used"
9592 : " for static variables",
9593 33 : alloc_name[mpz_get_ui (n->u2.allocator->value.integer)
9594 33 : - 6 /* cgroup */], &n->u2.allocator->where,
9595 : com ? "/" : "",
9596 33 : com ? n->sym->common_head->name : n->sym->name,
9597 : com ? "/" : "", &n->where);
9598 : }
9599 67 : while (n->sym->attr.in_common && n->next && n->next->sym
9600 186 : && n->sym->common_head == n->next->sym->common_head)
9601 : n = n->next;
9602 : }
9603 55 : else if (n->u2.allocator
9604 55 : && (!gfc_resolve_expr (n->u2.allocator)
9605 20 : || n->u2.allocator->ts.type != BT_INTEGER
9606 19 : || n->u2.allocator->rank != 0
9607 18 : || n->u2.allocator->ts.kind != gfc_c_intptr_kind))
9608 3 : gfc_error ("Expected integer expression of the "
9609 : "%<omp_allocator_handle_kind%> kind at %L",
9610 3 : &n->u2.allocator->where);
9611 : }
9612 62 : }
9613 :
9614 : /* Resolve ASSUME's and ASSUMES' assumption clauses. Note that absent/contains
9615 : is handled during parse time in omp_verify_merge_absent_contains. */
9616 :
9617 : void
9618 30 : gfc_resolve_omp_assumptions (gfc_omp_assumptions *assume)
9619 : {
9620 47 : for (gfc_expr_list *el = assume->holds; el; el = el->next)
9621 17 : if (!gfc_resolve_expr (el->expr)
9622 17 : || el->expr->ts.type != BT_LOGICAL
9623 32 : || el->expr->rank != 0)
9624 4 : gfc_error ("HOLDS expression at %L must be a scalar logical expression",
9625 4 : &el->expr->where);
9626 30 : }
9627 :
9628 :
9629 : /* Resolve the OpenMP ALLOCATE clauses. */
9630 :
9631 : static void
9632 33061 : resolve_omp_allocate_clauses (gfc_code *code, gfc_omp_clauses *omp_clauses,
9633 : gfc_namespace *ns)
9634 : {
9635 33061 : gfc_omp_namelist *n;
9636 33061 : enum gfc_omp_list_type list;
9637 :
9638 33061 : if (!omp_clauses->lists[OMP_LIST_ALLOCATE])
9639 : return;
9640 795 : for (n = omp_clauses->lists[OMP_LIST_ALLOCATE]; n; n = n->next)
9641 : {
9642 515 : if (n->u2.allocator
9643 515 : && (!gfc_resolve_expr (n->u2.allocator)
9644 290 : || n->u2.allocator->ts.type != BT_INTEGER
9645 288 : || n->u2.allocator->rank != 0
9646 287 : || n->u2.allocator->ts.kind != gfc_c_intptr_kind))
9647 : {
9648 8 : gfc_error ("Expected integer expression of the "
9649 : "%<omp_allocator_handle_kind%> kind at %L",
9650 8 : &n->u2.allocator->where);
9651 28 : break;
9652 : }
9653 507 : if (!n->u.align)
9654 399 : continue;
9655 108 : HOST_WIDE_INT alignment = 0;
9656 108 : if (!gfc_resolve_expr (n->u.align)
9657 108 : || n->u.align->ts.type != BT_INTEGER
9658 105 : || n->u.align->rank != 0
9659 102 : || n->u.align->expr_type != EXPR_CONSTANT
9660 99 : || gfc_extract_hwi (n->u.align, &alignment)
9661 99 : || alignment <= 0
9662 207 : || !pow2p_hwi (alignment))
9663 : {
9664 12 : gfc_error ("ALIGN requires a scalar positive constant integer "
9665 : "alignment expression at %L that is a power of two",
9666 12 : &n->u.align->where);
9667 12 : break;
9668 : }
9669 : }
9670 :
9671 : /* Check for 2 things here.
9672 : 1. There is no duplication of variable in allocate clause.
9673 : 2. Variable in allocate clause are also present in some
9674 : privatization clase (non-composite case). */
9675 815 : for (n = omp_clauses->lists[OMP_LIST_ALLOCATE]; n; n = n->next)
9676 515 : if (n->sym)
9677 489 : n->sym->mark = 0;
9678 :
9679 : gfc_omp_namelist *prev = NULL;
9680 815 : for (n = omp_clauses->lists[OMP_LIST_ALLOCATE]; n; )
9681 : {
9682 515 : if (n->sym == NULL)
9683 : {
9684 26 : n = n->next;
9685 26 : continue;
9686 : }
9687 489 : if (n->sym->mark == 1)
9688 : {
9689 3 : gfc_warning (OPT_Wopenmp, "%qs appears more than once in "
9690 : "%<allocate%> at %L" , n->sym->name, &n->where);
9691 : /* We have already seen this variable so it is a duplicate.
9692 : Remove it. */
9693 3 : if (prev != NULL && prev->next == n)
9694 : {
9695 3 : prev->next = n->next;
9696 3 : n->next = NULL;
9697 3 : gfc_free_omp_namelist (n, OMP_LIST_ALLOCATE);
9698 3 : n = prev->next;
9699 : }
9700 3 : continue;
9701 : }
9702 486 : n->sym->mark = 1;
9703 486 : prev = n;
9704 486 : n = n->next;
9705 : }
9706 :
9707 : /* Non-composite constructs. */
9708 300 : if (code && code->op < EXEC_OMP_DO_SIMD)
9709 : {
9710 4760 : for (list = OMP_LIST_FIRST; list < OMP_LIST_NUM;
9711 4641 : list = gfc_omp_list_type (list + 1))
9712 4641 : switch (list)
9713 : {
9714 1071 : case OMP_LIST_PRIVATE:
9715 1071 : case OMP_LIST_FIRSTPRIVATE:
9716 1071 : case OMP_LIST_LASTPRIVATE:
9717 1071 : case OMP_LIST_REDUCTION:
9718 1071 : case OMP_LIST_REDUCTION_INSCAN:
9719 1071 : case OMP_LIST_REDUCTION_TASK:
9720 1071 : case OMP_LIST_IN_REDUCTION:
9721 1071 : case OMP_LIST_TASK_REDUCTION:
9722 1071 : case OMP_LIST_LINEAR:
9723 1370 : for (n = omp_clauses->lists[list]; n; n = n->next)
9724 299 : n->sym->mark = 0;
9725 : break;
9726 : default:
9727 : break;
9728 : }
9729 :
9730 410 : for (n = omp_clauses->lists[OMP_LIST_ALLOCATE]; n; n = n->next)
9731 291 : if (n->sym->mark == 1)
9732 4 : gfc_error ("%qs specified in %<allocate%> clause at %L but not "
9733 : "in an explicit privatization clause",
9734 : n->sym->name, &n->where);
9735 : }
9736 71 : if (!(code
9737 300 : && (code->op == EXEC_OMP_ALLOCATORS || code->op == EXEC_OMP_ALLOCATE)
9738 73 : && code->block
9739 72 : && code->block->next
9740 71 : && code->block->next->op == EXEC_ALLOCATE))
9741 : return;
9742 :
9743 68 : if (code->op == EXEC_OMP_ALLOCATE)
9744 49 : gfc_warning (OPT_Wdeprecated_openmp,
9745 : "The use of one or more %<allocate%> directives with "
9746 : "an associated %<allocate%> statement at %L is "
9747 : "deprecated since OpenMP 5.2, use an %<allocators%> "
9748 : "directive", &code->loc);
9749 68 : gfc_alloc *a;
9750 68 : gfc_omp_namelist *n_null = NULL;
9751 68 : bool missing_allocator = false;
9752 68 : gfc_symbol *missing_allocator_sym = NULL;
9753 161 : for (n = omp_clauses->lists[OMP_LIST_ALLOCATE]; n; n = n->next)
9754 : {
9755 93 : if (n->u2.allocator == NULL)
9756 : {
9757 77 : if (!missing_allocator_sym)
9758 59 : missing_allocator_sym = n->sym;
9759 : missing_allocator = true;
9760 : }
9761 93 : if (n->sym == NULL)
9762 : {
9763 26 : n_null = n;
9764 26 : continue;
9765 : }
9766 67 : if (n->sym->attr.codimension)
9767 2 : gfc_error ("Unexpected coarray %qs in %<allocate%> at %L",
9768 : n->sym->name, &n->where);
9769 103 : for (a = code->block->next->ext.alloc.list; a; a = a->next)
9770 101 : if (a->expr->expr_type == EXPR_VARIABLE
9771 101 : && a->expr->symtree->n.sym == n->sym)
9772 : {
9773 65 : gfc_ref *ref;
9774 82 : for (ref = a->expr->ref; ref; ref = ref->next)
9775 17 : if (ref->type == REF_COMPONENT)
9776 : break;
9777 : if (ref == NULL)
9778 : break;
9779 : }
9780 67 : if (a == NULL)
9781 2 : gfc_error ("%qs specified in %<allocate%> at %L but not "
9782 : "in the associated ALLOCATE statement",
9783 2 : n->sym->name, &n->where);
9784 : }
9785 : /* If there is an ALLOCATE directive without list argument, a
9786 : namelist with its allocator/align clauses and n->sym = NULL is
9787 : created during parsing; here, we add all not otherwise specified
9788 : items from the Fortran allocate to that list.
9789 : For an ALLOCATORS directive, not listed items use the normal
9790 : Fortran way.
9791 : The behavior of an ALLOCATE directive that does not list all
9792 : arguments but there is no directive without list argument is not
9793 : well specified. Thus, we reject such code below. In OpenMP 5.2
9794 : the executable ALLOCATE directive is deprecated and in 6.0
9795 : deleted such that no spec clarification is to be expected. */
9796 125 : for (a = code->block->next->ext.alloc.list; a; a = a->next)
9797 89 : if (a->expr->expr_type == EXPR_VARIABLE)
9798 : {
9799 154 : for (n = omp_clauses->lists[OMP_LIST_ALLOCATE]; n; n = n->next)
9800 122 : if (a->expr->symtree->n.sym == n->sym)
9801 : {
9802 57 : gfc_ref *ref;
9803 72 : for (ref = a->expr->ref; ref; ref = ref->next)
9804 15 : if (ref->type == REF_COMPONENT)
9805 : break;
9806 : if (ref == NULL)
9807 : break;
9808 : }
9809 89 : if (n == NULL && n_null == NULL)
9810 : {
9811 : /* OK for ALLOCATORS but for ALLOCATE: Unspecified whether
9812 : that should use the default allocator of OpenMP or the
9813 : Fortran allocator. Thus, just reject it. */
9814 7 : if (code->op == EXEC_OMP_ALLOCATE)
9815 1 : gfc_error ("%qs listed in %<allocate%> statement at %L "
9816 : "but it is neither explicitly in listed in "
9817 : "the %<!$OMP ALLOCATE%> directive nor exists"
9818 : " a directive without argument list",
9819 1 : a->expr->symtree->n.sym->name,
9820 : &a->expr->where);
9821 : break;
9822 : }
9823 82 : if (n == NULL)
9824 : {
9825 25 : if (a->expr->symtree->n.sym->attr.codimension)
9826 1 : gfc_error ("Unexpected coarray %qs in %<allocate%> at "
9827 : "%L, implicitly listed in %<!$OMP ALLOCATE%>"
9828 : " at %L", a->expr->symtree->n.sym->name,
9829 : &a->expr->where, &n_null->where);
9830 : break;
9831 : }
9832 : }
9833 68 : gfc_namespace *prog_unit = ns;
9834 87 : while (prog_unit->parent)
9835 : prog_unit = prog_unit->parent;
9836 : gfc_namespace *fn_ns = ns;
9837 72 : while (fn_ns)
9838 : {
9839 70 : if (ns->proc_name
9840 70 : && (ns->proc_name->attr.subroutine
9841 6 : || ns->proc_name->attr.function))
9842 : break;
9843 4 : fn_ns = fn_ns->parent;
9844 : }
9845 68 : if (missing_allocator
9846 58 : && !(prog_unit->omp_requires & OMP_REQ_DYNAMIC_ALLOCATORS)
9847 58 : && ((fn_ns && fn_ns->proc_name->attr.omp_declare_target)
9848 55 : || omp_clauses->contained_in_target_construct))
9849 : {
9850 6 : if (code->op == EXEC_OMP_ALLOCATORS)
9851 2 : gfc_error ("ALLOCATORS directive at %L inside a target region "
9852 : "must specify an ALLOCATOR modifier for %qs",
9853 : &code->loc, missing_allocator_sym->name);
9854 4 : else if (missing_allocator_sym)
9855 2 : gfc_error ("ALLOCATE directive at %L inside a target region "
9856 : "must specify an ALLOCATOR clause for %qs",
9857 : &code->loc, missing_allocator_sym->name);
9858 : else
9859 2 : gfc_error ("ALLOCATE directive at %L inside a target region "
9860 : "must specify an ALLOCATOR clause", &code->loc);
9861 : }
9862 : }
9863 :
9864 :
9865 : /* Diagnose list items that appear multiple times in OpenMP or OpenACC clauses,
9866 : unless permitted by the specification. */
9867 :
9868 : static void
9869 33061 : check_omp_clauses_dupl_syms (gfc_code *code, gfc_omp_clauses *omp_clauses,
9870 : bool openacc)
9871 : {
9872 33061 : gfc_omp_namelist *n;
9873 33061 : enum gfc_omp_list_type list;
9874 :
9875 : /* Check that no symbol appears on multiple clauses, except that
9876 : a symbol can appear on both firstprivate and lastprivate. */
9877 1322440 : for (list = OMP_LIST_FIRST; list < OMP_LIST_NUM;
9878 1289379 : list = gfc_omp_list_type (list + 1))
9879 1335230 : for (n = omp_clauses->lists[list]; n; n = n->next)
9880 : {
9881 45851 : if (!n->sym) /* omp_all_memory. */
9882 47 : continue;
9883 45804 : n->sym->mark = 0;
9884 45804 : n->sym->comp_mark = 0;
9885 45804 : n->sym->data_mark = 0;
9886 45804 : n->sym->dev_mark = 0;
9887 45804 : n->sym->gen_mark = 0;
9888 45804 : n->sym->reduc_mark = 0;
9889 : }
9890 1322440 : for (list = OMP_LIST_FIRST; list < OMP_LIST_NUM;
9891 1289379 : list = gfc_omp_list_type (list + 1))
9892 1289379 : if (list != OMP_LIST_FIRSTPRIVATE
9893 1289379 : && list != OMP_LIST_LASTPRIVATE
9894 1289379 : && list != OMP_LIST_ALIGNED
9895 1190196 : && list != OMP_LIST_DEPEND
9896 1190196 : && list != OMP_LIST_FROM
9897 1124074 : && list != OMP_LIST_TO
9898 1124074 : && list != OMP_LIST_INTEROP
9899 1057952 : && (list != OMP_LIST_REDUCTION || !openacc)
9900 1044957 : && list != OMP_LIST_ALLOCATE)
9901 1046837 : for (n = omp_clauses->lists[list]; n; n = n->next)
9902 : {
9903 34941 : bool component_ref_p = false;
9904 :
9905 : /* Allow multiple components of the same (e.g. derived-type)
9906 : variable here. Duplicate components are detected elsewhere. */
9907 34941 : if (n->expr && n->expr->expr_type == EXPR_VARIABLE)
9908 16009 : for (gfc_ref *ref = n->expr->ref; ref; ref = ref->next)
9909 9738 : if (ref->type == REF_COMPONENT)
9910 3191 : component_ref_p = true;
9911 34941 : if ((list == OMP_LIST_IS_DEVICE_PTR
9912 34941 : || list == OMP_LIST_HAS_DEVICE_ADDR)
9913 314 : && !component_ref_p)
9914 : {
9915 314 : if (n->sym->gen_mark
9916 312 : || n->sym->dev_mark
9917 311 : || n->sym->reduc_mark
9918 311 : || n->sym->mark)
9919 5 : gfc_error ("Symbol %qs present on multiple clauses at %L",
9920 : n->sym->name, &n->where);
9921 : else
9922 309 : n->sym->dev_mark = 1;
9923 : }
9924 34627 : else if ((list == OMP_LIST_USE_DEVICE_PTR
9925 34627 : || list == OMP_LIST_USE_DEVICE_ADDR
9926 34627 : || list == OMP_LIST_PRIVATE
9927 : || list == OMP_LIST_SHARED)
9928 12855 : && !component_ref_p)
9929 : {
9930 12855 : if (n->sym->gen_mark || n->sym->dev_mark || n->sym->reduc_mark)
9931 13 : gfc_error ("Symbol %qs present on multiple clauses at %L",
9932 : n->sym->name, &n->where);
9933 : else
9934 : {
9935 12842 : n->sym->gen_mark = 1;
9936 : /* Set both generic and device bits if we have
9937 : use_device_*(x) or shared(x). This allows us to diagnose
9938 : "map(x) private(x)" below. */
9939 12842 : if (list != OMP_LIST_PRIVATE)
9940 3456 : n->sym->dev_mark = 1;
9941 : }
9942 : }
9943 21772 : else if ((list == OMP_LIST_REDUCTION
9944 21772 : || list == OMP_LIST_REDUCTION_TASK
9945 19311 : || list == OMP_LIST_REDUCTION_INSCAN
9946 19311 : || list == OMP_LIST_IN_REDUCTION
9947 19098 : || list == OMP_LIST_TASK_REDUCTION)
9948 2674 : && !component_ref_p)
9949 : {
9950 : /* Attempts to mix reduction types are diagnosed below. */
9951 2674 : if (n->sym->gen_mark || n->sym->dev_mark)
9952 2 : gfc_error ("Symbol %qs present on multiple clauses at %L",
9953 : n->sym->name, &n->where);
9954 2674 : n->sym->reduc_mark = 1;
9955 : }
9956 19098 : else if ((!component_ref_p && n->sym->comp_mark)
9957 19097 : || (component_ref_p && n->sym->mark))
9958 : {
9959 42 : if (openacc)
9960 3 : gfc_error ("Symbol %qs has mixed component and non-component "
9961 3 : "accesses at %L", n->sym->name, &n->where);
9962 : }
9963 19056 : else if ((openacc || list != OMP_LIST_MAP) && n->sym->mark)
9964 88 : gfc_error ("Symbol %qs present on multiple clauses at %L",
9965 : n->sym->name, &n->where);
9966 : else
9967 : {
9968 18968 : if (component_ref_p)
9969 2467 : n->sym->comp_mark = 1;
9970 : else
9971 16501 : n->sym->mark = 1;
9972 : }
9973 : }
9974 :
9975 : /* Detect specifically the case where we have "map(x) private(x)" and raise
9976 : an error. If we have "...simd" combined directives though, the "private"
9977 : applies to the simd part, so this is permitted though. */
9978 42455 : for (n = omp_clauses->lists[OMP_LIST_PRIVATE]; n; n = n->next)
9979 9394 : if (n->sym->mark
9980 6 : && n->sym->gen_mark
9981 6 : && !n->sym->dev_mark
9982 6 : && !n->sym->reduc_mark
9983 5 : && code->op != EXEC_OMP_TARGET_SIMD
9984 : && code->op != EXEC_OMP_TARGET_PARALLEL_DO_SIMD
9985 : && code->op != EXEC_OMP_TARGET_TEAMS_DISTRIBUTE_SIMD
9986 : && code->op != EXEC_OMP_TARGET_TEAMS_DISTRIBUTE_PARALLEL_DO_SIMD)
9987 1 : gfc_error ("Symbol %qs present on multiple clauses at %L",
9988 : n->sym->name, &n->where);
9989 :
9990 : gcc_assert (OMP_LIST_LASTPRIVATE == OMP_LIST_FIRSTPRIVATE + 1);
9991 99183 : for (list = OMP_LIST_FIRSTPRIVATE; list <= OMP_LIST_LASTPRIVATE;
9992 66122 : list = gfc_omp_list_type (list + 1))
9993 70345 : for (n = omp_clauses->lists[list]; n; n = n->next)
9994 4223 : if (n->sym->data_mark || n->sym->gen_mark || n->sym->dev_mark)
9995 : {
9996 9 : gfc_error ("Symbol %qs present on multiple clauses at %L",
9997 : n->sym->name, &n->where);
9998 9 : n->sym->data_mark = n->sym->gen_mark = n->sym->dev_mark = 0;
9999 : }
10000 4214 : else if (n->sym->mark
10001 18 : && code->op != EXEC_OMP_TARGET_TEAMS
10002 : && code->op != EXEC_OMP_TARGET_TEAMS_DISTRIBUTE
10003 : && code->op != EXEC_OMP_TARGET_TEAMS_LOOP
10004 : && code->op != EXEC_OMP_TARGET_TEAMS_DISTRIBUTE_SIMD
10005 : && code->op != EXEC_OMP_TARGET_TEAMS_DISTRIBUTE_PARALLEL_DO
10006 : && code->op != EXEC_OMP_TARGET_PARALLEL
10007 : && code->op != EXEC_OMP_TARGET_PARALLEL_DO
10008 : && code->op != EXEC_OMP_TARGET_PARALLEL_LOOP
10009 : && code->op != EXEC_OMP_TARGET_PARALLEL_DO_SIMD
10010 : && code->op != EXEC_OMP_TARGET_TEAMS_DISTRIBUTE_PARALLEL_DO_SIMD)
10011 7 : gfc_error ("Symbol %qs present on both data and map clauses "
10012 : "at %L", n->sym->name, &n->where);
10013 :
10014 34976 : for (n = omp_clauses->lists[OMP_LIST_FIRSTPRIVATE]; n; n = n->next)
10015 : {
10016 1915 : if (n->sym->data_mark || n->sym->gen_mark || n->sym->dev_mark)
10017 7 : gfc_error ("Symbol %qs present on multiple clauses at %L",
10018 : n->sym->name, &n->where);
10019 : else
10020 1908 : n->sym->data_mark = 1;
10021 : }
10022 :
10023 : /* LASTPRIVATE clauses. */
10024 35369 : for (n = omp_clauses->lists[OMP_LIST_LASTPRIVATE]; n; n = n->next)
10025 2308 : n->sym->data_mark = 0;
10026 35369 : for (n = omp_clauses->lists[OMP_LIST_LASTPRIVATE]; n; n = n->next)
10027 : {
10028 2308 : if (n->sym->data_mark || n->sym->gen_mark || n->sym->dev_mark)
10029 0 : gfc_error ("Symbol %qs present on multiple clauses at %L",
10030 : n->sym->name, &n->where);
10031 : else
10032 2308 : n->sym->data_mark = 1;
10033 : }
10034 :
10035 : /* ALIGNED clauses. */
10036 33211 : for (n = omp_clauses->lists[OMP_LIST_ALIGNED]; n; n = n->next)
10037 150 : n->sym->mark = 0;
10038 :
10039 33211 : for (n = omp_clauses->lists[OMP_LIST_ALIGNED]; n; n = n->next)
10040 : {
10041 150 : if (n->sym->mark)
10042 0 : gfc_error ("Symbol %qs present on multiple clauses at %L",
10043 : n->sym->name, &n->where);
10044 : else
10045 150 : n->sym->mark = 1;
10046 : }
10047 :
10048 : /* FROM and TO clauses. */
10049 33831 : for (n = omp_clauses->lists[OMP_LIST_TO]; n; n = n->next)
10050 770 : n->sym->mark = 0;
10051 34096 : for (n = omp_clauses->lists[OMP_LIST_FROM]; n; n = n->next)
10052 1035 : if (n->expr == NULL)
10053 1017 : n->sym->mark = 1;
10054 33831 : for (n = omp_clauses->lists[OMP_LIST_TO]; n; n = n->next)
10055 : {
10056 770 : if (n->expr == NULL && n->sym->mark)
10057 0 : gfc_error ("Symbol %qs present on both FROM and TO clauses at %L",
10058 : n->sym->name, &n->where);
10059 : else
10060 770 : n->sym->mark = 1;
10061 : }
10062 :
10063 : /* OpenACC reductions. */
10064 33061 : if (openacc)
10065 : {
10066 15131 : for (n = omp_clauses->lists[OMP_LIST_REDUCTION]; n; n = n->next)
10067 2136 : n->sym->mark = 0;
10068 15131 : for (n = omp_clauses->lists[OMP_LIST_REDUCTION]; n; n = n->next)
10069 : {
10070 2136 : if (n->sym->mark)
10071 0 : gfc_error ("Symbol %qs present on multiple clauses at %L",
10072 : n->sym->name, &n->where);
10073 : else
10074 2136 : n->sym->mark = 1;
10075 :
10076 : /* OpenACC does not support reductions on arrays. */
10077 2136 : if (n->sym->as)
10078 71 : gfc_error ("Array %qs is not permitted in reduction at %L",
10079 : n->sym->name, &n->where);
10080 : }
10081 : }
10082 33061 : }
10083 :
10084 : /* OpenMP/OpenACC: Resolve the list item of a MAP, TO, FROM, CACHE, AFFINITY
10085 : or DEPEND clause. */
10086 :
10087 : static void
10088 20956 : resolve_omp_clauses_aff_dep_map_cache (gfc_code *code,
10089 : gfc_omp_namelist *n,
10090 : const char *name,
10091 : enum gfc_omp_list_type list,
10092 : gfc_omp_clauses *omp_clauses,
10093 : bool openacc)
10094 : {
10095 20956 : gcc_checking_assert (list == OMP_LIST_AFFINITY || list == OMP_LIST_DEPEND
10096 : || list == OMP_LIST_MAP || list == OMP_LIST_TO
10097 : || list == OMP_LIST_FROM || list == OMP_LIST_CACHE);
10098 :
10099 20956 : if (list != OMP_LIST_CACHE && n->u2.ns && !n->u2.ns->resolved)
10100 : {
10101 109 : n->u2.ns->resolved = 1;
10102 109 : for (gfc_symbol *sym = n->u2.ns->omp_affinity_iterators;
10103 235 : sym; sym = sym->tlink)
10104 : {
10105 126 : gfc_constructor *c;
10106 126 : c = gfc_constructor_first (sym->value->value.constructor);
10107 126 : if (!gfc_resolve_expr (c->expr)
10108 126 : || c->expr->ts.type != BT_INTEGER
10109 250 : || c->expr->rank != 0)
10110 2 : gfc_error ("Scalar integer expression for range begin expected "
10111 2 : "at %L", &c->expr->where);
10112 126 : c = gfc_constructor_next (c);
10113 126 : if (!gfc_resolve_expr (c->expr)
10114 126 : || c->expr->ts.type != BT_INTEGER
10115 250 : || c->expr->rank != 0)
10116 2 : gfc_error ("Scalar integer expression for range end expected at %L",
10117 2 : &c->expr->where);
10118 126 : c = gfc_constructor_next (c);
10119 126 : if (c && (!gfc_resolve_expr (c->expr)
10120 16 : || c->expr->ts.type != BT_INTEGER
10121 14 : || c->expr->rank != 0))
10122 2 : gfc_error ("Scalar integer expression for range step expected "
10123 2 : "at %L", &c->expr->where);
10124 124 : else if (c
10125 14 : && c->expr->expr_type == EXPR_CONSTANT
10126 12 : && mpz_cmp_si (c->expr->value.integer, 0) == 0)
10127 2 : gfc_error ("Nonzero range step expected at %L", &c->expr->where);
10128 : }
10129 : }
10130 20855 : if (list == OMP_LIST_DEPEND)
10131 : {
10132 1963 : if (n->u.depend_doacross_op == OMP_DEPEND_SINK_FIRST
10133 : || n->u.depend_doacross_op == OMP_DOACROSS_SINK_FIRST
10134 1963 : || n->u.depend_doacross_op == OMP_DOACROSS_SINK)
10135 : {
10136 1233 : if (omp_clauses->doacross_source)
10137 : {
10138 0 : gfc_error ("Dependence-type SINK used together with SOURCE on "
10139 : "the same construct at %L", &n->where);
10140 0 : omp_clauses->doacross_source = false;
10141 : }
10142 1233 : else if (n->expr)
10143 : {
10144 571 : if (!gfc_resolve_expr (n->expr)
10145 571 : || n->expr->ts.type != BT_INTEGER
10146 1142 : || n->expr->rank != 0)
10147 0 : gfc_error ("SINK addend not a constant integer at %L",
10148 : &n->where);
10149 : }
10150 1233 : if (n->sym == NULL
10151 4 : && (n->expr == NULL
10152 3 : || mpz_cmp_si (n->expr->value.integer, -1) != 0))
10153 2 : gfc_error ("omp_cur_iteration at %L requires %<-1%> as "
10154 : "logical offset", &n->where);
10155 : return;
10156 : }
10157 730 : if (n->u.depend_doacross_op == OMP_DEPEND_DEPOBJ
10158 38 : && !n->expr
10159 22 : && (n->sym->ts.type != BT_INTEGER
10160 22 : || n->sym->ts.kind != 2 * gfc_index_integer_kind
10161 22 : || n->sym->attr.dimension))
10162 0 : gfc_error ("Locator %qs at %L in DEPEND clause of depobj type shall be "
10163 : "a scalar integer of OMP_DEPEND_KIND kind",
10164 : n->sym->name, &n->where);
10165 730 : else if (n->u.depend_doacross_op == OMP_DEPEND_DEPOBJ
10166 38 : && n->expr
10167 746 : && (!gfc_resolve_expr (n->expr)
10168 16 : || n->expr->ts.type != BT_INTEGER
10169 16 : || n->expr->ts.kind != 2 * gfc_index_integer_kind
10170 16 : || n->expr->rank != 0))
10171 0 : gfc_error ("Locator at %L in DEPEND clause of depobj type shall be a "
10172 0 : "scalar integer of OMP_DEPEND_KIND kind", &n->expr->where);
10173 : }
10174 19723 : gfc_ref *lastref = NULL, *lastslice = NULL;
10175 19723 : bool resolved = false;
10176 19723 : if (n->expr)
10177 : {
10178 6540 : lastref = n->expr->ref;
10179 6540 : resolved = gfc_resolve_expr (n->expr);
10180 :
10181 : /* Look through component refs to find last array reference. */
10182 6540 : if (resolved)
10183 : {
10184 16573 : for (gfc_ref *ref = n->expr->ref; ref; ref = ref->next)
10185 10051 : if (ref->type == REF_COMPONENT
10186 : || ref->type == REF_SUBSTRING
10187 10051 : || ref->type == REF_INQUIRY)
10188 : lastref = ref;
10189 6799 : else if (ref->type == REF_ARRAY)
10190 : {
10191 14290 : for (int i = 0; i < ref->u.ar.dimen; i++)
10192 7491 : if (ref->u.ar.dimen_type[i] == DIMEN_RANGE)
10193 6277 : lastslice = ref;
10194 : lastref = ref;
10195 : }
10196 :
10197 : /* The "!$acc cache" directive allows rectangular subarrays to be
10198 : specified, with some restrictions on the form of bounds (not
10199 : implemented). Only raise an error here if we're really sure the
10200 : array isn't contiguous. An expression such as arr(-n:n,-n:n)
10201 : could be contiguous even if it looks like it may not be. */
10202 6522 : if (code
10203 6502 : && code->op != EXEC_OACC_UPDATE
10204 5720 : && list != OMP_LIST_CACHE
10205 5720 : && list != OMP_LIST_DEPEND
10206 5398 : && !gfc_is_simply_contiguous (n->expr, false, true)
10207 1517 : && gfc_is_not_contiguous (n->expr)
10208 6535 : && !(lastslice && (lastslice->next
10209 3 : || lastslice->type != REF_ARRAY)))
10210 3 : gfc_error ("Array is not contiguous at %L", &n->where);
10211 : }
10212 : }
10213 19723 : if (list == OMP_LIST_MAP
10214 17052 : && (n->sym->attr.omp_groupprivate
10215 17051 : || n->sym->attr.omp_declare_target_local))
10216 2 : gfc_error ("%qs argument to MAP clause at %L must not be a device-local "
10217 : "variable, including GROUPPRIVATE", n->sym->name, &n->where);
10218 19723 : if (openacc
10219 19723 : && list == OMP_LIST_MAP
10220 9571 : && (n->u.map.op == OMP_MAP_ATTACH || n->u.map.op == OMP_MAP_DETACH))
10221 : {
10222 117 : symbol_attribute attr;
10223 117 : if (n->expr)
10224 99 : attr = gfc_expr_attr (n->expr);
10225 : else
10226 18 : attr = n->sym->attr;
10227 117 : if (!attr.pointer && !attr.allocatable)
10228 7 : gfc_error ("%qs clause argument must be ALLOCATABLE or a POINTER at %L",
10229 7 : (n->u.map.op == OMP_MAP_ATTACH) ? "attach" : "detach",
10230 : &n->where);
10231 : }
10232 19723 : if (lastref
10233 13195 : || (n->expr && (!resolved || n->expr->expr_type != EXPR_VARIABLE)))
10234 : {
10235 6540 : if (!lastslice && lastref && lastref->type == REF_SUBSTRING)
10236 11 : gfc_error ("Unexpected substring reference in %s clause at %L",
10237 : name, &n->where);
10238 6529 : else if (!lastslice && lastref && lastref->type == REF_INQUIRY)
10239 : {
10240 12 : gcc_assert (lastref->u.i == INQUIRY_RE || lastref->u.i == INQUIRY_IM);
10241 12 : gfc_error ("Unexpected complex-parts designator reference in %s "
10242 : "clause at %L", name, &n->where);
10243 : }
10244 6517 : else if (!resolved
10245 6499 : || n->expr->expr_type != EXPR_VARIABLE
10246 6487 : || (lastslice
10247 5615 : && (lastslice->next || lastslice->type != REF_ARRAY)))
10248 46 : gfc_error ("%qs in %s clause at %L is not a proper array section",
10249 46 : n->sym->name, name, &n->where);
10250 : else if (lastslice)
10251 : {
10252 : int i;
10253 : gfc_array_ref *ar = &lastslice->u.ar;
10254 11873 : for (i = 0; i < ar->dimen; i++)
10255 6275 : if (ar->stride[i] && code && code->op != EXEC_OACC_UPDATE)
10256 : {
10257 1 : gfc_error ("Stride should not be specified for array section "
10258 : "in %s clause at %L", name, &n->where);
10259 1 : break;
10260 : }
10261 6274 : else if (ar->dimen_type[i] != DIMEN_ELEMENT
10262 6274 : && ar->dimen_type[i] != DIMEN_RANGE)
10263 : {
10264 0 : gfc_error ("%qs in %s clause at %L is not a proper array "
10265 0 : "section", n->sym->name, name, &n->where);
10266 0 : break;
10267 : }
10268 6274 : else if ((list == OMP_LIST_DEPEND || list == OMP_LIST_AFFINITY)
10269 161 : && ar->start[i]
10270 133 : && ar->start[i]->expr_type == EXPR_CONSTANT
10271 97 : && ar->end[i]
10272 72 : && ar->end[i]->expr_type == EXPR_CONSTANT
10273 72 : && mpz_cmp (ar->start[i]->value.integer,
10274 72 : ar->end[i]->value.integer) > 0)
10275 : {
10276 0 : gfc_error ("%qs in %s clause at %L is a zero size array "
10277 0 : "section", n->sym->name,
10278 : list == OMP_LIST_DEPEND ? "DEPEND" : "AFFINITY",
10279 : &n->where);
10280 0 : break;
10281 : }
10282 : }
10283 : }
10284 13183 : else if (openacc)
10285 : {
10286 5915 : if (list == OMP_LIST_MAP && n->u.map.op == OMP_MAP_FORCE_DEVICEPTR)
10287 65 : resolve_oacc_deviceptr_clause (n->sym, n->where, name);
10288 : else
10289 5850 : resolve_oacc_data_clauses (n->sym, n->where, name);
10290 : }
10291 7268 : else if (list != OMP_LIST_DEPEND
10292 6775 : && n->sym->as
10293 3340 : && n->sym->as->type == AS_ASSUMED_SIZE)
10294 5 : gfc_error ("Assumed size array %qs in %s clause at %L",
10295 : n->sym->name, name, &n->where);
10296 19723 : if (code && list == OMP_LIST_MAP && !openacc)
10297 7442 : switch (code->op)
10298 : {
10299 6161 : case EXEC_OMP_TARGET:
10300 6161 : case EXEC_OMP_TARGET_PARALLEL:
10301 6161 : case EXEC_OMP_TARGET_PARALLEL_DO:
10302 6161 : case EXEC_OMP_TARGET_PARALLEL_DO_SIMD:
10303 6161 : case EXEC_OMP_TARGET_PARALLEL_LOOP:
10304 6161 : case EXEC_OMP_TARGET_SIMD:
10305 6161 : case EXEC_OMP_TARGET_TEAMS:
10306 6161 : case EXEC_OMP_TARGET_TEAMS_DISTRIBUTE:
10307 6161 : case EXEC_OMP_TARGET_TEAMS_DISTRIBUTE_PARALLEL_DO:
10308 6161 : case EXEC_OMP_TARGET_TEAMS_DISTRIBUTE_PARALLEL_DO_SIMD:
10309 6161 : case EXEC_OMP_TARGET_TEAMS_DISTRIBUTE_SIMD:
10310 6161 : case EXEC_OMP_TARGET_TEAMS_LOOP:
10311 6161 : case EXEC_OMP_TARGET_DATA:
10312 6161 : switch (n->u.map.op)
10313 : {
10314 : case OMP_MAP_TO:
10315 : case OMP_MAP_ALWAYS_TO:
10316 : case OMP_MAP_PRESENT_TO:
10317 : case OMP_MAP_ALWAYS_PRESENT_TO:
10318 : case OMP_MAP_FROM:
10319 : case OMP_MAP_ALWAYS_FROM:
10320 : case OMP_MAP_PRESENT_FROM:
10321 : case OMP_MAP_ALWAYS_PRESENT_FROM:
10322 : case OMP_MAP_TOFROM:
10323 : case OMP_MAP_ALWAYS_TOFROM:
10324 : case OMP_MAP_PRESENT_TOFROM:
10325 : case OMP_MAP_ALWAYS_PRESENT_TOFROM:
10326 : case OMP_MAP_ALLOC:
10327 : case OMP_MAP_PRESENT_ALLOC:
10328 : break;
10329 2 : default:
10330 2 : gfc_error ("TARGET%s with map-type other than TO, "
10331 : "FROM, TOFROM, or ALLOC on MAP clause "
10332 : "at %L",
10333 : code->op == EXEC_OMP_TARGET_DATA
10334 : ? " DATA" : "", &n->where);
10335 2 : break;
10336 : }
10337 : break;
10338 701 : case EXEC_OMP_TARGET_ENTER_DATA:
10339 701 : switch (n->u.map.op)
10340 : {
10341 : case OMP_MAP_TO:
10342 : case OMP_MAP_ALWAYS_TO:
10343 : case OMP_MAP_PRESENT_TO:
10344 : case OMP_MAP_ALWAYS_PRESENT_TO:
10345 : case OMP_MAP_ALLOC:
10346 : case OMP_MAP_PRESENT_ALLOC:
10347 : break;
10348 181 : case OMP_MAP_TOFROM:
10349 181 : n->u.map.op = OMP_MAP_TO;
10350 181 : break;
10351 3 : case OMP_MAP_ALWAYS_TOFROM:
10352 3 : n->u.map.op = OMP_MAP_ALWAYS_TO;
10353 3 : break;
10354 2 : case OMP_MAP_PRESENT_TOFROM:
10355 2 : n->u.map.op = OMP_MAP_PRESENT_TO;
10356 2 : break;
10357 2 : case OMP_MAP_ALWAYS_PRESENT_TOFROM:
10358 2 : n->u.map.op = OMP_MAP_ALWAYS_PRESENT_TO;
10359 2 : break;
10360 2 : default:
10361 2 : gfc_error ("TARGET ENTER DATA with map-type other "
10362 : "than TO, TOFROM or ALLOC on MAP clause "
10363 : "at %L", &n->where);
10364 2 : break;
10365 : }
10366 : break;
10367 580 : case EXEC_OMP_TARGET_EXIT_DATA:
10368 580 : switch (n->u.map.op)
10369 : {
10370 : case OMP_MAP_FROM:
10371 : case OMP_MAP_ALWAYS_FROM:
10372 : case OMP_MAP_PRESENT_FROM:
10373 : case OMP_MAP_ALWAYS_PRESENT_FROM:
10374 : case OMP_MAP_RELEASE:
10375 : case OMP_MAP_DELETE:
10376 : break;
10377 134 : case OMP_MAP_TOFROM:
10378 134 : n->u.map.op = OMP_MAP_FROM;
10379 134 : break;
10380 1 : case OMP_MAP_ALWAYS_TOFROM:
10381 1 : n->u.map.op = OMP_MAP_ALWAYS_FROM;
10382 1 : break;
10383 0 : case OMP_MAP_PRESENT_TOFROM:
10384 0 : n->u.map.op = OMP_MAP_PRESENT_FROM;
10385 0 : break;
10386 0 : case OMP_MAP_ALWAYS_PRESENT_TOFROM:
10387 0 : n->u.map.op = OMP_MAP_ALWAYS_PRESENT_FROM;
10388 0 : break;
10389 2 : default:
10390 2 : gfc_error ("TARGET EXIT DATA with map-type other "
10391 : "than FROM, TOFROM, RELEASE, or DELETE on "
10392 : "MAP clause at %L", &n->where);
10393 2 : break;
10394 : }
10395 : break;
10396 : default:
10397 : break;
10398 : }
10399 19723 : if (list == OMP_LIST_MAP || list == OMP_LIST_TO || list == OMP_LIST_FROM)
10400 : {
10401 18857 : gfc_typespec *ts = n->expr ? &n->expr->ts : &n->sym->ts;
10402 :
10403 18857 : if (ts->type == BT_DERIVED || ts->type == BT_CLASS)
10404 : {
10405 10 : const char *mapper_id = (n->u3.udm
10406 1002 : ? n->u3.udm->requested_mapper_id : "");
10407 1002 : gfc_omp_udm *udm = gfc_find_omp_udm (gfc_current_ns, mapper_id, ts);
10408 1002 : if (mapper_id[0] != '\0' && !udm)
10409 1 : gfc_error ("User-defined mapper %qs not found at %L",
10410 : mapper_id, &n->where);
10411 997 : else if (udm)
10412 : {
10413 27 : if (!n->u3.udm)
10414 : {
10415 18 : gcc_assert (mapper_id[0] == '\0');
10416 18 : n->u3.udm = gfc_get_omp_namelist_udm ();
10417 18 : n->u3.udm->requested_mapper_id = mapper_id;
10418 : }
10419 27 : n->u3.udm->resolved_udm = udm;
10420 : }
10421 : }
10422 : }
10423 :
10424 19723 : if (list != OMP_LIST_DEPEND)
10425 : {
10426 18993 : n->sym->attr.referenced = 1;
10427 18993 : if (n->sym->attr.threadprivate)
10428 1 : gfc_error ("THREADPRIVATE object %qs in %s clause at %L",
10429 : n->sym->name, name, &n->where);
10430 18993 : if (n->sym->attr.cray_pointee)
10431 14 : gfc_error ("Cray pointee %qs in %s clause at %L",
10432 : n->sym->name, name, &n->where);
10433 : }
10434 : }
10435 :
10436 : /* OpenMP directive resolving routines. */
10437 :
10438 : static void
10439 33061 : resolve_omp_clauses (gfc_code *code, gfc_omp_clauses *omp_clauses,
10440 : gfc_namespace *ns, bool openacc = false)
10441 : {
10442 33061 : gfc_omp_namelist *n, *last;
10443 33061 : gfc_expr_list *el;
10444 33061 : enum gfc_omp_list_type list;
10445 33061 : int ifc;
10446 33061 : bool if_without_mod = false;
10447 33061 : gfc_omp_linear_op linear_op = OMP_LINEAR_DEFAULT;
10448 33061 : static const char *clause_names[]
10449 : = { "PRIVATE", "FIRSTPRIVATE", "LASTPRIVATE", "COPYPRIVATE", "SHARED",
10450 : "COPYIN", "UNIFORM", "AFFINITY", "ALIGNED", "LINEAR", "DEPEND", "MAP",
10451 : "TO", "FROM", "INCLUSIVE", "EXCLUSIVE",
10452 : "REDUCTION", "REDUCTION" /*inscan*/, "REDUCTION" /*task*/,
10453 : "IN_REDUCTION", "TASK_REDUCTION",
10454 : "DEVICE_RESIDENT", "LINK", "LOCAL", "USE_DEVICE",
10455 : "CACHE", "IS_DEVICE_PTR", "USE_DEVICE_PTR", "USE_DEVICE_ADDR",
10456 : "NONTEMPORAL", "ALLOCATE", "HAS_DEVICE_ADDR", "ENTER",
10457 : "USES_ALLOCATORS", "INIT", "USE", "DESTROY", "INTEROP", "ADJUST_ARGS" };
10458 33061 : STATIC_ASSERT (ARRAY_SIZE (clause_names) == OMP_LIST_NUM);
10459 :
10460 33061 : if (omp_clauses == NULL)
10461 : return;
10462 :
10463 33061 : if (ns == NULL)
10464 32615 : ns = gfc_current_ns;
10465 :
10466 33061 : check_omp_clauses_dupl_syms (code, omp_clauses, openacc);
10467 :
10468 33061 : if (omp_clauses->orderedc && omp_clauses->orderedc < omp_clauses->collapse)
10469 0 : gfc_error ("ORDERED clause parameter is less than COLLAPSE at %L",
10470 : &code->loc);
10471 33061 : if (omp_clauses->order_concurrent && omp_clauses->ordered)
10472 4 : gfc_error ("ORDER clause must not be used together with ORDERED at %L",
10473 : &code->loc);
10474 33061 : if (omp_clauses->if_expr)
10475 : {
10476 1299 : gfc_expr *expr = omp_clauses->if_expr;
10477 1299 : if (!gfc_resolve_expr (expr)
10478 1299 : || expr->ts.type != BT_LOGICAL || expr->rank != 0)
10479 16 : gfc_error ("IF clause at %L requires a scalar LOGICAL expression",
10480 : &expr->where);
10481 : if_without_mod = true;
10482 : }
10483 363671 : for (ifc = 0; ifc < OMP_IF_LAST; ifc++)
10484 330610 : if (omp_clauses->if_exprs[ifc])
10485 : {
10486 141 : gfc_expr *expr = omp_clauses->if_exprs[ifc];
10487 141 : bool ok = true;
10488 141 : if (!gfc_resolve_expr (expr)
10489 141 : || expr->ts.type != BT_LOGICAL || expr->rank != 0)
10490 0 : gfc_error ("IF clause at %L requires a scalar LOGICAL expression",
10491 : &expr->where);
10492 141 : else if (if_without_mod)
10493 : {
10494 1 : gfc_error ("IF clause without modifier at %L used together with "
10495 : "IF clauses with modifiers",
10496 1 : &omp_clauses->if_expr->where);
10497 1 : if_without_mod = false;
10498 : }
10499 : else
10500 140 : switch (code->op)
10501 : {
10502 13 : case EXEC_OMP_CANCEL:
10503 13 : ok = ifc == OMP_IF_CANCEL;
10504 13 : break;
10505 :
10506 16 : case EXEC_OMP_PARALLEL:
10507 16 : case EXEC_OMP_PARALLEL_DO:
10508 16 : case EXEC_OMP_PARALLEL_LOOP:
10509 16 : case EXEC_OMP_PARALLEL_MASKED:
10510 16 : case EXEC_OMP_PARALLEL_MASTER:
10511 16 : case EXEC_OMP_PARALLEL_SECTIONS:
10512 16 : case EXEC_OMP_PARALLEL_WORKSHARE:
10513 16 : case EXEC_OMP_DISTRIBUTE_PARALLEL_DO:
10514 16 : case EXEC_OMP_TEAMS_DISTRIBUTE_PARALLEL_DO:
10515 16 : ok = ifc == OMP_IF_PARALLEL;
10516 16 : break;
10517 :
10518 28 : case EXEC_OMP_PARALLEL_DO_SIMD:
10519 28 : case EXEC_OMP_DISTRIBUTE_PARALLEL_DO_SIMD:
10520 28 : case EXEC_OMP_TEAMS_DISTRIBUTE_PARALLEL_DO_SIMD:
10521 28 : ok = ifc == OMP_IF_PARALLEL || ifc == OMP_IF_SIMD;
10522 28 : break;
10523 :
10524 8 : case EXEC_OMP_PARALLEL_MASKED_TASKLOOP:
10525 8 : case EXEC_OMP_PARALLEL_MASTER_TASKLOOP:
10526 8 : ok = ifc == OMP_IF_PARALLEL || ifc == OMP_IF_TASKLOOP;
10527 8 : break;
10528 :
10529 12 : case EXEC_OMP_PARALLEL_MASKED_TASKLOOP_SIMD:
10530 12 : case EXEC_OMP_PARALLEL_MASTER_TASKLOOP_SIMD:
10531 12 : ok = (ifc == OMP_IF_PARALLEL
10532 12 : || ifc == OMP_IF_TASKLOOP
10533 : || ifc == OMP_IF_SIMD);
10534 : break;
10535 :
10536 0 : case EXEC_OMP_SIMD:
10537 0 : case EXEC_OMP_DO_SIMD:
10538 0 : case EXEC_OMP_DISTRIBUTE_SIMD:
10539 0 : case EXEC_OMP_TEAMS_DISTRIBUTE_SIMD:
10540 0 : ok = ifc == OMP_IF_SIMD;
10541 0 : break;
10542 :
10543 1 : case EXEC_OMP_TASK:
10544 1 : ok = ifc == OMP_IF_TASK;
10545 1 : break;
10546 :
10547 5 : case EXEC_OMP_TASKLOOP:
10548 5 : case EXEC_OMP_MASKED_TASKLOOP:
10549 5 : case EXEC_OMP_MASTER_TASKLOOP:
10550 5 : ok = ifc == OMP_IF_TASKLOOP;
10551 5 : break;
10552 :
10553 20 : case EXEC_OMP_TASKLOOP_SIMD:
10554 20 : case EXEC_OMP_MASKED_TASKLOOP_SIMD:
10555 20 : case EXEC_OMP_MASTER_TASKLOOP_SIMD:
10556 20 : ok = ifc == OMP_IF_TASKLOOP || ifc == OMP_IF_SIMD;
10557 20 : break;
10558 :
10559 5 : case EXEC_OMP_TARGET:
10560 5 : case EXEC_OMP_TARGET_TEAMS:
10561 5 : case EXEC_OMP_TARGET_TEAMS_DISTRIBUTE:
10562 5 : case EXEC_OMP_TARGET_TEAMS_LOOP:
10563 5 : ok = ifc == OMP_IF_TARGET;
10564 5 : break;
10565 :
10566 4 : case EXEC_OMP_TARGET_TEAMS_DISTRIBUTE_SIMD:
10567 4 : case EXEC_OMP_TARGET_SIMD:
10568 4 : ok = ifc == OMP_IF_TARGET || ifc == OMP_IF_SIMD;
10569 4 : break;
10570 :
10571 2 : case EXEC_OMP_TARGET_DATA:
10572 2 : ok = ifc == OMP_IF_TARGET_DATA;
10573 2 : break;
10574 :
10575 2 : case EXEC_OMP_TARGET_UPDATE:
10576 2 : ok = ifc == OMP_IF_TARGET_UPDATE;
10577 2 : break;
10578 :
10579 2 : case EXEC_OMP_TARGET_ENTER_DATA:
10580 2 : ok = ifc == OMP_IF_TARGET_ENTER_DATA;
10581 2 : break;
10582 :
10583 2 : case EXEC_OMP_TARGET_EXIT_DATA:
10584 2 : ok = ifc == OMP_IF_TARGET_EXIT_DATA;
10585 2 : break;
10586 :
10587 10 : case EXEC_OMP_TARGET_TEAMS_DISTRIBUTE_PARALLEL_DO:
10588 10 : case EXEC_OMP_TARGET_PARALLEL:
10589 10 : case EXEC_OMP_TARGET_PARALLEL_DO:
10590 10 : case EXEC_OMP_TARGET_PARALLEL_LOOP:
10591 10 : ok = ifc == OMP_IF_TARGET || ifc == OMP_IF_PARALLEL;
10592 10 : break;
10593 :
10594 10 : case EXEC_OMP_TARGET_PARALLEL_DO_SIMD:
10595 10 : case EXEC_OMP_TARGET_TEAMS_DISTRIBUTE_PARALLEL_DO_SIMD:
10596 10 : ok = (ifc == OMP_IF_TARGET
10597 10 : || ifc == OMP_IF_PARALLEL
10598 : || ifc == OMP_IF_SIMD);
10599 : break;
10600 :
10601 : default:
10602 : ok = false;
10603 : break;
10604 : }
10605 119 : if (!ok)
10606 : {
10607 2 : static const char *ifs[] = {
10608 : "CANCEL",
10609 : "PARALLEL",
10610 : "SIMD",
10611 : "TASK",
10612 : "TASKLOOP",
10613 : "TARGET",
10614 : "TARGET DATA",
10615 : "TARGET UPDATE",
10616 : "TARGET ENTER DATA",
10617 : "TARGET EXIT DATA"
10618 : };
10619 2 : gfc_error ("IF clause modifier %s at %L not appropriate for "
10620 : "the current OpenMP construct", ifs[ifc], &expr->where);
10621 : }
10622 : }
10623 :
10624 33061 : if (omp_clauses->self_expr)
10625 : {
10626 177 : gfc_expr *expr = omp_clauses->self_expr;
10627 177 : if (!gfc_resolve_expr (expr)
10628 177 : || expr->ts.type != BT_LOGICAL || expr->rank != 0)
10629 6 : gfc_error ("SELF clause at %L requires a scalar LOGICAL expression",
10630 : &expr->where);
10631 : }
10632 :
10633 33061 : if (omp_clauses->final_expr)
10634 : {
10635 64 : gfc_expr *expr = omp_clauses->final_expr;
10636 64 : if (!gfc_resolve_expr (expr)
10637 64 : || expr->ts.type != BT_LOGICAL || expr->rank != 0)
10638 0 : gfc_error ("FINAL clause at %L requires a scalar LOGICAL expression",
10639 : &expr->where);
10640 : }
10641 33061 : if (omp_clauses->novariants)
10642 : {
10643 9 : gfc_expr *expr = omp_clauses->novariants;
10644 18 : if (!gfc_resolve_expr (expr) || expr->ts.type != BT_LOGICAL
10645 17 : || expr->rank != 0)
10646 1 : gfc_error (
10647 : "NOVARIANTS clause at %L requires a scalar LOGICAL expression",
10648 : &expr->where);
10649 33061 : if_without_mod = true;
10650 : }
10651 33061 : if (omp_clauses->nocontext)
10652 : {
10653 12 : gfc_expr *expr = omp_clauses->nocontext;
10654 24 : if (!gfc_resolve_expr (expr) || expr->ts.type != BT_LOGICAL
10655 23 : || expr->rank != 0)
10656 1 : gfc_error (
10657 : "NOCONTEXT clause at %L requires a scalar LOGICAL expression",
10658 : &expr->where);
10659 33061 : if_without_mod = true;
10660 : }
10661 :
10662 34077 : for (el = omp_clauses->num_threads_list; el; el = el->next)
10663 1016 : resolve_positive_int_expr (el->expr, "NUM_THREADS");
10664 :
10665 33061 : if (omp_clauses->dyn_groupprivate)
10666 10 : resolve_nonnegative_int_expr (omp_clauses->dyn_groupprivate,
10667 : "DYN_GROUPPRIVATE");
10668 33061 : if (omp_clauses->chunk_size)
10669 : {
10670 510 : gfc_expr *expr = omp_clauses->chunk_size;
10671 510 : if (!gfc_resolve_expr (expr)
10672 510 : || expr->ts.type != BT_INTEGER || expr->rank != 0)
10673 0 : gfc_error ("SCHEDULE clause's chunk_size at %L requires "
10674 : "a scalar INTEGER expression", &expr->where);
10675 510 : else if (expr->expr_type == EXPR_CONSTANT
10676 : && expr->ts.type == BT_INTEGER
10677 485 : && mpz_sgn (expr->value.integer) <= 0)
10678 2 : gfc_warning (OPT_Wopenmp, "INTEGER expression of SCHEDULE clause's "
10679 : "chunk_size at %L must be positive", &expr->where);
10680 : }
10681 33061 : if (omp_clauses->sched_kind != OMP_SCHED_NONE
10682 891 : && omp_clauses->sched_nonmonotonic)
10683 : {
10684 34 : if (omp_clauses->sched_monotonic)
10685 2 : gfc_error ("Both MONOTONIC and NONMONOTONIC schedule modifiers "
10686 : "specified at %L", &code->loc);
10687 32 : else if (omp_clauses->ordered)
10688 4 : gfc_error ("NONMONOTONIC schedule modifier specified with ORDERED "
10689 : "clause at %L", &code->loc);
10690 : }
10691 :
10692 33061 : if (omp_clauses->depobj
10693 33061 : && (!gfc_resolve_expr (omp_clauses->depobj)
10694 115 : || omp_clauses->depobj->ts.type != BT_INTEGER
10695 114 : || omp_clauses->depobj->ts.kind != 2 * gfc_index_integer_kind
10696 113 : || omp_clauses->depobj->rank != 0))
10697 4 : gfc_error ("DEPOBJ in DEPOBJ construct at %L shall be a scalar integer "
10698 4 : "of OMP_DEPEND_KIND kind", &omp_clauses->depobj->where);
10699 :
10700 : /* Check that list items are variables. */
10701 1322440 : for (list = OMP_LIST_FIRST; list < OMP_LIST_NUM;
10702 1289379 : list = gfc_omp_list_type (list + 1))
10703 1335230 : for (n = omp_clauses->lists[list]; n; n = n->next)
10704 : {
10705 45851 : if (!n->sym) /* omp_all_memory. */
10706 47 : continue;
10707 45804 : if (n->sym->attr.flavor == FL_VARIABLE
10708 277 : || n->sym->attr.proc_pointer
10709 236 : || (!code
10710 0 : && !ns->omp_udm_ns
10711 0 : && (!n->sym->attr.dummy || n->sym->ns != ns)))
10712 : {
10713 45568 : if (!code
10714 304 : && !ns->omp_udm_ns
10715 265 : && (!n->sym->attr.dummy || n->sym->ns != ns))
10716 0 : gfc_error ("Variable %qs is not a dummy argument at %L",
10717 : n->sym->name, &n->where);
10718 45568 : continue;
10719 : }
10720 236 : if (n->sym->attr.flavor == FL_PROCEDURE
10721 153 : && n->sym->result == n->sym
10722 138 : && n->sym->attr.function)
10723 : {
10724 138 : if (ns->proc_name == n->sym
10725 44 : || (ns->parent && ns->parent->proc_name == n->sym))
10726 101 : continue;
10727 37 : if (ns->proc_name->attr.entry_master)
10728 : {
10729 32 : gfc_entry_list *el = ns->entries;
10730 51 : for (; el; el = el->next)
10731 51 : if (el->sym == n->sym)
10732 : break;
10733 32 : if (el)
10734 32 : continue;
10735 : }
10736 5 : if (ns->parent
10737 3 : && ns->parent->proc_name->attr.entry_master)
10738 : {
10739 2 : gfc_entry_list *el = ns->parent->entries;
10740 3 : for (; el; el = el->next)
10741 3 : if (el->sym == n->sym)
10742 : break;
10743 2 : if (el)
10744 2 : continue;
10745 : }
10746 : }
10747 101 : if (list == OMP_LIST_MAP
10748 18 : && n->sym->attr.flavor == FL_PARAMETER)
10749 : {
10750 : /* OpenACC since 3.4 permits for Fortran named constants, but
10751 : permits removing then as optimization is not needed and such
10752 : ignore them. Likewise below for FIRSTPRIVATE. */
10753 12 : if (openacc)
10754 10 : gfc_warning (OPT_Wsurprising, "Clause for object %qs at %L is "
10755 : "ignored as parameters need not be copied",
10756 : n->sym->name, &n->where);
10757 : else
10758 2 : gfc_error ("Object %qs is not a variable at %L; parameters"
10759 : " cannot be and need not be mapped", n->sym->name,
10760 : &n->where);
10761 : }
10762 89 : else if (openacc && n->sym->attr.flavor == FL_PARAMETER)
10763 9 : gfc_warning (OPT_Wsurprising, "Clause for object %qs at %L is ignored"
10764 : " as it is a parameter", n->sym->name, &n->where);
10765 80 : else if (list != OMP_LIST_USES_ALLOCATORS)
10766 30 : gfc_error ("Object %qs is not a variable at %L", n->sym->name,
10767 : &n->where);
10768 : }
10769 :
10770 33061 : if (omp_clauses->lists[OMP_LIST_REDUCTION_INSCAN])
10771 : {
10772 69 : locus *loc = &omp_clauses->lists[OMP_LIST_REDUCTION_INSCAN]->where;
10773 69 : if (code->op != EXEC_OMP_DO
10774 : && code->op != EXEC_OMP_SIMD
10775 : && code->op != EXEC_OMP_DO_SIMD
10776 : && code->op != EXEC_OMP_PARALLEL_DO
10777 : && code->op != EXEC_OMP_PARALLEL_DO_SIMD)
10778 23 : gfc_error ("%<inscan%> REDUCTION clause on construct other than DO, "
10779 : "SIMD, DO SIMD, PARALLEL DO, PARALLEL DO SIMD at %L",
10780 : loc);
10781 69 : if (omp_clauses->ordered)
10782 2 : gfc_error ("ORDERED clause specified together with %<inscan%> "
10783 : "REDUCTION clause at %L", loc);
10784 69 : if (omp_clauses->sched_kind != OMP_SCHED_NONE)
10785 3 : gfc_error ("SCHEDULE clause specified together with %<inscan%> "
10786 : "REDUCTION clause at %L", loc);
10787 : }
10788 :
10789 33061 : if (code
10790 32818 : && code->op == EXEC_OMP_INTEROP
10791 63 : && omp_clauses->lists[OMP_LIST_DEPEND])
10792 : {
10793 12 : if (!omp_clauses->lists[OMP_LIST_INIT]
10794 5 : && !omp_clauses->lists[OMP_LIST_USE]
10795 1 : && !omp_clauses->lists[OMP_LIST_DESTROY])
10796 : {
10797 1 : gfc_error ("DEPEND clause at %L requires action clause with "
10798 : "%<targetsync%> interop-type",
10799 : &omp_clauses->lists[OMP_LIST_DEPEND]->where);
10800 : }
10801 22 : for (n = omp_clauses->lists[OMP_LIST_INIT]; n; n = n->next)
10802 12 : if (!n->u.init.targetsync)
10803 : {
10804 2 : gfc_error ("DEPEND clause at %L requires %<targetsync%> "
10805 : "interop-type, lacking it for %qs at %L",
10806 2 : &omp_clauses->lists[OMP_LIST_DEPEND]->where,
10807 2 : n->sym->name, &n->where);
10808 2 : break;
10809 : }
10810 : }
10811 32818 : if (code && (code->op == EXEC_OMP_INTEROP || code->op == EXEC_OMP_DISPATCH))
10812 1085 : for (list = OMP_LIST_INIT; list <= OMP_LIST_INTEROP;
10813 868 : list = gfc_omp_list_type (list + 1))
10814 1123 : for (n = omp_clauses->lists[list]; n; n = n->next)
10815 : {
10816 255 : if (n->sym->ts.type != BT_INTEGER
10817 252 : || n->sym->ts.kind != gfc_index_integer_kind
10818 248 : || n->sym->attr.dimension
10819 243 : || n->sym->attr.flavor != FL_VARIABLE)
10820 16 : gfc_error ("%qs at %L in %qs clause must be a scalar integer "
10821 : "variable of %<omp_interop_kind%> kind", n->sym->name,
10822 : &n->where, clause_names[list]);
10823 255 : if (list != OMP_LIST_USE && list != OMP_LIST_INTEROP
10824 109 : && n->sym->attr.intent == INTENT_IN)
10825 2 : gfc_error ("%qs at %L in %qs clause must be definable",
10826 : n->sym->name, &n->where, clause_names[list]);
10827 : }
10828 :
10829 33061 : resolve_omp_allocate_clauses (code, omp_clauses, ns);
10830 :
10831 33061 : bool has_inscan = false, has_notinscan = false;
10832 1355501 : for (enum gfc_omp_list_type list = OMP_LIST_FIRST; list < OMP_LIST_NUM;
10833 1289379 : list = gfc_omp_list_type (list + 1))
10834 1289379 : if ((n = omp_clauses->lists[list]) != NULL)
10835 : {
10836 29315 : const char *name = clause_names[list];
10837 :
10838 29315 : switch (list)
10839 : {
10840 : case OMP_LIST_COPYIN:
10841 267 : for (; n != NULL; n = n->next)
10842 : {
10843 170 : if (!n->sym->attr.threadprivate)
10844 0 : gfc_error ("Non-THREADPRIVATE object %qs in COPYIN clause"
10845 : " at %L", n->sym->name, &n->where);
10846 : }
10847 : break;
10848 83 : case OMP_LIST_COPYPRIVATE:
10849 83 : if (omp_clauses->nowait)
10850 6 : gfc_error ("NOWAIT clause must not be used with COPYPRIVATE "
10851 : "clause at %L", &n->where);
10852 376 : for (; n != NULL; n = n->next)
10853 : {
10854 293 : if (n->sym->as && n->sym->as->type == AS_ASSUMED_SIZE)
10855 0 : gfc_error ("Assumed size array %qs in COPYPRIVATE clause "
10856 : "at %L", n->sym->name, &n->where);
10857 293 : if (n->sym->attr.pointer && n->sym->attr.intent == INTENT_IN)
10858 1 : gfc_error ("INTENT(IN) POINTER %qs in COPYPRIVATE clause "
10859 : "at %L", n->sym->name, &n->where);
10860 : }
10861 : break;
10862 : case OMP_LIST_SHARED:
10863 2604 : for (; n != NULL; n = n->next)
10864 : {
10865 1642 : if (n->sym->attr.threadprivate)
10866 0 : gfc_error ("THREADPRIVATE object %qs in SHARED clause at "
10867 : "%L", n->sym->name, &n->where);
10868 1642 : if (n->sym->attr.cray_pointee)
10869 1 : gfc_error ("Cray pointee %qs in SHARED clause at %L",
10870 : n->sym->name, &n->where);
10871 1642 : if (n->sym->attr.associate_var)
10872 8 : gfc_error ("Associate name %qs in SHARED clause at %L",
10873 8 : n->sym->attr.select_type_temporary
10874 4 : ? n->sym->assoc->target->symtree->n.sym->name
10875 : : n->sym->name, &n->where);
10876 1642 : if (omp_clauses->detach
10877 1 : && n->sym == omp_clauses->detach->symtree->n.sym)
10878 1 : gfc_error ("DETACH event handle %qs in SHARED clause at %L",
10879 : n->sym->name, &n->where);
10880 : }
10881 : break;
10882 : case OMP_LIST_ALIGNED:
10883 256 : for (; n != NULL; n = n->next)
10884 : {
10885 150 : if (!n->sym->attr.pointer
10886 45 : && !n->sym->attr.allocatable
10887 30 : && !n->sym->attr.cray_pointer
10888 18 : && (n->sym->ts.type != BT_DERIVED
10889 18 : || (n->sym->ts.u.derived->from_intmod
10890 : != INTMOD_ISO_C_BINDING)
10891 18 : || (n->sym->ts.u.derived->intmod_sym_id
10892 : != ISOCBINDING_PTR)))
10893 0 : gfc_error ("%qs in ALIGNED clause must be POINTER, "
10894 : "ALLOCATABLE, Cray pointer or C_PTR at %L",
10895 : n->sym->name, &n->where);
10896 150 : else if (n->expr)
10897 : {
10898 147 : if (!gfc_resolve_expr (n->expr)
10899 147 : || n->expr->ts.type != BT_INTEGER
10900 146 : || n->expr->rank != 0
10901 146 : || n->expr->expr_type != EXPR_CONSTANT
10902 292 : || mpz_sgn (n->expr->value.integer) <= 0)
10903 4 : gfc_error ("%qs in ALIGNED clause at %L requires a scalar"
10904 : " positive constant integer alignment "
10905 4 : "expression", n->sym->name, &n->where);
10906 : }
10907 : }
10908 : break;
10909 : case OMP_LIST_AFFINITY:
10910 : case OMP_LIST_DEPEND:
10911 : case OMP_LIST_MAP:
10912 : case OMP_LIST_TO:
10913 : case OMP_LIST_FROM:
10914 : case OMP_LIST_CACHE:
10915 33222 : for (; n != NULL; n = n->next)
10916 20956 : resolve_omp_clauses_aff_dep_map_cache (code, n, name, list,
10917 : omp_clauses, openacc);
10918 : break;
10919 : case OMP_LIST_IS_DEVICE_PTR:
10920 : last = NULL;
10921 377 : for (n = omp_clauses->lists[list]; n != NULL; )
10922 : {
10923 257 : if ((n->sym->ts.type != BT_DERIVED
10924 71 : || !n->sym->ts.u.derived->ts.is_iso_c
10925 71 : || (n->sym->ts.u.derived->intmod_sym_id
10926 : != ISOCBINDING_PTR))
10927 187 : && code->op == EXEC_OMP_DISPATCH)
10928 : /* Non-TARGET (i.e. DISPATCH) requires a C_PTR. */
10929 3 : gfc_error ("List item %qs in %s clause at %L must be of "
10930 : "TYPE(C_PTR)", n->sym->name, name, &n->where);
10931 254 : else if (n->sym->ts.type != BT_DERIVED
10932 70 : || !n->sym->ts.u.derived->ts.is_iso_c
10933 70 : || (n->sym->ts.u.derived->intmod_sym_id
10934 : != ISOCBINDING_PTR))
10935 : {
10936 : /* For TARGET, non-C_PTR are deprecated and handled as
10937 : has_device_addr. */
10938 184 : gfc_warning (OPT_Wdeprecated_openmp,
10939 : "Non-C_PTR type argument at %L is deprecated, "
10940 : "use HAS_DEVICE_ADDR", &n->where);
10941 184 : gfc_omp_namelist *n2 = n;
10942 184 : n = n->next;
10943 184 : if (last)
10944 0 : last->next = n;
10945 : else
10946 184 : omp_clauses->lists[list] = n;
10947 184 : n2->next = omp_clauses->lists[OMP_LIST_HAS_DEVICE_ADDR];
10948 184 : omp_clauses->lists[OMP_LIST_HAS_DEVICE_ADDR] = n2;
10949 184 : continue;
10950 184 : }
10951 73 : last = n;
10952 73 : n = n->next;
10953 : }
10954 : break;
10955 : case OMP_LIST_HAS_DEVICE_ADDR:
10956 : case OMP_LIST_USE_DEVICE_ADDR:
10957 : break;
10958 : case OMP_LIST_USE_DEVICE_PTR:
10959 : /* Non-C_PTR are deprecated and handled as use_device_ADDR. */
10960 : last = NULL;
10961 475 : for (n = omp_clauses->lists[list]; n != NULL; )
10962 : {
10963 312 : gfc_omp_namelist *n2 = n;
10964 312 : if (n->sym->ts.type != BT_DERIVED
10965 18 : || !n->sym->ts.u.derived->ts.is_iso_c)
10966 : {
10967 294 : gfc_warning (OPT_Wdeprecated_openmp,
10968 : "Non-C_PTR type argument at %L is "
10969 : "deprecated, use USE_DEVICE_ADDR", &n->where);
10970 294 : n = n->next;
10971 294 : if (last)
10972 0 : last->next = n;
10973 : else
10974 294 : omp_clauses->lists[list] = n;
10975 294 : n2->next = omp_clauses->lists[OMP_LIST_USE_DEVICE_ADDR];
10976 294 : omp_clauses->lists[OMP_LIST_USE_DEVICE_ADDR] = n2;
10977 294 : continue;
10978 : }
10979 18 : last = n;
10980 18 : n = n->next;
10981 : }
10982 : break;
10983 65 : case OMP_LIST_USES_ALLOCATORS:
10984 65 : {
10985 65 : if (n != NULL
10986 65 : && n->u.memspace_sym
10987 20 : && (n->u.memspace_sym->attr.flavor != FL_PARAMETER
10988 18 : || n->u.memspace_sym->ts.type != BT_INTEGER
10989 18 : || n->u.memspace_sym->ts.kind != gfc_c_intptr_kind
10990 18 : || n->u.memspace_sym->attr.dimension
10991 18 : || (!startswith (n->u.memspace_sym->name, "omp_")
10992 0 : && !startswith (n->u.memspace_sym->name, "ompx_"))
10993 18 : || !endswith (n->u.memspace_sym->name, "_mem_space")))
10994 3 : gfc_error ("Memspace %qs at %L in USES_ALLOCATORS must be "
10995 : "a predefined memory space",
10996 : n->u.memspace_sym->name, &n->where);
10997 180 : for (; n != NULL; n = n->next)
10998 : {
10999 122 : if (n->sym->ts.type != BT_INTEGER
11000 121 : || n->sym->ts.kind != gfc_c_intptr_kind
11001 120 : || n->sym->attr.dimension)
11002 3 : gfc_error ("Allocator %qs at %L in USES_ALLOCATORS must "
11003 : "be a scalar integer of kind "
11004 : "%<omp_allocator_handle_kind%>", n->sym->name,
11005 : &n->where);
11006 119 : else if (n->sym->attr.flavor != FL_VARIABLE
11007 50 : && strcmp (n->sym->name, "omp_null_allocator") != 0
11008 165 : && ((!startswith (n->sym->name, "omp_")
11009 1 : && !startswith (n->sym->name, "ompx_"))
11010 45 : || !endswith (n->sym->name, "_mem_alloc")))
11011 2 : gfc_error ("Allocator %qs at %L in USES_ALLOCATORS must "
11012 : "either a variable or a predefined allocator",
11013 : n->sym->name, &n->where);
11014 117 : else if ((n->u.memspace_sym || n->u2.traits_sym)
11015 61 : && n->sym->attr.flavor != FL_VARIABLE)
11016 3 : gfc_error ("A memory space or traits array may not be "
11017 : "specified for predefined allocator %qs at %L",
11018 : n->sym->name, &n->where);
11019 122 : if (n->u2.traits_sym
11020 50 : && (n->u2.traits_sym->attr.flavor != FL_PARAMETER
11021 47 : || !n->u2.traits_sym->attr.dimension
11022 45 : || n->u2.traits_sym->as->rank != 1
11023 45 : || n->u2.traits_sym->ts.type != BT_DERIVED
11024 43 : || strcmp (n->u2.traits_sym->ts.u.derived->name,
11025 : "omp_alloctrait") != 0))
11026 : {
11027 7 : gfc_error ("Traits array %qs in USES_ALLOCATORS %L must "
11028 : "be a one-dimensional named constant array of "
11029 : "type %<omp_alloctrait%>",
11030 : n->u2.traits_sym->name, &n->where);
11031 7 : break;
11032 : }
11033 : }
11034 : break;
11035 : }
11036 : default:
11037 34780 : for (; n != NULL; n = n->next)
11038 : {
11039 20382 : if (n->sym == NULL)
11040 : {
11041 26 : gcc_assert (code->op == EXEC_OMP_ALLOCATORS
11042 : || code->op == EXEC_OMP_ALLOCATE);
11043 26 : continue;
11044 : }
11045 20356 : bool bad = false;
11046 20356 : bool is_reduction = (list == OMP_LIST_REDUCTION
11047 : || list == OMP_LIST_REDUCTION_INSCAN
11048 : || list == OMP_LIST_REDUCTION_TASK
11049 : || list == OMP_LIST_IN_REDUCTION
11050 20356 : || list == OMP_LIST_TASK_REDUCTION);
11051 20356 : if (list == OMP_LIST_REDUCTION_INSCAN)
11052 : has_inscan = true;
11053 20284 : else if (is_reduction)
11054 4738 : has_notinscan = true;
11055 20356 : if (has_inscan && has_notinscan && is_reduction)
11056 : {
11057 3 : gfc_error ("%<inscan%> and non-%<inscan%> %<reduction%> "
11058 : "clauses on the same construct at %L",
11059 : &n->where);
11060 3 : break;
11061 : }
11062 20353 : if (n->sym->attr.threadprivate)
11063 1 : gfc_error ("THREADPRIVATE object %qs in %s clause at %L",
11064 : n->sym->name, name, &n->where);
11065 20353 : if (n->sym->attr.cray_pointee)
11066 14 : gfc_error ("Cray pointee %qs in %s clause at %L",
11067 : n->sym->name, name, &n->where);
11068 20353 : if (n->sym->attr.associate_var)
11069 22 : gfc_error ("Associate name %qs in %s clause at %L",
11070 22 : n->sym->attr.select_type_temporary
11071 4 : ? n->sym->assoc->target->symtree->n.sym->name
11072 : : n->sym->name, name, &n->where);
11073 20353 : if (list != OMP_LIST_PRIVATE && is_reduction)
11074 : {
11075 4807 : if (n->sym->attr.proc_pointer)
11076 1 : gfc_error ("Procedure pointer %qs in %s clause at %L",
11077 : n->sym->name, name, &n->where);
11078 4807 : if (n->sym->attr.pointer)
11079 3 : gfc_error ("POINTER object %qs in %s clause at %L",
11080 : n->sym->name, name, &n->where);
11081 4807 : if (n->sym->attr.cray_pointer)
11082 5 : gfc_error ("Cray pointer %qs in %s clause at %L",
11083 : n->sym->name, name, &n->where);
11084 : }
11085 20353 : if (code
11086 20353 : && (oacc_is_loop (code)
11087 : || code->op == EXEC_OACC_PARALLEL
11088 : || code->op == EXEC_OACC_SERIAL))
11089 8741 : check_array_not_assumed (n->sym, n->where, name);
11090 11612 : else if (list != OMP_LIST_UNIFORM
11091 11495 : && n->sym->as && n->sym->as->type == AS_ASSUMED_SIZE)
11092 2 : gfc_error ("Assumed size array %qs in %s clause at %L",
11093 : n->sym->name, name, &n->where);
11094 20353 : if (n->sym->attr.in_namelist && !is_reduction)
11095 0 : gfc_error ("Variable %qs in %s clause is used in "
11096 : "NAMELIST statement at %L",
11097 : n->sym->name, name, &n->where);
11098 20353 : if (n->sym->attr.pointer && n->sym->attr.intent == INTENT_IN)
11099 3 : switch (list)
11100 : {
11101 3 : case OMP_LIST_PRIVATE:
11102 3 : case OMP_LIST_LASTPRIVATE:
11103 3 : case OMP_LIST_LINEAR:
11104 : /* case OMP_LIST_REDUCTION: */
11105 3 : gfc_error ("INTENT(IN) POINTER %qs in %s clause at %L",
11106 : n->sym->name, name, &n->where);
11107 3 : break;
11108 : default:
11109 : break;
11110 : }
11111 20353 : if (omp_clauses->detach
11112 3 : && (list == OMP_LIST_PRIVATE
11113 : || list == OMP_LIST_FIRSTPRIVATE
11114 : || list == OMP_LIST_LASTPRIVATE)
11115 3 : && n->sym == omp_clauses->detach->symtree->n.sym)
11116 1 : gfc_error ("DETACH event handle %qs in %s clause at %L",
11117 : n->sym->name, name, &n->where);
11118 :
11119 20353 : if (!openacc
11120 20353 : && (list == OMP_LIST_PRIVATE
11121 20353 : || list == OMP_LIST_FIRSTPRIVATE)
11122 4704 : && ((n->sym->ts.type == BT_DERIVED
11123 158 : && n->sym->ts.u.derived->attr.alloc_comp)
11124 4594 : || n->sym->ts.type == BT_CLASS))
11125 170 : switch (code->op)
11126 : {
11127 8 : case EXEC_OMP_TARGET:
11128 8 : case EXEC_OMP_TARGET_PARALLEL:
11129 8 : case EXEC_OMP_TARGET_PARALLEL_DO:
11130 8 : case EXEC_OMP_TARGET_PARALLEL_DO_SIMD:
11131 8 : case EXEC_OMP_TARGET_PARALLEL_LOOP:
11132 8 : case EXEC_OMP_TARGET_SIMD:
11133 8 : case EXEC_OMP_TARGET_TEAMS:
11134 8 : case EXEC_OMP_TARGET_TEAMS_DISTRIBUTE:
11135 8 : case EXEC_OMP_TARGET_TEAMS_DISTRIBUTE_PARALLEL_DO:
11136 8 : case EXEC_OMP_TARGET_TEAMS_DISTRIBUTE_PARALLEL_DO_SIMD:
11137 8 : case EXEC_OMP_TARGET_TEAMS_DISTRIBUTE_SIMD:
11138 8 : case EXEC_OMP_TARGET_TEAMS_LOOP:
11139 8 : if (n->sym->ts.type == BT_DERIVED
11140 2 : && n->sym->ts.u.derived->attr.alloc_comp)
11141 3 : gfc_error ("Sorry, list item %qs at %L with allocatable"
11142 : " components is not yet supported in %s "
11143 : "clause", n->sym->name, &n->where,
11144 : list == OMP_LIST_PRIVATE ? "PRIVATE"
11145 : : "FIRSTPRIVATE");
11146 : else
11147 9 : gfc_error ("Polymorphic list item %qs at %L in %s "
11148 : "clause has unspecified behavior and "
11149 : "unsupported", n->sym->name, &n->where,
11150 : list == OMP_LIST_PRIVATE ? "PRIVATE"
11151 : : "FIRSTPRIVATE");
11152 : break;
11153 : default:
11154 : break;
11155 : }
11156 :
11157 20353 : switch (list)
11158 : {
11159 104 : case OMP_LIST_REDUCTION_TASK:
11160 104 : if (code
11161 104 : && (code->op == EXEC_OMP_LOOP
11162 : || code->op == EXEC_OMP_TASKLOOP
11163 : || code->op == EXEC_OMP_TASKLOOP_SIMD
11164 : || code->op == EXEC_OMP_MASKED_TASKLOOP
11165 : || code->op == EXEC_OMP_MASKED_TASKLOOP_SIMD
11166 : || code->op == EXEC_OMP_MASTER_TASKLOOP
11167 : || code->op == EXEC_OMP_MASTER_TASKLOOP_SIMD
11168 : || code->op == EXEC_OMP_PARALLEL_LOOP
11169 : || code->op == EXEC_OMP_PARALLEL_MASKED_TASKLOOP
11170 : || code->op == EXEC_OMP_PARALLEL_MASKED_TASKLOOP_SIMD
11171 : || code->op == EXEC_OMP_PARALLEL_MASTER_TASKLOOP
11172 : || code->op == EXEC_OMP_PARALLEL_MASTER_TASKLOOP_SIMD
11173 : || code->op == EXEC_OMP_TARGET_PARALLEL_LOOP
11174 : || code->op == EXEC_OMP_TARGET_TEAMS_LOOP
11175 : || code->op == EXEC_OMP_TEAMS
11176 : || code->op == EXEC_OMP_TEAMS_DISTRIBUTE
11177 : || code->op == EXEC_OMP_TEAMS_LOOP))
11178 : {
11179 17 : gfc_error ("Only DEFAULT permitted as reduction-"
11180 : "modifier in REDUCTION clause at %L",
11181 : &n->where);
11182 17 : break;
11183 : }
11184 4790 : gcc_fallthrough ();
11185 4790 : case OMP_LIST_REDUCTION:
11186 4790 : case OMP_LIST_IN_REDUCTION:
11187 4790 : case OMP_LIST_TASK_REDUCTION:
11188 4790 : case OMP_LIST_REDUCTION_INSCAN:
11189 4790 : switch (n->u.reduction_op)
11190 : {
11191 2655 : case OMP_REDUCTION_PLUS:
11192 2655 : case OMP_REDUCTION_TIMES:
11193 2655 : case OMP_REDUCTION_MINUS:
11194 2655 : if (!gfc_numeric_ts (&n->sym->ts))
11195 : bad = true;
11196 : break;
11197 1112 : case OMP_REDUCTION_AND:
11198 1112 : case OMP_REDUCTION_OR:
11199 1112 : case OMP_REDUCTION_EQV:
11200 1112 : case OMP_REDUCTION_NEQV:
11201 1112 : if (n->sym->ts.type != BT_LOGICAL)
11202 : bad = true;
11203 : break;
11204 480 : case OMP_REDUCTION_MAX:
11205 480 : case OMP_REDUCTION_MIN:
11206 480 : if (n->sym->ts.type != BT_INTEGER
11207 212 : && n->sym->ts.type != BT_REAL)
11208 : bad = true;
11209 : break;
11210 192 : case OMP_REDUCTION_IAND:
11211 192 : case OMP_REDUCTION_IOR:
11212 192 : case OMP_REDUCTION_IEOR:
11213 192 : if (n->sym->ts.type != BT_INTEGER)
11214 : bad = true;
11215 : break;
11216 : case OMP_REDUCTION_USER:
11217 : bad = true;
11218 : break;
11219 : default:
11220 : break;
11221 : }
11222 : if (!bad)
11223 4215 : n->u2.udr = NULL;
11224 : else
11225 : {
11226 575 : const char *udr_name = NULL;
11227 575 : if (n->u2.udr)
11228 : {
11229 471 : udr_name = n->u2.udr->udr->name;
11230 471 : n->u2.udr->udr
11231 942 : = gfc_find_omp_udr (NULL, udr_name,
11232 471 : &n->sym->ts);
11233 471 : if (n->u2.udr->udr == NULL)
11234 : {
11235 0 : free (n->u2.udr);
11236 0 : n->u2.udr = NULL;
11237 : }
11238 : }
11239 575 : if (n->u2.udr == NULL)
11240 : {
11241 104 : if (udr_name == NULL)
11242 104 : switch (n->u.reduction_op)
11243 : {
11244 50 : case OMP_REDUCTION_PLUS:
11245 50 : case OMP_REDUCTION_TIMES:
11246 50 : case OMP_REDUCTION_MINUS:
11247 50 : case OMP_REDUCTION_AND:
11248 50 : case OMP_REDUCTION_OR:
11249 50 : case OMP_REDUCTION_EQV:
11250 50 : case OMP_REDUCTION_NEQV:
11251 50 : udr_name = gfc_op2string ((gfc_intrinsic_op)
11252 : n->u.reduction_op);
11253 50 : break;
11254 : case OMP_REDUCTION_MAX:
11255 : udr_name = "max";
11256 : break;
11257 9 : case OMP_REDUCTION_MIN:
11258 9 : udr_name = "min";
11259 9 : break;
11260 12 : case OMP_REDUCTION_IAND:
11261 12 : udr_name = "iand";
11262 12 : break;
11263 12 : case OMP_REDUCTION_IOR:
11264 12 : udr_name = "ior";
11265 12 : break;
11266 9 : case OMP_REDUCTION_IEOR:
11267 9 : udr_name = "ieor";
11268 9 : break;
11269 0 : default:
11270 0 : gcc_unreachable ();
11271 : }
11272 104 : gfc_error ("!$OMP DECLARE REDUCTION %s not found "
11273 : "for type %s at %L", udr_name,
11274 104 : gfc_typename (&n->sym->ts), &n->where);
11275 : }
11276 : else
11277 : {
11278 471 : gfc_omp_udr *udr = n->u2.udr->udr;
11279 471 : n->u.reduction_op = OMP_REDUCTION_USER;
11280 471 : n->u2.udr->combiner
11281 942 : = resolve_omp_udr_clause (n, udr->combiner_ns,
11282 471 : udr->omp_out,
11283 471 : udr->omp_in);
11284 471 : if (udr->initializer_ns)
11285 331 : n->u2.udr->initializer
11286 331 : = resolve_omp_udr_clause (n,
11287 : udr->initializer_ns,
11288 331 : udr->omp_priv,
11289 331 : udr->omp_orig);
11290 : }
11291 : }
11292 : break;
11293 875 : case OMP_LIST_LINEAR:
11294 875 : if (code)
11295 : {
11296 727 : bool is_worksharing_for = false;
11297 727 : switch (code->op)
11298 : {
11299 54 : case EXEC_OMP_DO:
11300 54 : case EXEC_OMP_PARALLEL_DO:
11301 54 : case EXEC_OMP_DISTRIBUTE_PARALLEL_DO:
11302 54 : case EXEC_OMP_TARGET_PARALLEL_DO:
11303 54 : case EXEC_OMP_TEAMS_DISTRIBUTE_PARALLEL_DO:
11304 54 : case EXEC_OMP_TARGET_TEAMS_DISTRIBUTE_PARALLEL_DO:
11305 54 : is_worksharing_for = true;
11306 54 : break;
11307 : default:
11308 : break;
11309 : }
11310 :
11311 54 : if (is_worksharing_for
11312 54 : && (n->sym->attr.dimension
11313 53 : || n->sym->attr.allocatable))
11314 : {
11315 1 : if (n->sym->attr.allocatable)
11316 0 : gfc_error ("Sorry, ALLOCATABLE object %qs in "
11317 : "LINEAR clause on worksharing-loop "
11318 : "construct at %L is not yet supported",
11319 : n->sym->name, &n->where);
11320 : else
11321 1 : gfc_error ("Sorry, array %qs in LINEAR clause "
11322 : "on worksharing-loop construct at %L "
11323 : "is not yet supported",
11324 : n->sym->name, &n->where);
11325 : break;
11326 : }
11327 : }
11328 :
11329 726 : if (code
11330 726 : && n->u.linear.op != OMP_LINEAR_DEFAULT
11331 23 : && n->u.linear.op != linear_op)
11332 : {
11333 23 : if (n->u.linear.old_modifier)
11334 : {
11335 9 : gfc_error ("LINEAR clause modifier used on DO or "
11336 : "SIMD construct at %L", &n->where);
11337 9 : linear_op = n->u.linear.op;
11338 : }
11339 14 : else if (n->u.linear.op != OMP_LINEAR_VAL)
11340 : {
11341 6 : gfc_error ("LINEAR clause modifier other than VAL "
11342 : "used on DO or SIMD construct at %L",
11343 : &n->where);
11344 6 : linear_op = n->u.linear.op;
11345 : }
11346 : }
11347 851 : else if (n->u.linear.op != OMP_LINEAR_REF
11348 801 : && n->sym->ts.type != BT_INTEGER)
11349 1 : gfc_error ("LINEAR variable %qs must be INTEGER "
11350 : "at %L", n->sym->name, &n->where);
11351 850 : else if ((n->u.linear.op == OMP_LINEAR_REF
11352 800 : || n->u.linear.op == OMP_LINEAR_UVAL)
11353 61 : && n->sym->attr.value)
11354 0 : gfc_error ("LINEAR dummy argument %qs with VALUE "
11355 : "attribute with %s modifier at %L",
11356 : n->sym->name,
11357 : n->u.linear.op == OMP_LINEAR_REF
11358 : ? "REF" : "UVAL", &n->where);
11359 850 : else if (n->expr)
11360 : {
11361 831 : gfc_expr *expr = n->expr;
11362 831 : if (!gfc_resolve_expr (expr)
11363 831 : || expr->ts.type != BT_INTEGER
11364 1662 : || expr->rank != 0)
11365 0 : gfc_error ("%qs in LINEAR clause at %L requires "
11366 : "a scalar integer linear-step expression",
11367 0 : n->sym->name, &n->where);
11368 831 : else if (!code && expr->expr_type != EXPR_CONSTANT)
11369 : {
11370 11 : if (expr->expr_type == EXPR_VARIABLE
11371 7 : && expr->symtree->n.sym->attr.dummy
11372 6 : && expr->symtree->n.sym->ns == ns)
11373 : {
11374 6 : gfc_omp_namelist *n2;
11375 6 : for (n2 = omp_clauses->lists[OMP_LIST_UNIFORM];
11376 6 : n2; n2 = n2->next)
11377 6 : if (n2->sym == expr->symtree->n.sym)
11378 : break;
11379 6 : if (n2)
11380 : break;
11381 : }
11382 5 : gfc_error ("%qs in LINEAR clause at %L requires "
11383 : "a constant integer linear-step "
11384 : "expression or dummy argument "
11385 : "specified in UNIFORM clause",
11386 5 : n->sym->name, &n->where);
11387 : }
11388 : }
11389 : break;
11390 : /* Workaround for PR middle-end/26316, nothing really needs
11391 : to be done here for OMP_LIST_PRIVATE. */
11392 9394 : case OMP_LIST_PRIVATE:
11393 9394 : gcc_assert (code && code->op != EXEC_NOP);
11394 : break;
11395 98 : case OMP_LIST_USE_DEVICE:
11396 98 : if (n->sym->attr.allocatable
11397 98 : || (n->sym->ts.type == BT_CLASS && CLASS_DATA (n->sym)
11398 0 : && CLASS_DATA (n->sym)->attr.allocatable))
11399 0 : gfc_error ("ALLOCATABLE object %qs in %s clause at %L",
11400 : n->sym->name, name, &n->where);
11401 98 : if (n->sym->ts.type == BT_CLASS
11402 0 : && CLASS_DATA (n->sym)
11403 0 : && CLASS_DATA (n->sym)->attr.class_pointer)
11404 0 : gfc_error ("POINTER object %qs of polymorphic type in "
11405 : "%s clause at %L", n->sym->name, name,
11406 : &n->where);
11407 98 : if (n->sym->attr.cray_pointer)
11408 2 : gfc_error ("Cray pointer object %qs in %s clause at %L",
11409 : n->sym->name, name, &n->where);
11410 96 : else if (n->sym->attr.cray_pointee)
11411 2 : gfc_error ("Cray pointee object %qs in %s clause at %L",
11412 : n->sym->name, name, &n->where);
11413 94 : else if (n->sym->attr.flavor == FL_VARIABLE
11414 93 : && !n->sym->as
11415 54 : && !n->sym->attr.pointer)
11416 13 : gfc_error ("%s clause variable %qs at %L is neither "
11417 : "a POINTER nor an array", name,
11418 : n->sym->name, &n->where);
11419 : /* FALLTHRU */
11420 98 : case OMP_LIST_DEVICE_RESIDENT:
11421 98 : check_symbol_not_pointer (n->sym, n->where, name);
11422 98 : check_array_not_assumed (n->sym, n->where, name);
11423 98 : break;
11424 : default:
11425 : break;
11426 : }
11427 : }
11428 : break;
11429 : }
11430 : }
11431 : /* OpenMP 5.1: use_device_ptr acts like use_device_addr, except for
11432 : type(c_ptr). */
11433 33061 : if (omp_clauses->lists[OMP_LIST_USE_DEVICE_PTR])
11434 : {
11435 9 : gfc_omp_namelist *n_prev, *n_next, *n_addr;
11436 9 : n_addr = omp_clauses->lists[OMP_LIST_USE_DEVICE_ADDR];
11437 28 : for (; n_addr && n_addr->next; n_addr = n_addr->next)
11438 : ;
11439 : n_prev = NULL;
11440 : n = omp_clauses->lists[OMP_LIST_USE_DEVICE_PTR];
11441 27 : while (n)
11442 : {
11443 18 : n_next = n->next;
11444 18 : if (n->sym->ts.type != BT_DERIVED
11445 18 : || n->sym->ts.u.derived->ts.f90_type != BT_VOID)
11446 : {
11447 0 : n->next = NULL;
11448 0 : if (n_addr)
11449 0 : n_addr->next = n;
11450 : else
11451 0 : omp_clauses->lists[OMP_LIST_USE_DEVICE_ADDR] = n;
11452 0 : n_addr = n;
11453 0 : if (n_prev)
11454 0 : n_prev->next = n_next;
11455 : else
11456 0 : omp_clauses->lists[OMP_LIST_USE_DEVICE_PTR] = n_next;
11457 : }
11458 : else
11459 : n_prev = n;
11460 18 : n = n_next;
11461 : }
11462 : }
11463 33061 : if (omp_clauses->safelen_expr)
11464 93 : resolve_positive_int_expr (omp_clauses->safelen_expr, "SAFELEN");
11465 33061 : if (omp_clauses->simdlen_expr)
11466 123 : resolve_positive_int_expr (omp_clauses->simdlen_expr, "SIMDLEN");
11467 33255 : for (el = omp_clauses->num_teams_list; el; el = el->next)
11468 194 : resolve_positive_int_expr (el->expr, "NUM_TEAMS");
11469 33061 : if (omp_clauses->num_teams_list
11470 153 : && omp_clauses->num_teams_list->next
11471 34 : && !omp_clauses->num_teams_dims
11472 27 : && omp_clauses->num_teams_list->expr->expr_type == EXPR_CONSTANT
11473 13 : && omp_clauses->num_teams_list->next->expr->expr_type == EXPR_CONSTANT
11474 13 : && mpz_cmp (omp_clauses->num_teams_list->expr->value.integer,
11475 13 : omp_clauses->num_teams_list->next->expr->value.integer) > 0)
11476 2 : gfc_warning (OPT_Wopenmp, "NUM_TEAMS lower bound at %L larger than upper "
11477 : "bound at %L", &omp_clauses->num_teams_list->expr->where,
11478 : &omp_clauses->num_teams_list->next->expr->where);
11479 33061 : if (omp_clauses->device)
11480 333 : resolve_scalar_int_expr (omp_clauses->device, "DEVICE");
11481 33061 : if (omp_clauses->filter)
11482 42 : resolve_nonnegative_int_expr (omp_clauses->filter, "FILTER");
11483 33061 : if (omp_clauses->hint)
11484 : {
11485 42 : resolve_scalar_int_expr (omp_clauses->hint, "HINT");
11486 42 : if (omp_clauses->hint->ts.type != BT_INTEGER
11487 40 : || omp_clauses->hint->expr_type != EXPR_CONSTANT
11488 38 : || mpz_sgn (omp_clauses->hint->value.integer) < 0)
11489 5 : gfc_error ("Value of HINT clause at %L shall be a valid "
11490 : "constant hint expression", &omp_clauses->hint->where);
11491 : }
11492 33061 : if (omp_clauses->priority)
11493 34 : resolve_nonnegative_int_expr (omp_clauses->priority, "PRIORITY");
11494 33061 : if (omp_clauses->dist_chunk_size)
11495 : {
11496 83 : gfc_expr *expr = omp_clauses->dist_chunk_size;
11497 83 : if (!gfc_resolve_expr (expr)
11498 83 : || expr->ts.type != BT_INTEGER || expr->rank != 0)
11499 0 : gfc_error ("DIST_SCHEDULE clause's chunk_size at %L requires "
11500 : "a scalar INTEGER expression", &expr->where);
11501 : }
11502 33183 : for (el = omp_clauses->thread_limit_list; el; el = el->next)
11503 122 : resolve_positive_int_expr (el->expr, "THREAD_LIMIT");
11504 33061 : if (omp_clauses->grainsize)
11505 34 : resolve_positive_int_expr (omp_clauses->grainsize, "GRAINSIZE");
11506 33061 : if (omp_clauses->num_tasks)
11507 26 : resolve_positive_int_expr (omp_clauses->num_tasks, "NUM_TASKS");
11508 33061 : if (omp_clauses->grainsize && omp_clauses->num_tasks)
11509 1 : gfc_error ("%<GRAINSIZE%> clause at %L must not be used together with "
11510 : "%<NUM_TASKS%> clause", &omp_clauses->grainsize->where);
11511 33061 : if (omp_clauses->lists[OMP_LIST_REDUCTION] && omp_clauses->nogroup)
11512 1 : gfc_error ("%<REDUCTION%> clause at %L must not be used together with "
11513 : "%<NOGROUP%> clause",
11514 : &omp_clauses->lists[OMP_LIST_REDUCTION]->where);
11515 33061 : if (omp_clauses->full && omp_clauses->partial)
11516 0 : gfc_error ("%<FULL%> clause at %C must not be used together with "
11517 : "%<PARTIAL%> clause");
11518 33061 : if (omp_clauses->async)
11519 610 : if (omp_clauses->async_expr)
11520 610 : resolve_scalar_int_expr (omp_clauses->async_expr, "ASYNC");
11521 33061 : if (omp_clauses->device_num_expr)
11522 105 : resolve_scalar_int_expr (omp_clauses->device_num_expr, "DEVICE_NUM");
11523 33061 : if (code && code->op == EXEC_OACC_SET
11524 121 : && !omp_clauses->device_num_expr
11525 52 : && !omp_clauses->oacc_device_type_present)
11526 2 : gfc_error ("At least one of the clauses %<DEVICE_TYPE%> and %<DEVICE_NUM%> "
11527 : "should be present in %<SET%> directive at %L", &code->loc);
11528 33061 : if (omp_clauses->num_gangs_expr)
11529 682 : resolve_positive_int_expr (omp_clauses->num_gangs_expr, "NUM_GANGS");
11530 33061 : if (omp_clauses->num_workers_expr)
11531 599 : resolve_positive_int_expr (omp_clauses->num_workers_expr, "NUM_WORKERS");
11532 33061 : if (omp_clauses->vector_length_expr)
11533 569 : resolve_positive_int_expr (omp_clauses->vector_length_expr,
11534 : "VECTOR_LENGTH");
11535 33061 : if (omp_clauses->gang_num_expr)
11536 114 : resolve_positive_int_expr (omp_clauses->gang_num_expr, "GANG");
11537 33061 : if (omp_clauses->gang_static_expr)
11538 94 : resolve_positive_int_expr (omp_clauses->gang_static_expr, "GANG");
11539 33061 : if (omp_clauses->worker_expr)
11540 101 : resolve_positive_int_expr (omp_clauses->worker_expr, "WORKER");
11541 33061 : if (omp_clauses->vector_expr)
11542 132 : resolve_positive_int_expr (omp_clauses->vector_expr, "VECTOR");
11543 33400 : for (el = omp_clauses->wait_list; el; el = el->next)
11544 339 : resolve_scalar_int_expr (el->expr, "WAIT");
11545 33061 : if (omp_clauses->collapse && omp_clauses->tile_list)
11546 4 : gfc_error ("Incompatible use of TILE and COLLAPSE at %L", &code->loc);
11547 33061 : if (omp_clauses->message)
11548 : {
11549 56 : gfc_expr *expr = omp_clauses->message;
11550 56 : if (!gfc_resolve_expr (expr)
11551 56 : || expr->ts.kind != gfc_default_character_kind
11552 109 : || expr->ts.type != BT_CHARACTER || expr->rank != 0)
11553 4 : gfc_error ("MESSAGE clause at %L requires a scalar default-kind "
11554 : "CHARACTER expression", &expr->where);
11555 : }
11556 33061 : if (!openacc
11557 33061 : && code
11558 19823 : && omp_clauses->lists[OMP_LIST_MAP] == NULL
11559 16026 : && omp_clauses->lists[OMP_LIST_USE_DEVICE_PTR] == NULL
11560 16023 : && omp_clauses->lists[OMP_LIST_USE_DEVICE_ADDR] == NULL)
11561 : {
11562 16000 : const char *p = NULL;
11563 16000 : switch (code->op)
11564 : {
11565 1 : case EXEC_OMP_TARGET_ENTER_DATA: p = "TARGET ENTER DATA"; break;
11566 1 : case EXEC_OMP_TARGET_EXIT_DATA: p = "TARGET EXIT DATA"; break;
11567 : default: break;
11568 : }
11569 16000 : if (code->op == EXEC_OMP_TARGET_DATA)
11570 1 : gfc_error ("TARGET DATA must contain at least one MAP, USE_DEVICE_PTR, "
11571 : "or USE_DEVICE_ADDR clause at %L", &code->loc);
11572 15999 : else if (p)
11573 2 : gfc_error ("%s must contain at least one MAP clause at %L",
11574 : p, &code->loc);
11575 : }
11576 33061 : if (omp_clauses->sizes_list)
11577 : {
11578 : gfc_expr_list *el;
11579 572 : for (el = omp_clauses->sizes_list; el; el = el->next)
11580 : {
11581 377 : resolve_scalar_int_expr (el->expr, "SIZES");
11582 377 : if (el->expr->expr_type != EXPR_CONSTANT)
11583 1 : gfc_error ("SIZES requires constant expression at %L",
11584 : &el->expr->where);
11585 376 : else if (el->expr->expr_type == EXPR_CONSTANT
11586 376 : && el->expr->ts.type == BT_INTEGER
11587 376 : && mpz_sgn (el->expr->value.integer) <= 0)
11588 2 : gfc_error ("INTEGER expression of %s clause at %L must be "
11589 : "positive", "SIZES", &el->expr->where);
11590 : }
11591 : }
11592 :
11593 33061 : if (!openacc && omp_clauses->detach)
11594 : {
11595 125 : if (!gfc_resolve_expr (omp_clauses->detach)
11596 125 : || omp_clauses->detach->ts.type != BT_INTEGER
11597 124 : || omp_clauses->detach->ts.kind != gfc_c_intptr_kind
11598 248 : || omp_clauses->detach->rank != 0)
11599 3 : gfc_error ("%qs at %L should be a scalar of type "
11600 : "integer(kind=omp_event_handle_kind)",
11601 3 : omp_clauses->detach->symtree->n.sym->name,
11602 3 : &omp_clauses->detach->where);
11603 122 : else if (omp_clauses->detach->symtree->n.sym->attr.dimension > 0)
11604 1 : gfc_error ("The event handle at %L must not be an array element",
11605 : &omp_clauses->detach->where);
11606 121 : else if (omp_clauses->detach->symtree->n.sym->ts.type == BT_DERIVED
11607 120 : || omp_clauses->detach->symtree->n.sym->ts.type == BT_CLASS)
11608 1 : gfc_error ("The event handle at %L must not be part of "
11609 : "a derived type or class", &omp_clauses->detach->where);
11610 :
11611 125 : if (omp_clauses->mergeable)
11612 2 : gfc_error ("%<DETACH%> clause at %L must not be used together with "
11613 2 : "%<MERGEABLE%> clause", &omp_clauses->detach->where);
11614 : }
11615 :
11616 : if (openacc
11617 12995 : && code->op == EXEC_OACC_HOST_DATA
11618 60 : && omp_clauses->lists[OMP_LIST_USE_DEVICE] == NULL)
11619 1 : gfc_error ("%<host_data%> construct at %L requires %<use_device%> clause",
11620 : &code->loc);
11621 :
11622 33061 : if (omp_clauses->assume)
11623 16 : gfc_resolve_omp_assumptions (omp_clauses->assume);
11624 : }
11625 :
11626 :
11627 : /* Return true if SYM is ever referenced in EXPR except in the SE node. */
11628 :
11629 : static bool
11630 4991 : expr_references_sym (gfc_expr *e, gfc_symbol *s, gfc_expr *se)
11631 : {
11632 6617 : gfc_actual_arglist *arg;
11633 6617 : if (e == NULL || e == se)
11634 : return false;
11635 5366 : switch (e->expr_type)
11636 : {
11637 3120 : case EXPR_CONSTANT:
11638 3120 : case EXPR_NULL:
11639 3120 : case EXPR_VARIABLE:
11640 3120 : case EXPR_STRUCTURE:
11641 3120 : case EXPR_ARRAY:
11642 3120 : if (e->symtree != NULL
11643 1152 : && e->symtree->n.sym == s)
11644 470 : return true;
11645 : return false;
11646 0 : case EXPR_SUBSTRING:
11647 0 : if (e->ref != NULL
11648 0 : && (expr_references_sym (e->ref->u.ss.start, s, se)
11649 0 : || expr_references_sym (e->ref->u.ss.end, s, se)))
11650 0 : return true;
11651 : return false;
11652 1735 : case EXPR_OP:
11653 1735 : if (expr_references_sym (e->value.op.op2, s, se))
11654 : return true;
11655 1626 : return expr_references_sym (e->value.op.op1, s, se);
11656 511 : case EXPR_FUNCTION:
11657 896 : for (arg = e->value.function.actual; arg; arg = arg->next)
11658 586 : if (expr_references_sym (arg->expr, s, se))
11659 : return true;
11660 : return false;
11661 0 : default:
11662 0 : gcc_unreachable ();
11663 : }
11664 : }
11665 :
11666 :
11667 : /* If EXPR is a conversion function that widens the type
11668 : if WIDENING is true or narrows the type if NARROW is true,
11669 : return the inner expression, otherwise return NULL. */
11670 :
11671 : static gfc_expr *
11672 5911 : is_conversion (gfc_expr *expr, bool narrowing, bool widening)
11673 : {
11674 5911 : gfc_typespec *ts1, *ts2;
11675 :
11676 5911 : if (expr->expr_type != EXPR_FUNCTION
11677 917 : || expr->value.function.isym == NULL
11678 894 : || expr->value.function.esym != NULL
11679 894 : || expr->value.function.isym->id != GFC_ISYM_CONVERSION
11680 388 : || (!narrowing && !widening))
11681 : return NULL;
11682 :
11683 388 : if (narrowing && widening)
11684 267 : return expr->value.function.actual->expr;
11685 :
11686 121 : if (widening)
11687 : {
11688 121 : ts1 = &expr->ts;
11689 121 : ts2 = &expr->value.function.actual->expr->ts;
11690 : }
11691 : else
11692 : {
11693 0 : ts1 = &expr->value.function.actual->expr->ts;
11694 0 : ts2 = &expr->ts;
11695 : }
11696 :
11697 121 : if (ts1->type > ts2->type
11698 49 : || (ts1->type == ts2->type && ts1->kind > ts2->kind))
11699 121 : return expr->value.function.actual->expr;
11700 :
11701 : return NULL;
11702 : }
11703 :
11704 : static bool
11705 6855 : is_scalar_intrinsic_expr (gfc_expr *expr, bool must_be_var, bool conv_ok)
11706 : {
11707 6855 : if (must_be_var
11708 4020 : && (expr->expr_type != EXPR_VARIABLE || !expr->symtree))
11709 : {
11710 37 : if (!conv_ok)
11711 : return false;
11712 37 : gfc_expr *conv = is_conversion (expr, true, true);
11713 37 : if (!conv)
11714 : return false;
11715 36 : if (conv->expr_type != EXPR_VARIABLE || !conv->symtree)
11716 : return false;
11717 : }
11718 6852 : return (expr->rank == 0
11719 6848 : && !gfc_is_coindexed (expr)
11720 13700 : && (expr->ts.type == BT_INTEGER
11721 1522 : || expr->ts.type == BT_REAL
11722 590 : || expr->ts.type == BT_COMPLEX
11723 572 : || expr->ts.type == BT_LOGICAL));
11724 : }
11725 :
11726 : static void
11727 2697 : resolve_omp_atomic (gfc_code *code)
11728 : {
11729 2697 : gfc_code *atomic_code = code->block;
11730 2697 : gfc_symbol *var;
11731 2697 : gfc_expr *stmt_expr2, *capt_expr2;
11732 2697 : gfc_omp_atomic_op aop
11733 2697 : = (gfc_omp_atomic_op) (atomic_code->ext.omp_clauses->atomic_op
11734 : & GFC_OMP_ATOMIC_MASK);
11735 2697 : gfc_code *stmt = NULL, *capture_stmt = NULL, *tailing_stmt = NULL;
11736 2697 : gfc_expr *comp_cond = NULL;
11737 2697 : locus *loc = NULL;
11738 :
11739 2697 : code = code->block->next;
11740 : /* resolve_blocks asserts this is initially EXEC_ASSIGN or EXEC_IF
11741 : If it changed to EXEC_NOP, assume an error has been emitted already. */
11742 2697 : if (code->op == EXEC_NOP)
11743 : return;
11744 :
11745 2696 : if (atomic_code->ext.omp_clauses->compare
11746 156 : && atomic_code->ext.omp_clauses->capture)
11747 : {
11748 : /* Must be either "if (x == e) then; x = d; else; v = x; end if"
11749 : or "v = expr" followed/preceded by
11750 : "if (x == e) then; x = d; end if" or "if (x == e) x = d". */
11751 103 : gfc_code *next = code;
11752 103 : if (code->op == EXEC_ASSIGN)
11753 : {
11754 19 : capture_stmt = code;
11755 19 : next = code->next;
11756 : }
11757 103 : if (next->op == EXEC_IF
11758 103 : && next->block
11759 103 : && next->block->op == EXEC_IF
11760 103 : && next->block->next
11761 102 : && next->block->next->op == EXEC_ASSIGN)
11762 : {
11763 102 : comp_cond = next->block->expr1;
11764 102 : stmt = next->block->next;
11765 102 : if (stmt->next)
11766 : {
11767 0 : loc = &stmt->loc;
11768 0 : goto unexpected;
11769 : }
11770 : }
11771 1 : else if (capture_stmt)
11772 : {
11773 0 : gfc_error ("Expected IF at %L in atomic compare capture",
11774 : &next->loc);
11775 0 : return;
11776 : }
11777 103 : if (stmt && !capture_stmt && next->block->block)
11778 : {
11779 64 : if (next->block->block->expr1)
11780 : {
11781 0 : gfc_error ("Expected ELSE at %L in atomic compare capture",
11782 : &next->block->block->expr1->where);
11783 0 : return;
11784 : }
11785 64 : if (!code->block->block->next
11786 64 : || code->block->block->next->op != EXEC_ASSIGN)
11787 : {
11788 0 : loc = (code->block->block->next ? &code->block->block->next->loc
11789 : : &code->block->block->loc);
11790 0 : goto unexpected;
11791 : }
11792 64 : capture_stmt = code->block->block->next;
11793 64 : if (capture_stmt->next)
11794 : {
11795 0 : loc = &capture_stmt->next->loc;
11796 0 : goto unexpected;
11797 : }
11798 : }
11799 103 : if (stmt && !capture_stmt && next->next->op == EXEC_ASSIGN)
11800 : capture_stmt = next->next;
11801 84 : else if (!capture_stmt)
11802 : {
11803 1 : loc = &code->loc;
11804 1 : goto unexpected;
11805 : }
11806 : }
11807 2593 : else if (atomic_code->ext.omp_clauses->compare)
11808 : {
11809 : /* Must be: "if (x == e) then; x = d; end if" or "if (x == e) x = d". */
11810 53 : if (code->op == EXEC_IF
11811 53 : && code->block
11812 53 : && code->block->op == EXEC_IF
11813 53 : && code->block->next
11814 51 : && code->block->next->op == EXEC_ASSIGN)
11815 : {
11816 51 : comp_cond = code->block->expr1;
11817 51 : stmt = code->block->next;
11818 51 : if (stmt->next || code->block->block)
11819 : {
11820 0 : loc = stmt->next ? &stmt->next->loc : &code->block->block->loc;
11821 0 : goto unexpected;
11822 : }
11823 : }
11824 : else
11825 : {
11826 2 : loc = &code->loc;
11827 2 : goto unexpected;
11828 : }
11829 : }
11830 2540 : else if (atomic_code->ext.omp_clauses->capture)
11831 : {
11832 : /* Must be: "v = x" followed/preceded by "x = ...". */
11833 489 : if (code->op != EXEC_ASSIGN)
11834 0 : goto unexpected;
11835 489 : if (code->next->op != EXEC_ASSIGN)
11836 : {
11837 0 : loc = &code->next->loc;
11838 0 : goto unexpected;
11839 : }
11840 489 : gfc_expr *expr2, *expr2_next;
11841 489 : expr2 = is_conversion (code->expr2, true, true);
11842 489 : if (expr2 == NULL)
11843 447 : expr2 = code->expr2;
11844 489 : expr2_next = is_conversion (code->next->expr2, true, true);
11845 489 : if (expr2_next == NULL)
11846 478 : expr2_next = code->next->expr2;
11847 489 : if (code->expr1->expr_type == EXPR_VARIABLE
11848 489 : && code->next->expr1->expr_type == EXPR_VARIABLE
11849 489 : && expr2->expr_type == EXPR_VARIABLE
11850 243 : && expr2_next->expr_type == EXPR_VARIABLE)
11851 : {
11852 1 : if (code->expr1->symtree->n.sym == expr2_next->symtree->n.sym)
11853 : {
11854 : stmt = code;
11855 : capture_stmt = code->next;
11856 : }
11857 : else
11858 : {
11859 489 : capture_stmt = code;
11860 489 : stmt = code->next;
11861 : }
11862 : }
11863 488 : else if (expr2->expr_type == EXPR_VARIABLE)
11864 : {
11865 : capture_stmt = code;
11866 : stmt = code->next;
11867 : }
11868 : else
11869 : {
11870 247 : stmt = code;
11871 247 : capture_stmt = code->next;
11872 : }
11873 : /* Shall be NULL but can happen for invalid code. */
11874 489 : tailing_stmt = code->next->next;
11875 : }
11876 : else
11877 : {
11878 : /* x = ... */
11879 2051 : stmt = code;
11880 2051 : if (!atomic_code->ext.omp_clauses->compare && stmt->op != EXEC_ASSIGN)
11881 1 : goto unexpected;
11882 : /* Shall be NULL but can happen for invalid code. */
11883 2050 : tailing_stmt = code->next;
11884 : }
11885 :
11886 2692 : if (comp_cond)
11887 : {
11888 153 : if (comp_cond->expr_type != EXPR_OP
11889 153 : || (comp_cond->value.op.op != INTRINSIC_EQ
11890 : && comp_cond->value.op.op != INTRINSIC_EQ_OS
11891 : && comp_cond->value.op.op != INTRINSIC_EQV))
11892 : {
11893 0 : gfc_error ("Expected %<==%>, %<.EQ.%> or %<.EQV.%> atomic comparison "
11894 : "expression at %L", &comp_cond->where);
11895 0 : return;
11896 : }
11897 153 : if (!is_scalar_intrinsic_expr (comp_cond->value.op.op1, true, true))
11898 : {
11899 1 : gfc_error ("Expected scalar intrinsic variable at %L in atomic "
11900 1 : "comparison", &comp_cond->value.op.op1->where);
11901 1 : return;
11902 : }
11903 152 : if (!gfc_resolve_expr (comp_cond->value.op.op2))
11904 : return;
11905 152 : if (!is_scalar_intrinsic_expr (comp_cond->value.op.op2, false, false))
11906 : {
11907 0 : gfc_error ("Expected scalar intrinsic expression at %L in atomic "
11908 0 : "comparison", &comp_cond->value.op.op1->where);
11909 0 : return;
11910 : }
11911 : }
11912 :
11913 2691 : if (!is_scalar_intrinsic_expr (stmt->expr1, true, false))
11914 : {
11915 4 : gfc_error ("!$OMP ATOMIC statement must set a scalar variable of "
11916 4 : "intrinsic type at %L", &stmt->expr1->where);
11917 4 : return;
11918 : }
11919 :
11920 2687 : if (!gfc_resolve_expr (stmt->expr2))
11921 : return;
11922 2683 : if (!is_scalar_intrinsic_expr (stmt->expr2, false, false))
11923 : {
11924 0 : gfc_error ("!$OMP ATOMIC statement must assign an expression of "
11925 0 : "intrinsic type at %L", &stmt->expr2->where);
11926 0 : return;
11927 : }
11928 :
11929 2683 : if (gfc_expr_attr (stmt->expr1).allocatable)
11930 : {
11931 0 : gfc_error ("!$OMP ATOMIC with ALLOCATABLE variable at %L",
11932 0 : &stmt->expr1->where);
11933 0 : return;
11934 : }
11935 :
11936 : /* Should be diagnosed above already. */
11937 2683 : gcc_assert (tailing_stmt == NULL);
11938 :
11939 2683 : var = stmt->expr1->symtree->n.sym;
11940 2683 : stmt_expr2 = is_conversion (stmt->expr2, true, true);
11941 2683 : if (stmt_expr2 == NULL)
11942 2527 : stmt_expr2 = stmt->expr2;
11943 :
11944 2683 : switch (aop)
11945 : {
11946 503 : case GFC_OMP_ATOMIC_READ:
11947 503 : if (stmt_expr2->expr_type != EXPR_VARIABLE)
11948 0 : gfc_error ("!$OMP ATOMIC READ statement must read from a scalar "
11949 : "variable of intrinsic type at %L", &stmt_expr2->where);
11950 : return;
11951 421 : case GFC_OMP_ATOMIC_WRITE:
11952 421 : if (expr_references_sym (stmt_expr2, var, NULL))
11953 0 : gfc_error ("expr in !$OMP ATOMIC WRITE assignment var = expr "
11954 : "must be scalar and cannot reference var at %L",
11955 : &stmt_expr2->where);
11956 : return;
11957 1759 : default:
11958 1759 : break;
11959 : }
11960 :
11961 1759 : if (atomic_code->ext.omp_clauses->capture)
11962 : {
11963 588 : if (!is_scalar_intrinsic_expr (capture_stmt->expr1, true, false))
11964 : {
11965 0 : gfc_error ("!$OMP ATOMIC capture-statement must set a scalar "
11966 : "variable of intrinsic type at %L",
11967 0 : &capture_stmt->expr1->where);
11968 0 : return;
11969 : }
11970 :
11971 588 : if (!is_scalar_intrinsic_expr (capture_stmt->expr2, true, true))
11972 : {
11973 2 : gfc_error ("!$OMP ATOMIC capture-statement requires a scalar variable"
11974 2 : " of intrinsic type at %L", &capture_stmt->expr2->where);
11975 2 : return;
11976 : }
11977 586 : capt_expr2 = is_conversion (capture_stmt->expr2, true, true);
11978 586 : if (capt_expr2 == NULL)
11979 564 : capt_expr2 = capture_stmt->expr2;
11980 :
11981 586 : if (capt_expr2->symtree->n.sym != var)
11982 : {
11983 1 : gfc_error ("!$OMP ATOMIC CAPTURE capture statement reads from "
11984 : "different variable than update statement writes "
11985 : "into at %L", &capture_stmt->expr2->where);
11986 1 : return;
11987 : }
11988 : }
11989 :
11990 1756 : if (atomic_code->ext.omp_clauses->compare)
11991 : {
11992 149 : gfc_expr *var_expr;
11993 149 : if (comp_cond->value.op.op1->expr_type == EXPR_VARIABLE)
11994 : var_expr = comp_cond->value.op.op1;
11995 : else
11996 12 : var_expr = comp_cond->value.op.op1->value.function.actual->expr;
11997 149 : if (var_expr->symtree->n.sym != var)
11998 : {
11999 2 : gfc_error ("For !$OMP ATOMIC COMPARE, the first operand in comparison"
12000 : " at %L must be the variable %qs that the update statement"
12001 : " writes into at %L", &var_expr->where, var->name,
12002 2 : &stmt->expr1->where);
12003 2 : return;
12004 : }
12005 147 : if (stmt_expr2->rank != 0 || expr_references_sym (stmt_expr2, var, NULL))
12006 : {
12007 1 : gfc_error ("expr in !$OMP ATOMIC COMPARE assignment var = expr "
12008 : "must be scalar and cannot reference var at %L",
12009 : &stmt_expr2->where);
12010 1 : return;
12011 : }
12012 : }
12013 1607 : else if (atomic_code->ext.omp_clauses->capture
12014 1607 : && !expr_references_sym (stmt_expr2, var, NULL))
12015 22 : atomic_code->ext.omp_clauses->atomic_op
12016 22 : = (gfc_omp_atomic_op) (atomic_code->ext.omp_clauses->atomic_op
12017 : | GFC_OMP_ATOMIC_SWAP);
12018 1585 : else if (stmt_expr2->expr_type == EXPR_OP)
12019 : {
12020 1229 : gfc_expr *v = NULL, *e, *c;
12021 1229 : gfc_intrinsic_op op = stmt_expr2->value.op.op;
12022 1229 : gfc_intrinsic_op alt_op = INTRINSIC_NONE;
12023 :
12024 1229 : if (atomic_code->ext.omp_clauses->fail != OMP_MEMORDER_UNSET)
12025 3 : gfc_error ("!$OMP ATOMIC UPDATE at %L with FAIL clause requires either"
12026 : " the COMPARE clause or using the intrinsic MIN/MAX "
12027 : "procedure", &atomic_code->loc);
12028 1229 : switch (op)
12029 : {
12030 742 : case INTRINSIC_PLUS:
12031 742 : alt_op = INTRINSIC_MINUS;
12032 742 : break;
12033 94 : case INTRINSIC_TIMES:
12034 94 : alt_op = INTRINSIC_DIVIDE;
12035 94 : break;
12036 120 : case INTRINSIC_MINUS:
12037 120 : alt_op = INTRINSIC_PLUS;
12038 120 : break;
12039 94 : case INTRINSIC_DIVIDE:
12040 94 : alt_op = INTRINSIC_TIMES;
12041 94 : break;
12042 : case INTRINSIC_AND:
12043 : case INTRINSIC_OR:
12044 : break;
12045 43 : case INTRINSIC_EQV:
12046 43 : alt_op = INTRINSIC_NEQV;
12047 43 : break;
12048 43 : case INTRINSIC_NEQV:
12049 43 : alt_op = INTRINSIC_EQV;
12050 43 : break;
12051 1 : default:
12052 1 : gfc_error ("!$OMP ATOMIC assignment operator must be binary "
12053 : "+, *, -, /, .AND., .OR., .EQV. or .NEQV. at %L",
12054 : &stmt_expr2->where);
12055 1 : return;
12056 : }
12057 :
12058 : /* Check for var = var op expr resp. var = expr op var where
12059 : expr doesn't reference var and var op expr is mathematically
12060 : equivalent to var op (expr) resp. expr op var equivalent to
12061 : (expr) op var. We rely here on the fact that the matcher
12062 : for x op1 y op2 z where op1 and op2 have equal precedence
12063 : returns (x op1 y) op2 z. */
12064 1228 : e = stmt_expr2->value.op.op2;
12065 1228 : if (e->expr_type == EXPR_VARIABLE
12066 288 : && e->symtree != NULL
12067 288 : && e->symtree->n.sym == var)
12068 : v = e;
12069 999 : else if ((c = is_conversion (e, false, true)) != NULL
12070 48 : && c->expr_type == EXPR_VARIABLE
12071 48 : && c->symtree != NULL
12072 1047 : && c->symtree->n.sym == var)
12073 : v = c;
12074 : else
12075 : {
12076 951 : gfc_expr **p = NULL, **q;
12077 1049 : for (q = &stmt_expr2->value.op.op1; (e = *q) != NULL; )
12078 1049 : if (e->expr_type == EXPR_VARIABLE
12079 948 : && e->symtree != NULL
12080 948 : && e->symtree->n.sym == var)
12081 : {
12082 : v = e;
12083 : break;
12084 : }
12085 101 : else if ((c = is_conversion (e, false, true)) != NULL)
12086 60 : q = &e->value.function.actual->expr;
12087 41 : else if (e->expr_type != EXPR_OP
12088 41 : || (e->value.op.op != op
12089 15 : && e->value.op.op != alt_op)
12090 38 : || e->rank != 0)
12091 : break;
12092 : else
12093 : {
12094 38 : p = q;
12095 38 : q = &e->value.op.op1;
12096 : }
12097 :
12098 951 : if (v == NULL)
12099 : {
12100 3 : gfc_error ("!$OMP ATOMIC assignment must be var = var op expr "
12101 : "or var = expr op var at %L", &stmt_expr2->where);
12102 3 : return;
12103 : }
12104 :
12105 948 : if (p != NULL)
12106 : {
12107 38 : e = *p;
12108 38 : switch (e->value.op.op)
12109 : {
12110 8 : case INTRINSIC_MINUS:
12111 8 : case INTRINSIC_DIVIDE:
12112 8 : case INTRINSIC_EQV:
12113 8 : case INTRINSIC_NEQV:
12114 8 : gfc_error ("!$OMP ATOMIC var = var op expr not "
12115 : "mathematically equivalent to var = var op "
12116 : "(expr) at %L", &stmt_expr2->where);
12117 8 : break;
12118 : default:
12119 : break;
12120 : }
12121 :
12122 : /* Canonicalize into var = var op (expr). */
12123 38 : *p = e->value.op.op2;
12124 38 : e->value.op.op2 = stmt_expr2;
12125 38 : e->ts = stmt_expr2->ts;
12126 38 : if (stmt->expr2 == stmt_expr2)
12127 26 : stmt->expr2 = stmt_expr2 = e;
12128 : else
12129 12 : stmt->expr2->value.function.actual->expr = stmt_expr2 = e;
12130 :
12131 38 : if (!gfc_compare_types (&stmt_expr2->value.op.op1->ts,
12132 : &stmt_expr2->ts))
12133 : {
12134 24 : for (p = &stmt_expr2->value.op.op1; *p != v;
12135 12 : p = &(*p)->value.function.actual->expr)
12136 : ;
12137 12 : *p = NULL;
12138 12 : gfc_free_expr (stmt_expr2->value.op.op1);
12139 12 : stmt_expr2->value.op.op1 = v;
12140 12 : gfc_convert_type (v, &stmt_expr2->ts, 2);
12141 : }
12142 : }
12143 : }
12144 :
12145 1225 : if (e->rank != 0 || expr_references_sym (stmt->expr2, var, v))
12146 : {
12147 1 : gfc_error ("expr in !$OMP ATOMIC assignment var = var op expr "
12148 : "must be scalar and cannot reference var at %L",
12149 : &stmt_expr2->where);
12150 1 : return;
12151 : }
12152 : }
12153 356 : else if (stmt_expr2->expr_type == EXPR_FUNCTION
12154 355 : && stmt_expr2->value.function.isym != NULL
12155 355 : && stmt_expr2->value.function.esym == NULL
12156 355 : && stmt_expr2->value.function.actual != NULL
12157 355 : && stmt_expr2->value.function.actual->next != NULL)
12158 : {
12159 355 : gfc_actual_arglist *arg, *var_arg;
12160 :
12161 355 : switch (stmt_expr2->value.function.isym->id)
12162 : {
12163 : case GFC_ISYM_MIN:
12164 : case GFC_ISYM_MAX:
12165 : break;
12166 147 : case GFC_ISYM_IAND:
12167 147 : case GFC_ISYM_IOR:
12168 147 : case GFC_ISYM_IEOR:
12169 147 : if (stmt_expr2->value.function.actual->next->next != NULL)
12170 : {
12171 0 : gfc_error ("!$OMP ATOMIC assignment intrinsic IAND, IOR "
12172 : "or IEOR must have two arguments at %L",
12173 : &stmt_expr2->where);
12174 0 : return;
12175 : }
12176 : break;
12177 1 : default:
12178 1 : gfc_error ("!$OMP ATOMIC assignment intrinsic must be "
12179 : "MIN, MAX, IAND, IOR or IEOR at %L",
12180 : &stmt_expr2->where);
12181 1 : return;
12182 : }
12183 :
12184 : var_arg = NULL;
12185 1088 : for (arg = stmt_expr2->value.function.actual; arg; arg = arg->next)
12186 : {
12187 741 : gfc_expr *e = NULL;
12188 741 : if (arg == stmt_expr2->value.function.actual
12189 387 : || (var_arg == NULL && arg->next == NULL))
12190 : {
12191 527 : e = is_conversion (arg->expr, false, true);
12192 527 : if (!e)
12193 514 : e = arg->expr;
12194 527 : if (e->expr_type == EXPR_VARIABLE
12195 453 : && e->symtree != NULL
12196 453 : && e->symtree->n.sym == var)
12197 741 : var_arg = arg;
12198 : }
12199 741 : if ((!var_arg || !e) && expr_references_sym (arg->expr, var, NULL))
12200 : {
12201 7 : gfc_error ("!$OMP ATOMIC intrinsic arguments except one must "
12202 : "not reference %qs at %L",
12203 : var->name, &arg->expr->where);
12204 7 : return;
12205 : }
12206 734 : if (arg->expr->rank != 0)
12207 : {
12208 0 : gfc_error ("!$OMP ATOMIC intrinsic arguments must be scalar "
12209 : "at %L", &arg->expr->where);
12210 0 : return;
12211 : }
12212 : }
12213 :
12214 347 : if (var_arg == NULL)
12215 : {
12216 1 : gfc_error ("First or last !$OMP ATOMIC intrinsic argument must "
12217 : "be %qs at %L", var->name, &stmt_expr2->where);
12218 1 : return;
12219 : }
12220 :
12221 346 : if (var_arg != stmt_expr2->value.function.actual)
12222 : {
12223 : /* Canonicalize, so that var comes first. */
12224 172 : gcc_assert (var_arg->next == NULL);
12225 : for (arg = stmt_expr2->value.function.actual;
12226 185 : arg->next != var_arg; arg = arg->next)
12227 : ;
12228 172 : var_arg->next = stmt_expr2->value.function.actual;
12229 172 : stmt_expr2->value.function.actual = var_arg;
12230 172 : arg->next = NULL;
12231 : }
12232 : }
12233 : else
12234 1 : gfc_error ("!$OMP ATOMIC assignment must have an operator or "
12235 : "intrinsic on right hand side at %L", &stmt_expr2->where);
12236 : return;
12237 :
12238 4 : unexpected:
12239 4 : gfc_error ("unexpected !$OMP ATOMIC expression at %L",
12240 : loc ? loc : &code->loc);
12241 4 : return;
12242 : }
12243 :
12244 :
12245 : static struct fortran_omp_context
12246 : {
12247 : gfc_code *code;
12248 : hash_set<gfc_symbol *> *sharing_clauses;
12249 : hash_set<gfc_symbol *> *private_iterators;
12250 : struct fortran_omp_context *previous;
12251 : bool is_openmp;
12252 : } *omp_current_ctx;
12253 : static gfc_code *omp_current_do_code;
12254 : static int omp_current_do_collapse;
12255 :
12256 : /* Forward declaration for mutually recursive functions. */
12257 : static gfc_code *
12258 : find_nested_loop_in_block (gfc_code *block);
12259 :
12260 : /* Return the first nested DO loop in CHAIN, or NULL if there
12261 : isn't one. Does no error checking on intervening code. */
12262 :
12263 : static gfc_code *
12264 27482 : find_nested_loop_in_chain (gfc_code *chain)
12265 : {
12266 27482 : gfc_code *code;
12267 :
12268 27482 : if (!chain)
12269 : return NULL;
12270 :
12271 31643 : for (code = chain; code; code = code->next)
12272 31222 : switch (code->op)
12273 : {
12274 : case EXEC_DO:
12275 : case EXEC_OMP_TILE:
12276 : case EXEC_OMP_UNROLL:
12277 : return code;
12278 621 : case EXEC_BLOCK:
12279 621 : if (gfc_code *c = find_nested_loop_in_block (code))
12280 : return c;
12281 : break;
12282 : default:
12283 : break;
12284 : }
12285 : return NULL;
12286 : }
12287 :
12288 : /* Return the first nested DO loop in BLOCK, or NULL if there
12289 : isn't one. Does no error checking on intervening code. */
12290 : static gfc_code *
12291 939 : find_nested_loop_in_block (gfc_code *block)
12292 : {
12293 939 : gfc_namespace *ns;
12294 939 : gcc_assert (block->op == EXEC_BLOCK);
12295 939 : ns = block->ext.block.ns;
12296 939 : gcc_assert (ns);
12297 939 : return find_nested_loop_in_chain (ns->code);
12298 : }
12299 :
12300 : void
12301 5433 : gfc_resolve_omp_do_blocks (gfc_code *code, gfc_namespace *ns)
12302 : {
12303 5433 : if (code->block->next && code->block->next->op == EXEC_DO)
12304 : {
12305 5080 : int i;
12306 :
12307 5080 : omp_current_do_code = code->block->next;
12308 5080 : if (code->ext.omp_clauses->orderedc)
12309 142 : omp_current_do_collapse = code->ext.omp_clauses->orderedc;
12310 4938 : else if (code->ext.omp_clauses->collapse)
12311 1121 : omp_current_do_collapse = code->ext.omp_clauses->collapse;
12312 3817 : else if (code->ext.omp_clauses->sizes_list)
12313 175 : omp_current_do_collapse
12314 175 : = gfc_expr_list_len (code->ext.omp_clauses->sizes_list);
12315 : else
12316 3642 : omp_current_do_collapse = 1;
12317 5080 : if (code->ext.omp_clauses->lists[OMP_LIST_REDUCTION_INSCAN])
12318 : {
12319 : /* Checking that there is a matching EXEC_OMP_SCAN in the
12320 : innermost body cannot be deferred to resolve_omp_do because
12321 : we process directives nested in the loop before we get
12322 : there. */
12323 60 : locus *loc
12324 : = &code->ext.omp_clauses->lists[OMP_LIST_REDUCTION_INSCAN]->where;
12325 60 : gfc_code *c;
12326 :
12327 80 : for (i = 1, c = omp_current_do_code;
12328 80 : i < omp_current_do_collapse; i++)
12329 : {
12330 22 : c = find_nested_loop_in_chain (c->block->next);
12331 22 : if (!c || c->op != EXEC_DO || c->block == NULL)
12332 : break;
12333 : }
12334 :
12335 : /* Skip this if we don't have enough nested loops. That
12336 : problem will be diagnosed elsewhere. */
12337 60 : if (c && c->op == EXEC_DO)
12338 : {
12339 58 : gfc_code *block = c->block ? c->block->next : NULL;
12340 58 : if (block && block->op != EXEC_OMP_SCAN)
12341 54 : while (block && block->next
12342 54 : && block->next->op != EXEC_OMP_SCAN)
12343 : block = block->next;
12344 43 : if (!block
12345 46 : || (block->op != EXEC_OMP_SCAN
12346 43 : && (!block->next || block->next->op != EXEC_OMP_SCAN)))
12347 19 : gfc_error ("With INSCAN at %L, expected loop body with "
12348 : "!$OMP SCAN between two "
12349 : "structured block sequences", loc);
12350 : else
12351 : {
12352 39 : if (block->op == EXEC_OMP_SCAN)
12353 3 : gfc_warning (OPT_Wopenmp,
12354 : "!$OMP SCAN at %L with zero executable "
12355 : "statements in preceding structured block "
12356 : "sequence", &block->loc);
12357 39 : if ((block->op == EXEC_OMP_SCAN && !block->next)
12358 38 : || (block->next && block->next->op == EXEC_OMP_SCAN
12359 36 : && !block->next->next))
12360 3 : gfc_warning (OPT_Wopenmp,
12361 : "!$OMP SCAN at %L with zero executable "
12362 : "statements in succeeding structured block "
12363 : "sequence", block->op == EXEC_OMP_SCAN
12364 1 : ? &block->loc : &block->next->loc);
12365 : }
12366 58 : if (block && block->op != EXEC_OMP_SCAN)
12367 43 : block = block->next;
12368 46 : if (block && block->op == EXEC_OMP_SCAN)
12369 : /* Mark 'omp scan' as checked; flag will be unset later. */
12370 39 : block->ext.omp_clauses->if_present = true;
12371 : }
12372 : }
12373 : }
12374 5433 : gfc_resolve_blocks (code->block, ns);
12375 5433 : omp_current_do_collapse = 0;
12376 5433 : omp_current_do_code = NULL;
12377 5433 : }
12378 :
12379 :
12380 : void
12381 6104 : gfc_resolve_omp_parallel_blocks (gfc_code *code, gfc_namespace *ns)
12382 : {
12383 6104 : struct fortran_omp_context ctx;
12384 6104 : gfc_omp_clauses *omp_clauses = code->ext.omp_clauses;
12385 6104 : gfc_omp_namelist *n;
12386 :
12387 6104 : ctx.code = code;
12388 6104 : ctx.sharing_clauses = new hash_set<gfc_symbol *>;
12389 6104 : ctx.private_iterators = new hash_set<gfc_symbol *>;
12390 6104 : ctx.previous = omp_current_ctx;
12391 6104 : ctx.is_openmp = true;
12392 6104 : omp_current_ctx = &ctx;
12393 :
12394 244160 : for (enum gfc_omp_list_type list = OMP_LIST_FIRST; list < OMP_LIST_NUM;
12395 238056 : list = gfc_omp_list_type (list + 1))
12396 238056 : switch (list)
12397 : {
12398 61040 : case OMP_LIST_SHARED:
12399 61040 : case OMP_LIST_PRIVATE:
12400 61040 : case OMP_LIST_FIRSTPRIVATE:
12401 61040 : case OMP_LIST_LASTPRIVATE:
12402 61040 : case OMP_LIST_REDUCTION:
12403 61040 : case OMP_LIST_REDUCTION_INSCAN:
12404 61040 : case OMP_LIST_REDUCTION_TASK:
12405 61040 : case OMP_LIST_IN_REDUCTION:
12406 61040 : case OMP_LIST_TASK_REDUCTION:
12407 61040 : case OMP_LIST_LINEAR:
12408 70031 : for (n = omp_clauses->lists[list]; n; n = n->next)
12409 8991 : ctx.sharing_clauses->add (n->sym);
12410 : break;
12411 : default:
12412 : break;
12413 : }
12414 :
12415 6104 : switch (code->op)
12416 : {
12417 2368 : case EXEC_OMP_DISTRIBUTE_PARALLEL_DO:
12418 2368 : case EXEC_OMP_DISTRIBUTE_PARALLEL_DO_SIMD:
12419 2368 : case EXEC_OMP_MASKED_TASKLOOP:
12420 2368 : case EXEC_OMP_MASKED_TASKLOOP_SIMD:
12421 2368 : case EXEC_OMP_MASTER_TASKLOOP:
12422 2368 : case EXEC_OMP_MASTER_TASKLOOP_SIMD:
12423 2368 : case EXEC_OMP_PARALLEL_DO:
12424 2368 : case EXEC_OMP_PARALLEL_DO_SIMD:
12425 2368 : case EXEC_OMP_PARALLEL_LOOP:
12426 2368 : case EXEC_OMP_PARALLEL_MASKED_TASKLOOP:
12427 2368 : case EXEC_OMP_PARALLEL_MASKED_TASKLOOP_SIMD:
12428 2368 : case EXEC_OMP_PARALLEL_MASTER_TASKLOOP:
12429 2368 : case EXEC_OMP_PARALLEL_MASTER_TASKLOOP_SIMD:
12430 2368 : case EXEC_OMP_TARGET_PARALLEL_DO:
12431 2368 : case EXEC_OMP_TARGET_PARALLEL_DO_SIMD:
12432 2368 : case EXEC_OMP_TARGET_PARALLEL_LOOP:
12433 2368 : case EXEC_OMP_TARGET_TEAMS_DISTRIBUTE:
12434 2368 : case EXEC_OMP_TARGET_TEAMS_DISTRIBUTE_PARALLEL_DO:
12435 2368 : case EXEC_OMP_TARGET_TEAMS_DISTRIBUTE_PARALLEL_DO_SIMD:
12436 2368 : case EXEC_OMP_TARGET_TEAMS_DISTRIBUTE_SIMD:
12437 2368 : case EXEC_OMP_TARGET_TEAMS_LOOP:
12438 2368 : case EXEC_OMP_TASKLOOP:
12439 2368 : case EXEC_OMP_TASKLOOP_SIMD:
12440 2368 : case EXEC_OMP_TEAMS_DISTRIBUTE:
12441 2368 : case EXEC_OMP_TEAMS_DISTRIBUTE_PARALLEL_DO:
12442 2368 : case EXEC_OMP_TEAMS_DISTRIBUTE_PARALLEL_DO_SIMD:
12443 2368 : case EXEC_OMP_TEAMS_DISTRIBUTE_SIMD:
12444 2368 : case EXEC_OMP_TEAMS_LOOP:
12445 2368 : gfc_resolve_omp_do_blocks (code, ns);
12446 2368 : break;
12447 3736 : default:
12448 3736 : gfc_resolve_blocks (code->block, ns);
12449 : }
12450 :
12451 6104 : omp_current_ctx = ctx.previous;
12452 12208 : delete ctx.sharing_clauses;
12453 12208 : delete ctx.private_iterators;
12454 6104 : }
12455 :
12456 :
12457 : /* Save and clear openmp.cc private state. */
12458 :
12459 : void
12460 302624 : gfc_omp_save_and_clear_state (struct gfc_omp_saved_state *state)
12461 : {
12462 302624 : state->ptrs[0] = omp_current_ctx;
12463 302624 : state->ptrs[1] = omp_current_do_code;
12464 302624 : state->ints[0] = omp_current_do_collapse;
12465 302624 : omp_current_ctx = NULL;
12466 302624 : omp_current_do_code = NULL;
12467 302624 : omp_current_do_collapse = 0;
12468 302624 : }
12469 :
12470 :
12471 : /* Restore openmp.cc private state from the saved state. */
12472 :
12473 : void
12474 302623 : gfc_omp_restore_state (struct gfc_omp_saved_state *state)
12475 : {
12476 302623 : omp_current_ctx = (struct fortran_omp_context *) state->ptrs[0];
12477 302623 : omp_current_do_code = (gfc_code *) state->ptrs[1];
12478 302623 : omp_current_do_collapse = state->ints[0];
12479 302623 : }
12480 :
12481 :
12482 : /* Note a DO iterator variable. This is special in !$omp parallel
12483 : construct, where they are predetermined private. */
12484 :
12485 : void
12486 33370 : gfc_resolve_do_iterator (gfc_code *code, gfc_symbol *sym, bool add_clause)
12487 : {
12488 33370 : if (omp_current_ctx == NULL)
12489 : return;
12490 :
12491 13113 : int i = omp_current_do_collapse;
12492 13113 : gfc_code *c = omp_current_do_code;
12493 :
12494 13113 : if (sym->attr.threadprivate)
12495 : return;
12496 :
12497 : /* !$omp do and !$omp parallel do iteration variable is predetermined
12498 : private just in the !$omp do resp. !$omp parallel do construct,
12499 : with no implications for the outer parallel constructs. */
12500 :
12501 17948 : while (i-- >= 1 && c)
12502 : {
12503 9502 : if (code == c)
12504 : return;
12505 4835 : c = find_nested_loop_in_chain (c->block->next);
12506 4835 : if (c && (c->op == EXEC_OMP_TILE || c->op == EXEC_OMP_UNROLL))
12507 : return;
12508 : }
12509 :
12510 : /* An openacc context may represent a data clause. Abort if so. */
12511 8446 : if (!omp_current_ctx->is_openmp && !oacc_is_loop (omp_current_ctx->code))
12512 : return;
12513 :
12514 7468 : if (omp_current_ctx->sharing_clauses->contains (sym))
12515 : return;
12516 :
12517 6466 : if (! omp_current_ctx->private_iterators->add (sym) && add_clause)
12518 : {
12519 6276 : gfc_omp_clauses *omp_clauses = omp_current_ctx->code->ext.omp_clauses;
12520 6276 : gfc_omp_namelist *p;
12521 :
12522 6276 : p = gfc_get_omp_namelist ();
12523 6276 : p->sym = sym;
12524 6276 : p->where = omp_current_ctx->code->loc;
12525 6276 : p->next = omp_clauses->lists[OMP_LIST_PRIVATE];
12526 6276 : omp_clauses->lists[OMP_LIST_PRIVATE] = p;
12527 : }
12528 : }
12529 :
12530 : static void
12531 775 : handle_local_var (gfc_symbol *sym)
12532 : {
12533 775 : if (sym->attr.flavor != FL_VARIABLE
12534 180 : || sym->as != NULL
12535 139 : || (sym->ts.type != BT_INTEGER && sym->ts.type != BT_REAL))
12536 : return;
12537 72 : gfc_resolve_do_iterator (sym->ns->code, sym, false);
12538 : }
12539 :
12540 : void
12541 350315 : gfc_resolve_omp_local_vars (gfc_namespace *ns)
12542 : {
12543 350315 : if (omp_current_ctx)
12544 469 : gfc_traverse_ns (ns, handle_local_var);
12545 350315 : }
12546 :
12547 :
12548 : /* Error checking on intervening code uses a code walker. */
12549 :
12550 : struct icode_error_state
12551 : {
12552 : const char *name;
12553 : bool errorp;
12554 : gfc_code *nested;
12555 : gfc_code *next;
12556 : };
12557 :
12558 : static int
12559 944 : icode_code_error_callback (gfc_code **codep,
12560 : int *walk_subtrees ATTRIBUTE_UNUSED, void *opaque)
12561 : {
12562 944 : gfc_code *code = *codep;
12563 944 : icode_error_state *state = (icode_error_state *)opaque;
12564 :
12565 : /* gfc_code_walker walks down CODE's next chain as well as
12566 : walking things that are actually nested in CODE. We need to
12567 : special-case traversal of outer blocks, so stop immediately if we
12568 : are heading down such a next chain. */
12569 944 : if (code == state->next)
12570 : return 1;
12571 :
12572 647 : switch (code->op)
12573 : {
12574 1 : case EXEC_DO:
12575 1 : case EXEC_DO_WHILE:
12576 1 : case EXEC_DO_CONCURRENT:
12577 1 : gfc_error ("%s cannot contain loop in intervening code at %L",
12578 : state->name, &code->loc);
12579 1 : state->errorp = true;
12580 1 : break;
12581 0 : case EXEC_CYCLE:
12582 0 : case EXEC_EXIT:
12583 : /* Errors have already been diagnosed in match_exit_cycle. */
12584 0 : state->errorp = true;
12585 0 : break;
12586 : case EXEC_OMP_ASSUME:
12587 : case EXEC_OMP_METADIRECTIVE:
12588 : /* Per OpenMP 6.0, some non-executable directives are allowed in
12589 : intervening code. */
12590 : break;
12591 477 : case EXEC_CALL:
12592 : /* Per OpenMP 5.2, the "omp_" prefix is reserved, so we don't have to
12593 : consider the possibility that some locally-bound definition
12594 : overrides the runtime routine. */
12595 477 : if (code->resolved_sym
12596 477 : && omp_runtime_api_procname (code->resolved_sym->name))
12597 : {
12598 1 : gfc_error ("%s cannot contain OpenMP API call in intervening code "
12599 : "at %L",
12600 : state->name, &code->loc);
12601 1 : state->errorp = true;
12602 : }
12603 : break;
12604 168 : default:
12605 168 : if (code->op >= EXEC_OMP_FIRST_OPENMP_EXEC
12606 168 : && code->op <= EXEC_OMP_LAST_OPENMP_EXEC)
12607 : {
12608 2 : gfc_error ("%s cannot contain OpenMP directive in intervening code "
12609 : "at %L",
12610 : state->name, &code->loc);
12611 2 : state->errorp = true;
12612 : }
12613 : }
12614 : return 0;
12615 : }
12616 :
12617 : static int
12618 1081 : icode_expr_error_callback (gfc_expr **expr,
12619 : int *walk_subtrees ATTRIBUTE_UNUSED, void *opaque)
12620 : {
12621 1081 : icode_error_state *state = (icode_error_state *)opaque;
12622 :
12623 1081 : switch ((*expr)->expr_type)
12624 : {
12625 : /* As for EXPR_CALL with "omp_"-prefixed symbols. */
12626 2 : case EXPR_FUNCTION:
12627 2 : {
12628 2 : gfc_symbol *sym = (*expr)->value.function.esym;
12629 2 : if (sym && omp_runtime_api_procname (sym->name))
12630 : {
12631 1 : gfc_error ("%s cannot contain OpenMP API call in intervening code "
12632 : "at %L",
12633 1 : state->name, &((*expr)->where));
12634 1 : state->errorp = true;
12635 : }
12636 : }
12637 :
12638 : break;
12639 : default:
12640 : break;
12641 : }
12642 :
12643 : /* FIXME: The description of canonical loop form in the OpenMP standard
12644 : also says "array expressions" are not permitted in intervening code.
12645 : That term is not defined in either the OpenMP spec or the Fortran
12646 : standard, although the latter uses it informally to refer to any
12647 : expression that is not scalar-valued. It is also apparently not the
12648 : thing GCC internally calls EXPR_ARRAY. It seems the intent of the
12649 : OpenMP restriction is to disallow elemental operations/intrinsics
12650 : (including things that are not expressions, like assignment
12651 : statements) that generate implicit loops over array operands
12652 : (even if the result is a scalar), but even if the spec said
12653 : that there is no list of all the cases that would be forbidden.
12654 : This is OpenMP issue 3326. */
12655 :
12656 1081 : return 0;
12657 : }
12658 :
12659 : static void
12660 267 : diagnose_intervening_code_errors_1 (gfc_code *chain,
12661 : struct icode_error_state *state)
12662 : {
12663 267 : gfc_code *code;
12664 1080 : for (code = chain; code; code = code->next)
12665 : {
12666 813 : if (code == state->nested)
12667 : /* Do not walk the nested loop or its body, we are only
12668 : interested in intervening code. */
12669 : ;
12670 636 : else if (code->op == EXEC_BLOCK
12671 636 : && find_nested_loop_in_block (code) == state->nested)
12672 : /* This block contains the nested loop, recurse on its
12673 : statements. */
12674 : {
12675 90 : gfc_namespace* ns = code->ext.block.ns;
12676 90 : diagnose_intervening_code_errors_1 (ns->code, state);
12677 : }
12678 : else
12679 : /* Treat the whole statement as a unit. */
12680 : {
12681 546 : gfc_code *temp = state->next;
12682 546 : state->next = code->next;
12683 546 : gfc_code_walker (&code, icode_code_error_callback,
12684 : icode_expr_error_callback, state);
12685 546 : state->next = temp;
12686 : }
12687 : }
12688 267 : }
12689 :
12690 : /* Diagnose intervening code errors in BLOCK with nested loop NESTED.
12691 : NAME is the user-friendly name of the OMP directive, used for error
12692 : messages. Returns true if any error was found. */
12693 : static bool
12694 177 : diagnose_intervening_code_errors (gfc_code *chain, const char *name,
12695 : gfc_code *nested)
12696 : {
12697 177 : struct icode_error_state state;
12698 177 : state.name = name;
12699 177 : state.errorp = false;
12700 177 : state.nested = nested;
12701 177 : state.next = NULL;
12702 0 : diagnose_intervening_code_errors_1 (chain, &state);
12703 177 : return state.errorp;
12704 : }
12705 :
12706 : /* Helper function for restructure_intervening_code: wrap CHAIN in
12707 : a marker to indicate that it is a structured block sequence. That
12708 : information will be used later on (in omp-low.cc) for error checking. */
12709 : static gfc_code *
12710 461 : make_structured_block (gfc_code *chain)
12711 : {
12712 461 : gcc_assert (chain);
12713 461 : gfc_namespace *ns = gfc_build_block_ns (gfc_current_ns);
12714 461 : gfc_code *result = gfc_get_code (EXEC_BLOCK);
12715 461 : result->op = EXEC_BLOCK;
12716 461 : result->ext.block.ns = ns;
12717 461 : result->ext.block.assoc = NULL;
12718 461 : result->loc = chain->loc;
12719 461 : ns->omp_structured_block = 1;
12720 461 : ns->code = chain;
12721 461 : return result;
12722 : }
12723 :
12724 : /* Push intervening code surrounding a loop, including nested scopes,
12725 : into the body of the loop. CHAINP is the pointer to the head of
12726 : the next-chain to scan, OUTER_LOOP is the EXEC_DO for the next outer
12727 : loop level, and COLLAPSE is the number of nested loops we need to
12728 : process.
12729 : Note that CHAINP may point at outer_loop->block->next when we
12730 : are scanning the body of a loop, but if there is an intervening block
12731 : CHAINP points into the block's chain rather than its enclosing outer
12732 : loop. This is why OUTER_LOOP is passed separately. */
12733 : static gfc_code *
12734 7183 : restructure_intervening_code (gfc_code **chainp, gfc_code *outer_loop,
12735 : int count)
12736 : {
12737 7183 : gfc_code *code;
12738 7183 : gfc_code *head = *chainp;
12739 7183 : gfc_code *tail = NULL;
12740 7183 : gfc_code *innermost_loop = NULL;
12741 :
12742 7447 : for (code = *chainp; code; code = code->next, chainp = &(*chainp)->next)
12743 : {
12744 7447 : if (code->op == EXEC_DO)
12745 : {
12746 : /* Cut CODE free from its chain, leaving the ends dangling. */
12747 7099 : *chainp = NULL;
12748 7099 : tail = code->next;
12749 7099 : code->next = NULL;
12750 :
12751 7099 : if (count == 1)
12752 : innermost_loop = code;
12753 : else
12754 2090 : innermost_loop
12755 2090 : = restructure_intervening_code (&code->block->next,
12756 : code, count - 1);
12757 : break;
12758 : }
12759 348 : else if (code->op == EXEC_BLOCK
12760 348 : && find_nested_loop_in_block (code))
12761 : {
12762 84 : gfc_namespace *ns = code->ext.block.ns;
12763 :
12764 : /* Cut CODE free from its chain, leaving the ends dangling. */
12765 84 : *chainp = NULL;
12766 84 : tail = code->next;
12767 84 : code->next = NULL;
12768 :
12769 84 : innermost_loop
12770 84 : = restructure_intervening_code (&ns->code, outer_loop,
12771 : count);
12772 :
12773 : /* At this point we have already pulled out the nested loop and
12774 : pointed outer_loop at it, and moved the intervening code that
12775 : was previously in the block into the body of innermost_loop.
12776 : Now we want to move the BLOCK itself so it wraps the entire
12777 : current body of innermost_loop. */
12778 84 : ns->code = innermost_loop->block->next;
12779 84 : innermost_loop->block->next = code;
12780 84 : break;
12781 : }
12782 : }
12783 :
12784 2174 : gcc_assert (innermost_loop);
12785 :
12786 : /* Now we have split the intervening code into two parts:
12787 : head is the start of the part before the loop/block, terminating
12788 : at *chainp, and tail is the part after it. Mark each part as
12789 : a structured block sequence, and splice the two parts around the
12790 : existing body of the innermost loop. */
12791 7183 : if (head != code)
12792 : {
12793 222 : gfc_code *block = make_structured_block (head);
12794 222 : if (innermost_loop->block->next)
12795 221 : gfc_append_code (block, innermost_loop->block->next);
12796 222 : innermost_loop->block->next = block;
12797 : }
12798 7183 : if (tail)
12799 : {
12800 239 : gfc_code *block = make_structured_block (tail);
12801 239 : if (innermost_loop->block->next)
12802 237 : gfc_append_code (innermost_loop->block->next, block);
12803 : else
12804 2 : innermost_loop->block->next = block;
12805 : }
12806 :
12807 : /* For loops, finally splice CODE into OUTER_LOOP. We already handled
12808 : relinking EXEC_BLOCK above. */
12809 7183 : if (code->op == EXEC_DO && outer_loop)
12810 7099 : outer_loop->block->next = code;
12811 :
12812 7183 : return innermost_loop;
12813 : }
12814 :
12815 : /* CODE is an OMP loop construct. Return true if VAR matches an iteration
12816 : variable outer to level DEPTH. */
12817 : static bool
12818 8096 : is_outer_iteration_variable (gfc_code *code, int depth, gfc_symbol *var)
12819 : {
12820 8096 : int i;
12821 8096 : gfc_code *do_code = code;
12822 :
12823 12623 : for (i = 1; i < depth; i++)
12824 : {
12825 5028 : do_code = find_nested_loop_in_chain (do_code->block->next);
12826 5028 : gcc_assert (do_code);
12827 5028 : if (do_code->op == EXEC_OMP_TILE || do_code->op == EXEC_OMP_UNROLL)
12828 : {
12829 51 : --i;
12830 51 : continue;
12831 : }
12832 4977 : gfc_symbol *ivar = do_code->ext.iterator->var->symtree->n.sym;
12833 4977 : if (var == ivar)
12834 : return true;
12835 : }
12836 : return false;
12837 : }
12838 :
12839 : /* Forward declaration for recursive functions. */
12840 : static gfc_code *
12841 : check_nested_loop_in_block (gfc_code *block, gfc_expr *expr, gfc_symbol *sym,
12842 : bool *bad);
12843 :
12844 : /* Like find_nested_loop_in_chain, but additionally check that EXPR
12845 : does not reference any variables bound in intervening EXEC_BLOCKs
12846 : and that SYM is not bound in such intervening blocks. Either EXPR or SYM
12847 : may be null. Sets *BAD to true if either test fails. */
12848 : static gfc_code *
12849 48217 : check_nested_loop_in_chain (gfc_code *chain, gfc_expr *expr, gfc_symbol *sym,
12850 : bool *bad)
12851 : {
12852 51821 : for (gfc_code *code = chain; code; code = code->next)
12853 : {
12854 51533 : if (code->op == EXEC_DO)
12855 : return code;
12856 4123 : else if (code->op == EXEC_OMP_TILE || code->op == EXEC_OMP_UNROLL)
12857 1682 : return check_nested_loop_in_chain (code->block->next, expr, sym, bad);
12858 2441 : else if (code->op == EXEC_BLOCK)
12859 : {
12860 807 : gfc_code *c = check_nested_loop_in_block (code, expr, sym, bad);
12861 807 : if (c)
12862 : return c;
12863 : }
12864 : }
12865 : return NULL;
12866 : }
12867 :
12868 : /* Code walker for block symtrees. It doesn't take any kind of state
12869 : argument, so use a static variable. */
12870 : static struct check_nested_loop_in_block_state_t {
12871 : gfc_expr *expr;
12872 : gfc_symbol *sym;
12873 : bool *bad;
12874 : } check_nested_loop_in_block_state;
12875 :
12876 : static void
12877 766 : check_nested_loop_in_block_symbol (gfc_symbol *sym)
12878 : {
12879 766 : if (sym == check_nested_loop_in_block_state.sym
12880 766 : || (check_nested_loop_in_block_state.expr
12881 567 : && gfc_find_sym_in_expr (sym,
12882 : check_nested_loop_in_block_state.expr)))
12883 5 : *check_nested_loop_in_block_state.bad = true;
12884 766 : }
12885 :
12886 : /* Return the first nested DO loop in BLOCK, or NULL if there
12887 : isn't one. Set *BAD to true if EXPR references any variables in BLOCK, or
12888 : SYM is bound in BLOCK. Either EXPR or SYM may be null. */
12889 : static gfc_code *
12890 807 : check_nested_loop_in_block (gfc_code *block, gfc_expr *expr,
12891 : gfc_symbol *sym, bool *bad)
12892 : {
12893 807 : gfc_namespace *ns;
12894 807 : gcc_assert (block->op == EXEC_BLOCK);
12895 807 : ns = block->ext.block.ns;
12896 807 : gcc_assert (ns);
12897 :
12898 : /* Skip the check if this block doesn't contain the nested loop, or
12899 : if we already know it's bad. */
12900 807 : gfc_code *result = check_nested_loop_in_chain (ns->code, expr, sym, bad);
12901 807 : if (result && !*bad)
12902 : {
12903 519 : check_nested_loop_in_block_state.expr = expr;
12904 519 : check_nested_loop_in_block_state.sym = sym;
12905 519 : check_nested_loop_in_block_state.bad = bad;
12906 519 : gfc_traverse_ns (ns, check_nested_loop_in_block_symbol);
12907 519 : check_nested_loop_in_block_state.expr = NULL;
12908 519 : check_nested_loop_in_block_state.sym = NULL;
12909 519 : check_nested_loop_in_block_state.bad = NULL;
12910 : }
12911 807 : return result;
12912 : }
12913 :
12914 : /* CODE is an OMP loop construct. Return true if EXPR references
12915 : any variables bound in intervening code, to level DEPTH. */
12916 : static bool
12917 22756 : expr_uses_intervening_var (gfc_code *code, int depth, gfc_expr *expr)
12918 : {
12919 22756 : int i;
12920 22756 : gfc_code *do_code = code;
12921 :
12922 58291 : for (i = 0; i < depth; i++)
12923 : {
12924 35538 : bool bad = false;
12925 35538 : do_code = check_nested_loop_in_chain (do_code->block->next,
12926 : expr, NULL, &bad);
12927 35538 : if (bad)
12928 3 : return true;
12929 : }
12930 : return false;
12931 : }
12932 :
12933 : /* CODE is an OMP loop construct. Return true if SYM is bound in
12934 : intervening code, to level DEPTH. */
12935 : static bool
12936 7595 : is_intervening_var (gfc_code *code, int depth, gfc_symbol *sym)
12937 : {
12938 7595 : int i;
12939 7595 : gfc_code *do_code = code;
12940 :
12941 19465 : for (i = 0; i < depth; i++)
12942 : {
12943 11872 : bool bad = false;
12944 11872 : do_code = check_nested_loop_in_chain (do_code->block->next,
12945 : NULL, sym, &bad);
12946 11872 : if (bad)
12947 2 : return true;
12948 : }
12949 : return false;
12950 : }
12951 :
12952 : /* CODE is an OMP loop construct. Return true if EXPR does not reference
12953 : any iteration variables outer to level DEPTH. */
12954 : static bool
12955 23835 : expr_is_invariant (gfc_code *code, int depth, gfc_expr *expr)
12956 : {
12957 23835 : int i;
12958 23835 : gfc_code *do_code = code;
12959 :
12960 37157 : for (i = 1; i < depth; i++)
12961 : {
12962 14388 : do_code = find_nested_loop_in_chain (do_code->block->next);
12963 14388 : gcc_assert (do_code);
12964 14388 : if (do_code->op == EXEC_OMP_TILE || do_code->op == EXEC_OMP_UNROLL)
12965 : {
12966 136 : --i;
12967 136 : continue;
12968 : }
12969 14252 : gfc_symbol *ivar = do_code->ext.iterator->var->symtree->n.sym;
12970 14252 : if (gfc_find_sym_in_expr (ivar, expr))
12971 : return false;
12972 : }
12973 : return true;
12974 : }
12975 :
12976 : /* CODE is an OMP loop construct. Return true if EXPR matches one of the
12977 : canonical forms for a bound expression. It may include references to
12978 : an iteration variable outer to level DEPTH; set OUTER_VARP if so. */
12979 : static bool
12980 15181 : bound_expr_is_canonical (gfc_code *code, int depth, gfc_expr *expr,
12981 : gfc_symbol **outer_varp)
12982 : {
12983 15181 : gfc_expr *expr2 = NULL;
12984 :
12985 : /* Rectangular case. */
12986 15181 : if (depth == 0 || expr_is_invariant (code, depth, expr))
12987 : return true;
12988 :
12989 : /* Any simple variable that didn't pass expr_is_invariant must be
12990 : an outer_var. */
12991 568 : if (expr->expr_type == EXPR_VARIABLE && expr->rank == 0)
12992 : {
12993 63 : *outer_varp = expr->symtree->n.sym;
12994 63 : return true;
12995 : }
12996 :
12997 : /* All other permitted forms are binary operators. */
12998 505 : if (expr->expr_type != EXPR_OP)
12999 : return false;
13000 :
13001 : /* Check for plus/minus a loop invariant expr. */
13002 503 : if (expr->value.op.op == INTRINSIC_PLUS
13003 503 : || expr->value.op.op == INTRINSIC_MINUS)
13004 : {
13005 483 : if (expr_is_invariant (code, depth, expr->value.op.op1))
13006 48 : expr2 = expr->value.op.op2;
13007 435 : else if (expr_is_invariant (code, depth, expr->value.op.op2))
13008 434 : expr2 = expr->value.op.op1;
13009 : else
13010 : return false;
13011 : }
13012 : else
13013 : expr2 = expr;
13014 :
13015 : /* Check for a product with a loop-invariant expr. */
13016 502 : if (expr2->expr_type == EXPR_OP
13017 96 : && expr2->value.op.op == INTRINSIC_TIMES)
13018 : {
13019 96 : if (expr_is_invariant (code, depth, expr2->value.op.op1))
13020 40 : expr2 = expr2->value.op.op2;
13021 56 : else if (expr_is_invariant (code, depth, expr2->value.op.op2))
13022 53 : expr2 = expr2->value.op.op1;
13023 : else
13024 : return false;
13025 : }
13026 :
13027 : /* What's left must be a reference to an outer loop variable. */
13028 499 : if (expr2->expr_type == EXPR_VARIABLE
13029 499 : && expr2->rank == 0
13030 998 : && is_outer_iteration_variable (code, depth, expr2->symtree->n.sym))
13031 : {
13032 499 : *outer_varp = expr2->symtree->n.sym;
13033 499 : return true;
13034 : }
13035 :
13036 : return false;
13037 : }
13038 :
13039 : static void
13040 5433 : resolve_omp_do (gfc_code *code)
13041 : {
13042 5433 : gfc_code *do_code, *next;
13043 5433 : int i, count, non_generated_count;
13044 5433 : gfc_omp_namelist *n;
13045 5433 : gfc_symbol *dovar;
13046 5433 : const char *name;
13047 5433 : bool is_simd = false;
13048 5433 : bool errorp = false;
13049 5433 : bool perfect_nesting_errorp = false;
13050 5433 : bool imperfect = false;
13051 :
13052 5433 : switch (code->op)
13053 : {
13054 : case EXEC_OMP_DISTRIBUTE: name = "!$OMP DISTRIBUTE"; break;
13055 49 : case EXEC_OMP_DISTRIBUTE_PARALLEL_DO:
13056 49 : name = "!$OMP DISTRIBUTE PARALLEL DO";
13057 49 : break;
13058 32 : case EXEC_OMP_DISTRIBUTE_PARALLEL_DO_SIMD:
13059 32 : name = "!$OMP DISTRIBUTE PARALLEL DO SIMD";
13060 32 : is_simd = true;
13061 32 : break;
13062 50 : case EXEC_OMP_DISTRIBUTE_SIMD:
13063 50 : name = "!$OMP DISTRIBUTE SIMD";
13064 50 : is_simd = true;
13065 50 : break;
13066 1336 : case EXEC_OMP_DO: name = "!$OMP DO"; break;
13067 134 : case EXEC_OMP_DO_SIMD: name = "!$OMP DO SIMD"; is_simd = true; break;
13068 64 : case EXEC_OMP_LOOP: name = "!$OMP LOOP"; break;
13069 1220 : case EXEC_OMP_PARALLEL_DO: name = "!$OMP PARALLEL DO"; break;
13070 304 : case EXEC_OMP_PARALLEL_DO_SIMD:
13071 304 : name = "!$OMP PARALLEL DO SIMD";
13072 304 : is_simd = true;
13073 304 : break;
13074 46 : case EXEC_OMP_PARALLEL_LOOP: name = "!$OMP PARALLEL LOOP"; break;
13075 7 : case EXEC_OMP_PARALLEL_MASKED_TASKLOOP:
13076 7 : name = "!$OMP PARALLEL MASKED TASKLOOP";
13077 7 : break;
13078 10 : case EXEC_OMP_PARALLEL_MASKED_TASKLOOP_SIMD:
13079 10 : name = "!$OMP PARALLEL MASKED TASKLOOP SIMD";
13080 10 : is_simd = true;
13081 10 : break;
13082 12 : case EXEC_OMP_PARALLEL_MASTER_TASKLOOP:
13083 12 : name = "!$OMP PARALLEL MASTER TASKLOOP";
13084 12 : break;
13085 18 : case EXEC_OMP_PARALLEL_MASTER_TASKLOOP_SIMD:
13086 18 : name = "!$OMP PARALLEL MASTER TASKLOOP SIMD";
13087 18 : is_simd = true;
13088 18 : break;
13089 8 : case EXEC_OMP_MASKED_TASKLOOP: name = "!$OMP MASKED TASKLOOP"; break;
13090 14 : case EXEC_OMP_MASKED_TASKLOOP_SIMD:
13091 14 : name = "!$OMP MASKED TASKLOOP SIMD";
13092 14 : is_simd = true;
13093 14 : break;
13094 14 : case EXEC_OMP_MASTER_TASKLOOP: name = "!$OMP MASTER TASKLOOP"; break;
13095 19 : case EXEC_OMP_MASTER_TASKLOOP_SIMD:
13096 19 : name = "!$OMP MASTER TASKLOOP SIMD";
13097 19 : is_simd = true;
13098 19 : break;
13099 784 : case EXEC_OMP_SIMD: name = "!$OMP SIMD"; is_simd = true; break;
13100 88 : case EXEC_OMP_TARGET_PARALLEL_DO: name = "!$OMP TARGET PARALLEL DO"; break;
13101 20 : case EXEC_OMP_TARGET_PARALLEL_DO_SIMD:
13102 20 : name = "!$OMP TARGET PARALLEL DO SIMD";
13103 20 : is_simd = true;
13104 20 : break;
13105 16 : case EXEC_OMP_TARGET_PARALLEL_LOOP:
13106 16 : name = "!$OMP TARGET PARALLEL LOOP";
13107 16 : break;
13108 33 : case EXEC_OMP_TARGET_SIMD:
13109 33 : name = "!$OMP TARGET SIMD";
13110 33 : is_simd = true;
13111 33 : break;
13112 20 : case EXEC_OMP_TARGET_TEAMS_DISTRIBUTE:
13113 20 : name = "!$OMP TARGET TEAMS DISTRIBUTE";
13114 20 : break;
13115 77 : case EXEC_OMP_TARGET_TEAMS_DISTRIBUTE_PARALLEL_DO:
13116 77 : name = "!$OMP TARGET TEAMS DISTRIBUTE PARALLEL DO";
13117 77 : break;
13118 38 : case EXEC_OMP_TARGET_TEAMS_DISTRIBUTE_PARALLEL_DO_SIMD:
13119 38 : name = "!$OMP TARGET TEAMS DISTRIBUTE PARALLEL DO SIMD";
13120 38 : is_simd = true;
13121 38 : break;
13122 20 : case EXEC_OMP_TARGET_TEAMS_DISTRIBUTE_SIMD:
13123 20 : name = "!$OMP TARGET TEAMS DISTRIBUTE SIMD";
13124 20 : is_simd = true;
13125 20 : break;
13126 19 : case EXEC_OMP_TARGET_TEAMS_LOOP: name = "!$OMP TARGET TEAMS LOOP"; break;
13127 69 : case EXEC_OMP_TASKLOOP: name = "!$OMP TASKLOOP"; break;
13128 38 : case EXEC_OMP_TASKLOOP_SIMD:
13129 38 : name = "!$OMP TASKLOOP SIMD";
13130 38 : is_simd = true;
13131 38 : break;
13132 20 : case EXEC_OMP_TEAMS_DISTRIBUTE: name = "!$OMP TEAMS DISTRIBUTE"; break;
13133 39 : case EXEC_OMP_TEAMS_DISTRIBUTE_PARALLEL_DO:
13134 39 : name = "!$OMP TEAMS DISTRIBUTE PARALLEL DO";
13135 39 : break;
13136 61 : case EXEC_OMP_TEAMS_DISTRIBUTE_PARALLEL_DO_SIMD:
13137 61 : name = "!$OMP TEAMS DISTRIBUTE PARALLEL DO SIMD";
13138 61 : is_simd = true;
13139 61 : break;
13140 42 : case EXEC_OMP_TEAMS_DISTRIBUTE_SIMD:
13141 42 : name = "!$OMP TEAMS DISTRIBUTE SIMD";
13142 42 : is_simd = true;
13143 42 : break;
13144 48 : case EXEC_OMP_TEAMS_LOOP: name = "!$OMP TEAMS LOOP"; break;
13145 195 : case EXEC_OMP_TILE: name = "!$OMP TILE"; break;
13146 415 : case EXEC_OMP_UNROLL: name = "!$OMP UNROLL"; break;
13147 0 : default: gcc_unreachable ();
13148 : }
13149 :
13150 5433 : if (code->ext.omp_clauses)
13151 5433 : resolve_omp_clauses (code, code->ext.omp_clauses, NULL);
13152 :
13153 5433 : if (code->op == EXEC_OMP_TILE && code->ext.omp_clauses->sizes_list == NULL)
13154 0 : gfc_error ("SIZES clause is required on !$OMP TILE construct at %L",
13155 : &code->loc);
13156 :
13157 5433 : do_code = code->block->next;
13158 5433 : if (code->ext.omp_clauses->orderedc)
13159 : count = code->ext.omp_clauses->orderedc;
13160 5289 : else if (code->ext.omp_clauses->sizes_list)
13161 195 : count = gfc_expr_list_len (code->ext.omp_clauses->sizes_list);
13162 : else
13163 : {
13164 5094 : count = code->ext.omp_clauses->collapse;
13165 5094 : if (count <= 0)
13166 : count = 1;
13167 : }
13168 :
13169 5433 : non_generated_count = count;
13170 : /* While the spec defines the loop nest depth independently of the COLLAPSE
13171 : clause, in practice the middle end only pays attention to the COLLAPSE
13172 : depth and treats any further inner loops as the final-loop-body. So
13173 : here we also check canonical loop nest form only for the number of
13174 : outer loops specified by the COLLAPSE clause too. */
13175 8073 : for (i = 1; i <= count; i++)
13176 : {
13177 8073 : gfc_symbol *start_var = NULL, *end_var = NULL;
13178 : /* Parse errors are not recoverable. */
13179 8073 : if (do_code->op == EXEC_DO_WHILE)
13180 : {
13181 6 : gfc_error ("%s cannot be a DO WHILE or DO without loop control "
13182 : "at %L", name, &do_code->loc);
13183 106 : goto fail;
13184 : }
13185 8067 : if (do_code->op == EXEC_DO_CONCURRENT)
13186 : {
13187 4 : gfc_error ("%s cannot be a DO CONCURRENT loop at %L", name,
13188 : &do_code->loc);
13189 4 : goto fail;
13190 : }
13191 8063 : if (do_code->op == EXEC_OMP_TILE || do_code->op == EXEC_OMP_UNROLL)
13192 : {
13193 466 : if (do_code->op == EXEC_OMP_UNROLL)
13194 : {
13195 308 : if (!do_code->ext.omp_clauses->partial)
13196 : {
13197 53 : gfc_error ("Generated loop of UNROLL construct at %L "
13198 : "without PARTIAL clause does not have "
13199 : "canonical form", &do_code->loc);
13200 53 : goto fail;
13201 : }
13202 255 : else if (i != count)
13203 : {
13204 5 : gfc_error ("UNROLL construct at %L with PARTIAL clause "
13205 : "generates just one loop with canonical form "
13206 : "but %d loops are needed",
13207 5 : &do_code->loc, count - i + 1);
13208 5 : goto fail;
13209 : }
13210 : }
13211 158 : else if (do_code->op == EXEC_OMP_TILE)
13212 : {
13213 158 : if (do_code->ext.omp_clauses->sizes_list == NULL)
13214 : /* This should have been diagnosed earlier already. */
13215 0 : return;
13216 158 : int l = gfc_expr_list_len (do_code->ext.omp_clauses->sizes_list);
13217 158 : if (count - i + 1 > l)
13218 : {
13219 14 : gfc_error ("TILE construct at %L generates %d loops "
13220 : "with canonical form but %d loops are needed",
13221 : &do_code->loc, l, count - i + 1);
13222 14 : goto fail;
13223 : }
13224 : }
13225 394 : if (do_code->ext.omp_clauses && do_code->ext.omp_clauses->erroneous)
13226 17 : goto fail;
13227 377 : if (imperfect && !perfect_nesting_errorp)
13228 : {
13229 4 : sorry_at (gfc_get_location (&do_code->loc),
13230 : "Imperfectly nested loop using generated loops");
13231 4 : errorp = true;
13232 : }
13233 377 : if (non_generated_count == count)
13234 329 : non_generated_count = i - 1;
13235 377 : --i;
13236 377 : do_code = do_code->block->next;
13237 377 : continue;
13238 377 : }
13239 7597 : gcc_assert (do_code->op == EXEC_DO);
13240 7597 : if (do_code->ext.iterator->var->ts.type != BT_INTEGER)
13241 : {
13242 3 : gfc_error ("%s iteration variable must be of type integer at %L",
13243 : name, &do_code->loc);
13244 3 : errorp = true;
13245 : }
13246 7597 : dovar = do_code->ext.iterator->var->symtree->n.sym;
13247 7597 : if (dovar->attr.threadprivate)
13248 : {
13249 0 : gfc_error ("%s iteration variable must not be THREADPRIVATE "
13250 : "at %L", name, &do_code->loc);
13251 0 : errorp = true;
13252 : }
13253 7597 : if (code->ext.omp_clauses)
13254 303880 : for (enum gfc_omp_list_type list = OMP_LIST_FIRST; list < OMP_LIST_NUM;
13255 296283 : list = gfc_omp_list_type (list + 1))
13256 97617 : if (!is_simd || code->ext.omp_clauses->collapse > 1
13257 296283 : ? (list != OMP_LIST_PRIVATE && list != OMP_LIST_LASTPRIVATE
13258 255021 : && list != OMP_LIST_ALLOCATE)
13259 41262 : : (list != OMP_LIST_PRIVATE && list != OMP_LIST_LASTPRIVATE
13260 41262 : && list != OMP_LIST_ALLOCATE && list != OMP_LIST_LINEAR))
13261 276820 : for (n = code->ext.omp_clauses->lists[list]; n; n = n->next)
13262 4386 : if (dovar == n->sym)
13263 : {
13264 5 : if (!is_simd || code->ext.omp_clauses->collapse > 1)
13265 4 : gfc_error ("%s iteration variable present on clause "
13266 : "other than PRIVATE, LASTPRIVATE or "
13267 : "ALLOCATE at %L", name, &do_code->loc);
13268 : else
13269 1 : gfc_error ("%s iteration variable present on clause "
13270 : "other than PRIVATE, LASTPRIVATE, ALLOCATE or "
13271 : "LINEAR at %L", name, &do_code->loc);
13272 : errorp = true;
13273 : }
13274 7597 : if (is_outer_iteration_variable (code, i, dovar))
13275 : {
13276 2 : gfc_error ("%s iteration variable used in more than one loop at %L",
13277 : name, &do_code->loc);
13278 2 : errorp = true;
13279 : }
13280 7595 : else if (is_intervening_var (code, i, dovar))
13281 : {
13282 2 : gfc_error ("%s iteration variable at %L is bound in "
13283 : "intervening code",
13284 : name, &do_code->loc);
13285 2 : errorp = true;
13286 : }
13287 7593 : else if (!bound_expr_is_canonical (code, i,
13288 7593 : do_code->ext.iterator->start,
13289 : &start_var))
13290 : {
13291 4 : gfc_error ("%s loop start expression not in canonical form at %L",
13292 : name, &do_code->loc);
13293 4 : errorp = true;
13294 : }
13295 7589 : else if (expr_uses_intervening_var (code, i,
13296 7589 : do_code->ext.iterator->start))
13297 : {
13298 1 : gfc_error ("%s loop start expression at %L uses variable bound in "
13299 : "intervening code",
13300 : name, &do_code->loc);
13301 1 : errorp = true;
13302 : }
13303 7588 : else if (!bound_expr_is_canonical (code, i,
13304 7588 : do_code->ext.iterator->end,
13305 : &end_var))
13306 : {
13307 2 : gfc_error ("%s loop end expression not in canonical form at %L",
13308 : name, &do_code->loc);
13309 2 : errorp = true;
13310 : }
13311 7586 : else if (expr_uses_intervening_var (code, i,
13312 7586 : do_code->ext.iterator->end))
13313 : {
13314 1 : gfc_error ("%s loop end expression at %L uses variable bound in "
13315 : "intervening code",
13316 : name, &do_code->loc);
13317 1 : errorp = true;
13318 : }
13319 7585 : else if (start_var && end_var && start_var != end_var)
13320 : {
13321 1 : gfc_error ("%s loop bounds reference different "
13322 : "iteration variables at %L", name, &do_code->loc);
13323 1 : errorp = true;
13324 : }
13325 7584 : else if (!expr_is_invariant (code, i, do_code->ext.iterator->step))
13326 : {
13327 3 : gfc_error ("%s loop increment not in canonical form at %L",
13328 : name, &do_code->loc);
13329 3 : errorp = true;
13330 : }
13331 7581 : else if (expr_uses_intervening_var (code, i,
13332 7581 : do_code->ext.iterator->step))
13333 : {
13334 1 : gfc_error ("%s loop increment expression at %L uses variable "
13335 : "bound in intervening code",
13336 : name, &do_code->loc);
13337 1 : errorp = true;
13338 : }
13339 7597 : if (start_var || end_var)
13340 : {
13341 528 : code->ext.omp_clauses->non_rectangular = 1;
13342 528 : if (i > non_generated_count)
13343 : {
13344 3 : sorry_at (gfc_get_location (&do_code->loc),
13345 : "Non-rectangular loops from generated loops "
13346 : "unsupported");
13347 3 : errorp = true;
13348 : }
13349 : }
13350 :
13351 : /* Only parse loop body into nested loop and intervening code if
13352 : there are supposed to be more loops in the nest to collapse. */
13353 7597 : if (i == count)
13354 : break;
13355 :
13356 2270 : next = find_nested_loop_in_chain (do_code->block->next);
13357 :
13358 2270 : if (!next)
13359 : {
13360 : /* Parse error, can't recover from this. */
13361 7 : gfc_error ("not enough DO loops for collapsed %s (level %d) at %L",
13362 : name, i, &code->loc);
13363 7 : goto fail;
13364 : }
13365 2263 : else if (next != do_code->block->next
13366 2103 : || (next->next && next->next->op != EXEC_CONTINUE))
13367 : /* Imperfectly nested loop found. */
13368 : {
13369 : /* Only diagnose violation of imperfect nesting constraints once. */
13370 177 : if (!perfect_nesting_errorp)
13371 : {
13372 176 : if (code->ext.omp_clauses->orderedc)
13373 : {
13374 3 : gfc_error ("%s inner loops must be perfectly nested with "
13375 : "ORDERED clause at %L",
13376 : name, &code->loc);
13377 3 : perfect_nesting_errorp = true;
13378 : }
13379 173 : else if (code->ext.omp_clauses->lists[OMP_LIST_REDUCTION_INSCAN])
13380 : {
13381 2 : gfc_error ("%s inner loops must be perfectly nested with "
13382 : "REDUCTION INSCAN clause at %L",
13383 : name, &code->loc);
13384 2 : perfect_nesting_errorp = true;
13385 : }
13386 171 : else if (code->op == EXEC_OMP_TILE)
13387 : {
13388 8 : gfc_error ("%s inner loops must be perfectly nested at %L",
13389 : name, &code->loc);
13390 8 : perfect_nesting_errorp = true;
13391 : }
13392 13 : if (perfect_nesting_errorp)
13393 : errorp = true;
13394 : }
13395 177 : if (diagnose_intervening_code_errors (do_code->block->next,
13396 : name, next))
13397 5 : errorp = true;
13398 : imperfect = true;
13399 : }
13400 2263 : do_code = next;
13401 : }
13402 :
13403 : /* Give up now if we found any constraint violations. */
13404 5327 : if (errorp)
13405 : {
13406 48 : fail:
13407 154 : if (code->ext.omp_clauses)
13408 154 : code->ext.omp_clauses->erroneous = 1;
13409 : return;
13410 : }
13411 :
13412 5279 : if (non_generated_count)
13413 5009 : restructure_intervening_code (&code->block->next, code,
13414 : non_generated_count);
13415 : }
13416 :
13417 : /* Resolve the context selector. In particular, SKIP_P is set to true,
13418 : the context can never be matched. */
13419 :
13420 : static void
13421 765 : gfc_resolve_omp_context_selector (gfc_omp_set_selector *oss,
13422 : bool is_metadirective, bool *skip_p)
13423 : {
13424 765 : if (skip_p)
13425 310 : *skip_p = false;
13426 1455 : for (gfc_omp_set_selector *set_selector = oss; set_selector;
13427 690 : set_selector = set_selector->next)
13428 1487 : for (gfc_omp_selector *os = set_selector->trait_selectors; os; os = os->next)
13429 : {
13430 815 : if (os->score)
13431 : {
13432 52 : if (!gfc_resolve_expr (os->score)
13433 52 : || os->score->ts.type != BT_INTEGER
13434 104 : || os->score->rank != 0)
13435 : {
13436 0 : gfc_error ("%<score%> argument must be constant integer "
13437 0 : "expression at %L", &os->score->where);
13438 0 : gfc_free_expr (os->score);
13439 0 : os->score = nullptr;
13440 : }
13441 52 : else if (os->score->expr_type == EXPR_CONSTANT
13442 52 : && mpz_sgn (os->score->value.integer) < 0)
13443 : {
13444 1 : gfc_error ("%<score%> argument must be non-negative at %L",
13445 : &os->score->where);
13446 1 : gfc_free_expr (os->score);
13447 1 : os->score = nullptr;
13448 : }
13449 : }
13450 :
13451 815 : if (os->code == OMP_TRAIT_INVALID)
13452 : break;
13453 797 : enum omp_tp_type property_kind = omp_ts_map[os->code].tp_type;
13454 797 : gfc_omp_trait_property *otp = os->properties;
13455 :
13456 797 : if (!otp)
13457 410 : continue;
13458 387 : switch (property_kind)
13459 : {
13460 139 : case OMP_TRAIT_PROPERTY_DEV_NUM_EXPR:
13461 139 : case OMP_TRAIT_PROPERTY_BOOL_EXPR:
13462 139 : if (!gfc_resolve_expr (otp->expr)
13463 138 : || (property_kind == OMP_TRAIT_PROPERTY_BOOL_EXPR
13464 124 : && otp->expr->ts.type != BT_LOGICAL)
13465 137 : || (property_kind == OMP_TRAIT_PROPERTY_DEV_NUM_EXPR
13466 14 : && otp->expr->ts.type != BT_INTEGER)
13467 137 : || otp->expr->rank != 0
13468 276 : || (!is_metadirective && otp->expr->expr_type != EXPR_CONSTANT))
13469 : {
13470 3 : if (is_metadirective)
13471 : {
13472 0 : if (property_kind == OMP_TRAIT_PROPERTY_BOOL_EXPR)
13473 0 : gfc_error ("property must be a "
13474 : "logical expression at %L",
13475 0 : &otp->expr->where);
13476 : else
13477 0 : gfc_error ("property must be an "
13478 : "integer expression at %L",
13479 0 : &otp->expr->where);
13480 : }
13481 : else
13482 : {
13483 3 : if (property_kind == OMP_TRAIT_PROPERTY_BOOL_EXPR)
13484 2 : gfc_error ("property must be a constant "
13485 : "logical expression at %L",
13486 2 : &otp->expr->where);
13487 : else
13488 1 : gfc_error ("property must be a constant "
13489 : "integer expression at %L",
13490 1 : &otp->expr->where);
13491 : }
13492 : /* Prevent later ICEs. */
13493 3 : gfc_expr *e;
13494 3 : if (property_kind == OMP_TRAIT_PROPERTY_BOOL_EXPR)
13495 2 : e = gfc_get_logical_expr (gfc_default_logical_kind,
13496 2 : &otp->expr->where, true);
13497 : else
13498 1 : e = gfc_get_int_expr (gfc_default_integer_kind,
13499 1 : &otp->expr->where, 0);
13500 3 : gfc_free_expr (otp->expr);
13501 3 : otp->expr = e;
13502 3 : continue;
13503 3 : }
13504 : /* Device number must be conforming, which includes
13505 : omp_initial_device (-1), omp_invalid_device (-4),
13506 : and omp_default_device (-5). */
13507 136 : if (property_kind == OMP_TRAIT_PROPERTY_DEV_NUM_EXPR
13508 14 : && otp->expr->expr_type == EXPR_CONSTANT
13509 5 : && mpz_sgn (otp->expr->value.integer) < 0
13510 3 : && mpz_cmp_si (otp->expr->value.integer, -1) != 0
13511 2 : && mpz_cmp_si (otp->expr->value.integer, -4) != 0
13512 1 : && mpz_cmp_si (otp->expr->value.integer, -5) != 0)
13513 1 : gfc_error ("property must be a conforming device number at %L",
13514 : &otp->expr->where);
13515 : break;
13516 : default:
13517 : break;
13518 : }
13519 : /* This only handles one specific case: User condition.
13520 : FIXME: Handle more cases by calling omp_context_selector_matches;
13521 : unfortunately, we cannot generate the tree here as, e.g., PARM_DECL
13522 : backend decl are not available at this stage - but might be used in,
13523 : e.g. user conditions. See PR122361. */
13524 384 : if (skip_p && otp
13525 138 : && os->code == OMP_TRAIT_USER_CONDITION
13526 81 : && otp->expr->expr_type == EXPR_CONSTANT
13527 14 : && otp->expr->value.logical == false)
13528 12 : *skip_p = true;
13529 : }
13530 765 : }
13531 :
13532 :
13533 : static void
13534 138 : resolve_omp_metadirective (gfc_code *code, gfc_namespace *ns)
13535 : {
13536 138 : gfc_omp_variant *variant = code->ext.omp_variants;
13537 138 : gfc_omp_variant *prev_variant = variant;
13538 :
13539 448 : while (variant)
13540 : {
13541 310 : bool skip;
13542 310 : gfc_resolve_omp_context_selector (variant->selectors, true, &skip);
13543 310 : gfc_code *variant_code = variant->code;
13544 310 : gfc_resolve_code (variant_code, ns);
13545 310 : if (skip)
13546 : {
13547 : /* The following should only be true if an error occurred
13548 : as the 'otherwise' clause should always match. */
13549 12 : if (variant == code->ext.omp_variants && !variant->next)
13550 : break;
13551 12 : gfc_omp_variant *tmp = variant;
13552 12 : if (variant == code->ext.omp_variants)
13553 11 : variant = prev_variant = code->ext.omp_variants = variant->next;
13554 : else
13555 1 : variant = prev_variant->next = variant->next;
13556 12 : gfc_free_omp_set_selector_list (tmp->selectors);
13557 12 : free (tmp);
13558 : }
13559 : else
13560 : {
13561 298 : prev_variant = variant;
13562 298 : variant = variant->next;
13563 : }
13564 : }
13565 : /* Replace metadirective by its body if only 'nothing' remains. */
13566 138 : if (!code->ext.omp_variants->next && code->ext.omp_variants->stmt == ST_NONE)
13567 : {
13568 11 : gfc_code *next = code->next;
13569 11 : gfc_code *inner = code->ext.omp_variants->code;
13570 11 : gfc_free_omp_set_selector_list (code->ext.omp_variants->selectors);
13571 11 : free (code->ext.omp_variants);
13572 11 : *code = *inner;
13573 11 : free (inner);
13574 11 : while (code->next)
13575 : code = code->next;
13576 11 : code->next = next;
13577 : }
13578 138 : }
13579 :
13580 :
13581 : static gfc_statement
13582 63 : omp_code_to_statement (gfc_code *code)
13583 : {
13584 63 : switch (code->op)
13585 : {
13586 : case EXEC_OMP_PARALLEL:
13587 : return ST_OMP_PARALLEL;
13588 0 : case EXEC_OMP_PARALLEL_MASKED:
13589 0 : return ST_OMP_PARALLEL_MASKED;
13590 0 : case EXEC_OMP_PARALLEL_MASKED_TASKLOOP:
13591 0 : return ST_OMP_PARALLEL_MASKED_TASKLOOP;
13592 0 : case EXEC_OMP_PARALLEL_MASKED_TASKLOOP_SIMD:
13593 0 : return ST_OMP_PARALLEL_MASKED_TASKLOOP_SIMD;
13594 0 : case EXEC_OMP_PARALLEL_MASTER:
13595 0 : return ST_OMP_PARALLEL_MASTER;
13596 0 : case EXEC_OMP_PARALLEL_MASTER_TASKLOOP:
13597 0 : return ST_OMP_PARALLEL_MASTER_TASKLOOP;
13598 0 : case EXEC_OMP_PARALLEL_MASTER_TASKLOOP_SIMD:
13599 0 : return ST_OMP_PARALLEL_MASTER_TASKLOOP_SIMD;
13600 1 : case EXEC_OMP_PARALLEL_SECTIONS:
13601 1 : return ST_OMP_PARALLEL_SECTIONS;
13602 1 : case EXEC_OMP_SECTIONS:
13603 1 : return ST_OMP_SECTIONS;
13604 1 : case EXEC_OMP_ORDERED:
13605 1 : return ST_OMP_ORDERED;
13606 1 : case EXEC_OMP_CRITICAL:
13607 1 : return ST_OMP_CRITICAL;
13608 0 : case EXEC_OMP_MASKED:
13609 0 : return ST_OMP_MASKED;
13610 0 : case EXEC_OMP_MASKED_TASKLOOP:
13611 0 : return ST_OMP_MASKED_TASKLOOP;
13612 0 : case EXEC_OMP_MASKED_TASKLOOP_SIMD:
13613 0 : return ST_OMP_MASKED_TASKLOOP_SIMD;
13614 1 : case EXEC_OMP_MASTER:
13615 1 : return ST_OMP_MASTER;
13616 0 : case EXEC_OMP_MASTER_TASKLOOP:
13617 0 : return ST_OMP_MASTER_TASKLOOP;
13618 0 : case EXEC_OMP_MASTER_TASKLOOP_SIMD:
13619 0 : return ST_OMP_MASTER_TASKLOOP_SIMD;
13620 1 : case EXEC_OMP_SINGLE:
13621 1 : return ST_OMP_SINGLE;
13622 1 : case EXEC_OMP_TASK:
13623 1 : return ST_OMP_TASK;
13624 1 : case EXEC_OMP_WORKSHARE:
13625 1 : return ST_OMP_WORKSHARE;
13626 1 : case EXEC_OMP_PARALLEL_WORKSHARE:
13627 1 : return ST_OMP_PARALLEL_WORKSHARE;
13628 3 : case EXEC_OMP_DO:
13629 3 : return ST_OMP_DO;
13630 0 : case EXEC_OMP_LOOP:
13631 0 : return ST_OMP_LOOP;
13632 0 : case EXEC_OMP_ALLOCATE:
13633 0 : return ST_OMP_ALLOCATE_EXEC;
13634 0 : case EXEC_OMP_ALLOCATORS:
13635 0 : return ST_OMP_ALLOCATORS;
13636 0 : case EXEC_OMP_ASSUME:
13637 0 : return ST_OMP_ASSUME;
13638 1 : case EXEC_OMP_ATOMIC:
13639 1 : return ST_OMP_ATOMIC;
13640 1 : case EXEC_OMP_BARRIER:
13641 1 : return ST_OMP_BARRIER;
13642 1 : case EXEC_OMP_CANCEL:
13643 1 : return ST_OMP_CANCEL;
13644 1 : case EXEC_OMP_CANCELLATION_POINT:
13645 1 : return ST_OMP_CANCELLATION_POINT;
13646 0 : case EXEC_OMP_ERROR:
13647 0 : return ST_OMP_ERROR;
13648 1 : case EXEC_OMP_FLUSH:
13649 1 : return ST_OMP_FLUSH;
13650 0 : case EXEC_OMP_INTEROP:
13651 0 : return ST_OMP_INTEROP;
13652 1 : case EXEC_OMP_DISTRIBUTE:
13653 1 : return ST_OMP_DISTRIBUTE;
13654 1 : case EXEC_OMP_DISTRIBUTE_PARALLEL_DO:
13655 1 : return ST_OMP_DISTRIBUTE_PARALLEL_DO;
13656 1 : case EXEC_OMP_DISTRIBUTE_PARALLEL_DO_SIMD:
13657 1 : return ST_OMP_DISTRIBUTE_PARALLEL_DO_SIMD;
13658 1 : case EXEC_OMP_DISTRIBUTE_SIMD:
13659 1 : return ST_OMP_DISTRIBUTE_SIMD;
13660 1 : case EXEC_OMP_DO_SIMD:
13661 1 : return ST_OMP_DO_SIMD;
13662 0 : case EXEC_OMP_SCAN:
13663 0 : return ST_OMP_SCAN;
13664 0 : case EXEC_OMP_SCOPE:
13665 0 : return ST_OMP_SCOPE;
13666 1 : case EXEC_OMP_SIMD:
13667 1 : return ST_OMP_SIMD;
13668 1 : case EXEC_OMP_TARGET:
13669 1 : return ST_OMP_TARGET;
13670 1 : case EXEC_OMP_TARGET_DATA:
13671 1 : return ST_OMP_TARGET_DATA;
13672 1 : case EXEC_OMP_TARGET_ENTER_DATA:
13673 1 : return ST_OMP_TARGET_ENTER_DATA;
13674 1 : case EXEC_OMP_TARGET_EXIT_DATA:
13675 1 : return ST_OMP_TARGET_EXIT_DATA;
13676 1 : case EXEC_OMP_TARGET_PARALLEL:
13677 1 : return ST_OMP_TARGET_PARALLEL;
13678 1 : case EXEC_OMP_TARGET_PARALLEL_DO:
13679 1 : return ST_OMP_TARGET_PARALLEL_DO;
13680 1 : case EXEC_OMP_TARGET_PARALLEL_DO_SIMD:
13681 1 : return ST_OMP_TARGET_PARALLEL_DO_SIMD;
13682 0 : case EXEC_OMP_TARGET_PARALLEL_LOOP:
13683 0 : return ST_OMP_TARGET_PARALLEL_LOOP;
13684 1 : case EXEC_OMP_TARGET_SIMD:
13685 1 : return ST_OMP_TARGET_SIMD;
13686 1 : case EXEC_OMP_TARGET_TEAMS:
13687 1 : return ST_OMP_TARGET_TEAMS;
13688 1 : case EXEC_OMP_TARGET_TEAMS_DISTRIBUTE:
13689 1 : return ST_OMP_TARGET_TEAMS_DISTRIBUTE;
13690 1 : case EXEC_OMP_TARGET_TEAMS_DISTRIBUTE_PARALLEL_DO:
13691 1 : return ST_OMP_TARGET_TEAMS_DISTRIBUTE_PARALLEL_DO;
13692 1 : case EXEC_OMP_TARGET_TEAMS_DISTRIBUTE_PARALLEL_DO_SIMD:
13693 1 : return ST_OMP_TARGET_TEAMS_DISTRIBUTE_PARALLEL_DO_SIMD;
13694 1 : case EXEC_OMP_TARGET_TEAMS_DISTRIBUTE_SIMD:
13695 1 : return ST_OMP_TARGET_TEAMS_DISTRIBUTE_SIMD;
13696 0 : case EXEC_OMP_TARGET_TEAMS_LOOP:
13697 0 : return ST_OMP_TARGET_TEAMS_LOOP;
13698 1 : case EXEC_OMP_TARGET_UPDATE:
13699 1 : return ST_OMP_TARGET_UPDATE;
13700 1 : case EXEC_OMP_TASKGROUP:
13701 1 : return ST_OMP_TASKGROUP;
13702 1 : case EXEC_OMP_TASKLOOP:
13703 1 : return ST_OMP_TASKLOOP;
13704 1 : case EXEC_OMP_TASKLOOP_SIMD:
13705 1 : return ST_OMP_TASKLOOP_SIMD;
13706 1 : case EXEC_OMP_TASKWAIT:
13707 1 : return ST_OMP_TASKWAIT;
13708 1 : case EXEC_OMP_TASKYIELD:
13709 1 : return ST_OMP_TASKYIELD;
13710 1 : case EXEC_OMP_TEAMS:
13711 1 : return ST_OMP_TEAMS;
13712 1 : case EXEC_OMP_TEAMS_DISTRIBUTE:
13713 1 : return ST_OMP_TEAMS_DISTRIBUTE;
13714 1 : case EXEC_OMP_TEAMS_DISTRIBUTE_PARALLEL_DO:
13715 1 : return ST_OMP_TEAMS_DISTRIBUTE_PARALLEL_DO;
13716 1 : case EXEC_OMP_TEAMS_DISTRIBUTE_PARALLEL_DO_SIMD:
13717 1 : return ST_OMP_TEAMS_DISTRIBUTE_PARALLEL_DO_SIMD;
13718 1 : case EXEC_OMP_TEAMS_DISTRIBUTE_SIMD:
13719 1 : return ST_OMP_TEAMS_DISTRIBUTE_SIMD;
13720 0 : case EXEC_OMP_TEAMS_LOOP:
13721 0 : return ST_OMP_TEAMS_LOOP;
13722 6 : case EXEC_OMP_PARALLEL_DO:
13723 6 : return ST_OMP_PARALLEL_DO;
13724 1 : case EXEC_OMP_PARALLEL_DO_SIMD:
13725 1 : return ST_OMP_PARALLEL_DO_SIMD;
13726 0 : case EXEC_OMP_PARALLEL_LOOP:
13727 0 : return ST_OMP_PARALLEL_LOOP;
13728 1 : case EXEC_OMP_DEPOBJ:
13729 1 : return ST_OMP_DEPOBJ;
13730 0 : case EXEC_OMP_TILE:
13731 0 : return ST_OMP_TILE;
13732 0 : case EXEC_OMP_UNROLL:
13733 0 : return ST_OMP_UNROLL;
13734 0 : case EXEC_OMP_DISPATCH:
13735 0 : return ST_OMP_DISPATCH;
13736 0 : default:
13737 0 : gcc_unreachable ();
13738 : }
13739 : }
13740 :
13741 : static gfc_statement
13742 63 : oacc_code_to_statement (gfc_code *code)
13743 : {
13744 63 : switch (code->op)
13745 : {
13746 : case EXEC_OACC_PARALLEL:
13747 : return ST_OACC_PARALLEL;
13748 : case EXEC_OACC_KERNELS:
13749 : return ST_OACC_KERNELS;
13750 : case EXEC_OACC_SERIAL:
13751 : return ST_OACC_SERIAL;
13752 : case EXEC_OACC_DATA:
13753 : return ST_OACC_DATA;
13754 : case EXEC_OACC_HOST_DATA:
13755 : return ST_OACC_HOST_DATA;
13756 : case EXEC_OACC_PARALLEL_LOOP:
13757 : return ST_OACC_PARALLEL_LOOP;
13758 : case EXEC_OACC_KERNELS_LOOP:
13759 : return ST_OACC_KERNELS_LOOP;
13760 : case EXEC_OACC_SERIAL_LOOP:
13761 : return ST_OACC_SERIAL_LOOP;
13762 : case EXEC_OACC_LOOP:
13763 : return ST_OACC_LOOP;
13764 : case EXEC_OACC_ATOMIC:
13765 : return ST_OACC_ATOMIC;
13766 : case EXEC_OACC_ROUTINE:
13767 : return ST_OACC_ROUTINE;
13768 : case EXEC_OACC_UPDATE:
13769 : return ST_OACC_UPDATE;
13770 : case EXEC_OACC_WAIT:
13771 : return ST_OACC_WAIT;
13772 : case EXEC_OACC_CACHE:
13773 : return ST_OACC_CACHE;
13774 : case EXEC_OACC_ENTER_DATA:
13775 : return ST_OACC_ENTER_DATA;
13776 : case EXEC_OACC_EXIT_DATA:
13777 : return ST_OACC_EXIT_DATA;
13778 : case EXEC_OACC_DECLARE:
13779 : return ST_OACC_DECLARE;
13780 : case EXEC_OACC_INIT:
13781 : return ST_OACC_INIT;
13782 : case EXEC_OACC_SHUTDOWN:
13783 : return ST_OACC_SHUTDOWN;
13784 : case EXEC_OACC_SET:
13785 : return ST_OACC_SET;
13786 0 : default:
13787 0 : gcc_unreachable ();
13788 : }
13789 : }
13790 :
13791 : static void
13792 13538 : resolve_oacc_directive_inside_omp_region (gfc_code *code)
13793 : {
13794 13538 : if (omp_current_ctx != NULL && omp_current_ctx->is_openmp)
13795 : {
13796 11 : gfc_statement st = omp_code_to_statement (omp_current_ctx->code);
13797 11 : gfc_statement oacc_st = oacc_code_to_statement (code);
13798 11 : gfc_error ("The %s directive cannot be specified within "
13799 : "a %s region at %L", gfc_ascii_statement (oacc_st),
13800 : gfc_ascii_statement (st), &code->loc);
13801 : }
13802 13538 : }
13803 :
13804 : static void
13805 21264 : resolve_omp_directive_inside_oacc_region (gfc_code *code)
13806 : {
13807 21264 : if (omp_current_ctx != NULL && !omp_current_ctx->is_openmp)
13808 : {
13809 52 : gfc_statement st = oacc_code_to_statement (omp_current_ctx->code);
13810 52 : gfc_statement omp_st = omp_code_to_statement (code);
13811 52 : gfc_error ("The %s directive cannot be specified within "
13812 : "a %s region at %L", gfc_ascii_statement (omp_st),
13813 : gfc_ascii_statement (st), &code->loc);
13814 : }
13815 21264 : }
13816 :
13817 :
13818 : static void
13819 5272 : resolve_oacc_nested_loops (gfc_code *code, gfc_code* do_code, int collapse,
13820 : const char *clause)
13821 : {
13822 5272 : gfc_symbol *dovar;
13823 5272 : gfc_code *c;
13824 5272 : int i;
13825 :
13826 5792 : for (i = 1; i <= collapse; i++)
13827 : {
13828 5792 : if (do_code->op == EXEC_DO_WHILE)
13829 : {
13830 10 : gfc_error ("!$ACC LOOP cannot be a DO WHILE or DO without loop control "
13831 : "at %L", &do_code->loc);
13832 10 : break;
13833 : }
13834 5782 : if (do_code->op == EXEC_DO_CONCURRENT)
13835 : {
13836 3 : gfc_error ("!$ACC LOOP cannot be a DO CONCURRENT loop at %L",
13837 : &do_code->loc);
13838 3 : break;
13839 : }
13840 5779 : gcc_assert (do_code->op == EXEC_DO);
13841 5779 : if (do_code->ext.iterator->var->ts.type != BT_INTEGER)
13842 6 : gfc_error ("!$ACC LOOP iteration variable must be of type integer at %L",
13843 : &do_code->loc);
13844 5779 : dovar = do_code->ext.iterator->var->symtree->n.sym;
13845 5779 : if (i > 1)
13846 : {
13847 518 : gfc_code *do_code2 = code->block->next;
13848 518 : int j;
13849 :
13850 1218 : for (j = 1; j < i; j++)
13851 : {
13852 710 : gfc_symbol *ivar = do_code2->ext.iterator->var->symtree->n.sym;
13853 710 : if (dovar == ivar
13854 710 : || gfc_find_sym_in_expr (ivar, do_code->ext.iterator->start)
13855 701 : || gfc_find_sym_in_expr (ivar, do_code->ext.iterator->end)
13856 1410 : || gfc_find_sym_in_expr (ivar, do_code->ext.iterator->step))
13857 : {
13858 10 : gfc_error ("!$ACC LOOP %s loops don't form rectangular "
13859 : "iteration space at %L", clause, &do_code->loc);
13860 10 : break;
13861 : }
13862 700 : do_code2 = do_code2->block->next;
13863 : }
13864 : }
13865 5779 : if (i == collapse)
13866 : break;
13867 577 : for (c = do_code->next; c; c = c->next)
13868 48 : if (c->op != EXEC_NOP && c->op != EXEC_CONTINUE)
13869 : {
13870 0 : gfc_error ("%s !$ACC LOOP loops not perfectly nested at %L",
13871 : clause, &c->loc);
13872 0 : break;
13873 : }
13874 529 : if (c)
13875 : break;
13876 529 : do_code = do_code->block;
13877 529 : if (do_code->op != EXEC_DO && do_code->op != EXEC_DO_WHILE
13878 0 : && do_code->op != EXEC_DO_CONCURRENT)
13879 : {
13880 0 : gfc_error ("not enough DO loops for %s !$ACC LOOP at %L",
13881 : clause, &code->loc);
13882 0 : break;
13883 : }
13884 529 : do_code = do_code->next;
13885 529 : if (do_code == NULL
13886 522 : || (do_code->op != EXEC_DO && do_code->op != EXEC_DO_WHILE
13887 2 : && do_code->op != EXEC_DO_CONCURRENT))
13888 : {
13889 9 : gfc_error ("not enough DO loops for %s !$ACC LOOP at %L",
13890 : clause, &code->loc);
13891 9 : break;
13892 : }
13893 : }
13894 5272 : }
13895 :
13896 :
13897 : static void
13898 10119 : resolve_oacc_loop_blocks (gfc_code *code)
13899 : {
13900 10119 : if (!oacc_is_loop (code))
13901 : return;
13902 :
13903 5272 : if (code->ext.omp_clauses->tile_list && code->ext.omp_clauses->gang
13904 24 : && code->ext.omp_clauses->worker && code->ext.omp_clauses->vector)
13905 0 : gfc_error ("Tiled loop cannot be parallelized across gangs, workers and "
13906 : "vectors at the same time at %L", &code->loc);
13907 :
13908 5272 : if (code->ext.omp_clauses->tile_list)
13909 : {
13910 : gfc_expr_list *el;
13911 501 : for (el = code->ext.omp_clauses->tile_list; el; el = el->next)
13912 : {
13913 304 : if (el->expr == NULL)
13914 : {
13915 : /* NULL expressions are used to represent '*' arguments.
13916 : Convert those to a 0 expressions. */
13917 113 : el->expr = gfc_get_constant_expr (BT_INTEGER,
13918 : gfc_default_integer_kind,
13919 : &code->loc);
13920 113 : mpz_set_si (el->expr->value.integer, 0);
13921 : }
13922 : else
13923 : {
13924 191 : resolve_positive_int_expr (el->expr, "TILE");
13925 191 : if (el->expr->expr_type != EXPR_CONSTANT)
13926 14 : gfc_error ("TILE requires constant expression at %L",
13927 : &code->loc);
13928 : }
13929 : }
13930 : }
13931 : }
13932 :
13933 :
13934 : void
13935 10119 : gfc_resolve_oacc_blocks (gfc_code *code, gfc_namespace *ns)
13936 : {
13937 10119 : fortran_omp_context ctx;
13938 10119 : gfc_omp_clauses *omp_clauses = code->ext.omp_clauses;
13939 10119 : gfc_omp_namelist *n;
13940 :
13941 10119 : resolve_oacc_loop_blocks (code);
13942 :
13943 10119 : ctx.code = code;
13944 10119 : ctx.sharing_clauses = new hash_set<gfc_symbol *>;
13945 10119 : ctx.private_iterators = new hash_set<gfc_symbol *>;
13946 10119 : ctx.previous = omp_current_ctx;
13947 10119 : ctx.is_openmp = false;
13948 10119 : omp_current_ctx = &ctx;
13949 :
13950 404760 : for (enum gfc_omp_list_type list = OMP_LIST_FIRST; list < OMP_LIST_NUM;
13951 394641 : list = gfc_omp_list_type (list + 1))
13952 394641 : switch (list)
13953 : {
13954 10119 : case OMP_LIST_PRIVATE:
13955 10710 : for (n = omp_clauses->lists[list]; n; n = n->next)
13956 591 : ctx.sharing_clauses->add (n->sym);
13957 : break;
13958 : default:
13959 : break;
13960 : }
13961 :
13962 10119 : gfc_resolve_blocks (code->block, ns);
13963 :
13964 10119 : omp_current_ctx = ctx.previous;
13965 20238 : delete ctx.sharing_clauses;
13966 20238 : delete ctx.private_iterators;
13967 10119 : }
13968 :
13969 :
13970 : static void
13971 5272 : resolve_oacc_loop (gfc_code *code)
13972 : {
13973 5272 : gfc_code *do_code;
13974 5272 : int collapse;
13975 :
13976 5272 : if (code->ext.omp_clauses)
13977 5272 : resolve_omp_clauses (code, code->ext.omp_clauses, NULL, true);
13978 :
13979 5272 : do_code = code->block->next;
13980 5272 : collapse = code->ext.omp_clauses->collapse;
13981 :
13982 : /* Both collapsed and tiled loops are lowered the same way, but are not
13983 : compatible. In gfc_trans_omp_do, the tile is prioritized. */
13984 5272 : if (code->ext.omp_clauses->tile_list)
13985 : {
13986 : int num = 0;
13987 : gfc_expr_list *el;
13988 501 : for (el = code->ext.omp_clauses->tile_list; el; el = el->next)
13989 304 : ++num;
13990 197 : resolve_oacc_nested_loops (code, code->block->next, num, "tiled");
13991 197 : return;
13992 : }
13993 :
13994 5075 : if (collapse <= 0)
13995 : collapse = 1;
13996 5075 : resolve_oacc_nested_loops (code, do_code, collapse, "collapsed");
13997 : }
13998 :
13999 : void
14000 350315 : gfc_resolve_oacc_declare (gfc_namespace *ns)
14001 : {
14002 350315 : enum gfc_omp_list_type list;
14003 350315 : gfc_omp_namelist *n;
14004 350315 : gfc_oacc_declare *oc;
14005 :
14006 350315 : if (ns->oacc_declare == NULL)
14007 : return;
14008 :
14009 290 : for (oc = ns->oacc_declare; oc; oc = oc->next)
14010 : {
14011 6480 : for (list = OMP_LIST_FIRST; list < OMP_LIST_NUM;
14012 6318 : list = gfc_omp_list_type (list + 1))
14013 6574 : for (n = oc->clauses->lists[list]; n; n = n->next)
14014 : {
14015 256 : n->sym->mark = 0;
14016 256 : if (n->sym->attr.flavor != FL_VARIABLE
14017 16 : && (n->sym->attr.flavor != FL_PROCEDURE
14018 8 : || n->sym->result != n->sym))
14019 : {
14020 14 : if (n->sym->attr.flavor != FL_PARAMETER)
14021 : {
14022 8 : gfc_error ("Object %qs is not a variable at %L",
14023 : n->sym->name, &oc->loc);
14024 8 : continue;
14025 : }
14026 : /* Note that OpenACC 3.4 permits name constants, but the
14027 : implementation is permitted to ignore the clause;
14028 : as semantically, device_resident kind of makes sense
14029 : (and the wording with it is a bit odd), the warning
14030 : is suppressed. */
14031 6 : if (list != OMP_LIST_DEVICE_RESIDENT)
14032 5 : gfc_warning (OPT_Wsurprising, "Object %qs at %L is ignored as"
14033 : " parameters need not be copied", n->sym->name,
14034 : &oc->loc);
14035 : }
14036 :
14037 248 : if (n->expr && n->expr->ref->type == REF_ARRAY)
14038 : {
14039 1 : gfc_error ("Array sections: %qs not allowed in"
14040 1 : " !$ACC DECLARE at %L", n->sym->name, &oc->loc);
14041 1 : continue;
14042 : }
14043 : }
14044 :
14045 252 : for (n = oc->clauses->lists[OMP_LIST_DEVICE_RESIDENT]; n; n = n->next)
14046 90 : check_array_not_assumed (n->sym, oc->loc, "DEVICE_RESIDENT");
14047 : }
14048 :
14049 290 : for (oc = ns->oacc_declare; oc; oc = oc->next)
14050 : {
14051 6480 : for (list = OMP_LIST_FIRST; list < OMP_LIST_NUM;
14052 6318 : list = gfc_omp_list_type (list + 1))
14053 6574 : for (n = oc->clauses->lists[list]; n; n = n->next)
14054 : {
14055 256 : if (n->sym->mark)
14056 : {
14057 9 : gfc_error ("Symbol %qs present on multiple clauses at %L",
14058 : n->sym->name, &oc->loc);
14059 9 : continue;
14060 : }
14061 : else
14062 247 : n->sym->mark = 1;
14063 : }
14064 : }
14065 :
14066 290 : for (oc = ns->oacc_declare; oc; oc = oc->next)
14067 : {
14068 6480 : for (list = OMP_LIST_FIRST; list < OMP_LIST_NUM;
14069 6318 : list = gfc_omp_list_type (list + 1))
14070 6574 : for (n = oc->clauses->lists[list]; n; n = n->next)
14071 256 : n->sym->mark = 0;
14072 : }
14073 : }
14074 :
14075 :
14076 : void
14077 350315 : gfc_resolve_oacc_routines (gfc_namespace *ns)
14078 : {
14079 350315 : for (gfc_oacc_routine_name *orn = ns->oacc_routine_names;
14080 350415 : orn;
14081 100 : orn = orn->next)
14082 : {
14083 100 : gfc_symbol *sym = orn->sym;
14084 100 : if (!sym->attr.external
14085 29 : && !sym->attr.function
14086 27 : && !sym->attr.subroutine)
14087 : {
14088 7 : gfc_error ("NAME %qs does not refer to a subroutine or function"
14089 : " in !$ACC ROUTINE ( NAME ) at %L", sym->name, &orn->loc);
14090 7 : continue;
14091 : }
14092 93 : if (!gfc_add_omp_declare_target (&sym->attr, sym->name, &orn->loc))
14093 : {
14094 20 : gfc_error ("NAME %qs invalid"
14095 : " in !$ACC ROUTINE ( NAME ) at %L", sym->name, &orn->loc);
14096 20 : continue;
14097 : }
14098 : }
14099 350315 : }
14100 :
14101 :
14102 : void
14103 13538 : gfc_resolve_oacc_directive (gfc_code *code, gfc_namespace *ns ATTRIBUTE_UNUSED)
14104 : {
14105 13538 : resolve_oacc_directive_inside_omp_region (code);
14106 :
14107 13538 : switch (code->op)
14108 : {
14109 7723 : case EXEC_OACC_PARALLEL:
14110 7723 : case EXEC_OACC_KERNELS:
14111 7723 : case EXEC_OACC_SERIAL:
14112 7723 : case EXEC_OACC_DATA:
14113 7723 : case EXEC_OACC_HOST_DATA:
14114 7723 : case EXEC_OACC_UPDATE:
14115 7723 : case EXEC_OACC_ENTER_DATA:
14116 7723 : case EXEC_OACC_EXIT_DATA:
14117 7723 : case EXEC_OACC_WAIT:
14118 7723 : case EXEC_OACC_CACHE:
14119 7723 : case EXEC_OACC_INIT:
14120 7723 : case EXEC_OACC_SHUTDOWN:
14121 7723 : case EXEC_OACC_SET:
14122 7723 : resolve_omp_clauses (code, code->ext.omp_clauses, NULL, true);
14123 7723 : break;
14124 5272 : case EXEC_OACC_PARALLEL_LOOP:
14125 5272 : case EXEC_OACC_KERNELS_LOOP:
14126 5272 : case EXEC_OACC_SERIAL_LOOP:
14127 5272 : case EXEC_OACC_LOOP:
14128 5272 : resolve_oacc_loop (code);
14129 5272 : break;
14130 543 : case EXEC_OACC_ATOMIC:
14131 543 : resolve_omp_atomic (code);
14132 543 : break;
14133 : default:
14134 : break;
14135 : }
14136 13538 : }
14137 :
14138 :
14139 : static void
14140 2185 : resolve_omp_target (gfc_code *code)
14141 : {
14142 : #define GFC_IS_TEAMS_CONSTRUCT(op) \
14143 : (op == EXEC_OMP_TEAMS \
14144 : || op == EXEC_OMP_TEAMS_DISTRIBUTE \
14145 : || op == EXEC_OMP_TEAMS_DISTRIBUTE_SIMD \
14146 : || op == EXEC_OMP_TEAMS_DISTRIBUTE_PARALLEL_DO \
14147 : || op == EXEC_OMP_TEAMS_DISTRIBUTE_PARALLEL_DO_SIMD \
14148 : || op == EXEC_OMP_TEAMS_LOOP)
14149 :
14150 2185 : if (!code->ext.omp_clauses->contains_teams_construct)
14151 : return;
14152 203 : gfc_code *c = code->block->next;
14153 203 : if (c->op == EXEC_BLOCK)
14154 30 : c = c->ext.block.ns->code;
14155 203 : if (code->ext.omp_clauses->target_first_st_is_teams_or_meta)
14156 : {
14157 192 : if (c->op == EXEC_OMP_METADIRECTIVE)
14158 : {
14159 15 : struct gfc_omp_variant *mc
14160 : = c->ext.omp_variants;
14161 : /* All mc->(next...->)code should be identical with regards
14162 : to the diagnostic below. */
14163 16 : do
14164 : {
14165 16 : if (mc->stmt != ST_NONE
14166 15 : && GFC_IS_TEAMS_CONSTRUCT (mc->code->op))
14167 : {
14168 14 : if (c->next == NULL && mc->code->next == NULL)
14169 : return;
14170 23 : c = mc->code;
14171 : break;
14172 : }
14173 2 : mc = mc->next;
14174 : }
14175 2 : while (mc);
14176 : }
14177 177 : else if (GFC_IS_TEAMS_CONSTRUCT (c->op) && c->next == NULL)
14178 : return;
14179 : }
14180 :
14181 31 : while (c && !GFC_IS_TEAMS_CONSTRUCT (c->op))
14182 8 : c = c->next;
14183 23 : if (c)
14184 19 : gfc_error ("!$OMP TARGET region at %L with a nested TEAMS at %L may not "
14185 : "contain any other statement, declaration or directive outside "
14186 : "of the single TEAMS construct", &c->loc, &code->loc);
14187 : else
14188 4 : gfc_error ("!$OMP TARGET region at %L with a nested TEAMS may not "
14189 : "contain any other statement, declaration or directive outside "
14190 : "of the single TEAMS construct", &code->loc);
14191 : #undef GFC_IS_TEAMS_CONSTRUCT
14192 : }
14193 :
14194 : static void
14195 154 : resolve_omp_dispatch (gfc_code *code)
14196 : {
14197 154 : gfc_code *next = code->block->next;
14198 154 : if (next == NULL)
14199 : return;
14200 :
14201 151 : gfc_exec_op op = next->op;
14202 151 : gcc_assert (op == EXEC_CALL || op == EXEC_ASSIGN);
14203 151 : if (op != EXEC_CALL
14204 74 : && (op != EXEC_ASSIGN || next->expr2->expr_type != EXPR_FUNCTION))
14205 3 : gfc_error (
14206 : "%<OMP DISPATCH%> directive at %L must be followed by a procedure "
14207 : "call with optional assignment",
14208 : &code->loc);
14209 :
14210 77 : if ((op == EXEC_CALL && next->resolved_sym != NULL
14211 76 : && next->resolved_sym->attr.proc_pointer)
14212 151 : || (op == EXEC_ASSIGN && gfc_expr_attr (next->expr2).proc_pointer))
14213 1 : gfc_error ("%<OMP DISPATCH%> directive at %L cannot be followed by a "
14214 : "procedure pointer",
14215 : &code->loc);
14216 : }
14217 :
14218 : /* Resolve OpenMP directive clauses and check various requirements
14219 : of each directive. */
14220 :
14221 : void
14222 21264 : gfc_resolve_omp_directive (gfc_code *code, gfc_namespace *ns)
14223 : {
14224 21264 : resolve_omp_directive_inside_oacc_region (code);
14225 :
14226 21264 : if (code->op != EXEC_OMP_ATOMIC)
14227 19110 : gfc_maybe_initialize_eh ();
14228 :
14229 21264 : switch (code->op)
14230 : {
14231 5433 : case EXEC_OMP_DISTRIBUTE:
14232 5433 : case EXEC_OMP_DISTRIBUTE_PARALLEL_DO:
14233 5433 : case EXEC_OMP_DISTRIBUTE_PARALLEL_DO_SIMD:
14234 5433 : case EXEC_OMP_DISTRIBUTE_SIMD:
14235 5433 : case EXEC_OMP_DO:
14236 5433 : case EXEC_OMP_DO_SIMD:
14237 5433 : case EXEC_OMP_LOOP:
14238 5433 : case EXEC_OMP_PARALLEL_DO:
14239 5433 : case EXEC_OMP_PARALLEL_DO_SIMD:
14240 5433 : case EXEC_OMP_PARALLEL_LOOP:
14241 5433 : case EXEC_OMP_PARALLEL_MASKED_TASKLOOP:
14242 5433 : case EXEC_OMP_PARALLEL_MASKED_TASKLOOP_SIMD:
14243 5433 : case EXEC_OMP_PARALLEL_MASTER_TASKLOOP:
14244 5433 : case EXEC_OMP_PARALLEL_MASTER_TASKLOOP_SIMD:
14245 5433 : case EXEC_OMP_MASKED_TASKLOOP:
14246 5433 : case EXEC_OMP_MASKED_TASKLOOP_SIMD:
14247 5433 : case EXEC_OMP_MASTER_TASKLOOP:
14248 5433 : case EXEC_OMP_MASTER_TASKLOOP_SIMD:
14249 5433 : case EXEC_OMP_SIMD:
14250 5433 : case EXEC_OMP_TARGET_PARALLEL_DO:
14251 5433 : case EXEC_OMP_TARGET_PARALLEL_DO_SIMD:
14252 5433 : case EXEC_OMP_TARGET_PARALLEL_LOOP:
14253 5433 : case EXEC_OMP_TARGET_SIMD:
14254 5433 : case EXEC_OMP_TARGET_TEAMS_DISTRIBUTE:
14255 5433 : case EXEC_OMP_TARGET_TEAMS_DISTRIBUTE_PARALLEL_DO:
14256 5433 : case EXEC_OMP_TARGET_TEAMS_DISTRIBUTE_PARALLEL_DO_SIMD:
14257 5433 : case EXEC_OMP_TARGET_TEAMS_DISTRIBUTE_SIMD:
14258 5433 : case EXEC_OMP_TARGET_TEAMS_LOOP:
14259 5433 : case EXEC_OMP_TASKLOOP:
14260 5433 : case EXEC_OMP_TASKLOOP_SIMD:
14261 5433 : case EXEC_OMP_TEAMS_DISTRIBUTE:
14262 5433 : case EXEC_OMP_TEAMS_DISTRIBUTE_PARALLEL_DO:
14263 5433 : case EXEC_OMP_TEAMS_DISTRIBUTE_PARALLEL_DO_SIMD:
14264 5433 : case EXEC_OMP_TEAMS_DISTRIBUTE_SIMD:
14265 5433 : case EXEC_OMP_TEAMS_LOOP:
14266 5433 : case EXEC_OMP_TILE:
14267 5433 : case EXEC_OMP_UNROLL:
14268 5433 : resolve_omp_do (code);
14269 5433 : break;
14270 2185 : case EXEC_OMP_TARGET:
14271 2185 : resolve_omp_target (code);
14272 10286 : gcc_fallthrough ();
14273 10286 : case EXEC_OMP_ALLOCATE:
14274 10286 : case EXEC_OMP_ALLOCATORS:
14275 10286 : case EXEC_OMP_ASSUME:
14276 10286 : case EXEC_OMP_CANCEL:
14277 10286 : case EXEC_OMP_ERROR:
14278 10286 : case EXEC_OMP_INTEROP:
14279 10286 : case EXEC_OMP_MASKED:
14280 10286 : case EXEC_OMP_ORDERED:
14281 10286 : case EXEC_OMP_PARALLEL_WORKSHARE:
14282 10286 : case EXEC_OMP_PARALLEL:
14283 10286 : case EXEC_OMP_PARALLEL_MASKED:
14284 10286 : case EXEC_OMP_PARALLEL_MASTER:
14285 10286 : case EXEC_OMP_PARALLEL_SECTIONS:
14286 10286 : case EXEC_OMP_SCOPE:
14287 10286 : case EXEC_OMP_SECTIONS:
14288 10286 : case EXEC_OMP_SINGLE:
14289 10286 : case EXEC_OMP_TARGET_DATA:
14290 10286 : case EXEC_OMP_TARGET_ENTER_DATA:
14291 10286 : case EXEC_OMP_TARGET_EXIT_DATA:
14292 10286 : case EXEC_OMP_TARGET_PARALLEL:
14293 10286 : case EXEC_OMP_TARGET_TEAMS:
14294 10286 : case EXEC_OMP_TASK:
14295 10286 : case EXEC_OMP_TASKWAIT:
14296 10286 : case EXEC_OMP_TEAMS:
14297 10286 : case EXEC_OMP_WORKSHARE:
14298 10286 : case EXEC_OMP_DEPOBJ:
14299 10286 : if (code->ext.omp_clauses)
14300 10153 : resolve_omp_clauses (code, code->ext.omp_clauses, NULL);
14301 : break;
14302 1720 : case EXEC_OMP_TARGET_UPDATE:
14303 1720 : if (code->ext.omp_clauses)
14304 1720 : resolve_omp_clauses (code, code->ext.omp_clauses, NULL);
14305 1720 : if (code->ext.omp_clauses == NULL
14306 1720 : || (code->ext.omp_clauses->lists[OMP_LIST_TO] == NULL
14307 996 : && code->ext.omp_clauses->lists[OMP_LIST_FROM] == NULL))
14308 0 : gfc_error ("OMP TARGET UPDATE at %L requires at least one TO or "
14309 : "FROM clause", &code->loc);
14310 : break;
14311 2154 : case EXEC_OMP_ATOMIC:
14312 2154 : resolve_omp_clauses (code, code->block->ext.omp_clauses, NULL);
14313 2154 : resolve_omp_atomic (code);
14314 2154 : break;
14315 160 : case EXEC_OMP_CRITICAL:
14316 160 : resolve_omp_clauses (code, code->ext.omp_clauses, NULL);
14317 160 : if (!code->ext.omp_clauses->critical_name
14318 112 : && code->ext.omp_clauses->hint
14319 3 : && code->ext.omp_clauses->hint->ts.type == BT_INTEGER
14320 3 : && code->ext.omp_clauses->hint->expr_type == EXPR_CONSTANT
14321 3 : && mpz_sgn (code->ext.omp_clauses->hint->value.integer) != 0)
14322 1 : gfc_error ("OMP CRITICAL at %L with HINT clause requires a NAME, "
14323 : "except when omp_sync_hint_none is used", &code->loc);
14324 : break;
14325 49 : case EXEC_OMP_SCAN:
14326 : /* Flag is only used to checking, hence, it is unset afterwards. */
14327 49 : if (!code->ext.omp_clauses->if_present)
14328 10 : gfc_error ("Unexpected !$OMP SCAN at %L outside loop construct with "
14329 : "%<inscan%> REDUCTION clause", &code->loc);
14330 49 : code->ext.omp_clauses->if_present = false;
14331 49 : resolve_omp_clauses (code, code->ext.omp_clauses, ns);
14332 49 : break;
14333 154 : case EXEC_OMP_DISPATCH:
14334 154 : if (code->ext.omp_clauses)
14335 154 : resolve_omp_clauses (code, code->ext.omp_clauses, ns);
14336 154 : resolve_omp_dispatch (code);
14337 154 : break;
14338 138 : case EXEC_OMP_METADIRECTIVE:
14339 138 : resolve_omp_metadirective (code, ns);
14340 138 : break;
14341 : default:
14342 : break;
14343 : }
14344 21264 : }
14345 :
14346 : /* Resolve !$omp declare {variant|simd} constructs in NS.
14347 : Note that !$omp declare target is resolved in resolve_symbol. */
14348 :
14349 : void
14350 362366 : gfc_resolve_omp_declare (gfc_namespace *ns)
14351 : {
14352 362366 : gfc_omp_declare_simd *ods;
14353 362603 : for (ods = ns->omp_declare_simd; ods; ods = ods->next)
14354 : {
14355 237 : if (ods->proc_name != NULL
14356 197 : && ods->proc_name != ns->proc_name)
14357 6 : gfc_error ("!$OMP DECLARE SIMD should refer to containing procedure "
14358 : "%qs at %L", ns->proc_name->name, &ods->where);
14359 237 : if (ods->clauses)
14360 219 : resolve_omp_clauses (NULL, ods->clauses, ns);
14361 : }
14362 :
14363 362366 : gfc_omp_declare_variant *odv;
14364 362366 : gfc_omp_namelist *range_begin = NULL;
14365 :
14366 362821 : for (odv = ns->omp_declare_variant; odv; odv = odv->next)
14367 455 : gfc_resolve_omp_context_selector (odv->set_selectors, false, nullptr);
14368 362821 : for (odv = ns->omp_declare_variant; odv; odv = odv->next)
14369 658 : for (gfc_omp_namelist *n = odv->adjust_args_list; n != NULL; n = n->next)
14370 : {
14371 203 : if ((n->expr == NULL
14372 6 : && (range_begin
14373 4 : || n->u.adj_args.range_start
14374 1 : || n->u.adj_args.omp_num_args_plus
14375 1 : || n->u.adj_args.omp_num_args_minus))
14376 198 : || n->u.adj_args.error_p)
14377 : {
14378 : }
14379 197 : else if (range_begin
14380 191 : || n->u.adj_args.range_start
14381 186 : || n->u.adj_args.omp_num_args_plus
14382 186 : || n->u.adj_args.omp_num_args_minus)
14383 : {
14384 11 : if (!n->expr
14385 11 : || !gfc_resolve_expr (n->expr)
14386 11 : || n->expr->expr_type != EXPR_CONSTANT
14387 10 : || n->expr->ts.type != BT_INTEGER
14388 10 : || n->expr->rank != 0
14389 10 : || mpz_sgn (n->expr->value.integer) < 0
14390 20 : || ((n->u.adj_args.omp_num_args_plus
14391 8 : || n->u.adj_args.omp_num_args_minus)
14392 5 : && mpz_sgn (n->expr->value.integer) == 0))
14393 : {
14394 2 : if (n->u.adj_args.omp_num_args_plus
14395 2 : || n->u.adj_args.omp_num_args_minus)
14396 0 : gfc_error ("Expected constant non-negative scalar integer "
14397 : "offset expression at %L", &n->where);
14398 : else
14399 2 : gfc_error ("For range-based %<adjust_args%>, a constant "
14400 : "positive scalar integer expression is required "
14401 : "at %L", &n->where);
14402 : }
14403 : }
14404 186 : else if (n->expr
14405 186 : && n->expr->expr_type == EXPR_CONSTANT
14406 21 : && n->expr->ts.type == BT_INTEGER
14407 20 : && mpz_sgn (n->expr->value.integer) > 0)
14408 : {
14409 : }
14410 166 : else if (!n->expr
14411 166 : || !gfc_resolve_expr (n->expr)
14412 331 : || n->expr->expr_type != EXPR_VARIABLE)
14413 2 : gfc_error ("Expected dummy parameter name or a positive integer "
14414 : "at %L", &n->where);
14415 164 : else if (n->expr->expr_type == EXPR_VARIABLE)
14416 164 : n->sym = n->expr->symtree->n.sym;
14417 :
14418 203 : range_begin = n->u.adj_args.range_start ? n : NULL;
14419 : }
14420 362366 : }
14421 :
14422 : struct omp_udr_callback_data
14423 : {
14424 : gfc_omp_udr *omp_udr;
14425 : bool is_initializer;
14426 : };
14427 :
14428 : static int
14429 3710 : omp_udr_callback (gfc_expr **e, int *walk_subtrees ATTRIBUTE_UNUSED,
14430 : void *data)
14431 : {
14432 3710 : struct omp_udr_callback_data *cd = (struct omp_udr_callback_data *) data;
14433 3710 : if ((*e)->expr_type == EXPR_VARIABLE)
14434 : {
14435 2279 : if (cd->is_initializer)
14436 : {
14437 539 : if ((*e)->symtree->n.sym != cd->omp_udr->omp_priv
14438 140 : && (*e)->symtree->n.sym != cd->omp_udr->omp_orig)
14439 4 : gfc_error ("Variable other than OMP_PRIV or OMP_ORIG used in "
14440 : "INITIALIZER clause of !$OMP DECLARE REDUCTION at %L",
14441 : &(*e)->where);
14442 : }
14443 : else
14444 : {
14445 1740 : if ((*e)->symtree->n.sym != cd->omp_udr->omp_out
14446 620 : && (*e)->symtree->n.sym != cd->omp_udr->omp_in)
14447 6 : gfc_error ("Variable other than OMP_OUT or OMP_IN used in "
14448 : "combiner of !$OMP DECLARE REDUCTION at %L",
14449 : &(*e)->where);
14450 : }
14451 : }
14452 3710 : return 0;
14453 : }
14454 :
14455 : /* Resolve !$omp declare reduction constructs. */
14456 :
14457 : static void
14458 627 : gfc_resolve_omp_udr (gfc_omp_udr *omp_udr)
14459 : {
14460 627 : gfc_actual_arglist *a;
14461 627 : const char *predef_name = NULL;
14462 :
14463 627 : switch (omp_udr->rop)
14464 : {
14465 626 : case OMP_REDUCTION_PLUS:
14466 626 : case OMP_REDUCTION_TIMES:
14467 626 : case OMP_REDUCTION_MINUS:
14468 626 : case OMP_REDUCTION_AND:
14469 626 : case OMP_REDUCTION_OR:
14470 626 : case OMP_REDUCTION_EQV:
14471 626 : case OMP_REDUCTION_NEQV:
14472 626 : case OMP_REDUCTION_MAX:
14473 626 : case OMP_REDUCTION_USER:
14474 626 : break;
14475 1 : default:
14476 1 : gfc_error ("Invalid operator for !$OMP DECLARE REDUCTION %s at %L",
14477 : omp_udr->name, &omp_udr->where);
14478 26 : return;
14479 : }
14480 :
14481 626 : if (gfc_omp_udr_predef (omp_udr->rop, omp_udr->name,
14482 : &omp_udr->ts, &predef_name))
14483 : {
14484 19 : if (predef_name)
14485 19 : gfc_error ("Redefinition of predefined %qs in "
14486 : "!$OMP DECLARE REDUCTION at %L",
14487 : predef_name, &omp_udr->where);
14488 : else
14489 0 : gfc_error ("Redefinition of predefined %qs in "
14490 : "!$OMP DECLARE REDUCTION at %L", omp_udr->name,
14491 : &omp_udr->where);
14492 : return;
14493 : }
14494 :
14495 607 : if (omp_udr->ts.type == BT_CHARACTER
14496 62 : && omp_udr->ts.u.cl->length
14497 32 : && omp_udr->ts.u.cl->length->expr_type != EXPR_CONSTANT)
14498 : {
14499 1 : gfc_error ("CHARACTER length in !$OMP DECLARE REDUCTION %qs not "
14500 : "constant at %L", omp_udr->name, &omp_udr->where);
14501 1 : return;
14502 : }
14503 :
14504 606 : struct omp_udr_callback_data cd;
14505 606 : cd.omp_udr = omp_udr;
14506 606 : cd.is_initializer = false;
14507 606 : gfc_code_walker (&omp_udr->combiner_ns->code, gfc_dummy_code_callback,
14508 : omp_udr_callback, &cd);
14509 606 : if (omp_udr->combiner_ns->code->op == EXEC_CALL)
14510 : {
14511 346 : for (a = omp_udr->combiner_ns->code->ext.actual; a; a = a->next)
14512 237 : if (a->expr == NULL)
14513 : break;
14514 110 : if (a)
14515 1 : gfc_error ("Subroutine call with alternate returns in combiner "
14516 : "of !$OMP DECLARE REDUCTION at %L",
14517 : &omp_udr->combiner_ns->code->loc);
14518 : }
14519 606 : if (omp_udr->initializer_ns)
14520 : {
14521 377 : cd.is_initializer = true;
14522 377 : gfc_code_walker (&omp_udr->initializer_ns->code, gfc_dummy_code_callback,
14523 : omp_udr_callback, &cd);
14524 377 : if (omp_udr->initializer_ns->code->op == EXEC_CALL)
14525 : {
14526 377 : for (a = omp_udr->initializer_ns->code->ext.actual; a; a = a->next)
14527 243 : if (a->expr == NULL)
14528 : break;
14529 135 : if (a)
14530 1 : gfc_error ("Subroutine call with alternate returns in "
14531 : "INITIALIZER clause of !$OMP DECLARE REDUCTION "
14532 : "at %L", &omp_udr->initializer_ns->code->loc);
14533 136 : for (a = omp_udr->initializer_ns->code->ext.actual; a; a = a->next)
14534 135 : if (a->expr
14535 135 : && a->expr->expr_type == EXPR_VARIABLE
14536 135 : && a->expr->symtree->n.sym == omp_udr->omp_priv
14537 134 : && a->expr->ref == NULL)
14538 : break;
14539 135 : if (a == NULL)
14540 1 : gfc_error ("One of actual subroutine arguments in INITIALIZER "
14541 : "clause of !$OMP DECLARE REDUCTION must be OMP_PRIV "
14542 : "at %L", &omp_udr->initializer_ns->code->loc);
14543 : }
14544 : }
14545 229 : else if (omp_udr->ts.type == BT_DERIVED
14546 229 : && !gfc_has_default_initializer (omp_udr->ts.u.derived))
14547 : {
14548 4 : gfc_error ("Missing INITIALIZER clause for !$OMP DECLARE REDUCTION "
14549 : "of derived type without default initializer at %L",
14550 : &omp_udr->where);
14551 4 : return;
14552 : }
14553 : }
14554 :
14555 : void
14556 363422 : gfc_resolve_omp_udrs (gfc_symtree *st)
14557 : {
14558 363422 : gfc_omp_udr *omp_udr;
14559 :
14560 363422 : if (st == NULL)
14561 : return;
14562 528 : gfc_resolve_omp_udrs (st->left);
14563 528 : gfc_resolve_omp_udrs (st->right);
14564 1155 : for (omp_udr = st->n.omp_udr; omp_udr; omp_udr = omp_udr->next)
14565 627 : gfc_resolve_omp_udr (omp_udr);
14566 : }
14567 :
14568 : /* Resolve !$omp declare mapper constructs. */
14569 :
14570 : static void
14571 24 : gfc_resolve_omp_udm (gfc_omp_udm *omp_udm)
14572 : {
14573 24 : resolve_omp_clauses (NULL, omp_udm->clauses, omp_udm->mapper_ns);
14574 :
14575 24 : gfc_omp_namelist *n;
14576 26 : for (n = omp_udm->clauses->lists[OMP_LIST_MAP]; n; n = n->next)
14577 24 : if (n->sym == omp_udm->var_sym)
14578 : break;
14579 24 : if (!n)
14580 2 : gfc_error ("At least one %<map%> clause in !$OMP DECLARE MAPPER at %L must "
14581 : "map %qs or an element of it",
14582 2 : &omp_udm->where, omp_udm->var_sym->name);
14583 24 : }
14584 :
14585 : void
14586 362412 : gfc_resolve_omp_udms (gfc_symtree *st)
14587 : {
14588 362412 : gfc_omp_udm *omp_udm;
14589 :
14590 362412 : if (st == NULL)
14591 : return;
14592 23 : gfc_resolve_omp_udms (st->left);
14593 23 : gfc_resolve_omp_udms (st->right);
14594 47 : for (omp_udm = st->n.omp_udm; omp_udm; omp_udm = omp_udm->next)
14595 24 : gfc_resolve_omp_udm (omp_udm);
14596 : }
|
