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 56346 : gfc_match_omp_eos (void)
146 : {
147 56346 : locus old_loc;
148 56346 : char c;
149 :
150 56346 : old_loc = gfc_current_locus;
151 56346 : gfc_gobble_whitespace ();
152 :
153 56346 : if (gfc_matching_omp_context_selector)
154 : {
155 287 : if (gfc_peek_ascii_char () == ')')
156 : return MATCH_YES;
157 : }
158 : else
159 : {
160 56059 : c = gfc_next_ascii_char ();
161 56059 : 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 1795 : gfc_current_locus = old_loc;
175 1795 : return MATCH_NO;
176 : }
177 :
178 : match
179 13228 : gfc_match_omp_eos_error (void)
180 : {
181 13228 : 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 83867 : gfc_free_omp_clauses (gfc_omp_clauses *c)
193 : {
194 83867 : if (c == NULL)
195 : return;
196 :
197 56828 : gfc_free_expr (c->if_expr);
198 681936 : for (int i = 0; i < OMP_IF_LAST; i++)
199 568280 : gfc_free_expr (c->if_exprs[i]);
200 56828 : gfc_free_expr (c->self_expr);
201 56828 : gfc_free_expr (c->final_expr);
202 56828 : gfc_free_expr (c->chunk_size);
203 56828 : gfc_free_expr (c->safelen_expr);
204 56828 : gfc_free_expr (c->simdlen_expr);
205 56828 : gfc_free_expr (c->simdlen_divisor);
206 56828 : gfc_free_expr (c->device);
207 56828 : gfc_free_expr (c->dyn_groupprivate);
208 56828 : gfc_free_expr (c->dist_chunk_size);
209 56828 : gfc_free_expr (c->grainsize);
210 56828 : gfc_free_expr (c->hint);
211 56828 : gfc_free_expr (c->num_tasks);
212 56828 : gfc_free_expr (c->priority);
213 56828 : gfc_free_expr (c->detach);
214 56828 : gfc_free_expr (c->novariants);
215 56828 : gfc_free_expr (c->nocontext);
216 56828 : gfc_free_expr (c->async_expr);
217 56828 : gfc_free_expr (c->gang_num_expr);
218 56828 : gfc_free_expr (c->gang_static_expr);
219 56828 : gfc_free_expr (c->worker_expr);
220 56828 : gfc_free_expr (c->vector_expr);
221 56828 : gfc_free_expr (c->num_gangs_expr);
222 56828 : gfc_free_expr (c->num_workers_expr);
223 56828 : gfc_free_expr (c->vector_length_expr);
224 56828 : gfc_free_expr (c->device_num_expr);
225 2329948 : for (enum gfc_omp_list_type t = OMP_LIST_FIRST; t < OMP_LIST_NUM;
226 2216292 : t = gfc_omp_list_type (t + 1))
227 2216292 : gfc_free_omp_namelist (c->lists[t], t);
228 56828 : gfc_free_expr_list (c->num_teams_list);
229 56828 : gfc_free_expr_list (c->thread_limit_list);
230 56828 : gfc_free_expr_list (c->num_threads_list);
231 56828 : gfc_free_expr_list (c->wait_list);
232 56828 : gfc_free_expr_list (c->tile_list);
233 56828 : gfc_free_expr_list (c->sizes_list);
234 56828 : free (const_cast<char *> (c->critical_name));
235 56828 : if (c->assume)
236 : {
237 33 : free (c->assume->absent);
238 33 : free (c->assume->contains);
239 33 : gfc_free_expr_list (c->assume->holds);
240 33 : free (c->assume);
241 : }
242 56828 : free (c);
243 : }
244 :
245 : /* Free oacc_declare structures. */
246 :
247 : void
248 76 : gfc_free_oacc_declare_clauses (struct gfc_oacc_declare *oc)
249 : {
250 76 : struct gfc_oacc_declare *decl = oc;
251 :
252 76 : do
253 : {
254 76 : struct gfc_oacc_declare *next;
255 :
256 76 : next = decl->next;
257 76 : gfc_free_omp_clauses (decl->clauses);
258 76 : free (decl);
259 76 : decl = next;
260 : }
261 76 : while (decl);
262 76 : }
263 :
264 : /* Free expression list. */
265 : void
266 342511 : gfc_free_expr_list (gfc_expr_list *list)
267 : {
268 342511 : gfc_expr_list *n;
269 :
270 345453 : for (; list; list = n)
271 : {
272 2942 : n = list->next;
273 2942 : free (list);
274 : }
275 342511 : }
276 :
277 : /* Free an !$omp declare simd construct list. */
278 :
279 : void
280 252 : gfc_free_omp_declare_simd (gfc_omp_declare_simd *ods)
281 : {
282 252 : if (ods)
283 : {
284 252 : gfc_free_omp_clauses (ods->clauses);
285 252 : free (ods);
286 : }
287 252 : }
288 :
289 : void
290 550659 : gfc_free_omp_declare_simd_list (gfc_omp_declare_simd *list)
291 : {
292 550911 : while (list)
293 : {
294 252 : gfc_omp_declare_simd *current = list;
295 252 : list = list->next;
296 252 : gfc_free_omp_declare_simd (current);
297 : }
298 550659 : }
299 :
300 : static void
301 762 : gfc_free_omp_trait_property_list (gfc_omp_trait_property *list)
302 : {
303 1194 : while (list)
304 : {
305 432 : gfc_omp_trait_property *current = list;
306 432 : list = list->next;
307 432 : switch (current->property_kind)
308 : {
309 24 : case OMP_TRAIT_PROPERTY_ID:
310 24 : free (current->name);
311 24 : break;
312 265 : case OMP_TRAIT_PROPERTY_NAME_LIST:
313 265 : if (current->is_name)
314 170 : free (current->name);
315 : break;
316 31 : case OMP_TRAIT_PROPERTY_CLAUSE_LIST:
317 31 : gfc_free_omp_clauses (current->clauses);
318 31 : break;
319 : default:
320 : break;
321 : }
322 432 : free (current);
323 : }
324 762 : }
325 :
326 : static void
327 629 : gfc_free_omp_selector_list (gfc_omp_selector *list)
328 : {
329 1391 : while (list)
330 : {
331 762 : gfc_omp_selector *current = list;
332 762 : list = list->next;
333 762 : gfc_free_omp_trait_property_list (current->properties);
334 762 : free (current);
335 : }
336 629 : }
337 :
338 : static void
339 700 : gfc_free_omp_set_selector_list (gfc_omp_set_selector *list)
340 : {
341 1329 : while (list)
342 : {
343 629 : gfc_omp_set_selector *current = list;
344 629 : list = list->next;
345 629 : gfc_free_omp_selector_list (current->trait_selectors);
346 629 : free (current);
347 : }
348 700 : }
349 :
350 : /* Free an !$omp declare variant construct list. */
351 :
352 : void
353 550659 : gfc_free_omp_declare_variant_list (gfc_omp_declare_variant *list)
354 : {
355 551136 : while (list)
356 : {
357 477 : gfc_omp_declare_variant *current = list;
358 477 : list = list->next;
359 477 : gfc_free_omp_set_selector_list (current->set_selectors);
360 477 : gfc_free_omp_namelist (current->adjust_args_list, OMP_LIST_NONE);
361 477 : free (current);
362 : }
363 550659 : }
364 :
365 : /* Free an !$omp declare reduction. */
366 :
367 : void
368 1285 : gfc_free_omp_udr (gfc_omp_udr *omp_udr)
369 : {
370 1285 : if (omp_udr)
371 : {
372 692 : gfc_free_omp_udr (omp_udr->next);
373 692 : gfc_free_namespace (omp_udr->combiner_ns);
374 692 : if (omp_udr->initializer_ns)
375 392 : gfc_free_namespace (omp_udr->initializer_ns);
376 692 : free (omp_udr);
377 : }
378 1285 : }
379 :
380 : /* Free variants of an !$omp metadirective construct. */
381 :
382 : void
383 97 : gfc_free_omp_variants (gfc_omp_variant *variant)
384 : {
385 297 : while (variant)
386 : {
387 200 : gfc_omp_variant *next_variant = variant->next;
388 200 : gfc_free_omp_set_selector_list (variant->selectors);
389 200 : free (variant);
390 200 : variant = next_variant;
391 : }
392 97 : }
393 :
394 : /* Free an !$omp declare mapper. */
395 :
396 : void
397 60 : gfc_free_omp_udm (gfc_omp_udm *omp_udm)
398 : {
399 60 : if (omp_udm)
400 : {
401 30 : gfc_free_omp_udm (omp_udm->next);
402 30 : gfc_free_namespace (omp_udm->mapper_ns);
403 30 : free (omp_udm);
404 : }
405 60 : }
406 :
407 : static gfc_omp_udr *
408 4719 : gfc_find_omp_udr (gfc_namespace *ns, const char *name, gfc_typespec *ts)
409 : {
410 4719 : gfc_symtree *st;
411 :
412 4719 : if (ns == NULL)
413 471 : ns = gfc_current_ns;
414 5675 : do
415 : {
416 5675 : gfc_omp_udr *omp_udr;
417 :
418 5675 : st = gfc_find_symtree (ns->omp_udr_root, name);
419 5675 : if (st != NULL)
420 : {
421 943 : for (omp_udr = st->n.omp_udr; omp_udr; omp_udr = omp_udr->next)
422 943 : if (ts == NULL)
423 : return omp_udr;
424 572 : else if (gfc_compare_types (&omp_udr->ts, ts))
425 : {
426 483 : if (ts->type == BT_CHARACTER)
427 : {
428 60 : if (omp_udr->ts.u.cl->length == NULL)
429 : return omp_udr;
430 36 : if (ts->u.cl->length == NULL)
431 0 : continue;
432 36 : if (gfc_compare_expr (omp_udr->ts.u.cl->length,
433 : ts->u.cl->length,
434 : INTRINSIC_EQ) != 0)
435 12 : continue;
436 : }
437 : return omp_udr;
438 : }
439 : }
440 :
441 : /* Don't escape an interface block. */
442 4833 : if (ns && !ns->has_import_set
443 4833 : && ns->proc_name && ns->proc_name->attr.if_source == IFSRC_IFBODY)
444 : break;
445 :
446 4833 : ns = ns->parent;
447 : }
448 4833 : while (ns != NULL);
449 :
450 : return NULL;
451 : }
452 :
453 :
454 : /* Match a variable/common block list and construct a namelist from it;
455 : if has_all_memory != NULL, *has_all_memory is set and omp_all_memory
456 : yields a list->sym NULL entry. */
457 :
458 : static match
459 31851 : gfc_match_omp_variable_list (const char *str, gfc_omp_namelist **list,
460 : bool allow_common, bool *end_colon = NULL,
461 : gfc_omp_namelist ***headp = NULL,
462 : bool allow_sections = false,
463 : bool allow_derived = false,
464 : bool *has_all_memory = NULL,
465 : bool reject_common_vars = false,
466 : bool reverse_order = false)
467 : {
468 31851 : gfc_omp_namelist *head, *tail, *p;
469 31851 : locus old_loc, cur_loc;
470 31851 : char n[GFC_MAX_SYMBOL_LEN+1];
471 31851 : gfc_symbol *sym;
472 31851 : match m;
473 31851 : gfc_symtree *st;
474 :
475 31851 : head = tail = NULL;
476 :
477 31851 : old_loc = gfc_current_locus;
478 31851 : if (has_all_memory)
479 709 : *has_all_memory = false;
480 31851 : m = gfc_match (str);
481 31851 : if (m != MATCH_YES)
482 : return m;
483 :
484 38532 : for (;;)
485 : {
486 38532 : gfc_gobble_whitespace ();
487 38532 : cur_loc = gfc_current_locus;
488 :
489 38532 : m = gfc_match_name (n);
490 38532 : if (m == MATCH_YES && strcmp (n, "omp_all_memory") == 0)
491 : {
492 23 : locus loc = gfc_get_location_range (NULL, 0, &cur_loc, 1,
493 : &gfc_current_locus);
494 23 : if (!has_all_memory)
495 : {
496 2 : gfc_error ("%<omp_all_memory%> at %L not permitted in this "
497 : "clause", &loc);
498 2 : goto cleanup;
499 : }
500 21 : *has_all_memory = true;
501 21 : p = gfc_get_omp_namelist ();
502 21 : if (head == NULL)
503 : head = tail = p;
504 : else
505 : {
506 3 : tail->next = p;
507 3 : tail = tail->next;
508 : }
509 21 : tail->where = loc;
510 21 : goto next_item;
511 : }
512 38253 : if (m == MATCH_YES)
513 : {
514 38253 : gfc_symtree *st;
515 38253 : if ((m = gfc_get_ha_sym_tree (n, &st) ? MATCH_ERROR : MATCH_YES)
516 : == MATCH_YES)
517 38253 : sym = st->n.sym;
518 : }
519 38509 : switch (m)
520 : {
521 38253 : case MATCH_YES:
522 38253 : gfc_expr *expr;
523 38253 : expr = NULL;
524 38253 : gfc_gobble_whitespace ();
525 23548 : if ((allow_sections && gfc_peek_ascii_char () == '(')
526 57439 : || (allow_derived && gfc_peek_ascii_char () == '%'))
527 : {
528 6609 : gfc_current_locus = cur_loc;
529 6609 : m = gfc_match_variable (&expr, 0);
530 6609 : switch (m)
531 : {
532 4 : case MATCH_ERROR:
533 12 : goto cleanup;
534 0 : case MATCH_NO:
535 0 : goto syntax;
536 6605 : default:
537 6605 : break;
538 : }
539 6605 : if (gfc_is_coindexed (expr))
540 : {
541 5 : gfc_error ("List item shall not be coindexed at %L",
542 5 : &expr->where);
543 5 : goto cleanup;
544 : }
545 : }
546 38244 : gfc_set_sym_referenced (sym);
547 38244 : p = gfc_get_omp_namelist ();
548 38244 : if (head == NULL)
549 : head = tail = p;
550 10161 : else if (reverse_order)
551 : {
552 57 : p->next = head;
553 57 : head = p;
554 : }
555 : else
556 : {
557 10104 : tail->next = p;
558 10104 : tail = tail->next;
559 : }
560 38244 : p->sym = sym;
561 38244 : p->expr = expr;
562 38244 : p->where = gfc_get_location_range (NULL, 0, &cur_loc, 1,
563 : &gfc_current_locus);
564 38244 : if (reject_common_vars && sym->attr.in_common)
565 : {
566 3 : gcc_assert (allow_common);
567 3 : gfc_error ("%qs at %L is part of the common block %</%s/%> and "
568 : "may only be specified implicitly via the named "
569 : "common block", sym->name, &cur_loc,
570 3 : sym->common_head->name);
571 3 : goto cleanup;
572 : }
573 38241 : goto next_item;
574 256 : case MATCH_NO:
575 256 : break;
576 0 : case MATCH_ERROR:
577 0 : goto cleanup;
578 : }
579 :
580 256 : if (!allow_common)
581 12 : goto syntax;
582 :
583 244 : m = gfc_match ("/ %n /", n);
584 244 : if (m == MATCH_ERROR)
585 0 : goto cleanup;
586 244 : if (m == MATCH_NO)
587 19 : goto syntax;
588 :
589 225 : cur_loc = gfc_get_location_range (NULL, 0, &cur_loc, 1,
590 : &gfc_current_locus);
591 225 : st = gfc_find_symtree (gfc_current_ns->common_root, n);
592 225 : if (st == NULL)
593 : {
594 2 : gfc_error ("COMMON block %</%s/%> not found at %L", n, &cur_loc);
595 2 : goto cleanup;
596 : }
597 724 : for (sym = st->n.common->head; sym; sym = sym->common_next)
598 : {
599 501 : gfc_set_sym_referenced (sym);
600 501 : p = gfc_get_omp_namelist ();
601 501 : if (head == NULL)
602 : head = tail = p;
603 325 : else if (reverse_order)
604 : {
605 0 : p->next = head;
606 0 : head = p;
607 : }
608 : else
609 : {
610 325 : tail->next = p;
611 325 : tail = tail->next;
612 : }
613 501 : p->sym = sym;
614 501 : p->where = cur_loc;
615 : }
616 :
617 223 : next_item:
618 38485 : if (end_colon && gfc_match_char (':') == MATCH_YES)
619 : {
620 806 : *end_colon = true;
621 806 : break;
622 : }
623 37679 : if (gfc_match_char (')') == MATCH_YES)
624 : break;
625 10232 : if (gfc_match_char (',') != MATCH_YES)
626 21 : goto syntax;
627 : }
628 :
629 38297 : while (*list)
630 10044 : list = &(*list)->next;
631 :
632 28253 : *list = head;
633 28253 : if (headp)
634 22352 : *headp = list;
635 : return MATCH_YES;
636 :
637 52 : syntax:
638 52 : gfc_error ("Syntax error in OpenMP variable list at %C");
639 :
640 68 : cleanup:
641 68 : gfc_free_omp_namelist (head, OMP_LIST_NONE);
642 68 : gfc_current_locus = old_loc;
643 68 : return MATCH_ERROR;
644 : }
645 :
646 : /* Match a variable/procedure/common block list and construct a namelist
647 : from it. */
648 :
649 : static match
650 392 : gfc_match_omp_to_link (const char *str, gfc_omp_namelist **list)
651 : {
652 392 : gfc_omp_namelist *head, *tail, *p;
653 392 : locus old_loc, cur_loc;
654 392 : char n[GFC_MAX_SYMBOL_LEN+1];
655 392 : gfc_symbol *sym;
656 392 : match m;
657 392 : gfc_symtree *st;
658 :
659 392 : head = tail = NULL;
660 :
661 392 : old_loc = gfc_current_locus;
662 :
663 392 : m = gfc_match (str);
664 392 : if (m != MATCH_YES)
665 : return m;
666 :
667 569 : for (;;)
668 : {
669 569 : cur_loc = gfc_current_locus;
670 569 : m = gfc_match_symbol (&sym, 1);
671 569 : switch (m)
672 : {
673 527 : case MATCH_YES:
674 527 : p = gfc_get_omp_namelist ();
675 527 : if (head == NULL)
676 : head = tail = p;
677 : else
678 : {
679 194 : tail->next = p;
680 194 : tail = tail->next;
681 : }
682 527 : tail->sym = sym;
683 527 : tail->where = cur_loc;
684 527 : goto next_item;
685 : case MATCH_NO:
686 : break;
687 0 : case MATCH_ERROR:
688 0 : goto cleanup;
689 : }
690 :
691 42 : m = gfc_match (" / %n /", n);
692 42 : if (m == MATCH_ERROR)
693 0 : goto cleanup;
694 42 : if (m == MATCH_NO)
695 0 : goto syntax;
696 :
697 42 : st = gfc_find_symtree (gfc_current_ns->common_root, n);
698 42 : if (st == NULL)
699 : {
700 0 : gfc_error ("COMMON block /%s/ not found at %C", n);
701 0 : goto cleanup;
702 : }
703 42 : p = gfc_get_omp_namelist ();
704 42 : if (head == NULL)
705 : head = tail = p;
706 : else
707 : {
708 4 : tail->next = p;
709 4 : tail = tail->next;
710 : }
711 42 : tail->u.common = st->n.common;
712 42 : tail->where = cur_loc;
713 :
714 569 : next_item:
715 569 : if (gfc_match_char (')') == MATCH_YES)
716 : break;
717 198 : if (gfc_match_char (',') != MATCH_YES)
718 0 : goto syntax;
719 : }
720 :
721 383 : while (*list)
722 12 : list = &(*list)->next;
723 :
724 371 : *list = head;
725 371 : return MATCH_YES;
726 :
727 0 : syntax:
728 0 : gfc_error ("Syntax error in OpenMP variable list at %C");
729 :
730 0 : cleanup:
731 0 : gfc_free_omp_namelist (head, OMP_LIST_NONE);
732 0 : gfc_current_locus = old_loc;
733 0 : return MATCH_ERROR;
734 : }
735 :
736 : /* Match detach(event-handle). */
737 :
738 : static match
739 126 : gfc_match_omp_detach (gfc_expr **expr)
740 : {
741 126 : locus old_loc = gfc_current_locus;
742 :
743 126 : if (gfc_match ("detach ( ") != MATCH_YES)
744 0 : goto syntax_error;
745 :
746 126 : if (gfc_match_variable (expr, 0) != MATCH_YES)
747 0 : goto syntax_error;
748 :
749 126 : if (gfc_match_char (')') != MATCH_YES)
750 0 : goto syntax_error;
751 :
752 : return MATCH_YES;
753 :
754 0 : syntax_error:
755 0 : gfc_error ("Syntax error in OpenMP detach clause at %C");
756 0 : gfc_current_locus = old_loc;
757 0 : return MATCH_ERROR;
758 :
759 : }
760 :
761 : /* Match doacross(sink : ...) construct a namelist from it;
762 : if depend is true, match legacy 'depend(sink : ...)'. */
763 :
764 : static match
765 241 : gfc_match_omp_doacross_sink (gfc_omp_namelist **list, bool depend)
766 : {
767 241 : char n[GFC_MAX_SYMBOL_LEN+1];
768 241 : gfc_omp_namelist *head, *tail, *p;
769 241 : locus old_loc, cur_loc;
770 241 : gfc_symbol *sym;
771 :
772 241 : head = tail = NULL;
773 :
774 241 : old_loc = gfc_current_locus;
775 :
776 2231 : for (;;)
777 : {
778 1236 : gfc_gobble_whitespace ();
779 1236 : cur_loc = gfc_current_locus;
780 :
781 1236 : if (gfc_match_name (n) != MATCH_YES)
782 1 : goto syntax;
783 1235 : locus loc = gfc_get_location_range (NULL, 0, &cur_loc, 1,
784 : &gfc_current_locus);
785 1235 : if (UNLIKELY (strcmp (n, "omp_all_memory") == 0))
786 : {
787 1 : gfc_error ("%<omp_all_memory%> used with dependence-type "
788 : "other than OUT or INOUT at %L", &loc);
789 1 : goto cleanup;
790 : }
791 1234 : sym = NULL;
792 1234 : if (!(strcmp (n, "omp_cur_iteration") == 0))
793 : {
794 1229 : gfc_symtree *st;
795 1229 : if (gfc_get_ha_sym_tree (n, &st))
796 0 : goto syntax;
797 1229 : sym = st->n.sym;
798 1229 : gfc_set_sym_referenced (sym);
799 : }
800 1234 : p = gfc_get_omp_namelist ();
801 1234 : if (head == NULL)
802 : {
803 239 : head = tail = p;
804 253 : head->u.depend_doacross_op = (depend ? OMP_DEPEND_SINK_FIRST
805 : : OMP_DOACROSS_SINK_FIRST);
806 : }
807 : else
808 : {
809 995 : tail->next = p;
810 995 : tail = tail->next;
811 995 : tail->u.depend_doacross_op = OMP_DOACROSS_SINK;
812 : }
813 1234 : tail->sym = sym;
814 1234 : tail->expr = NULL;
815 1234 : tail->where = loc;
816 1234 : if (gfc_match_char ('+') == MATCH_YES)
817 : {
818 154 : if (gfc_match_literal_constant (&tail->expr, 0) != MATCH_YES)
819 0 : goto syntax;
820 : }
821 1080 : else if (gfc_match_char ('-') == MATCH_YES)
822 : {
823 418 : if (gfc_match_literal_constant (&tail->expr, 0) != MATCH_YES)
824 1 : goto syntax;
825 417 : tail->expr = gfc_uminus (tail->expr);
826 : }
827 1233 : if (gfc_match_char (')') == MATCH_YES)
828 : break;
829 995 : if (gfc_match_char (',') != MATCH_YES)
830 0 : goto syntax;
831 995 : }
832 :
833 1030 : while (*list)
834 792 : list = &(*list)->next;
835 :
836 238 : *list = head;
837 238 : return MATCH_YES;
838 :
839 2 : syntax:
840 2 : gfc_error ("Syntax error in OpenMP SINK dependence-type list at %C");
841 :
842 3 : cleanup:
843 3 : gfc_free_omp_namelist (head, OMP_LIST_DEPEND);
844 3 : gfc_current_locus = old_loc;
845 3 : return MATCH_ERROR;
846 : }
847 :
848 : static int
849 332 : match_oacc_device_type_kind (void)
850 : {
851 332 : char name[GFC_MAX_SYMBOL_LEN + 1];
852 :
853 : /* Since device_type arg accept * as all,
854 : we need to check first the case when
855 : the user inputs * as the parameter. */
856 332 : gfc_gobble_whitespace ();
857 332 : name[0] = (char) gfc_next_char ();
858 :
859 332 : if (name[0] == '*')
860 : return GOMP_DEVICE_NONE;
861 :
862 : /* If is not *, we try to match the
863 : pre-defined names. */
864 :
865 332 : match m = gfc_match (" %n ", name + 1);
866 :
867 332 : if (m != MATCH_YES)
868 : return -1;
869 :
870 332 : if (strcmp (name ,"host") == 0)
871 : return GOMP_DEVICE_HOST;
872 144 : if (strcmp (name, "nvidia") == 0)
873 : return GOMP_DEVICE_NVIDIA_PTX;
874 72 : if (strcmp (name, "radeon") == 0)
875 69 : return GOMP_DEVICE_GCN;
876 :
877 : return -1;
878 : }
879 :
880 : static match
881 332 : match_oacc_device_type (gfc_omp_clauses *c)
882 : {
883 332 : locus old_loc = gfc_current_locus;
884 :
885 332 : int result = match_oacc_device_type_kind ();
886 332 : match m;
887 :
888 332 : if (result == -1)
889 3 : goto syntax;
890 :
891 329 : m = gfc_match_char (')', true);
892 :
893 329 : if (m != MATCH_YES)
894 3 : goto single_argument;
895 :
896 326 : c->oacc_device_type = (unsigned) result;
897 326 : c->oacc_device_type_present = 1;
898 :
899 326 : return MATCH_YES;
900 :
901 3 : single_argument:
902 3 : gfc_error ("OpenACC %<DEVICE_TYPE%> clause only accepts one argument, "
903 : "unexpected char at %C");
904 3 : goto cleanup;
905 :
906 3 : syntax:
907 3 : gfc_error ("Syntax error in OpenACC %<DEVICE_TYPE%> argument at %C. Expected "
908 : "host, radeon, nvidia or * as argument.");
909 :
910 6 : cleanup:
911 6 : gfc_current_locus = old_loc;
912 6 : return MATCH_ERROR;
913 : }
914 :
915 : static match
916 1962 : match_omp_oacc_expr_list (const char *str, gfc_expr_list **list,
917 : bool allow_asterisk, bool is_omp)
918 : {
919 1962 : gfc_expr_list *head, *tail, *p;
920 1962 : locus old_loc;
921 1962 : gfc_expr *expr;
922 1962 : match m;
923 :
924 1962 : head = tail = NULL;
925 :
926 1962 : old_loc = gfc_current_locus;
927 :
928 1962 : if (str && (m = gfc_match (str)) != MATCH_YES)
929 : return m;
930 :
931 2239 : for (;;)
932 : {
933 2239 : m = gfc_match_expr (&expr);
934 2239 : if (m == MATCH_YES || allow_asterisk)
935 : {
936 2222 : p = gfc_get_expr_list ();
937 2222 : if (head == NULL)
938 : head = tail = p;
939 : else
940 : {
941 400 : tail->next = p;
942 400 : tail = tail->next;
943 : }
944 2222 : if (m == MATCH_YES)
945 2089 : tail->expr = expr;
946 133 : else if (gfc_match (" *") != MATCH_YES)
947 18 : goto syntax;
948 2204 : goto next_item;
949 : }
950 17 : if (m == MATCH_ERROR)
951 0 : goto cleanup;
952 17 : goto syntax;
953 :
954 2204 : next_item:
955 2204 : if (gfc_match_char (')') == MATCH_YES)
956 : break;
957 422 : if (gfc_match_char (',') != MATCH_YES)
958 17 : goto syntax;
959 : }
960 :
961 1788 : while (*list)
962 6 : list = &(*list)->next;
963 :
964 1782 : *list = head;
965 1782 : return MATCH_YES;
966 :
967 52 : syntax:
968 52 : if (is_omp)
969 23 : gfc_error ("Syntax error in OpenMP expression list at %C");
970 : else
971 29 : gfc_error ("Syntax error in OpenACC expression list at %C");
972 :
973 52 : cleanup:
974 52 : gfc_free_expr_list (head);
975 52 : gfc_current_locus = old_loc;
976 52 : return MATCH_ERROR;
977 : }
978 :
979 : static match
980 3056 : match_oacc_clause_gwv (gfc_omp_clauses *cp, unsigned gwv)
981 : {
982 3056 : match ret = MATCH_YES;
983 :
984 3056 : if (gfc_match (" ( ") != MATCH_YES)
985 : return MATCH_NO;
986 :
987 470 : if (gwv == GOMP_DIM_GANG)
988 : {
989 : /* The gang clause accepts two optional arguments, num and static.
990 : The num argument may either be explicit (num: <val>) or
991 : implicit without (<val> without num:). */
992 :
993 457 : while (ret == MATCH_YES)
994 : {
995 236 : if (gfc_match (" static :") == MATCH_YES)
996 : {
997 114 : if (cp->gang_static)
998 : return MATCH_ERROR;
999 : else
1000 113 : cp->gang_static = true;
1001 113 : if (gfc_match_char ('*') == MATCH_YES)
1002 18 : cp->gang_static_expr = NULL;
1003 95 : else if (gfc_match (" %e ", &cp->gang_static_expr) != MATCH_YES)
1004 : return MATCH_ERROR;
1005 : }
1006 : else
1007 : {
1008 122 : if (cp->gang_num_expr)
1009 : return MATCH_ERROR;
1010 :
1011 : /* The 'num' argument is optional. */
1012 121 : gfc_match (" num :");
1013 :
1014 121 : if (gfc_match (" %e ", &cp->gang_num_expr) != MATCH_YES)
1015 : return MATCH_ERROR;
1016 : }
1017 :
1018 231 : ret = gfc_match (" , ");
1019 : }
1020 : }
1021 244 : else if (gwv == GOMP_DIM_WORKER)
1022 : {
1023 : /* The 'num' argument is optional. */
1024 107 : gfc_match (" num :");
1025 :
1026 107 : if (gfc_match (" %e ", &cp->worker_expr) != MATCH_YES)
1027 : return MATCH_ERROR;
1028 : }
1029 137 : else if (gwv == GOMP_DIM_VECTOR)
1030 : {
1031 : /* The 'length' argument is optional. */
1032 137 : gfc_match (" length :");
1033 :
1034 137 : if (gfc_match (" %e ", &cp->vector_expr) != MATCH_YES)
1035 : return MATCH_ERROR;
1036 : }
1037 : else
1038 0 : gfc_fatal_error ("Unexpected OpenACC parallelism.");
1039 :
1040 459 : return gfc_match (" )");
1041 : }
1042 :
1043 : static match
1044 8 : gfc_match_oacc_clause_link (const char *str, gfc_omp_namelist **list)
1045 : {
1046 8 : gfc_omp_namelist *head = NULL;
1047 8 : gfc_omp_namelist *tail, *p;
1048 8 : locus old_loc;
1049 8 : char n[GFC_MAX_SYMBOL_LEN+1];
1050 8 : gfc_symbol *sym;
1051 8 : match m;
1052 8 : gfc_symtree *st;
1053 :
1054 8 : old_loc = gfc_current_locus;
1055 :
1056 8 : m = gfc_match (str);
1057 8 : if (m != MATCH_YES)
1058 : return m;
1059 :
1060 8 : m = gfc_match (" (");
1061 :
1062 14 : for (;;)
1063 : {
1064 14 : m = gfc_match_symbol (&sym, 0);
1065 14 : switch (m)
1066 : {
1067 8 : case MATCH_YES:
1068 8 : if (sym->attr.in_common)
1069 : {
1070 2 : gfc_error_now ("Variable at %C is an element of a COMMON block");
1071 2 : goto cleanup;
1072 : }
1073 6 : gfc_set_sym_referenced (sym);
1074 6 : p = gfc_get_omp_namelist ();
1075 6 : if (head == NULL)
1076 : head = tail = p;
1077 : else
1078 : {
1079 4 : tail->next = p;
1080 4 : tail = tail->next;
1081 : }
1082 6 : tail->sym = sym;
1083 6 : tail->expr = NULL;
1084 6 : tail->where = gfc_current_locus;
1085 6 : goto next_item;
1086 : case MATCH_NO:
1087 : break;
1088 :
1089 0 : case MATCH_ERROR:
1090 0 : goto cleanup;
1091 : }
1092 :
1093 6 : m = gfc_match (" / %n /", n);
1094 6 : if (m == MATCH_ERROR)
1095 0 : goto cleanup;
1096 6 : if (m == MATCH_NO || n[0] == '\0')
1097 0 : goto syntax;
1098 :
1099 6 : st = gfc_find_symtree (gfc_current_ns->common_root, n);
1100 6 : if (st == NULL)
1101 : {
1102 1 : gfc_error ("COMMON block /%s/ not found at %C", n);
1103 1 : goto cleanup;
1104 : }
1105 :
1106 20 : for (sym = st->n.common->head; sym; sym = sym->common_next)
1107 : {
1108 15 : gfc_set_sym_referenced (sym);
1109 15 : p = gfc_get_omp_namelist ();
1110 15 : if (head == NULL)
1111 : head = tail = p;
1112 : else
1113 : {
1114 12 : tail->next = p;
1115 12 : tail = tail->next;
1116 : }
1117 15 : tail->sym = sym;
1118 15 : tail->where = gfc_current_locus;
1119 : }
1120 :
1121 5 : next_item:
1122 11 : if (gfc_match_char (')') == MATCH_YES)
1123 : break;
1124 6 : if (gfc_match_char (',') != MATCH_YES)
1125 0 : goto syntax;
1126 : }
1127 :
1128 5 : if (gfc_match_omp_eos () != MATCH_YES)
1129 : {
1130 1 : gfc_error ("Unexpected junk after !$ACC DECLARE at %C");
1131 1 : goto cleanup;
1132 : }
1133 :
1134 4 : while (*list)
1135 0 : list = &(*list)->next;
1136 4 : *list = head;
1137 4 : return MATCH_YES;
1138 :
1139 0 : syntax:
1140 0 : gfc_error ("Syntax error in !$ACC DECLARE list at %C");
1141 :
1142 4 : cleanup:
1143 4 : gfc_current_locus = old_loc;
1144 4 : return MATCH_ERROR;
1145 : }
1146 :
1147 : /* OpenMP clauses. */
1148 : enum omp_mask1
1149 : {
1150 : OMP_CLAUSE_PRIVATE,
1151 : OMP_CLAUSE_FIRSTPRIVATE,
1152 : OMP_CLAUSE_LASTPRIVATE,
1153 : OMP_CLAUSE_COPYPRIVATE,
1154 : OMP_CLAUSE_SHARED,
1155 : OMP_CLAUSE_COPYIN,
1156 : OMP_CLAUSE_REDUCTION,
1157 : OMP_CLAUSE_IN_REDUCTION,
1158 : OMP_CLAUSE_TASK_REDUCTION,
1159 : OMP_CLAUSE_IF,
1160 : OMP_CLAUSE_NUM_THREADS,
1161 : OMP_CLAUSE_SCHEDULE,
1162 : OMP_CLAUSE_DEFAULT,
1163 : OMP_CLAUSE_ORDER,
1164 : OMP_CLAUSE_ORDERED,
1165 : OMP_CLAUSE_COLLAPSE,
1166 : OMP_CLAUSE_UNTIED,
1167 : OMP_CLAUSE_FINAL,
1168 : OMP_CLAUSE_MERGEABLE,
1169 : OMP_CLAUSE_ALIGNED,
1170 : OMP_CLAUSE_DEPEND,
1171 : OMP_CLAUSE_INBRANCH,
1172 : OMP_CLAUSE_LINEAR,
1173 : OMP_CLAUSE_NOTINBRANCH,
1174 : OMP_CLAUSE_PROC_BIND,
1175 : OMP_CLAUSE_SAFELEN,
1176 : OMP_CLAUSE_SIMDLEN,
1177 : OMP_CLAUSE_UNIFORM,
1178 : OMP_CLAUSE_DEVICE,
1179 : OMP_CLAUSE_MAP,
1180 : OMP_CLAUSE_TO,
1181 : OMP_CLAUSE_FROM,
1182 : OMP_CLAUSE_NUM_TEAMS,
1183 : OMP_CLAUSE_THREAD_LIMIT,
1184 : OMP_CLAUSE_DIST_SCHEDULE,
1185 : OMP_CLAUSE_DEFAULTMAP,
1186 : OMP_CLAUSE_GRAINSIZE,
1187 : OMP_CLAUSE_HINT,
1188 : OMP_CLAUSE_IS_DEVICE_PTR,
1189 : OMP_CLAUSE_LINK,
1190 : OMP_CLAUSE_NOGROUP,
1191 : OMP_CLAUSE_NOTEMPORAL,
1192 : OMP_CLAUSE_NUM_TASKS,
1193 : OMP_CLAUSE_PRIORITY,
1194 : OMP_CLAUSE_SIMD,
1195 : OMP_CLAUSE_THREADS,
1196 : OMP_CLAUSE_USE_DEVICE_PTR,
1197 : OMP_CLAUSE_USE_DEVICE_ADDR, /* OpenMP 5.0. */
1198 : OMP_CLAUSE_DEVICE_TYPE, /* OpenMP 5.0. */
1199 : OMP_CLAUSE_ATOMIC, /* OpenMP 5.0. */
1200 : OMP_CLAUSE_CAPTURE, /* OpenMP 5.0. */
1201 : OMP_CLAUSE_MEMORDER, /* OpenMP 5.0. */
1202 : OMP_CLAUSE_DETACH, /* OpenMP 5.0. */
1203 : OMP_CLAUSE_AFFINITY, /* OpenMP 5.0. */
1204 : OMP_CLAUSE_ALLOCATE, /* OpenMP 5.0. */
1205 : OMP_CLAUSE_BIND, /* OpenMP 5.0. */
1206 : OMP_CLAUSE_FILTER, /* OpenMP 5.1. */
1207 : OMP_CLAUSE_AT, /* OpenMP 5.1. */
1208 : OMP_CLAUSE_MESSAGE, /* OpenMP 5.1. */
1209 : OMP_CLAUSE_SEVERITY, /* OpenMP 5.1. */
1210 : OMP_CLAUSE_COMPARE, /* OpenMP 5.1. */
1211 : OMP_CLAUSE_FAIL, /* OpenMP 5.1. */
1212 : OMP_CLAUSE_WEAK, /* OpenMP 5.1. */
1213 : OMP_CLAUSE_NOWAIT,
1214 : /* This must come last. */
1215 : OMP_MASK1_LAST
1216 : };
1217 :
1218 : /* More OpenMP clauses and OpenACC 2.0+ specific clauses. */
1219 : enum omp_mask2
1220 : {
1221 : OMP_CLAUSE_ASYNC,
1222 : OMP_CLAUSE_NUM_GANGS,
1223 : OMP_CLAUSE_NUM_WORKERS,
1224 : OMP_CLAUSE_VECTOR_LENGTH,
1225 : OMP_CLAUSE_COPY,
1226 : OMP_CLAUSE_COPYOUT,
1227 : OMP_CLAUSE_CREATE,
1228 : OMP_CLAUSE_NO_CREATE,
1229 : OMP_CLAUSE_PRESENT,
1230 : OMP_CLAUSE_DEVICEPTR,
1231 : OMP_CLAUSE_GANG,
1232 : OMP_CLAUSE_WORKER,
1233 : OMP_CLAUSE_VECTOR,
1234 : OMP_CLAUSE_SEQ,
1235 : OMP_CLAUSE_INDEPENDENT,
1236 : OMP_CLAUSE_USE_DEVICE,
1237 : OMP_CLAUSE_DEVICE_RESIDENT,
1238 : OMP_CLAUSE_SELF,
1239 : OMP_CLAUSE_HOST,
1240 : OMP_CLAUSE_WAIT,
1241 : OMP_CLAUSE_DELETE,
1242 : OMP_CLAUSE_AUTO,
1243 : OMP_CLAUSE_TILE,
1244 : OMP_CLAUSE_IF_PRESENT,
1245 : OMP_CLAUSE_FINALIZE,
1246 : OMP_CLAUSE_ATTACH,
1247 : OMP_CLAUSE_NOHOST,
1248 : OMP_CLAUSE_HAS_DEVICE_ADDR, /* OpenMP 5.1 */
1249 : OMP_CLAUSE_ENTER, /* OpenMP 5.2 */
1250 : OMP_CLAUSE_DOACROSS, /* OpenMP 5.2 */
1251 : OMP_CLAUSE_ASSUMPTIONS, /* OpenMP 5.1. */
1252 : OMP_CLAUSE_USES_ALLOCATORS, /* OpenMP 5.0 */
1253 : OMP_CLAUSE_INDIRECT, /* OpenMP 5.1 */
1254 : OMP_CLAUSE_FULL, /* OpenMP 5.1. */
1255 : OMP_CLAUSE_PARTIAL, /* OpenMP 5.1. */
1256 : OMP_CLAUSE_SIZES, /* OpenMP 5.1. */
1257 : OMP_CLAUSE_INIT, /* OpenMP 5.1. */
1258 : OMP_CLAUSE_DESTROY, /* OpenMP 5.1. */
1259 : OMP_CLAUSE_USE, /* OpenMP 5.1. */
1260 : OMP_CLAUSE_NOVARIANTS, /* OpenMP 5.1 */
1261 : OMP_CLAUSE_NOCONTEXT, /* OpenMP 5.1 */
1262 : OMP_CLAUSE_INTEROP, /* OpenMP 5.1 */
1263 : OMP_CLAUSE_LOCAL, /* OpenMP 6.0 */
1264 : OMP_CLAUSE_DYN_GROUPPRIVATE, /* OpenMP 6.1 */
1265 : OMP_CLAUSE_DEVICE_NUM,
1266 : /* This must come last. */
1267 : OMP_MASK2_LAST
1268 : };
1269 :
1270 : struct omp_inv_mask;
1271 :
1272 : /* Customized bitset for up to 128-bits.
1273 : The two enums above provide bit numbers to use, and which of the
1274 : two enums it is determines which of the two mask fields is used.
1275 : Supported operations are defining a mask, like:
1276 : #define XXX_CLAUSES \
1277 : (omp_mask (OMP_CLAUSE_XXX) | OMP_CLAUSE_YYY | OMP_CLAUSE_ZZZ)
1278 : oring such bitsets together or removing selected bits:
1279 : (XXX_CLAUSES | YYY_CLAUSES) & ~(omp_mask (OMP_CLAUSE_VVV))
1280 : and testing individual bits:
1281 : if (mask & OMP_CLAUSE_UUU) */
1282 :
1283 : struct omp_mask {
1284 : const uint64_t mask1;
1285 : const uint64_t mask2;
1286 : inline omp_mask ();
1287 : inline omp_mask (omp_mask1);
1288 : inline omp_mask (omp_mask2);
1289 : inline omp_mask (uint64_t, uint64_t);
1290 : inline omp_mask operator| (omp_mask1) const;
1291 : inline omp_mask operator| (omp_mask2) const;
1292 : inline omp_mask operator| (omp_mask) const;
1293 : inline omp_mask operator& (const omp_inv_mask &) const;
1294 : inline bool operator& (omp_mask1) const;
1295 : inline bool operator& (omp_mask2) const;
1296 : inline omp_inv_mask operator~ () const;
1297 : };
1298 :
1299 : struct omp_inv_mask : public omp_mask {
1300 : inline omp_inv_mask (const omp_mask &);
1301 : };
1302 :
1303 : omp_mask::omp_mask () : mask1 (0), mask2 (0)
1304 : {
1305 : }
1306 :
1307 33027 : omp_mask::omp_mask (omp_mask1 m) : mask1 (((uint64_t) 1) << m), mask2 (0)
1308 : {
1309 : }
1310 :
1311 2244 : omp_mask::omp_mask (omp_mask2 m) : mask1 (0), mask2 (((uint64_t) 1) << m)
1312 : {
1313 : }
1314 :
1315 33914 : omp_mask::omp_mask (uint64_t m1, uint64_t m2) : mask1 (m1), mask2 (m2)
1316 : {
1317 : }
1318 :
1319 : omp_mask
1320 32954 : omp_mask::operator| (omp_mask1 m) const
1321 : {
1322 32954 : return omp_mask (mask1 | (((uint64_t) 1) << m), mask2);
1323 : }
1324 :
1325 : omp_mask
1326 17307 : omp_mask::operator| (omp_mask2 m) const
1327 : {
1328 17307 : return omp_mask (mask1, mask2 | (((uint64_t) 1) << m));
1329 : }
1330 :
1331 : omp_mask
1332 4383 : omp_mask::operator| (omp_mask m) const
1333 : {
1334 4383 : return omp_mask (mask1 | m.mask1, mask2 | m.mask2);
1335 : }
1336 :
1337 : omp_mask
1338 2037 : omp_mask::operator& (const omp_inv_mask &m) const
1339 : {
1340 2037 : return omp_mask (mask1 & ~m.mask1, mask2 & ~m.mask2);
1341 : }
1342 :
1343 : bool
1344 130385 : omp_mask::operator& (omp_mask1 m) const
1345 : {
1346 130385 : return (mask1 & (((uint64_t) 1) << m)) != 0;
1347 : }
1348 :
1349 : bool
1350 92760 : omp_mask::operator& (omp_mask2 m) const
1351 : {
1352 92760 : return (mask2 & (((uint64_t) 1) << m)) != 0;
1353 : }
1354 :
1355 : omp_inv_mask
1356 2037 : omp_mask::operator~ () const
1357 : {
1358 2037 : return omp_inv_mask (*this);
1359 : }
1360 :
1361 2037 : omp_inv_mask::omp_inv_mask (const omp_mask &m) : omp_mask (m)
1362 : {
1363 : }
1364 :
1365 : /* Helper function for OpenACC and OpenMP clauses involving memory
1366 : mapping. */
1367 :
1368 : static bool
1369 5544 : gfc_match_omp_map_clause (gfc_omp_namelist **list, gfc_omp_map_op map_op,
1370 : bool allow_common, bool allow_derived)
1371 : {
1372 5544 : gfc_omp_namelist **head = NULL;
1373 5544 : if (gfc_match_omp_variable_list ("", list, allow_common, NULL, &head, true,
1374 : allow_derived)
1375 : == MATCH_YES)
1376 : {
1377 5535 : gfc_omp_namelist *n;
1378 13409 : for (n = *head; n; n = n->next)
1379 7874 : n->u.map.op = map_op;
1380 : return true;
1381 : }
1382 :
1383 : return false;
1384 : }
1385 :
1386 : static match
1387 8749 : gfc_match_iterator (gfc_namespace **ns, bool permit_var)
1388 : {
1389 8749 : locus old_loc = gfc_current_locus;
1390 :
1391 8749 : if (gfc_match ("iterator ( ") != MATCH_YES)
1392 : return MATCH_NO;
1393 :
1394 142 : gfc_typespec ts;
1395 142 : gfc_symbol *last = NULL;
1396 142 : gfc_expr *begin, *end, *step;
1397 142 : *ns = gfc_build_block_ns (gfc_current_ns);
1398 161 : char name[GFC_MAX_SYMBOL_LEN + 1];
1399 180 : while (true)
1400 : {
1401 161 : locus prev_loc = gfc_current_locus;
1402 161 : if (gfc_match_type_spec (&ts) == MATCH_YES
1403 161 : && gfc_match (" :: ") == MATCH_YES)
1404 : {
1405 5 : if (ts.type != BT_INTEGER)
1406 : {
1407 2 : gfc_error ("Expected INTEGER type at %L", &prev_loc);
1408 5 : return MATCH_ERROR;
1409 : }
1410 : permit_var = false;
1411 : }
1412 : else
1413 : {
1414 156 : ts.type = BT_INTEGER;
1415 156 : ts.kind = gfc_default_integer_kind;
1416 156 : gfc_current_locus = prev_loc;
1417 : }
1418 159 : prev_loc = gfc_current_locus;
1419 159 : if (gfc_match_name (name) != MATCH_YES)
1420 : {
1421 4 : gfc_error ("Expected identifier at %C");
1422 4 : goto failed;
1423 : }
1424 155 : if (gfc_find_symtree ((*ns)->sym_root, name))
1425 : {
1426 2 : gfc_error ("Same identifier %qs specified again at %C", name);
1427 2 : goto failed;
1428 : }
1429 :
1430 153 : gfc_symbol *sym = gfc_new_symbol (name, *ns);
1431 153 : if (last)
1432 17 : last->tlink = sym;
1433 : else
1434 136 : (*ns)->omp_affinity_iterators = sym;
1435 153 : last = sym;
1436 153 : sym->declared_at = prev_loc;
1437 153 : sym->ts = ts;
1438 153 : sym->attr.flavor = FL_VARIABLE;
1439 153 : sym->attr.artificial = 1;
1440 153 : sym->attr.referenced = 1;
1441 153 : sym->refs++;
1442 153 : gfc_symtree *st = gfc_new_symtree (&(*ns)->sym_root, name);
1443 153 : st->n.sym = sym;
1444 :
1445 153 : prev_loc = gfc_current_locus;
1446 153 : if (gfc_match (" = ") != MATCH_YES)
1447 3 : goto failed;
1448 150 : permit_var = false;
1449 150 : begin = end = step = NULL;
1450 150 : if (gfc_match ("%e : ", &begin) != MATCH_YES
1451 150 : || gfc_match ("%e ", &end) != MATCH_YES)
1452 : {
1453 3 : gfc_error ("Expected range-specification at %C");
1454 3 : gfc_free_expr (begin);
1455 3 : gfc_free_expr (end);
1456 3 : return MATCH_ERROR;
1457 : }
1458 147 : if (':' == gfc_peek_ascii_char ())
1459 : {
1460 23 : if (gfc_match (": %e ", &step) != MATCH_YES)
1461 : {
1462 5 : gfc_free_expr (begin);
1463 5 : gfc_free_expr (end);
1464 5 : gfc_free_expr (step);
1465 5 : goto failed;
1466 : }
1467 : }
1468 :
1469 142 : gfc_expr *e = gfc_get_expr ();
1470 142 : e->where = prev_loc;
1471 142 : e->expr_type = EXPR_ARRAY;
1472 142 : e->ts = ts;
1473 142 : e->rank = 1;
1474 142 : e->shape = gfc_get_shape (1);
1475 266 : mpz_init_set_ui (e->shape[0], step ? 3 : 2);
1476 142 : gfc_constructor_append_expr (&e->value.constructor, begin, &begin->where);
1477 142 : gfc_constructor_append_expr (&e->value.constructor, end, &end->where);
1478 142 : if (step)
1479 18 : gfc_constructor_append_expr (&e->value.constructor, step, &step->where);
1480 142 : sym->value = e;
1481 :
1482 142 : if (gfc_match (") ") == MATCH_YES)
1483 : break;
1484 19 : if (gfc_match (", ") != MATCH_YES)
1485 0 : goto failed;
1486 19 : }
1487 123 : return MATCH_YES;
1488 :
1489 14 : failed:
1490 14 : gfc_namespace *prev_ns = NULL;
1491 14 : for (gfc_namespace *it = gfc_current_ns->contained; it; it = it->sibling)
1492 : {
1493 0 : if (it == *ns)
1494 : {
1495 0 : if (prev_ns)
1496 0 : prev_ns->sibling = it->sibling;
1497 : else
1498 0 : gfc_current_ns->contained = it->sibling;
1499 0 : gfc_free_namespace (it);
1500 0 : break;
1501 : }
1502 0 : prev_ns = it;
1503 : }
1504 14 : *ns = NULL;
1505 14 : if (!permit_var)
1506 : return MATCH_ERROR;
1507 4 : gfc_current_locus = old_loc;
1508 4 : return MATCH_NO;
1509 : }
1510 :
1511 : /* Match target update's to/from( [present:] var-list). */
1512 :
1513 : static match
1514 1738 : gfc_match_motion_var_list (const char *str, gfc_omp_namelist **list,
1515 : gfc_omp_namelist ***headp)
1516 : {
1517 1738 : match m = gfc_match (str);
1518 1738 : if (m != MATCH_YES)
1519 : return m;
1520 :
1521 1738 : gfc_namespace *ns_iter = NULL, *ns_curr = gfc_current_ns;
1522 1738 : locus old_loc = gfc_current_locus;
1523 1738 : int present_modifier = 0;
1524 1738 : int iterator_modifier = 0;
1525 1738 : locus second_present_locus = old_loc;
1526 1738 : locus second_iterator_locus = old_loc;
1527 1738 : bool saw_modifier = false;
1528 :
1529 1750 : for (;;)
1530 : {
1531 1744 : locus current_locus = gfc_current_locus;
1532 1744 : if (gfc_match ("present ") == MATCH_YES)
1533 : {
1534 8 : if (present_modifier++ == 1)
1535 0 : second_present_locus = current_locus;
1536 : }
1537 1736 : else if (gfc_match_iterator (&ns_iter, true) == MATCH_YES)
1538 : {
1539 20 : if (iterator_modifier++ == 1)
1540 1 : second_iterator_locus = current_locus;
1541 : }
1542 1716 : else if (!saw_modifier)
1543 : break;
1544 : else
1545 : {
1546 2 : gfc_error ("Expected clause modifier at %C");
1547 4 : return MATCH_ERROR;
1548 : }
1549 :
1550 : /* OpenMP 5.1 syntax mistakenly allowed commas to be optional
1551 : between and after modifiers in a clause. This was corrected
1552 : in 5.2 and later specifications: they're now required between
1553 : modifiers and a trailing comma is not permitted. We implement
1554 : the 5.2 syntax here. */
1555 28 : saw_modifier = true;
1556 28 : if (gfc_match (" : ") == MATCH_YES)
1557 : break;
1558 8 : else if (gfc_match (", ") == MATCH_YES)
1559 6 : continue;
1560 : else
1561 : {
1562 2 : gfc_error ("Expected %<,%> or %<:%> after clause modifier at %C");
1563 2 : return MATCH_ERROR;
1564 : }
1565 6 : }
1566 :
1567 1734 : if (!saw_modifier)
1568 : {
1569 1714 : gfc_current_locus = old_loc;
1570 1714 : present_modifier = 0;
1571 1714 : iterator_modifier = 0;
1572 : }
1573 :
1574 1734 : if (present_modifier > 1)
1575 : {
1576 0 : gfc_error ("Too many %<present%> modifiers at %L", &second_present_locus);
1577 0 : return MATCH_ERROR;
1578 : }
1579 1734 : if (iterator_modifier > 1)
1580 : {
1581 1 : gfc_error ("Too many %<iterator%> modifiers at %L",
1582 : &second_iterator_locus);
1583 1 : return MATCH_ERROR;
1584 : }
1585 :
1586 1733 : if (ns_iter)
1587 14 : gfc_current_ns = ns_iter;
1588 :
1589 1733 : m = gfc_match_omp_variable_list ("", list, false, NULL, headp, true, true);
1590 1733 : gfc_current_ns = ns_curr;
1591 1733 : if (m != MATCH_YES)
1592 : return m;
1593 1731 : gfc_omp_namelist *n;
1594 3536 : for (n = **headp; n; n = n->next)
1595 : {
1596 1805 : if (present_modifier)
1597 6 : n->u.present_modifier = true;
1598 1805 : if (iterator_modifier)
1599 : {
1600 18 : n->u2.ns = ns_iter;
1601 18 : ns_iter->refs++;
1602 : }
1603 : }
1604 : return MATCH_YES;
1605 : }
1606 :
1607 : /* reduction ( reduction-modifier, reduction-operator : variable-list )
1608 : in_reduction ( reduction-operator : variable-list )
1609 : task_reduction ( reduction-operator : variable-list ) */
1610 :
1611 : static match
1612 4362 : gfc_match_omp_clause_reduction (char pc, gfc_omp_clauses *c, bool openacc,
1613 : bool allow_derived, bool openmp_target = false)
1614 : {
1615 4362 : if (pc == 'r' && gfc_match ("reduction ( ") != MATCH_YES)
1616 : return MATCH_NO;
1617 4362 : else if (pc == 'i' && gfc_match ("in_reduction ( ") != MATCH_YES)
1618 : return MATCH_NO;
1619 4250 : else if (pc == 't' && gfc_match ("task_reduction ( ") != MATCH_YES)
1620 : return MATCH_NO;
1621 :
1622 4250 : locus old_loc = gfc_current_locus;
1623 4250 : enum gfc_omp_list_type list_idx = OMP_LIST_NONE;
1624 :
1625 4250 : if (pc == 'r' && !openacc)
1626 : {
1627 2123 : if (gfc_match ("inscan") == MATCH_YES)
1628 : list_idx = OMP_LIST_REDUCTION_INSCAN;
1629 2053 : else if (gfc_match ("task") == MATCH_YES)
1630 : list_idx = OMP_LIST_REDUCTION_TASK;
1631 1948 : else if (gfc_match ("default") == MATCH_YES)
1632 : list_idx = OMP_LIST_REDUCTION;
1633 231 : if (list_idx != OMP_LIST_NONE && gfc_match (", ") != MATCH_YES)
1634 : {
1635 1 : gfc_error ("Comma expected at %C");
1636 1 : gfc_current_locus = old_loc;
1637 1 : return MATCH_NO;
1638 : }
1639 2122 : if (list_idx == OMP_LIST_NONE)
1640 3836 : list_idx = OMP_LIST_REDUCTION;
1641 : }
1642 2127 : else if (pc == 'i')
1643 : list_idx = OMP_LIST_IN_REDUCTION;
1644 2009 : else if (pc == 't')
1645 : list_idx = OMP_LIST_TASK_REDUCTION;
1646 : else
1647 3836 : list_idx = OMP_LIST_REDUCTION;
1648 :
1649 4249 : gfc_omp_reduction_op rop = OMP_REDUCTION_NONE;
1650 4249 : char buffer[GFC_MAX_SYMBOL_LEN + 3];
1651 4249 : if (gfc_match_char ('+') == MATCH_YES)
1652 : rop = OMP_REDUCTION_PLUS;
1653 2224 : else if (gfc_match_char ('*') == MATCH_YES)
1654 : rop = OMP_REDUCTION_TIMES;
1655 1992 : else if (gfc_match_char ('-') == MATCH_YES)
1656 : {
1657 171 : if (!openacc)
1658 16 : gfc_warning (OPT_Wdeprecated_openmp,
1659 : "%<-%> operator at %C for reductions deprecated in "
1660 : "OpenMP 5.2");
1661 : rop = OMP_REDUCTION_MINUS;
1662 : }
1663 1821 : else if (gfc_match (".and.") == MATCH_YES)
1664 : rop = OMP_REDUCTION_AND;
1665 1715 : else if (gfc_match (".or.") == MATCH_YES)
1666 : rop = OMP_REDUCTION_OR;
1667 930 : else if (gfc_match (".eqv.") == MATCH_YES)
1668 : rop = OMP_REDUCTION_EQV;
1669 832 : else if (gfc_match (".neqv.") == MATCH_YES)
1670 : rop = OMP_REDUCTION_NEQV;
1671 16 : if (rop != OMP_REDUCTION_NONE)
1672 3512 : snprintf (buffer, sizeof buffer, "operator %s",
1673 : gfc_op2string ((gfc_intrinsic_op) rop));
1674 737 : else if (gfc_match_defined_op_name (buffer + 1, 1) == MATCH_YES)
1675 : {
1676 38 : buffer[0] = '.';
1677 38 : strcat (buffer, ".");
1678 : }
1679 699 : else if (gfc_match_name (buffer) == MATCH_YES)
1680 : {
1681 698 : gfc_symbol *sym;
1682 698 : const char *n = buffer;
1683 :
1684 698 : gfc_find_symbol (buffer, NULL, 1, &sym);
1685 698 : if (sym != NULL)
1686 : {
1687 217 : if (sym->attr.intrinsic)
1688 139 : n = sym->name;
1689 78 : else if ((sym->attr.flavor != FL_UNKNOWN
1690 76 : && sym->attr.flavor != FL_PROCEDURE)
1691 76 : || sym->attr.external
1692 65 : || sym->attr.generic
1693 65 : || sym->attr.entry
1694 65 : || sym->attr.result
1695 65 : || sym->attr.dummy
1696 65 : || sym->attr.subroutine
1697 64 : || sym->attr.pointer
1698 64 : || sym->attr.target
1699 64 : || sym->attr.cray_pointer
1700 64 : || sym->attr.cray_pointee
1701 64 : || (sym->attr.proc != PROC_UNKNOWN
1702 2 : && sym->attr.proc != PROC_INTRINSIC)
1703 62 : || sym->attr.if_source != IFSRC_UNKNOWN
1704 62 : || sym == sym->ns->proc_name)
1705 : {
1706 : sym = NULL;
1707 : n = NULL;
1708 : }
1709 : else
1710 62 : n = sym->name;
1711 : }
1712 201 : if (n == NULL)
1713 : rop = OMP_REDUCTION_NONE;
1714 682 : else if (strcmp (n, "max") == 0)
1715 : rop = OMP_REDUCTION_MAX;
1716 517 : else if (strcmp (n, "min") == 0)
1717 : rop = OMP_REDUCTION_MIN;
1718 376 : else if (strcmp (n, "iand") == 0)
1719 : rop = OMP_REDUCTION_IAND;
1720 321 : else if (strcmp (n, "ior") == 0)
1721 : rop = OMP_REDUCTION_IOR;
1722 255 : else if (strcmp (n, "ieor") == 0)
1723 : rop = OMP_REDUCTION_IEOR;
1724 : if (rop != OMP_REDUCTION_NONE
1725 477 : && sym != NULL
1726 200 : && ! sym->attr.intrinsic
1727 61 : && ! sym->attr.use_assoc
1728 61 : && ((sym->attr.flavor == FL_UNKNOWN
1729 2 : && !gfc_add_flavor (&sym->attr, FL_PROCEDURE,
1730 : sym->name, NULL))
1731 61 : || !gfc_add_intrinsic (&sym->attr, NULL)))
1732 : rop = OMP_REDUCTION_NONE;
1733 : }
1734 : else
1735 1 : buffer[0] = '\0';
1736 4249 : gfc_omp_udr *udr = (buffer[0] ? gfc_find_omp_udr (gfc_current_ns, buffer, NULL)
1737 : : NULL);
1738 4249 : gfc_omp_namelist **head = NULL;
1739 4249 : if (rop == OMP_REDUCTION_NONE && udr)
1740 251 : rop = OMP_REDUCTION_USER;
1741 :
1742 4249 : if (gfc_match_omp_variable_list (" :", &c->lists[list_idx], false, NULL,
1743 : &head, openacc, allow_derived) != MATCH_YES)
1744 : {
1745 9 : gfc_current_locus = old_loc;
1746 9 : return MATCH_NO;
1747 : }
1748 4240 : gfc_omp_namelist *n;
1749 4240 : if (rop == OMP_REDUCTION_NONE)
1750 : {
1751 6 : n = *head;
1752 6 : *head = NULL;
1753 6 : gfc_error_now ("!$OMP DECLARE REDUCTION %s not found at %L",
1754 : buffer, &old_loc);
1755 6 : gfc_free_omp_namelist (n, OMP_LIST_NONE);
1756 : }
1757 : else
1758 9120 : for (n = *head; n; n = n->next)
1759 : {
1760 4886 : n->u.reduction_op = rop;
1761 4886 : if (udr)
1762 : {
1763 477 : n->u2.udr = gfc_get_omp_namelist_udr ();
1764 477 : n->u2.udr->udr = udr;
1765 : }
1766 4886 : if (openmp_target && list_idx == OMP_LIST_IN_REDUCTION)
1767 : {
1768 40 : gfc_omp_namelist *p = gfc_get_omp_namelist (), **tl;
1769 40 : p->sym = n->sym;
1770 40 : p->where = n->where;
1771 40 : p->u.map.op = OMP_MAP_ALWAYS_TOFROM;
1772 :
1773 40 : tl = &c->lists[OMP_LIST_MAP];
1774 52 : while (*tl)
1775 12 : tl = &((*tl)->next);
1776 40 : *tl = p;
1777 40 : p->next = NULL;
1778 : }
1779 : }
1780 : return MATCH_YES;
1781 : }
1782 :
1783 : static match
1784 47 : gfc_omp_absent_contains_clause (gfc_omp_assumptions **assume, bool is_absent)
1785 : {
1786 47 : if (*assume == NULL)
1787 22 : *assume = gfc_get_omp_assumptions ();
1788 77 : do
1789 : {
1790 62 : gfc_statement st = ST_NONE;
1791 62 : gfc_gobble_whitespace ();
1792 62 : locus old_loc = gfc_current_locus;
1793 62 : char c = gfc_peek_ascii_char ();
1794 62 : enum gfc_omp_directive_kind kind
1795 : = GFC_OMP_DIR_DECLARATIVE; /* Silence warning. */
1796 2369 : for (size_t i = 0; i < ARRAY_SIZE (gfc_omp_directives); i++)
1797 : {
1798 2307 : if (gfc_omp_directives[i].name[0] > c)
1799 : break;
1800 2245 : if (gfc_omp_directives[i].name[0] != c)
1801 1668 : continue;
1802 577 : if (gfc_match (gfc_omp_directives[i].name) == MATCH_YES)
1803 : {
1804 62 : st = gfc_omp_directives[i].st;
1805 62 : kind = gfc_omp_directives[i].kind;
1806 : }
1807 : }
1808 62 : gfc_gobble_whitespace ();
1809 62 : c = gfc_peek_ascii_char ();
1810 62 : if (st == ST_NONE || (c != ',' && c != ')'))
1811 : {
1812 0 : if (st == ST_NONE)
1813 0 : gfc_error ("Unknown directive at %L", &old_loc);
1814 : else
1815 0 : gfc_error ("Invalid combined or composite directive at %L",
1816 : &old_loc);
1817 9 : return MATCH_ERROR;
1818 : }
1819 62 : if (kind == GFC_OMP_DIR_DECLARATIVE
1820 62 : || kind == GFC_OMP_DIR_INFORMATIONAL
1821 : || kind == GFC_OMP_DIR_META)
1822 : {
1823 15 : gfc_error ("Invalid %qs directive at %L in %s clause: declarative, "
1824 : "informational, and meta directives not permitted",
1825 : gfc_ascii_statement (st, true), &old_loc,
1826 : is_absent ? "ABSENT" : "CONTAINS");
1827 9 : return MATCH_ERROR;
1828 : }
1829 53 : if (is_absent)
1830 : {
1831 : /* Use exponential allocation; equivalent to pow2p(x). */
1832 38 : int i = (*assume)->n_absent;
1833 38 : int size = ((i == 0) ? 4
1834 14 : : pow2p_hwi (i) == 1 ? i*2 : 0);
1835 11 : if (size != 0)
1836 35 : (*assume)->absent = XRESIZEVEC (gfc_statement,
1837 : (*assume)->absent, size);
1838 38 : (*assume)->absent[(*assume)->n_absent++] = st;
1839 : }
1840 : else
1841 : {
1842 15 : int i = (*assume)->n_contains;
1843 15 : int size = ((i == 0) ? 4
1844 4 : : pow2p_hwi (i) == 1 ? i*2 : 0);
1845 4 : if (size != 0)
1846 15 : (*assume)->contains = XRESIZEVEC (gfc_statement,
1847 : (*assume)->contains, size);
1848 15 : (*assume)->contains[(*assume)->n_contains++] = st;
1849 : }
1850 53 : gfc_gobble_whitespace ();
1851 53 : if (gfc_match(",") == MATCH_YES)
1852 15 : continue;
1853 38 : if (gfc_match(")") == MATCH_YES)
1854 : break;
1855 0 : gfc_error ("Expected %<,%> or %<)%> at %C");
1856 0 : return MATCH_ERROR;
1857 15 : }
1858 : while (true);
1859 :
1860 38 : return MATCH_YES;
1861 : }
1862 :
1863 : /* Check 'check' argument for duplicated statements in absent and/or contains
1864 : clauses. If 'merge', merge them from check to 'merge'. */
1865 :
1866 : static match
1867 50 : omp_verify_merge_absent_contains (gfc_statement st, gfc_omp_assumptions *check,
1868 : gfc_omp_assumptions *merge, locus *loc)
1869 : {
1870 50 : if (check == NULL)
1871 : return MATCH_YES;
1872 49 : bitmap_head absent_head, contains_head;
1873 49 : bitmap_obstack_initialize (NULL);
1874 49 : bitmap_initialize (&absent_head, &bitmap_default_obstack);
1875 49 : bitmap_initialize (&contains_head, &bitmap_default_obstack);
1876 :
1877 49 : match m = MATCH_YES;
1878 87 : for (int i = 0; i < check->n_absent; i++)
1879 38 : if (!bitmap_set_bit (&absent_head, check->absent[i]))
1880 : {
1881 2 : gfc_error ("%qs directive mentioned multiple times in %s clause in %s "
1882 : "directive at %L",
1883 2 : gfc_ascii_statement (check->absent[i], true),
1884 : "ABSENT", gfc_ascii_statement (st), loc);
1885 2 : m = MATCH_ERROR;
1886 : }
1887 64 : for (int i = 0; i < check->n_contains; i++)
1888 : {
1889 15 : if (!bitmap_set_bit (&contains_head, check->contains[i]))
1890 : {
1891 2 : gfc_error ("%qs directive mentioned multiple times in %s clause in %s "
1892 : "directive at %L",
1893 2 : gfc_ascii_statement (check->contains[i], true),
1894 : "CONTAINS", gfc_ascii_statement (st), loc);
1895 2 : m = MATCH_ERROR;
1896 : }
1897 15 : if (bitmap_bit_p (&absent_head, check->contains[i]))
1898 : {
1899 2 : gfc_error ("%qs directive mentioned both times in ABSENT and CONTAINS "
1900 : "clauses in %s directive at %L",
1901 2 : gfc_ascii_statement (check->absent[i], true),
1902 : gfc_ascii_statement (st), loc);
1903 2 : m = MATCH_ERROR;
1904 : }
1905 : }
1906 :
1907 49 : if (m == MATCH_ERROR)
1908 : return MATCH_ERROR;
1909 43 : if (merge == NULL)
1910 : return MATCH_YES;
1911 3 : if (merge->absent == NULL && check->absent)
1912 : {
1913 1 : merge->n_absent = check->n_absent;
1914 1 : merge->absent = check->absent;
1915 1 : check->absent = NULL;
1916 : }
1917 2 : else if (merge->absent && check->absent)
1918 : {
1919 0 : check->absent = XRESIZEVEC (gfc_statement, check->absent,
1920 : merge->n_absent + check->n_absent);
1921 0 : for (int i = 0; i < merge->n_absent; i++)
1922 0 : if (!bitmap_bit_p (&absent_head, merge->absent[i]))
1923 0 : check->absent[check->n_absent++] = merge->absent[i];
1924 0 : free (merge->absent);
1925 0 : merge->absent = check->absent;
1926 0 : merge->n_absent = check->n_absent;
1927 0 : check->absent = NULL;
1928 : }
1929 3 : if (merge->contains == NULL && check->contains)
1930 : {
1931 0 : merge->n_contains = check->n_contains;
1932 0 : merge->contains = check->contains;
1933 0 : check->contains = NULL;
1934 : }
1935 3 : else if (merge->contains && check->contains)
1936 : {
1937 0 : check->contains = XRESIZEVEC (gfc_statement, check->contains,
1938 : merge->n_contains + check->n_contains);
1939 0 : for (int i = 0; i < merge->n_contains; i++)
1940 0 : if (!bitmap_bit_p (&contains_head, merge->contains[i]))
1941 0 : check->contains[check->n_contains++] = merge->contains[i];
1942 0 : free (merge->contains);
1943 0 : merge->contains = check->contains;
1944 0 : merge->n_contains = check->n_contains;
1945 0 : check->contains = NULL;
1946 : }
1947 : return MATCH_YES;
1948 : }
1949 :
1950 : /* OpenMP 5.0
1951 : uses_allocators ( allocator-list )
1952 :
1953 : allocator:
1954 : predefined-allocator
1955 : variable ( traits-array )
1956 :
1957 : OpenMP 5.2 deprecated, 6.0 deleted: 'variable ( traits-array )'
1958 :
1959 : OpenMP 5.2:
1960 : uses_allocators ( [modifier-list :] allocator-list )
1961 :
1962 : OpenMP 6.0:
1963 : uses_allocators ( [modifier-list :] allocator-list [; ...])
1964 :
1965 : allocator:
1966 : variable or predefined-allocator
1967 : modifier:
1968 : traits ( traits-array )
1969 : memspace ( mem-space-handle ) */
1970 :
1971 : static match
1972 78 : gfc_match_omp_clause_uses_allocators (gfc_omp_clauses *c)
1973 : {
1974 82 : parse_next:
1975 82 : gfc_symbol *memspace_sym = NULL;
1976 82 : gfc_symbol *traits_sym = NULL;
1977 82 : gfc_omp_namelist *head = NULL;
1978 82 : gfc_omp_namelist *p, *tail, **list;
1979 82 : int ntraits, nmemspace;
1980 82 : bool has_modifiers;
1981 82 : locus old_loc, cur_loc;
1982 :
1983 82 : gfc_gobble_whitespace ();
1984 82 : old_loc = gfc_current_locus;
1985 82 : ntraits = nmemspace = 0;
1986 126 : do
1987 : {
1988 104 : cur_loc = gfc_current_locus;
1989 104 : if (gfc_match ("traits ( %S ) ", &traits_sym) == MATCH_YES)
1990 34 : ntraits++;
1991 70 : else if (gfc_match ("memspace ( %S ) ", &memspace_sym) == MATCH_YES)
1992 33 : nmemspace++;
1993 104 : if (ntraits > 1 || nmemspace > 1)
1994 : {
1995 5 : gfc_error ("Duplicate %s modifier at %L in USES_ALLOCATORS clause",
1996 : ntraits > 1 ? "TRAITS" : "MEMSPACE", &cur_loc);
1997 5 : return MATCH_ERROR;
1998 : }
1999 99 : if (gfc_match (", ") == MATCH_YES)
2000 22 : continue;
2001 77 : if (gfc_match (": ") != MATCH_YES)
2002 : {
2003 : /* Assume no modifier. */
2004 39 : memspace_sym = traits_sym = NULL;
2005 39 : gfc_current_locus = old_loc;
2006 39 : break;
2007 : }
2008 : break;
2009 : } while (true);
2010 :
2011 115 : has_modifiers = traits_sym != NULL || memspace_sym != NULL;
2012 179 : do
2013 : {
2014 128 : p = gfc_get_omp_namelist ();
2015 128 : p->where = gfc_current_locus;
2016 128 : if (head == NULL)
2017 : head = tail = p;
2018 : else
2019 : {
2020 51 : tail->next = p;
2021 51 : tail = tail->next;
2022 : }
2023 128 : if (gfc_match ("%S ", &p->sym) != MATCH_YES)
2024 1 : goto error;
2025 127 : if (!has_modifiers)
2026 : {
2027 83 : if (gfc_match ("( %S ) ", &p->u2.traits_sym) == MATCH_YES)
2028 22 : gfc_warning (OPT_Wdeprecated_openmp,
2029 : "The specification of arguments to "
2030 : "%<uses_allocators%> at %L where each item is of "
2031 : "the form %<allocator(traits)%> is deprecated since "
2032 : "OpenMP 5.2; instead use %<uses_allocators(traits(%s"
2033 22 : "): %s)%>", &p->where, p->u2.traits_sym->name,
2034 22 : p->sym->name);
2035 : }
2036 44 : else if (gfc_peek_ascii_char () == '(')
2037 : {
2038 1 : gfc_error ("Unexpected %<(%> at %C");
2039 1 : goto error;
2040 : }
2041 : else
2042 : {
2043 43 : p->u.memspace_sym = memspace_sym;
2044 43 : p->u2.traits_sym = traits_sym;
2045 : }
2046 126 : gfc_gobble_whitespace ();
2047 126 : const char c = gfc_peek_ascii_char ();
2048 126 : if (c == ';' || c == ')')
2049 : break;
2050 53 : if (c != ',')
2051 : {
2052 2 : gfc_error ("Expected %<,%>, %<)%> or %<;%> at %C");
2053 2 : goto error;
2054 : }
2055 51 : gfc_match_char (',');
2056 51 : gfc_gobble_whitespace ();
2057 51 : } while (true);
2058 :
2059 73 : list = &c->lists[OMP_LIST_USES_ALLOCATORS];
2060 91 : while (*list)
2061 18 : list = &(*list)->next;
2062 73 : *list = head;
2063 :
2064 73 : if (gfc_match_char (';') == MATCH_YES)
2065 4 : goto parse_next;
2066 :
2067 69 : gfc_match_char (')');
2068 69 : return MATCH_YES;
2069 :
2070 4 : error:
2071 4 : gfc_free_omp_namelist (head, OMP_LIST_USES_ALLOCATORS);
2072 4 : return MATCH_ERROR;
2073 : }
2074 :
2075 :
2076 : /* Match the 'prefer_type' modifier of the interop 'init' clause:
2077 : with either OpenMP 5.1's
2078 : prefer_type ( <const-int-expr|string literal> [, ...]
2079 : or
2080 : prefer_type ( '{' <fr(...) | attr (...)>, ...] '}' [, '{' ... '}' ] )
2081 : where 'fr' takes a constant expression or a string literal
2082 : and 'attr takes a list of string literals, starting with 'ompx_')
2083 :
2084 : For the foreign runtime identifiers, string values are converted to
2085 : their integer value; unknown string or integer values are set to
2086 : GOMP_INTEROP_IFR_KNOWN.
2087 :
2088 : Data format:
2089 : For the foreign runtime identifiers, string values are converted to
2090 : their integer value; unknown string or integer values are set to 0.
2091 :
2092 : Each item (a) GOMP_INTEROP_IFR_SEPARATOR
2093 : (b) for any 'fr', its integer value.
2094 : Note: Spec only permits 1 'fr' entry (6.0; changed after TR13)
2095 : (c) GOMP_INTEROP_IFR_SEPARATOR
2096 : (d) list of \0-terminated non-empty strings for 'attr'
2097 : (e) '\0'
2098 : Tailing '\0'. */
2099 :
2100 : static match
2101 82 : gfc_match_omp_prefer_type (char **type_str, int *type_str_len)
2102 : {
2103 82 : gfc_expr *e;
2104 82 : std::string type_string, attr_string;
2105 : /* New syntax. */
2106 82 : if (gfc_peek_ascii_char () == '{')
2107 115 : do
2108 : {
2109 85 : attr_string.clear ();
2110 85 : type_string += (char) GOMP_INTEROP_IFR_SEPARATOR;
2111 85 : if (gfc_match ("{ ") != MATCH_YES)
2112 : {
2113 1 : gfc_error ("Expected %<{%> at %C");
2114 1 : return MATCH_ERROR;
2115 : }
2116 : bool fr_found = false;
2117 148 : do
2118 : {
2119 116 : if (gfc_match ("fr ( ") == MATCH_YES)
2120 : {
2121 62 : if (fr_found)
2122 : {
2123 1 : gfc_error ("Duplicated %<fr%> preference-selector-name "
2124 : "at %C");
2125 1 : return MATCH_ERROR;
2126 : }
2127 61 : fr_found = true;
2128 61 : do
2129 : {
2130 61 : bool found_literal = false;
2131 61 : match m = MATCH_YES;
2132 61 : if (gfc_match_literal_constant (&e, false) == MATCH_YES)
2133 : found_literal = true;
2134 : else
2135 12 : m = gfc_match_expr (&e);
2136 12 : if (m != MATCH_YES
2137 61 : || !gfc_resolve_expr (e)
2138 61 : || e->rank != 0
2139 60 : || e->expr_type != EXPR_CONSTANT
2140 59 : || (e->ts.type != BT_INTEGER
2141 43 : && (!found_literal || e->ts.type != BT_CHARACTER))
2142 58 : || (e->ts.type == BT_INTEGER
2143 16 : && !mpz_fits_sint_p (e->value.integer))
2144 70 : || (e->ts.type == BT_CHARACTER
2145 42 : && (e->ts.kind != gfc_default_character_kind
2146 41 : || e->value.character.length == 0)))
2147 : {
2148 5 : gfc_error ("Expected constant scalar integer expression"
2149 : " or non-empty default-kind character "
2150 5 : "literal at %L", &e->where);
2151 5 : gfc_free_expr (e);
2152 5 : return MATCH_ERROR;
2153 : }
2154 56 : gfc_gobble_whitespace ();
2155 56 : int val;
2156 56 : if (e->ts.type == BT_INTEGER)
2157 : {
2158 16 : val = mpz_get_si (e->value.integer);
2159 16 : if (val < 1 || val > GOMP_INTEROP_IFR_LAST)
2160 : {
2161 0 : gfc_warning_now (OPT_Wopenmp,
2162 : "Unknown foreign runtime "
2163 : "identifier %qd at %L",
2164 : val, &e->where);
2165 0 : val = GOMP_INTEROP_IFR_UNKNOWN;
2166 : }
2167 : }
2168 : else
2169 : {
2170 40 : char *str = XALLOCAVEC (char,
2171 : e->value.character.length+1);
2172 229 : for (int i = 0; i < e->value.character.length + 1; i++)
2173 189 : str[i] = e->value.character.string[i];
2174 40 : if (memchr (str, '\0', e->value.character.length) != 0)
2175 : {
2176 0 : gfc_error ("Unexpected null character in character "
2177 : "literal at %L", &e->where);
2178 0 : return MATCH_ERROR;
2179 : }
2180 40 : val = omp_get_fr_id_from_name (str);
2181 40 : if (val == GOMP_INTEROP_IFR_UNKNOWN)
2182 2 : gfc_warning_now (OPT_Wopenmp,
2183 : "Unknown foreign runtime identifier "
2184 2 : "%qs at %L", str, &e->where);
2185 : }
2186 :
2187 56 : type_string += (char) val;
2188 56 : if (gfc_match (") ") == MATCH_YES)
2189 : break;
2190 4 : gfc_error ("Expected %<)%> at %C");
2191 4 : return MATCH_ERROR;
2192 : }
2193 : while (true);
2194 : }
2195 54 : else if (gfc_match ("attr ( ") == MATCH_YES)
2196 : {
2197 60 : do
2198 : {
2199 57 : if (gfc_match_literal_constant (&e, false) != MATCH_YES
2200 56 : || !gfc_resolve_expr (e)
2201 56 : || e->expr_type != EXPR_CONSTANT
2202 56 : || e->rank != 0
2203 56 : || e->ts.type != BT_CHARACTER
2204 113 : || e->ts.kind != gfc_default_character_kind)
2205 : {
2206 1 : gfc_error ("Expected default-kind character literal "
2207 1 : "at %L", &e->where);
2208 1 : gfc_free_expr (e);
2209 1 : return MATCH_ERROR;
2210 : }
2211 56 : gfc_gobble_whitespace ();
2212 56 : char *str = XALLOCAVEC (char, e->value.character.length+1);
2213 564 : for (int i = 0; i < e->value.character.length + 1; i++)
2214 508 : str[i] = e->value.character.string[i];
2215 56 : if (!startswith (str, "ompx_"))
2216 : {
2217 1 : gfc_error ("Character literal at %L must start with "
2218 : "%<ompx_%>", &e->where);
2219 1 : gfc_free_expr (e);
2220 1 : return MATCH_ERROR;
2221 : }
2222 55 : if (memchr (str, '\0', e->value.character.length) != 0
2223 55 : || memchr (str, ',', e->value.character.length) != 0)
2224 : {
2225 1 : gfc_error ("Unexpected null or %<,%> character in "
2226 : "character literal at %L", &e->where);
2227 1 : return MATCH_ERROR;
2228 : }
2229 54 : attr_string += str;
2230 54 : attr_string += '\0';
2231 54 : if (gfc_match (", ") == MATCH_YES)
2232 3 : continue;
2233 51 : if (gfc_match (") ") == MATCH_YES)
2234 : break;
2235 0 : gfc_error ("Expected %<,%> or %<)%> at %C");
2236 0 : return MATCH_ERROR;
2237 3 : }
2238 : while (true);
2239 : }
2240 : else
2241 : {
2242 0 : gfc_error ("Expected %<fr(%> or %<attr(%> at %C");
2243 0 : return MATCH_ERROR;
2244 : }
2245 103 : if (gfc_match (", ") == MATCH_YES)
2246 32 : continue;
2247 71 : if (gfc_match ("} ") == MATCH_YES)
2248 : break;
2249 2 : gfc_error ("Expected %<,%> or %<}%> at %C");
2250 2 : return MATCH_ERROR;
2251 32 : }
2252 : while (true);
2253 69 : type_string += (char) GOMP_INTEROP_IFR_SEPARATOR;
2254 69 : type_string += attr_string;
2255 69 : type_string += '\0';
2256 69 : if (gfc_match (", ") == MATCH_YES)
2257 30 : continue;
2258 39 : if (gfc_match (") ") == MATCH_YES)
2259 : break;
2260 1 : gfc_error ("Expected %<,%> or %<)%> at %C");
2261 1 : return MATCH_ERROR;
2262 30 : }
2263 : while (true);
2264 : else
2265 75 : do
2266 : {
2267 51 : type_string += (char) GOMP_INTEROP_IFR_SEPARATOR;
2268 51 : bool found_literal = false;
2269 51 : match m = MATCH_YES;
2270 51 : if (gfc_match_literal_constant (&e, false) == MATCH_YES)
2271 : found_literal = true;
2272 : else
2273 19 : m = gfc_match_expr (&e);
2274 19 : if (m != MATCH_YES
2275 51 : || !gfc_resolve_expr (e)
2276 51 : || e->rank != 0
2277 50 : || e->expr_type != EXPR_CONSTANT
2278 49 : || (e->ts.type != BT_INTEGER
2279 28 : && (!found_literal || e->ts.type != BT_CHARACTER))
2280 48 : || (e->ts.type == BT_INTEGER
2281 21 : && !mpz_fits_sint_p (e->value.integer))
2282 67 : || (e->ts.type == BT_CHARACTER
2283 27 : && (e->ts.kind != gfc_default_character_kind
2284 27 : || e->value.character.length == 0)))
2285 : {
2286 3 : gfc_error ("Expected constant scalar integer expression or "
2287 3 : "non-empty default-kind character literal at %L", &e->where);
2288 3 : gfc_free_expr (e);
2289 3 : return MATCH_ERROR;
2290 : }
2291 48 : gfc_gobble_whitespace ();
2292 48 : int val;
2293 48 : if (e->ts.type == BT_INTEGER)
2294 : {
2295 21 : val = mpz_get_si (e->value.integer);
2296 21 : if (val < 1 || val > GOMP_INTEROP_IFR_LAST)
2297 : {
2298 3 : gfc_warning_now (OPT_Wopenmp,
2299 : "Unknown foreign runtime identifier %qd at %L",
2300 : val, &e->where);
2301 3 : val = 0;
2302 : }
2303 : }
2304 : else
2305 : {
2306 27 : char *str = XALLOCAVEC (char, e->value.character.length+1);
2307 169 : for (int i = 0; i < e->value.character.length + 1; i++)
2308 142 : str[i] = e->value.character.string[i];
2309 27 : if (memchr (str, '\0', e->value.character.length) != 0)
2310 : {
2311 0 : gfc_error ("Unexpected null character in character "
2312 : "literal at %L", &e->where);
2313 0 : return MATCH_ERROR;
2314 : }
2315 27 : val = omp_get_fr_id_from_name (str);
2316 27 : if (val == GOMP_INTEROP_IFR_UNKNOWN)
2317 5 : gfc_warning_now (OPT_Wopenmp,
2318 : "Unknown foreign runtime identifier %qs at %L",
2319 5 : str, &e->where);
2320 : }
2321 48 : type_string += (char) val;
2322 48 : type_string += (char) GOMP_INTEROP_IFR_SEPARATOR;
2323 48 : type_string += '\0';
2324 48 : gfc_free_expr (e);
2325 48 : if (gfc_match (", ") == MATCH_YES)
2326 24 : continue;
2327 24 : if (gfc_match (") ") == MATCH_YES)
2328 : break;
2329 2 : gfc_error ("Expected %<,%> or %<)%> at %C");
2330 2 : return MATCH_ERROR;
2331 24 : }
2332 : while (true);
2333 60 : type_string += '\0';
2334 60 : *type_str_len = type_string.length();
2335 60 : *type_str = XNEWVEC (char, type_string.length ());
2336 60 : memcpy (*type_str, type_string.data (), type_string.length ());
2337 60 : return MATCH_YES;
2338 82 : }
2339 :
2340 :
2341 : /* Match OpenMP 5.1's 'init'-clause modifiers, used by the 'init' clause of
2342 : the 'interop' directive and the 'append_args' directive of 'declare variant'.
2343 : [prefer_type(...)][,][<target|targetsync>, ...])
2344 :
2345 : If is_init_clause, the modifier parsing ends with a ':'.
2346 : If not is_init_clause (i.e. append_args), the parsing ends with ')'. */
2347 :
2348 : static match
2349 164 : gfc_parser_omp_clause_init_modifiers (bool &target, bool &targetsync,
2350 : char **type_str, int &type_str_len,
2351 : bool is_init_clause)
2352 : {
2353 164 : target = false;
2354 164 : targetsync = false;
2355 164 : *type_str = NULL;
2356 164 : type_str_len = 0;
2357 286 : match m;
2358 :
2359 286 : do
2360 : {
2361 286 : if (gfc_match ("prefer_type ( ") == MATCH_YES)
2362 : {
2363 83 : if (*type_str)
2364 : {
2365 1 : gfc_error ("Duplicate %<prefer_type%> modifier at %C");
2366 1 : return MATCH_ERROR;
2367 : }
2368 82 : m = gfc_match_omp_prefer_type (type_str, &type_str_len);
2369 82 : if (m != MATCH_YES)
2370 : return m;
2371 60 : if (gfc_match (", ") == MATCH_YES)
2372 14 : continue;
2373 46 : if (is_init_clause)
2374 : {
2375 24 : if (gfc_match (": ") == MATCH_YES)
2376 : break;
2377 0 : gfc_error ("Expected %<,%> or %<:%> at %C");
2378 : }
2379 : else
2380 : {
2381 22 : if (gfc_match (") ") == MATCH_YES)
2382 : break;
2383 0 : gfc_error ("Expected %<,%> or %<)%> at %C");
2384 : }
2385 : return MATCH_ERROR;
2386 : }
2387 :
2388 203 : if (gfc_match ("prefer_type ") == MATCH_YES)
2389 : {
2390 2 : gfc_error ("Expected %<(%> after %<prefer_type%> at %C");
2391 2 : return MATCH_ERROR;
2392 : }
2393 :
2394 201 : if (gfc_match ("targetsync ") == MATCH_YES)
2395 : {
2396 57 : if (targetsync)
2397 : {
2398 3 : gfc_error ("Duplicate %<targetsync%> at %C");
2399 3 : return MATCH_ERROR;
2400 : }
2401 54 : targetsync = true;
2402 54 : if (gfc_match (", ") == MATCH_YES)
2403 13 : continue;
2404 41 : if (!is_init_clause)
2405 : {
2406 23 : if (gfc_match (") ") == MATCH_YES)
2407 : break;
2408 0 : gfc_error ("Expected %<,%> or %<)%> at %C");
2409 0 : return MATCH_ERROR;
2410 : }
2411 18 : if (gfc_match (": ") == MATCH_YES)
2412 : break;
2413 1 : gfc_error ("Expected %<,%> or %<:%> at %C");
2414 1 : return MATCH_ERROR;
2415 : }
2416 144 : if (gfc_match ("target ") == MATCH_YES)
2417 : {
2418 135 : if (target)
2419 : {
2420 3 : gfc_error ("Duplicate %<target%> at %C");
2421 3 : return MATCH_ERROR;
2422 : }
2423 132 : target = true;
2424 132 : if (gfc_match (", ") == MATCH_YES)
2425 95 : continue;
2426 37 : if (!is_init_clause)
2427 : {
2428 11 : if (gfc_match (") ") == MATCH_YES)
2429 : break;
2430 0 : gfc_error ("Expected %<,%> or %<)%> at %C");
2431 0 : return MATCH_ERROR;
2432 : }
2433 26 : if (gfc_match (": ") == MATCH_YES)
2434 : break;
2435 1 : gfc_error ("Expected %<,%> or %<:%> at %C");
2436 1 : return MATCH_ERROR;
2437 : }
2438 9 : gfc_error ("Expected %<prefer_type%>, %<target%>, or %<targetsync%> "
2439 : "at %C");
2440 9 : return MATCH_ERROR;
2441 : }
2442 : while (true);
2443 :
2444 122 : if (!target && !targetsync)
2445 : {
2446 4 : gfc_error ("Missing required %<target%> and/or %<targetsync%> "
2447 : "modifier at %C");
2448 4 : return MATCH_ERROR;
2449 : }
2450 : return MATCH_YES;
2451 : }
2452 :
2453 : /* Match OpenMP 5.1's 'init' clause for 'interop' objects:
2454 : init([prefer_type(...)][,][<target|targetsync>, ...] :] interop-obj-list) */
2455 :
2456 : static match
2457 108 : gfc_match_omp_init (gfc_omp_namelist **list)
2458 : {
2459 108 : bool target, targetsync;
2460 108 : char *type_str = NULL;
2461 108 : int type_str_len;
2462 108 : if (gfc_parser_omp_clause_init_modifiers (target, targetsync, &type_str,
2463 : type_str_len, true) == MATCH_ERROR)
2464 : return MATCH_ERROR;
2465 :
2466 64 : gfc_omp_namelist **head = NULL;
2467 64 : if (gfc_match_omp_variable_list ("", list, false, NULL, &head) != MATCH_YES)
2468 : return MATCH_ERROR;
2469 147 : for (gfc_omp_namelist *n = *head; n; n = n->next)
2470 : {
2471 84 : n->u.init.target = target;
2472 84 : n->u.init.targetsync = targetsync;
2473 84 : n->u.init.len = type_str_len;
2474 84 : n->u2.init_interop = type_str;
2475 : }
2476 : return MATCH_YES;
2477 : }
2478 :
2479 : /* Match boolean-type clause with duplicate check. Matches 'name' then matches
2480 : an optional '(const-logical-expr)'; already_set is used for the duplicate
2481 : check. If the clause is not matched NO is returned, if an error occurs ERROR
2482 : and otherwise YES. In the no-error case RES contains the value of the
2483 : expression or true if no expression exists.
2484 : If FALSE_OK, 'false' implies an absent clause, which can be repeated without
2485 : printing an error; that is the case for clause groups.
2486 : If DUPL_MSG is nonnull, the string is used as error message and must contain
2487 : %qs and %L in that order. */
2488 :
2489 : static match
2490 3748 : gfc_match_boolean_clause (bool *res, const char *name, bool already_set,
2491 : bool false_ok = false, const char *dupl_msg = NULL)
2492 : {
2493 3748 : gfc_expr *expr = NULL;
2494 3748 : match m;
2495 3748 : char c;
2496 3748 : locus old_loc = gfc_current_locus;
2497 3748 : locus old_loc2;
2498 3748 : if ((m = gfc_match (name)) != MATCH_YES)
2499 : return m;
2500 : /* Ensure that no partial string is matched. */
2501 2506 : if (gfc_current_form == FORM_FREE
2502 2506 : && gfc_match_eos () != MATCH_YES
2503 3254 : && ((c = gfc_peek_ascii_char ()) == '_' || ISALNUM (c)))
2504 : {
2505 1 : gfc_current_locus = old_loc;
2506 1 : return MATCH_NO;
2507 : }
2508 2505 : if (already_set && !false_ok)
2509 22 : goto dupl;
2510 2483 : if (gfc_match (" (") == MATCH_NO)
2511 : {
2512 2289 : if (already_set)
2513 3 : goto dupl;
2514 2286 : *res = true; /* Implicit boolean true. */
2515 2286 : return MATCH_YES;
2516 : }
2517 194 : old_loc2 = gfc_current_locus;
2518 194 : m = gfc_match_expr (&expr);
2519 194 : if (m != MATCH_YES
2520 193 : || gfc_match (" )") != MATCH_YES
2521 188 : || !gfc_resolve_expr (expr)
2522 188 : || expr->rank != 0
2523 187 : || expr->expr_type != EXPR_CONSTANT
2524 379 : || expr->ts.type != BT_LOGICAL)
2525 : {
2526 13 : gfc_free_expr (expr);
2527 13 : gfc_error ("Expected %<( const-logical-expr )%> at %L", &old_loc2);
2528 13 : return MATCH_ERROR;
2529 : }
2530 181 : if (already_set && expr->value.logical)
2531 4 : goto dupl;
2532 177 : *res = expr->value.logical;
2533 177 : gfc_free_expr (expr);
2534 177 : return MATCH_YES;
2535 :
2536 29 : dupl:
2537 29 : if (dupl_msg)
2538 12 : gfc_error (dupl_msg, name, &old_loc);
2539 : else
2540 17 : gfc_error ("Duplicated %qs clause at %L", name, &old_loc);
2541 : return MATCH_ERROR;
2542 : }
2543 :
2544 :
2545 : /* Match a clause from the atomic clauses set. */
2546 :
2547 : static match
2548 1231 : gfc_match_dupl_atomic (bool *res, const char *name, bool already_set)
2549 : {
2550 1231 : const char *msg = G_("Duplicated atomic clause: unexpected %qs clause at %L");
2551 0 : return gfc_match_boolean_clause (res, name, already_set, true, msg);
2552 : }
2553 :
2554 :
2555 : /* Match a clause from the memory-order clauses set. */
2556 :
2557 : static match
2558 451 : gfc_match_dupl_memorder (bool *res, const char *name, bool already_set)
2559 : {
2560 451 : const char *msg = G_("Duplicated memory-order clause: unexpected %qs clause "
2561 : "at %L");
2562 0 : return gfc_match_boolean_clause (res, name, already_set, true, msg);
2563 : }
2564 :
2565 :
2566 : /* Match a clause from the branch clauses set; interestingly, here
2567 : inbranch(false) branch(false/true) is not permitted! */
2568 :
2569 : static match
2570 62 : gfc_match_dupl_branch_clause (bool *res, const char *name, bool already_set)
2571 : {
2572 62 : const char *msg = G_("Duplicated branch clause: unexpected %qs clause "
2573 : "at %L");
2574 62 : return gfc_match_boolean_clause (res, name, already_set, false, msg);
2575 : }
2576 :
2577 :
2578 : /* Match with duplicate check. Matches 'name'. If expr != NULL, it
2579 : then matches '(expr)', otherwise, if open_parens is true,
2580 : it matches a ' ( ' after 'name'. */
2581 :
2582 : static match
2583 20454 : gfc_match_dupl_check (bool not_dupl, const char *name, bool open_parens = false,
2584 : gfc_expr **expr = NULL)
2585 : {
2586 20454 : match m;
2587 20454 : char c;
2588 20454 : locus old_loc = gfc_current_locus;
2589 20454 : if ((m = gfc_match (name)) != MATCH_YES)
2590 : return m;
2591 : /* Ensure that no partial string is matched. */
2592 16055 : if (gfc_current_form == FORM_FREE
2593 15557 : && gfc_match_eos () != MATCH_YES
2594 29148 : && ((c = gfc_peek_ascii_char ()) == '_' || ISALNUM (c)))
2595 : {
2596 12 : gfc_current_locus = old_loc;
2597 12 : return MATCH_NO;
2598 : }
2599 16043 : if (!not_dupl)
2600 : {
2601 46 : gfc_error ("Duplicated %qs clause at %L", name, &old_loc);
2602 46 : return MATCH_ERROR;
2603 : }
2604 15997 : if (open_parens || expr)
2605 : {
2606 10201 : if (gfc_match (" ( ") != MATCH_YES)
2607 : {
2608 25 : gfc_error ("Expected %<(%> after %qs at %C", name);
2609 25 : return MATCH_ERROR;
2610 : }
2611 10176 : if (expr)
2612 : {
2613 3289 : if (gfc_match ("%e )", expr) != MATCH_YES)
2614 : {
2615 9 : gfc_error ("Invalid expression after %<%s(%> at %C", name);
2616 9 : return MATCH_ERROR;
2617 : }
2618 : }
2619 : }
2620 : return MATCH_YES;
2621 : }
2622 :
2623 : /* Search upwards though namespace NS and its parents to find an
2624 : !$omp declare mapper named MAPPER_ID, for typespec TS. The default
2625 : mapper has mapper_id == "". */
2626 :
2627 : gfc_omp_udm *
2628 1002 : gfc_find_omp_udm (gfc_namespace *ns, const char *mapper_id, gfc_typespec *ts)
2629 : {
2630 1002 : gfc_symtree *st;
2631 :
2632 1002 : if (ns == NULL)
2633 0 : ns = gfc_current_ns;
2634 :
2635 1181 : do
2636 : {
2637 1181 : gfc_omp_udm *omp_udm;
2638 :
2639 1181 : st = gfc_find_symtree (ns->omp_udm_root, mapper_id);
2640 :
2641 1181 : if (st != NULL)
2642 : {
2643 29 : for (omp_udm = st->n.omp_udm; omp_udm; omp_udm = omp_udm->next)
2644 29 : if (gfc_compare_types (&omp_udm->ts, ts))
2645 : return omp_udm;
2646 : }
2647 :
2648 : /* Don't escape an interface block. */
2649 1154 : if (ns && !ns->has_import_set
2650 1154 : && ns->proc_name && ns->proc_name->attr.if_source == IFSRC_IFBODY)
2651 : break;
2652 :
2653 1154 : ns = ns->parent;
2654 : }
2655 1154 : while (ns != NULL);
2656 :
2657 : return NULL;
2658 : }
2659 :
2660 :
2661 : /* Match OpenMP and OpenACC directive clauses. MASK is a bitmask of
2662 : clauses that are allowed for a particular directive. */
2663 :
2664 : static match
2665 35271 : gfc_match_omp_clauses (gfc_omp_clauses **cp, const omp_mask mask,
2666 : bool first_no_comma = true, bool needs_space = true,
2667 : bool openacc = false, bool openmp_target = false,
2668 : gfc_omp_map_op default_map_op = OMP_MAP_TOFROM)
2669 : {
2670 35271 : bool error = false;
2671 35271 : bool bval;
2672 35271 : gfc_omp_clauses *c = gfc_get_omp_clauses ();
2673 35271 : gfc_omp_clauses *cfalse = openacc ? NULL : gfc_get_omp_clauses ();
2674 21403 : locus old_loc;
2675 : /* Determine whether we're dealing with an OpenACC directive that permits
2676 : derived type member accesses. This in particular disallows
2677 : "!$acc declare" from using such accesses, because it's not clear if/how
2678 : that should work. */
2679 21403 : bool allow_derived = (openacc
2680 13868 : && ((mask & OMP_CLAUSE_ATTACH)
2681 6326 : || (mask & OMP_CLAUSE_DETACH)));
2682 :
2683 35271 : gcc_checking_assert (OMP_MASK1_LAST <= 64 && OMP_MASK2_LAST <= 64);
2684 35271 : *cp = NULL;
2685 129551 : while (1)
2686 : {
2687 82411 : match m = MATCH_NO;
2688 82318 : if ((first_no_comma || (m = gfc_match_char (',')) != MATCH_YES)
2689 164284 : && (needs_space && gfc_match_space () != MATCH_YES))
2690 : break;
2691 77872 : needs_space = false;
2692 77872 : first_no_comma = false;
2693 77872 : gfc_gobble_whitespace ();
2694 77872 : bool end_colon;
2695 77872 : gfc_omp_namelist **head;
2696 77872 : old_loc = gfc_current_locus;
2697 77872 : char pc = gfc_peek_ascii_char ();
2698 77872 : if (pc == '\n' && m == MATCH_YES)
2699 : {
2700 1 : gfc_error ("Clause expected at %C after trailing comma");
2701 1 : goto error;
2702 : }
2703 77871 : switch (pc)
2704 : {
2705 1339 : case 'a':
2706 1339 : end_colon = false;
2707 1339 : head = NULL;
2708 1364 : if ((mask & OMP_CLAUSE_ASSUMPTIONS)
2709 1339 : && gfc_match ("absent ( ") == MATCH_YES)
2710 : {
2711 28 : if (gfc_omp_absent_contains_clause (&c->assume, true)
2712 : != MATCH_YES)
2713 3 : goto error;
2714 25 : continue;
2715 : }
2716 1311 : if ((mask & OMP_CLAUSE_ALIGNED)
2717 1311 : && gfc_match_omp_variable_list ("aligned (",
2718 : &c->lists[OMP_LIST_ALIGNED],
2719 : false, &end_colon,
2720 : &head) == MATCH_YES)
2721 : {
2722 112 : gfc_expr *alignment = NULL;
2723 112 : gfc_omp_namelist *n;
2724 :
2725 112 : if (end_colon && gfc_match (" %e )", &alignment) != MATCH_YES)
2726 : {
2727 0 : gfc_free_omp_namelist (*head, OMP_LIST_ALIGNED);
2728 0 : gfc_current_locus = old_loc;
2729 0 : *head = NULL;
2730 0 : break;
2731 : }
2732 268 : for (n = *head; n; n = n->next)
2733 156 : if (n->next && alignment)
2734 42 : n->expr = gfc_copy_expr (alignment);
2735 : else
2736 114 : n->expr = alignment;
2737 112 : continue;
2738 112 : }
2739 1218 : if ((mask & OMP_CLAUSE_MEMORDER)
2740 1234 : && (m = gfc_match_dupl_memorder (&bval, "acq_rel",
2741 35 : c->memorder != OMP_MEMORDER_UNSET)) != MATCH_NO)
2742 : {
2743 19 : if (m == MATCH_ERROR)
2744 0 : goto error;
2745 19 : if (bval)
2746 12 : c->memorder = OMP_MEMORDER_ACQ_REL;
2747 19 : continue;
2748 : }
2749 1196 : if ((mask & OMP_CLAUSE_MEMORDER)
2750 1196 : && (m = gfc_match_dupl_memorder (&bval, "acquire",
2751 16 : c->memorder != OMP_MEMORDER_UNSET)) != MATCH_NO)
2752 : {
2753 16 : if (m == MATCH_ERROR)
2754 0 : goto error;
2755 16 : if (bval)
2756 9 : c->memorder = OMP_MEMORDER_ACQUIRE;
2757 16 : continue;
2758 : }
2759 1164 : if ((mask & OMP_CLAUSE_AFFINITY)
2760 1164 : && gfc_match ("affinity ( ") == MATCH_YES)
2761 : {
2762 41 : gfc_namespace *ns_iter = NULL, *ns_curr = gfc_current_ns;
2763 41 : m = gfc_match_iterator (&ns_iter, true);
2764 41 : if (m == MATCH_ERROR)
2765 : break;
2766 31 : if (m == MATCH_YES && gfc_match (" : ") != MATCH_YES)
2767 : {
2768 1 : gfc_error ("Expected %<:%> at %C");
2769 1 : break;
2770 : }
2771 30 : if (ns_iter)
2772 18 : gfc_current_ns = ns_iter;
2773 30 : head = NULL;
2774 30 : m = gfc_match_omp_variable_list ("", &c->lists[OMP_LIST_AFFINITY],
2775 : false, NULL, &head, true);
2776 30 : gfc_current_ns = ns_curr;
2777 30 : if (m == MATCH_ERROR)
2778 : break;
2779 27 : if (ns_iter)
2780 : {
2781 45 : for (gfc_omp_namelist *n = *head; n; n = n->next)
2782 : {
2783 27 : n->u2.ns = ns_iter;
2784 27 : ns_iter->refs++;
2785 : }
2786 : }
2787 27 : continue;
2788 27 : }
2789 1123 : if ((mask & OMP_CLAUSE_ALLOCATE)
2790 1123 : && gfc_match ("allocate ( ") == MATCH_YES)
2791 : {
2792 281 : gfc_expr *allocator = NULL;
2793 281 : gfc_expr *align = NULL;
2794 281 : old_loc = gfc_current_locus;
2795 281 : if ((m = gfc_match ("allocator ( %e )", &allocator)) == MATCH_YES)
2796 50 : gfc_match (" , align ( %e )", &align);
2797 231 : else if ((m = gfc_match ("align ( %e )", &align)) == MATCH_YES)
2798 29 : gfc_match (" , allocator ( %e )", &allocator);
2799 :
2800 79 : if (m == MATCH_YES)
2801 : {
2802 79 : if (gfc_match (" : ") != MATCH_YES)
2803 : {
2804 5 : gfc_error ("Expected %<:%> at %C");
2805 8 : goto error;
2806 : }
2807 : }
2808 : else
2809 : {
2810 202 : m = gfc_match_expr (&allocator);
2811 202 : if (m == MATCH_YES && gfc_match (" : ") != MATCH_YES)
2812 : {
2813 : /* If no ":" then there is no allocator, we backtrack
2814 : and read the variable list. */
2815 101 : gfc_free_expr (allocator);
2816 101 : allocator = NULL;
2817 101 : gfc_current_locus = old_loc;
2818 : }
2819 : }
2820 276 : gfc_omp_namelist **head = NULL;
2821 276 : m = gfc_match_omp_variable_list ("", &c->lists[OMP_LIST_ALLOCATE],
2822 : true, NULL, &head);
2823 :
2824 276 : if (m != MATCH_YES)
2825 : {
2826 3 : gfc_free_expr (allocator);
2827 3 : gfc_free_expr (align);
2828 3 : gfc_error ("Expected variable list at %C");
2829 3 : goto error;
2830 : }
2831 :
2832 729 : for (gfc_omp_namelist *n = *head; n; n = n->next)
2833 : {
2834 456 : n->u2.allocator = allocator;
2835 456 : n->u.align = (align) ? gfc_copy_expr (align) : NULL;
2836 : }
2837 273 : gfc_free_expr (align);
2838 273 : continue;
2839 273 : }
2840 905 : if ((mask & OMP_CLAUSE_AT)
2841 842 : && (m = gfc_match_dupl_check (c->at == OMP_AT_UNSET, "at", true))
2842 : != MATCH_NO)
2843 : {
2844 69 : if (m == MATCH_ERROR)
2845 2 : goto error;
2846 67 : if (gfc_match ("compilation )") == MATCH_YES)
2847 15 : c->at = OMP_AT_COMPILATION;
2848 52 : else if (gfc_match ("execution )") == MATCH_YES)
2849 48 : c->at = OMP_AT_EXECUTION;
2850 : else
2851 : {
2852 4 : gfc_error ("Expected COMPILATION or EXECUTION in AT clause "
2853 : "at %C");
2854 4 : goto error;
2855 : }
2856 63 : continue;
2857 : }
2858 1416 : if ((mask & OMP_CLAUSE_ASYNC)
2859 773 : && (m = gfc_match_dupl_check (!c->async, "async")) != MATCH_NO)
2860 : {
2861 643 : if (m == MATCH_ERROR)
2862 0 : goto error;
2863 643 : c->async = true;
2864 643 : m = gfc_match (" ( %e )", &c->async_expr);
2865 643 : if (m == MATCH_ERROR)
2866 : {
2867 0 : gfc_current_locus = old_loc;
2868 0 : break;
2869 : }
2870 643 : else if (m == MATCH_NO)
2871 : {
2872 133 : c->async_expr
2873 133 : = gfc_get_constant_expr (BT_INTEGER,
2874 : gfc_default_integer_kind,
2875 : &gfc_current_locus);
2876 133 : mpz_set_si (c->async_expr->value.integer, GOMP_ASYNC_NOVAL);
2877 : }
2878 643 : continue;
2879 : }
2880 193 : if ((mask & OMP_CLAUSE_AUTO)
2881 130 : && (m = gfc_match_dupl_check (!c->par_auto, "auto"))
2882 : != MATCH_NO)
2883 : {
2884 63 : if (m == MATCH_ERROR)
2885 0 : goto error;
2886 63 : c->par_auto = true;
2887 63 : continue;
2888 : }
2889 128 : if ((mask & OMP_CLAUSE_ATTACH)
2890 62 : && gfc_match ("attach ( ") == MATCH_YES
2891 128 : && gfc_match_omp_map_clause (&c->lists[OMP_LIST_MAP],
2892 : OMP_MAP_ATTACH, false,
2893 : allow_derived))
2894 61 : continue;
2895 : break;
2896 36 : case 'b':
2897 70 : if ((mask & OMP_CLAUSE_BIND)
2898 36 : && (m = gfc_match_dupl_check (c->bind == OMP_BIND_UNSET, "bind",
2899 : true)) != MATCH_NO)
2900 : {
2901 36 : if (m == MATCH_ERROR)
2902 1 : goto error;
2903 35 : if (gfc_match ("teams )") == MATCH_YES)
2904 11 : c->bind = OMP_BIND_TEAMS;
2905 24 : else if (gfc_match ("parallel )") == MATCH_YES)
2906 15 : c->bind = OMP_BIND_PARALLEL;
2907 9 : else if (gfc_match ("thread )") == MATCH_YES)
2908 8 : c->bind = OMP_BIND_THREAD;
2909 : else
2910 : {
2911 1 : gfc_error ("Expected TEAMS, PARALLEL or THREAD as binding in "
2912 : "BIND at %C");
2913 1 : break;
2914 : }
2915 34 : continue;
2916 : }
2917 : break;
2918 7123 : case 'c':
2919 7399 : if ((mask & OMP_CLAUSE_CAPTURE)
2920 7571 : && (m = gfc_match_boolean_clause (&bval, "capture",
2921 448 : c->capture || cfalse->capture)) != MATCH_NO)
2922 : {
2923 277 : if (m == MATCH_ERROR)
2924 1 : goto error;
2925 276 : if (bval)
2926 273 : c->capture = true;
2927 : else
2928 3 : cfalse->capture = true;
2929 276 : continue;
2930 : }
2931 6846 : if (mask & OMP_CLAUSE_COLLAPSE)
2932 : {
2933 1996 : gfc_expr *cexpr = NULL;
2934 1996 : if ((m = gfc_match_dupl_check (!c->collapse, "collapse", true,
2935 : &cexpr)) != MATCH_NO)
2936 : {
2937 1506 : int collapse;
2938 1506 : if (m == MATCH_ERROR)
2939 0 : goto error;
2940 1506 : if (gfc_extract_int (cexpr, &collapse, -1))
2941 4 : collapse = 1;
2942 1502 : else if (collapse <= 0)
2943 : {
2944 8 : gfc_error_now ("COLLAPSE clause argument not constant "
2945 : "positive integer at %C");
2946 8 : collapse = 1;
2947 : }
2948 1506 : gfc_free_expr (cexpr);
2949 1506 : c->collapse = collapse;
2950 1506 : continue;
2951 1506 : }
2952 : }
2953 5510 : if ((mask & OMP_CLAUSE_COMPARE)
2954 5511 : && (m = gfc_match_boolean_clause (&bval, "compare",
2955 171 : c->compare || cfalse->compare)) != MATCH_NO)
2956 : {
2957 171 : if (m == MATCH_ERROR)
2958 1 : goto error;
2959 170 : if (bval)
2960 167 : c->compare = true;
2961 : else
2962 3 : cfalse->compare = true;
2963 170 : continue;
2964 : }
2965 5182 : if ((mask & OMP_CLAUSE_ASSUMPTIONS)
2966 5169 : && gfc_match ("contains ( ") == MATCH_YES)
2967 : {
2968 19 : if (gfc_omp_absent_contains_clause (&c->assume, false)
2969 : != MATCH_YES)
2970 6 : goto error;
2971 13 : continue;
2972 : }
2973 7266 : if ((mask & OMP_CLAUSE_COPY)
2974 3723 : && gfc_match ("copy ( ") == MATCH_YES
2975 7267 : && gfc_match_omp_map_clause (&c->lists[OMP_LIST_MAP],
2976 : OMP_MAP_TOFROM, true,
2977 : allow_derived))
2978 2116 : continue;
2979 3034 : if (mask & OMP_CLAUSE_COPYIN)
2980 : {
2981 2628 : if (openacc)
2982 : {
2983 2529 : if (gfc_match ("copyin ( ") == MATCH_YES)
2984 : {
2985 1458 : bool readonly = gfc_match ("readonly : ") == MATCH_YES;
2986 1458 : head = NULL;
2987 1458 : if (gfc_match_omp_variable_list ("",
2988 : &c->lists[OMP_LIST_MAP],
2989 : true, NULL, &head, true,
2990 : allow_derived)
2991 : == MATCH_YES)
2992 : {
2993 1452 : gfc_omp_namelist *n;
2994 3349 : for (n = *head; n; n = n->next)
2995 : {
2996 1897 : n->u.map.op = OMP_MAP_TO;
2997 1897 : n->u.map.readonly = readonly;
2998 : }
2999 1452 : continue;
3000 1452 : }
3001 : }
3002 : }
3003 99 : else if (gfc_match_omp_variable_list ("copyin (",
3004 : &c->lists[OMP_LIST_COPYIN],
3005 : true) == MATCH_YES)
3006 97 : continue;
3007 : }
3008 2556 : if ((mask & OMP_CLAUSE_COPYOUT)
3009 1216 : && gfc_match ("copyout ( ") == MATCH_YES
3010 2556 : && gfc_match_omp_map_clause (&c->lists[OMP_LIST_MAP],
3011 : OMP_MAP_FROM, true, allow_derived))
3012 1071 : continue;
3013 498 : if ((mask & OMP_CLAUSE_COPYPRIVATE)
3014 414 : && gfc_match_omp_variable_list ("copyprivate (",
3015 : &c->lists[OMP_LIST_COPYPRIVATE],
3016 : true) == MATCH_YES)
3017 84 : continue;
3018 651 : if ((mask & OMP_CLAUSE_CREATE)
3019 328 : && gfc_match ("create ( ") == MATCH_YES
3020 651 : && gfc_match_omp_map_clause (&c->lists[OMP_LIST_MAP],
3021 : OMP_MAP_ALLOC, true, allow_derived))
3022 321 : continue;
3023 : break;
3024 4199 : case 'd':
3025 4199 : if ((mask & OMP_CLAUSE_DEFAULTMAP)
3026 4199 : && gfc_match ("defaultmap ( ") == MATCH_YES)
3027 : {
3028 181 : enum gfc_omp_defaultmap behavior;
3029 181 : gfc_omp_defaultmap_category category
3030 : = OMP_DEFAULTMAP_CAT_UNCATEGORIZED;
3031 181 : if (gfc_match ("alloc ") == MATCH_YES)
3032 : behavior = OMP_DEFAULTMAP_ALLOC;
3033 175 : else if (gfc_match ("tofrom ") == MATCH_YES)
3034 : behavior = OMP_DEFAULTMAP_TOFROM;
3035 143 : else if (gfc_match ("to ") == MATCH_YES)
3036 : behavior = OMP_DEFAULTMAP_TO;
3037 133 : else if (gfc_match ("from ") == MATCH_YES)
3038 : behavior = OMP_DEFAULTMAP_FROM;
3039 130 : else if (gfc_match ("firstprivate ") == MATCH_YES)
3040 : behavior = OMP_DEFAULTMAP_FIRSTPRIVATE;
3041 95 : else if (gfc_match ("present ") == MATCH_YES)
3042 : behavior = OMP_DEFAULTMAP_PRESENT;
3043 91 : else if (gfc_match ("none ") == MATCH_YES)
3044 : behavior = OMP_DEFAULTMAP_NONE;
3045 10 : else if (gfc_match ("default ") == MATCH_YES)
3046 : behavior = OMP_DEFAULTMAP_DEFAULT;
3047 : else
3048 : {
3049 1 : gfc_error ("Expected ALLOC, TO, FROM, TOFROM, FIRSTPRIVATE, "
3050 : "PRESENT, NONE or DEFAULT at %C");
3051 1 : break;
3052 : }
3053 180 : if (')' == gfc_peek_ascii_char ())
3054 : ;
3055 102 : else if (gfc_match (": ") != MATCH_YES)
3056 : break;
3057 : else
3058 : {
3059 102 : if (gfc_match ("scalar ") == MATCH_YES)
3060 : category = OMP_DEFAULTMAP_CAT_SCALAR;
3061 67 : else if (gfc_match ("aggregate ") == MATCH_YES)
3062 : category = OMP_DEFAULTMAP_CAT_AGGREGATE;
3063 43 : else if (gfc_match ("allocatable ") == MATCH_YES)
3064 : category = OMP_DEFAULTMAP_CAT_ALLOCATABLE;
3065 31 : else if (gfc_match ("pointer ") == MATCH_YES)
3066 : category = OMP_DEFAULTMAP_CAT_POINTER;
3067 14 : else if (gfc_match ("all ") == MATCH_YES)
3068 : category = OMP_DEFAULTMAP_CAT_ALL;
3069 : else
3070 : {
3071 1 : gfc_error ("Expected SCALAR, AGGREGATE, ALLOCATABLE, "
3072 : "POINTER or ALL at %C");
3073 1 : break;
3074 : }
3075 : }
3076 1200 : for (int i = 0; i < OMP_DEFAULTMAP_CAT_NUM; ++i)
3077 : {
3078 1034 : if (i != category
3079 1034 : && category != OMP_DEFAULTMAP_CAT_UNCATEGORIZED
3080 486 : && category != OMP_DEFAULTMAP_CAT_ALL
3081 486 : && i != OMP_DEFAULTMAP_CAT_UNCATEGORIZED
3082 341 : && i != OMP_DEFAULTMAP_CAT_ALL)
3083 254 : continue;
3084 780 : if (c->defaultmap[i] != OMP_DEFAULTMAP_UNSET)
3085 : {
3086 13 : const char *pcategory = NULL;
3087 13 : switch (i)
3088 : {
3089 : case OMP_DEFAULTMAP_CAT_UNCATEGORIZED: break;
3090 3 : case OMP_DEFAULTMAP_CAT_ALL: pcategory = "ALL"; break;
3091 1 : case OMP_DEFAULTMAP_CAT_SCALAR: pcategory = "SCALAR"; break;
3092 2 : case OMP_DEFAULTMAP_CAT_AGGREGATE:
3093 2 : pcategory = "AGGREGATE";
3094 2 : break;
3095 1 : case OMP_DEFAULTMAP_CAT_ALLOCATABLE:
3096 1 : pcategory = "ALLOCATABLE";
3097 1 : break;
3098 : case OMP_DEFAULTMAP_CAT_POINTER:
3099 : pcategory = "POINTER";
3100 : break;
3101 0 : default: gcc_unreachable ();
3102 : }
3103 7 : if (i == OMP_DEFAULTMAP_CAT_UNCATEGORIZED)
3104 4 : gfc_error ("DEFAULTMAP at %C but prior DEFAULTMAP with "
3105 : "unspecified category");
3106 : else
3107 9 : gfc_error ("DEFAULTMAP at %C but prior DEFAULTMAP for "
3108 : "category %s", pcategory);
3109 13 : goto error;
3110 : }
3111 : }
3112 166 : c->defaultmap[category] = behavior;
3113 166 : if (gfc_match (")") != MATCH_YES)
3114 : break;
3115 166 : continue;
3116 166 : }
3117 4985 : if ((mask & OMP_CLAUSE_DEFAULT)
3118 4018 : && (m = gfc_match_dupl_check (c->default_sharing
3119 : == OMP_DEFAULT_UNKNOWN, "default",
3120 : true)) != MATCH_NO)
3121 : {
3122 1012 : if (m == MATCH_ERROR)
3123 6 : goto error;
3124 1006 : if (gfc_match ("none") == MATCH_YES)
3125 596 : c->default_sharing = OMP_DEFAULT_NONE;
3126 410 : else if (openacc)
3127 : {
3128 225 : if (gfc_match ("present") == MATCH_YES)
3129 195 : c->default_sharing = OMP_DEFAULT_PRESENT;
3130 : }
3131 : else
3132 : {
3133 185 : if (gfc_match ("firstprivate") == MATCH_YES)
3134 8 : c->default_sharing = OMP_DEFAULT_FIRSTPRIVATE;
3135 177 : else if (gfc_match ("private") == MATCH_YES)
3136 24 : c->default_sharing = OMP_DEFAULT_PRIVATE;
3137 153 : else if (gfc_match ("shared") == MATCH_YES)
3138 153 : c->default_sharing = OMP_DEFAULT_SHARED;
3139 : }
3140 1006 : if (c->default_sharing == OMP_DEFAULT_UNKNOWN)
3141 : {
3142 30 : if (openacc)
3143 30 : gfc_error ("Expected NONE or PRESENT in DEFAULT clause "
3144 : "at %C");
3145 : else
3146 0 : gfc_error ("Expected NONE, FIRSTPRIVATE, PRIVATE or SHARED "
3147 : "in DEFAULT clause at %C");
3148 30 : goto error;
3149 : }
3150 976 : if (gfc_match (" )") != MATCH_YES)
3151 9 : goto error;
3152 967 : continue;
3153 : }
3154 3314 : if ((mask & OMP_CLAUSE_DELETE)
3155 345 : && gfc_match ("delete ( ") == MATCH_YES
3156 3314 : && gfc_match_omp_map_clause (&c->lists[OMP_LIST_MAP],
3157 : OMP_MAP_RELEASE, true,
3158 : allow_derived))
3159 308 : continue;
3160 : /* DOACROSS: match 'doacross' and 'depend' with sink/source.
3161 : DEPEND: match 'depend' but not sink/source. */
3162 2698 : m = MATCH_NO;
3163 2698 : if (((mask & OMP_CLAUSE_DOACROSS)
3164 383 : && gfc_match ("doacross ( ") == MATCH_YES)
3165 3054 : || (((mask & OMP_CLAUSE_DEPEND) || (mask & OMP_CLAUSE_DOACROSS))
3166 1610 : && (m = gfc_match ("depend ( ")) == MATCH_YES))
3167 : {
3168 1101 : bool has_omp_all_memory;
3169 1101 : bool is_depend = m == MATCH_YES;
3170 1101 : gfc_namespace *ns_iter = NULL, *ns_curr = gfc_current_ns;
3171 1101 : match m_it = MATCH_NO;
3172 1101 : if (is_depend)
3173 1074 : m_it = gfc_match_iterator (&ns_iter, false);
3174 1074 : if (m_it == MATCH_ERROR)
3175 : break;
3176 1096 : if (m_it == MATCH_YES && gfc_match (" , ") != MATCH_YES)
3177 : break;
3178 1096 : m = MATCH_YES;
3179 1096 : gfc_omp_depend_doacross_op depend_op = OMP_DEPEND_OUT;
3180 1096 : if (gfc_match ("inoutset") == MATCH_YES)
3181 : depend_op = OMP_DEPEND_INOUTSET;
3182 1084 : else if (gfc_match ("inout") == MATCH_YES)
3183 : depend_op = OMP_DEPEND_INOUT;
3184 992 : else if (gfc_match ("in") == MATCH_YES)
3185 : depend_op = OMP_DEPEND_IN;
3186 704 : else if (gfc_match ("out") == MATCH_YES)
3187 : depend_op = OMP_DEPEND_OUT;
3188 442 : else if (gfc_match ("mutexinoutset") == MATCH_YES)
3189 : depend_op = OMP_DEPEND_MUTEXINOUTSET;
3190 424 : else if (gfc_match ("depobj") == MATCH_YES)
3191 : depend_op = OMP_DEPEND_DEPOBJ;
3192 387 : else if (gfc_match ("source") == MATCH_YES)
3193 : {
3194 143 : if (m_it == MATCH_YES)
3195 : {
3196 1 : gfc_error ("ITERATOR may not be combined with SOURCE "
3197 : "at %C");
3198 17 : goto error;
3199 : }
3200 142 : if (!(mask & OMP_CLAUSE_DOACROSS))
3201 : {
3202 1 : gfc_error ("SOURCE at %C not permitted as dependence-type"
3203 : " for this directive");
3204 1 : goto error;
3205 : }
3206 141 : if (c->doacross_source)
3207 : {
3208 0 : gfc_error ("Duplicated clause with SOURCE dependence-type"
3209 : " at %C");
3210 0 : goto error;
3211 : }
3212 141 : gfc_gobble_whitespace ();
3213 141 : m = gfc_match (": ");
3214 141 : if (m != MATCH_YES && !is_depend)
3215 : {
3216 1 : gfc_error ("Expected %<:%> at %C");
3217 1 : goto error;
3218 : }
3219 140 : if (gfc_match (")") != MATCH_YES
3220 146 : && !(m == MATCH_YES
3221 6 : && gfc_match ("omp_cur_iteration )") == MATCH_YES))
3222 : {
3223 2 : gfc_error ("Expected %<)%> or %<omp_cur_iteration)%> "
3224 : "at %C");
3225 2 : goto error;
3226 : }
3227 138 : if (is_depend)
3228 130 : gfc_warning (OPT_Wdeprecated_openmp,
3229 : "%<source%> modifier with %<depend%> clause "
3230 : "at %L deprecated since OpenMP 5.2, use with "
3231 : "%<doacross%>", &old_loc);
3232 138 : c->doacross_source = true;
3233 138 : c->depend_source = is_depend;
3234 1079 : continue;
3235 : }
3236 244 : else if (gfc_match ("sink ") == MATCH_YES)
3237 : {
3238 244 : if (!(mask & OMP_CLAUSE_DOACROSS))
3239 : {
3240 2 : gfc_error ("SINK at %C not permitted as dependence-type "
3241 : "for this directive");
3242 2 : goto error;
3243 : }
3244 242 : if (gfc_match (": ") != MATCH_YES)
3245 : {
3246 1 : gfc_error ("Expected %<:%> at %C");
3247 1 : goto error;
3248 : }
3249 241 : if (m_it == MATCH_YES)
3250 : {
3251 0 : gfc_error ("ITERATOR may not be combined with SINK "
3252 : "at %C");
3253 0 : goto error;
3254 : }
3255 241 : if (is_depend)
3256 226 : gfc_warning (OPT_Wdeprecated_openmp,
3257 : "%<sink%> modifier with %<depend%> clause at "
3258 : "%L deprecated since OpenMP 5.2, use with "
3259 : "%<doacross%>", &old_loc);
3260 241 : m = gfc_match_omp_doacross_sink (&c->lists[OMP_LIST_DEPEND],
3261 : is_depend);
3262 241 : if (m == MATCH_YES)
3263 238 : continue;
3264 3 : goto error;
3265 : }
3266 : else
3267 : m = MATCH_NO;
3268 709 : if (!(mask & OMP_CLAUSE_DEPEND))
3269 : {
3270 0 : gfc_error ("Expected dependence-type SINK or SOURCE at %C");
3271 0 : goto error;
3272 : }
3273 709 : head = NULL;
3274 709 : if (ns_iter)
3275 40 : gfc_current_ns = ns_iter;
3276 709 : if (m == MATCH_YES)
3277 709 : m = gfc_match_omp_variable_list (" : ",
3278 : &c->lists[OMP_LIST_DEPEND],
3279 : false, NULL, &head, true,
3280 : false, &has_omp_all_memory);
3281 709 : if (m != MATCH_YES)
3282 2 : goto error;
3283 707 : gfc_current_ns = ns_curr;
3284 707 : if (has_omp_all_memory && depend_op != OMP_DEPEND_INOUT
3285 21 : && depend_op != OMP_DEPEND_OUT)
3286 : {
3287 4 : gfc_error ("%<omp_all_memory%> used with DEPEND kind "
3288 : "other than OUT or INOUT at %C");
3289 4 : goto error;
3290 : }
3291 703 : gfc_omp_namelist *n;
3292 1437 : for (n = *head; n; n = n->next)
3293 : {
3294 734 : n->u.depend_doacross_op = depend_op;
3295 734 : n->u2.ns = ns_iter;
3296 734 : if (ns_iter)
3297 39 : ns_iter->refs++;
3298 : }
3299 703 : continue;
3300 703 : }
3301 1618 : if ((mask & OMP_CLAUSE_DESTROY)
3302 1597 : && gfc_match_omp_variable_list ("destroy (",
3303 : &c->lists[OMP_LIST_DESTROY],
3304 : true) == MATCH_YES)
3305 21 : continue;
3306 1702 : if ((mask & OMP_CLAUSE_DETACH)
3307 164 : && !openacc
3308 127 : && !c->detach
3309 1702 : && gfc_match_omp_detach (&c->detach) == MATCH_YES)
3310 126 : continue;
3311 1487 : if ((mask & OMP_CLAUSE_DETACH)
3312 38 : && openacc
3313 37 : && gfc_match ("detach ( ") == MATCH_YES
3314 1487 : && gfc_match_omp_map_clause (&c->lists[OMP_LIST_MAP],
3315 : OMP_MAP_DETACH, false,
3316 : allow_derived))
3317 37 : continue;
3318 1449 : if ((mask & OMP_CLAUSE_DEVICEPTR)
3319 87 : && gfc_match ("deviceptr ( ") == MATCH_YES
3320 1451 : && gfc_match_omp_map_clause (&c->lists[OMP_LIST_MAP],
3321 : OMP_MAP_FORCE_DEVICEPTR, false,
3322 : allow_derived))
3323 36 : continue;
3324 832 : if ((mask & OMP_CLAUSE_DEVICE_TYPE) && openacc
3325 444 : && gfc_match_dupl_check (!c->oacc_device_type_present,
3326 : "device_type", true) == MATCH_YES
3327 1709 : && match_oacc_device_type (c) == MATCH_YES)
3328 326 : continue;
3329 506 : if ((mask & OMP_CLAUSE_DEVICE_TYPE) && !openacc
3330 1439 : && gfc_match_dupl_check (c->device_type == OMP_DEVICE_TYPE_UNSET,
3331 : "device_type", true) == MATCH_YES)
3332 : {
3333 95 : if (gfc_match ("host") == MATCH_YES)
3334 32 : c->device_type = OMP_DEVICE_TYPE_HOST;
3335 63 : else if (gfc_match ("nohost") == MATCH_YES)
3336 24 : c->device_type = OMP_DEVICE_TYPE_NOHOST;
3337 39 : else if (gfc_match ("any") == MATCH_YES)
3338 38 : c->device_type = OMP_DEVICE_TYPE_ANY;
3339 : else
3340 : {
3341 1 : gfc_error ("Expected HOST, NOHOST or ANY at %C");
3342 1 : break;
3343 : }
3344 94 : if (gfc_match (" )") != MATCH_YES)
3345 : break;
3346 94 : continue;
3347 : }
3348 1063 : if ((mask & OMP_CLAUSE_DEVICE_NUM)
3349 956 : && (m = gfc_match_dupl_check (!c->device_num_expr,
3350 : "device_num")) != MATCH_NO)
3351 : {
3352 109 : if (m == MATCH_ERROR)
3353 2 : goto error;
3354 107 : if (gfc_match ("( %e )", &c->device_num_expr) != MATCH_YES)
3355 0 : goto error;
3356 107 : continue;
3357 : }
3358 895 : if ((mask & OMP_CLAUSE_DEVICE_RESIDENT)
3359 896 : && gfc_match_omp_variable_list
3360 49 : ("device_resident (",
3361 : &c->lists[OMP_LIST_DEVICE_RESIDENT], true) == MATCH_YES)
3362 48 : continue;
3363 1111 : if ((mask & OMP_CLAUSE_DEVICE)
3364 714 : && openacc
3365 314 : && gfc_match ("device ( ") == MATCH_YES
3366 1112 : && gfc_match_omp_map_clause (&c->lists[OMP_LIST_MAP],
3367 : OMP_MAP_FORCE_TO, true,
3368 : /* allow_derived = */ true))
3369 312 : continue;
3370 487 : if ((mask & OMP_CLAUSE_DEVICE)
3371 402 : && !openacc
3372 887 : && ((m = gfc_match_dupl_check (!c->device, "device", true))
3373 : != MATCH_NO))
3374 : {
3375 352 : if (m == MATCH_ERROR)
3376 0 : goto error;
3377 352 : c->ancestor = false;
3378 352 : if (gfc_match ("device_num : ") == MATCH_YES)
3379 : {
3380 18 : if (gfc_match ("%e )", &c->device) != MATCH_YES)
3381 : {
3382 1 : gfc_error ("Expected integer expression at %C");
3383 1 : break;
3384 : }
3385 : }
3386 334 : else if (gfc_match ("ancestor : ") == MATCH_YES)
3387 : {
3388 45 : bool has_requires = false;
3389 45 : c->ancestor = true;
3390 82 : for (gfc_namespace *ns = gfc_current_ns; ns; ns = ns->parent)
3391 80 : if (ns->omp_requires & OMP_REQ_REVERSE_OFFLOAD)
3392 : {
3393 : has_requires = true;
3394 : break;
3395 : }
3396 45 : if (!has_requires)
3397 : {
3398 2 : gfc_error ("%<ancestor%> device modifier not "
3399 : "preceded by %<requires%> directive "
3400 : "with %<reverse_offload%> clause at %C");
3401 5 : break;
3402 : }
3403 43 : locus old_loc2 = gfc_current_locus;
3404 43 : if (gfc_match ("%e )", &c->device) == MATCH_YES)
3405 : {
3406 43 : int device = 0;
3407 43 : if (!gfc_extract_int (c->device, &device) && device != 1)
3408 : {
3409 1 : gfc_current_locus = old_loc2;
3410 1 : gfc_error ("the %<device%> clause expression must "
3411 : "evaluate to %<1%> at %C");
3412 1 : break;
3413 : }
3414 : }
3415 : else
3416 : {
3417 0 : gfc_error ("Expected integer expression at %C");
3418 0 : break;
3419 : }
3420 : }
3421 289 : else if (gfc_match ("%e )", &c->device) != MATCH_YES)
3422 : {
3423 13 : gfc_error ("Expected integer expression or a single device-"
3424 : "modifier %<device_num%> or %<ancestor%> at %C");
3425 13 : break;
3426 : }
3427 335 : continue;
3428 335 : }
3429 135 : if ((mask & OMP_CLAUSE_DIST_SCHEDULE)
3430 97 : && c->dist_sched_kind == OMP_SCHED_NONE
3431 232 : && gfc_match ("dist_schedule ( static") == MATCH_YES)
3432 : {
3433 97 : m = MATCH_NO;
3434 97 : c->dist_sched_kind = OMP_SCHED_STATIC;
3435 97 : m = gfc_match (" , %e )", &c->dist_chunk_size);
3436 97 : if (m != MATCH_YES)
3437 14 : m = gfc_match_char (')');
3438 14 : if (m != MATCH_YES)
3439 : {
3440 0 : c->dist_sched_kind = OMP_SCHED_NONE;
3441 0 : gfc_current_locus = old_loc;
3442 : }
3443 : else
3444 97 : continue;
3445 : }
3446 38 : if ((mask & OMP_CLAUSE_DYN_GROUPPRIVATE)
3447 38 : && gfc_match_dupl_check (!c->dyn_groupprivate,
3448 : "dyn_groupprivate", true) == MATCH_YES)
3449 : {
3450 : bool cgroup = false;
3451 : bool first = true;
3452 28 : bool error_p = false;
3453 36 : do
3454 : {
3455 28 : old_loc = gfc_current_locus;
3456 28 : if (gfc_match ("cgroup ") == MATCH_YES)
3457 : {
3458 7 : if (cgroup)
3459 : {
3460 1 : gfc_error ("Duplicated %<cgroup%> modifier at %L",
3461 : &old_loc);
3462 1 : goto error;
3463 : }
3464 : cgroup = true;
3465 : }
3466 21 : else if (gfc_match ("fallback ( ") == MATCH_YES)
3467 : {
3468 12 : if (c->fallback != OMP_FALLBACK_NONE)
3469 : {
3470 1 : gfc_error ("Duplicated %<fallback%> modifier at %L",
3471 : &old_loc);
3472 1 : goto error;
3473 : }
3474 11 : old_loc = gfc_current_locus;
3475 11 : if (gfc_match ("abort ) ") == MATCH_YES)
3476 3 : c->fallback = OMP_FALLBACK_ABORT;
3477 8 : else if (gfc_match ("default_mem ) ") == MATCH_YES)
3478 3 : c->fallback = OMP_FALLBACK_DEFAULT_MEM;
3479 5 : else if (gfc_match ("null ) ") == MATCH_YES)
3480 4 : c->fallback = OMP_FALLBACK_NULL;
3481 : else
3482 : {
3483 1 : gfc_error ("Expected %<abort%>, %<default_mem%> or "
3484 : "%<null%> followed by %<)%> at %L",
3485 : &old_loc);
3486 1 : goto error;
3487 : }
3488 : }
3489 9 : else if (!first)
3490 : {
3491 1 : gfc_error ("Expected %<cgroup%> or %<fallback%> clause at %C");
3492 1 : goto error;
3493 : }
3494 24 : if (gfc_match (", ") == MATCH_YES)
3495 : {
3496 8 : first = false;
3497 8 : continue;
3498 : }
3499 16 : if (gfc_match (": ") == MATCH_YES)
3500 : {
3501 7 : old_loc = gfc_current_locus;
3502 7 : break;
3503 : }
3504 9 : if (!first)
3505 : {
3506 0 : gfc_error ("Expected %<:%> at %C");
3507 0 : goto error;
3508 : }
3509 : error_p = true;
3510 : break;
3511 : }
3512 : while (true);
3513 16 : if (gfc_match_expr (&c->dyn_groupprivate) != MATCH_YES)
3514 : {
3515 0 : gfc_error ("Expected numeric expression at %L, optionally preceeded by "
3516 : "the %<cgroup%> and %<fallback%> modifier", &old_loc);
3517 0 : goto error;
3518 : }
3519 16 : if (error_p)
3520 9 : c->fallback = OMP_FALLBACK_NONE;
3521 16 : if (gfc_match (" )") != MATCH_YES)
3522 : {
3523 1 : gfc_error ("Expected %<)%> at %C");
3524 1 : goto error;
3525 : }
3526 15 : continue;
3527 15 : }
3528 : break;
3529 98 : case 'e':
3530 98 : if ((mask & OMP_CLAUSE_ENTER))
3531 : {
3532 98 : m = gfc_match_omp_to_link ("enter (", &c->lists[OMP_LIST_ENTER]);
3533 98 : if (m == MATCH_ERROR)
3534 0 : goto error;
3535 98 : if (m == MATCH_YES)
3536 98 : continue;
3537 : }
3538 : break;
3539 2326 : case 'f':
3540 2375 : if ((mask & OMP_CLAUSE_FAIL)
3541 2326 : && (m = gfc_match_dupl_check (c->fail == OMP_MEMORDER_UNSET,
3542 : "fail", true)) != MATCH_NO)
3543 : {
3544 58 : if (m == MATCH_ERROR)
3545 3 : goto error;
3546 55 : if (gfc_match ("seq_cst") == MATCH_YES)
3547 6 : c->fail = OMP_MEMORDER_SEQ_CST;
3548 49 : else if (gfc_match ("acquire") == MATCH_YES)
3549 14 : c->fail = OMP_MEMORDER_ACQUIRE;
3550 35 : else if (gfc_match ("relaxed") == MATCH_YES)
3551 30 : c->fail = OMP_MEMORDER_RELAXED;
3552 : else
3553 : {
3554 5 : gfc_error ("Expected SEQ_CST, ACQUIRE or RELAXED at %C");
3555 5 : break;
3556 : }
3557 50 : if (gfc_match (" )") != MATCH_YES)
3558 1 : goto error;
3559 49 : continue;
3560 : }
3561 2311 : if ((mask & OMP_CLAUSE_FILTER)
3562 2268 : && (m = gfc_match_dupl_check (!c->filter, "filter", true,
3563 : &c->filter)) != MATCH_NO)
3564 : {
3565 44 : if (m == MATCH_ERROR)
3566 1 : goto error;
3567 43 : continue;
3568 : }
3569 2288 : if ((mask & OMP_CLAUSE_FINAL)
3570 2224 : && (m = gfc_match_dupl_check (!c->final_expr, "final", true,
3571 : &c->final_expr)) != MATCH_NO)
3572 : {
3573 64 : if (m == MATCH_ERROR)
3574 0 : goto error;
3575 64 : continue;
3576 : }
3577 2186 : if ((mask & OMP_CLAUSE_FINALIZE)
3578 2160 : && (m = gfc_match_dupl_check (!c->finalize, "finalize"))
3579 : != MATCH_NO)
3580 : {
3581 26 : if (m == MATCH_ERROR)
3582 0 : goto error;
3583 26 : c->finalize = true;
3584 26 : continue;
3585 : }
3586 3176 : if ((mask & OMP_CLAUSE_FIRSTPRIVATE)
3587 2134 : && gfc_match_omp_variable_list ("firstprivate (",
3588 : &c->lists[OMP_LIST_FIRSTPRIVATE],
3589 : true) == MATCH_YES)
3590 1042 : continue;
3591 2095 : if ((mask & OMP_CLAUSE_FROM)
3592 1092 : && gfc_match_motion_var_list ("from (", &c->lists[OMP_LIST_FROM],
3593 : &head) == MATCH_YES)
3594 1003 : continue;
3595 158 : if ((mask & OMP_CLAUSE_FULL)
3596 165 : && (m = gfc_match_boolean_clause (&bval, "full",
3597 76 : c->full || cfalse->full)) != MATCH_NO)
3598 : {
3599 76 : if (m == MATCH_ERROR)
3600 7 : goto error;
3601 69 : if (bval)
3602 68 : c->full = true;
3603 : else
3604 1 : cfalse->full = true;
3605 69 : continue;
3606 : }
3607 : break;
3608 1231 : case 'g':
3609 2423 : if ((mask & OMP_CLAUSE_GANG)
3610 1231 : && (m = gfc_match_dupl_check (!c->gang, "gang")) != MATCH_NO)
3611 : {
3612 1197 : if (m == MATCH_ERROR)
3613 0 : goto error;
3614 1197 : c->gang = true;
3615 1197 : m = match_oacc_clause_gwv (c, GOMP_DIM_GANG);
3616 1197 : if (m == MATCH_ERROR)
3617 : {
3618 5 : gfc_current_locus = old_loc;
3619 5 : break;
3620 : }
3621 1192 : continue;
3622 : }
3623 68 : if ((mask & OMP_CLAUSE_GRAINSIZE)
3624 34 : && (m = gfc_match_dupl_check (!c->grainsize, "grainsize", true))
3625 : != MATCH_NO)
3626 : {
3627 34 : if (m == MATCH_ERROR)
3628 0 : goto error;
3629 34 : if (gfc_match ("strict : ") == MATCH_YES)
3630 1 : c->grainsize_strict = true;
3631 34 : if (gfc_match (" %e )", &c->grainsize) != MATCH_YES)
3632 0 : goto error;
3633 34 : continue;
3634 : }
3635 : break;
3636 474 : case 'h':
3637 523 : if ((mask & OMP_CLAUSE_HAS_DEVICE_ADDR)
3638 523 : && gfc_match_omp_variable_list
3639 49 : ("has_device_addr (", &c->lists[OMP_LIST_HAS_DEVICE_ADDR],
3640 : false, NULL, NULL, true) == MATCH_YES)
3641 49 : continue;
3642 473 : if ((mask & OMP_CLAUSE_HINT)
3643 425 : && (m = gfc_match_dupl_check (!c->hint, "hint", true, &c->hint))
3644 : != MATCH_NO)
3645 : {
3646 48 : if (m == MATCH_ERROR)
3647 0 : goto error;
3648 48 : continue;
3649 : }
3650 377 : if ((mask & OMP_CLAUSE_ASSUMPTIONS)
3651 377 : && gfc_match ("holds ( ") == MATCH_YES)
3652 : {
3653 22 : gfc_expr *e;
3654 22 : if (gfc_match ("%e )", &e) != MATCH_YES)
3655 0 : goto error;
3656 22 : if (c->assume == NULL)
3657 15 : c->assume = gfc_get_omp_assumptions ();
3658 22 : gfc_expr_list *el = XCNEW (gfc_expr_list);
3659 22 : el->expr = e;
3660 22 : el->next = c->assume->holds;
3661 22 : c->assume->holds = el;
3662 22 : continue;
3663 22 : }
3664 709 : if ((mask & OMP_CLAUSE_HOST)
3665 355 : && gfc_match ("host ( ") == MATCH_YES
3666 710 : && gfc_match_omp_map_clause (&c->lists[OMP_LIST_MAP],
3667 : OMP_MAP_FORCE_FROM, true,
3668 : /* allow_derived = */ true))
3669 354 : continue;
3670 : break;
3671 2251 : case 'i':
3672 2274 : if ((mask & OMP_CLAUSE_IF_PRESENT)
3673 2251 : && (m = gfc_match_dupl_check (!c->if_present, "if_present"))
3674 : != MATCH_NO)
3675 : {
3676 23 : if (m == MATCH_ERROR)
3677 0 : goto error;
3678 23 : c->if_present = true;
3679 23 : continue;
3680 : }
3681 2228 : if ((mask & OMP_CLAUSE_IF)
3682 2228 : && (m = gfc_match_dupl_check (!c->if_expr, "if", true))
3683 : != MATCH_NO)
3684 : {
3685 1470 : if (m == MATCH_ERROR)
3686 14 : goto error;
3687 1456 : if (!openacc)
3688 : {
3689 : /* This should match the enum gfc_omp_if_kind order. */
3690 : static const char *ifs[OMP_IF_LAST] = {
3691 : "cancel : %e )",
3692 : "parallel : %e )",
3693 : "simd : %e )",
3694 : "task : %e )",
3695 : "taskloop : %e )",
3696 : "target : %e )",
3697 : "target data : %e )",
3698 : "target update : %e )",
3699 : "target enter data : %e )",
3700 : "target exit data : %e )" };
3701 : static const char *ifs2[] = {
3702 : "target_data : %e )",
3703 : "target_update : %e )",
3704 : "target_enter_data : %e )",
3705 : "target_exit_data : %e )" };
3706 : int i;
3707 4951 : for (i = 0; i < OMP_IF_LAST; i++)
3708 4543 : if (c->if_exprs[i] == NULL
3709 4543 : && gfc_match (ifs[i], &c->if_exprs[i]) == MATCH_YES)
3710 : break;
3711 546 : if (i < OMP_IF_LAST)
3712 138 : continue;
3713 2030 : for (i = 0; i < (int) ARRAY_SIZE (ifs2); i++)
3714 1626 : if (c->if_exprs[OMP_IF_TARGET_DATA + i] == NULL
3715 1626 : && (gfc_match (ifs2[i],
3716 : &c->if_exprs[OMP_IF_TARGET_DATA + i])
3717 : == MATCH_YES))
3718 : break;
3719 408 : if (i < (int) ARRAY_SIZE (ifs2))
3720 4 : continue;
3721 : }
3722 1314 : if (gfc_match (" %e )", &c->if_expr) == MATCH_YES)
3723 1309 : continue;
3724 5 : goto error;
3725 : }
3726 875 : if ((mask & OMP_CLAUSE_IN_REDUCTION)
3727 758 : && gfc_match_omp_clause_reduction (pc, c, openacc, allow_derived,
3728 : openmp_target) == MATCH_YES)
3729 117 : continue;
3730 668 : if ((mask & OMP_CLAUSE_INBRANCH)
3731 670 : && (m = gfc_match_dupl_branch_clause (&bval, "inbranch",
3732 29 : c->notinbranch || cfalse->notinbranch
3733 27 : || c->inbranch || cfalse->inbranch)) != MATCH_NO)
3734 : {
3735 29 : if (m == MATCH_ERROR)
3736 2 : goto error;
3737 27 : if (bval)
3738 25 : c->inbranch = true;
3739 : else
3740 2 : cfalse->inbranch = true;
3741 27 : continue;
3742 : }
3743 854 : if ((mask & OMP_CLAUSE_INDEPENDENT)
3744 612 : && (m = gfc_match_dupl_check (!c->independent, "independent"))
3745 : != MATCH_NO)
3746 : {
3747 242 : if (m == MATCH_ERROR)
3748 0 : goto error;
3749 242 : c->independent = true;
3750 242 : continue;
3751 : }
3752 426 : if ((mask & OMP_CLAUSE_INDIRECT)
3753 431 : && (m = gfc_match_boolean_clause (&bval, "indirect",
3754 61 : c->indirect || cfalse->indirect)) != MATCH_NO)
3755 : {
3756 61 : if (m == MATCH_ERROR)
3757 5 : goto error;
3758 56 : if (bval)
3759 51 : c->indirect = true;
3760 : else
3761 5 : cfalse->indirect = true;
3762 56 : continue;
3763 : }
3764 309 : if ((mask & OMP_CLAUSE_INIT)
3765 309 : && gfc_match ("init ( ") == MATCH_YES)
3766 : {
3767 108 : m = gfc_match_omp_init (&c->lists[OMP_LIST_INIT]);
3768 108 : if (m == MATCH_YES)
3769 63 : continue;
3770 45 : goto error;
3771 : }
3772 201 : if ((mask & OMP_CLAUSE_INTEROP)
3773 201 : && (m = gfc_match_dupl_check (!c->lists[OMP_LIST_INTEROP],
3774 : "interop", true)) != MATCH_NO)
3775 : {
3776 : /* Note: the interop objects are saved in reverse order to match
3777 : the order in C/C++. */
3778 125 : if (m == MATCH_YES
3779 63 : && (gfc_match_omp_variable_list ("",
3780 : &c->lists[OMP_LIST_INTEROP],
3781 : false, NULL, NULL, false,
3782 : false, NULL, false, true)
3783 : == MATCH_YES))
3784 62 : continue;
3785 1 : goto error;
3786 : }
3787 258 : if ((mask & OMP_CLAUSE_IS_DEVICE_PTR)
3788 258 : && gfc_match_omp_variable_list
3789 120 : ("is_device_ptr (",
3790 : &c->lists[OMP_LIST_IS_DEVICE_PTR], false) == MATCH_YES)
3791 120 : continue;
3792 : break;
3793 2360 : case 'l':
3794 2360 : if ((mask & OMP_CLAUSE_LASTPRIVATE)
3795 2360 : && gfc_match ("lastprivate ( ") == MATCH_YES)
3796 : {
3797 1433 : bool conditional = gfc_match ("conditional : ") == MATCH_YES;
3798 1433 : head = NULL;
3799 1433 : if (gfc_match_omp_variable_list ("",
3800 : &c->lists[OMP_LIST_LASTPRIVATE],
3801 : false, NULL, &head) == MATCH_YES)
3802 : {
3803 1433 : gfc_omp_namelist *n;
3804 3741 : for (n = *head; n; n = n->next)
3805 2308 : n->u.lastprivate_conditional = conditional;
3806 1433 : continue;
3807 1433 : }
3808 0 : gfc_current_locus = old_loc;
3809 0 : break;
3810 : }
3811 927 : end_colon = false;
3812 927 : head = NULL;
3813 927 : if ((mask & OMP_CLAUSE_LINEAR)
3814 927 : && gfc_match ("linear (") == MATCH_YES)
3815 : {
3816 849 : bool old_linear_modifier = false;
3817 849 : gfc_omp_linear_op linear_op = OMP_LINEAR_DEFAULT;
3818 849 : gfc_expr *step = NULL;
3819 849 : locus saved_loc = gfc_current_locus;
3820 :
3821 849 : if (gfc_match_omp_variable_list (" ref (",
3822 : &c->lists[OMP_LIST_LINEAR],
3823 : false, NULL, &head)
3824 : == MATCH_YES)
3825 : {
3826 : linear_op = OMP_LINEAR_REF;
3827 : old_linear_modifier = true;
3828 : }
3829 821 : else if (gfc_match_omp_variable_list (" val (",
3830 : &c->lists[OMP_LIST_LINEAR],
3831 : false, NULL, &head)
3832 : == MATCH_YES)
3833 : {
3834 : linear_op = OMP_LINEAR_VAL;
3835 : old_linear_modifier = true;
3836 : }
3837 810 : else if (gfc_match_omp_variable_list (" uval (",
3838 : &c->lists[OMP_LIST_LINEAR],
3839 : false, NULL, &head)
3840 : == MATCH_YES)
3841 : {
3842 : linear_op = OMP_LINEAR_UVAL;
3843 : old_linear_modifier = true;
3844 : }
3845 801 : else if (gfc_match_omp_variable_list ("",
3846 : &c->lists[OMP_LIST_LINEAR],
3847 : false, &end_colon, &head)
3848 : == MATCH_YES)
3849 : linear_op = OMP_LINEAR_DEFAULT;
3850 : else
3851 : {
3852 2 : gfc_current_locus = old_loc;
3853 2 : break;
3854 : }
3855 : if (linear_op != OMP_LINEAR_DEFAULT)
3856 : {
3857 48 : if (gfc_match (" :") == MATCH_YES)
3858 31 : end_colon = true;
3859 17 : else if (gfc_match (" )") != MATCH_YES)
3860 : {
3861 0 : gfc_free_omp_namelist (*head, OMP_LIST_LINEAR);
3862 0 : gfc_current_locus = old_loc;
3863 0 : *head = NULL;
3864 0 : break;
3865 : }
3866 : }
3867 847 : gfc_gobble_whitespace ();
3868 847 : if (old_linear_modifier && end_colon)
3869 : {
3870 31 : if (gfc_match (" %e )", &step) != MATCH_YES)
3871 : {
3872 1 : gfc_free_omp_namelist (*head, OMP_LIST_LINEAR);
3873 1 : gfc_current_locus = old_loc;
3874 1 : *head = NULL;
3875 5 : goto error;
3876 : }
3877 : }
3878 47 : if (old_linear_modifier)
3879 : {
3880 47 : char var_names[512]{};
3881 47 : int count, offset = 0;
3882 106 : for (gfc_omp_namelist *n = *head; n; n = n->next)
3883 : {
3884 59 : if (!n->next)
3885 47 : count = snprintf (var_names + offset,
3886 47 : sizeof (var_names) - offset,
3887 47 : "%s", n->sym->name);
3888 : else
3889 12 : count = snprintf (var_names + offset,
3890 12 : sizeof (var_names) - offset,
3891 12 : "%s, ", n->sym->name);
3892 59 : if (count < 0 || count >= ((int)sizeof (var_names))
3893 59 : - offset)
3894 : {
3895 0 : snprintf (var_names, 512, "%s, ..., ",
3896 0 : (*head)->sym->name);
3897 0 : while (n->next)
3898 : n = n->next;
3899 0 : offset = strlen (var_names);
3900 0 : snprintf (var_names + offset,
3901 0 : sizeof (var_names) - offset,
3902 0 : "%s", n->sym->name);
3903 0 : break;
3904 : }
3905 59 : offset += count;
3906 : }
3907 47 : char *var_names_for_warn = var_names;
3908 47 : const char *op_name;
3909 47 : switch (linear_op)
3910 : {
3911 : case OMP_LINEAR_REF: op_name = "ref"; break;
3912 10 : case OMP_LINEAR_VAL: op_name = "val"; break;
3913 9 : case OMP_LINEAR_UVAL: op_name = "uval"; break;
3914 0 : default: gcc_unreachable ();
3915 : }
3916 47 : gfc_warning (OPT_Wdeprecated_openmp,
3917 : "Specification of the list items as "
3918 : "arguments to the modifiers at %L is "
3919 : "deprecated; since OpenMP 5.2, use "
3920 : "%<linear(%s : %s%s)%>", &saved_loc,
3921 : var_names_for_warn, op_name,
3922 47 : step == nullptr ? "" : ", step(...)");
3923 : }
3924 799 : else if (end_colon)
3925 : {
3926 732 : bool has_error = false;
3927 : bool has_modifiers = false;
3928 : bool has_step = false;
3929 732 : bool duplicate_step = false;
3930 732 : bool duplicate_mod = false;
3931 732 : while (true)
3932 : {
3933 732 : old_loc = gfc_current_locus;
3934 732 : bool close_paren = gfc_match ("val )") == MATCH_YES;
3935 732 : if (close_paren || gfc_match ("val , ") == MATCH_YES)
3936 : {
3937 23 : if (linear_op != OMP_LINEAR_DEFAULT)
3938 : {
3939 : duplicate_mod = true;
3940 : break;
3941 : }
3942 22 : linear_op = OMP_LINEAR_VAL;
3943 22 : has_modifiers = true;
3944 22 : if (close_paren)
3945 : break;
3946 16 : continue;
3947 : }
3948 709 : close_paren = gfc_match ("uval )") == MATCH_YES;
3949 709 : if (close_paren || gfc_match ("uval , ") == MATCH_YES)
3950 : {
3951 7 : if (linear_op != OMP_LINEAR_DEFAULT)
3952 : {
3953 : duplicate_mod = true;
3954 : break;
3955 : }
3956 7 : linear_op = OMP_LINEAR_UVAL;
3957 7 : has_modifiers = true;
3958 7 : if (close_paren)
3959 : break;
3960 2 : continue;
3961 : }
3962 702 : close_paren = gfc_match ("ref )") == MATCH_YES;
3963 702 : if (close_paren || gfc_match ("ref , ") == MATCH_YES)
3964 : {
3965 16 : if (linear_op != OMP_LINEAR_DEFAULT)
3966 : {
3967 : duplicate_mod = true;
3968 : break;
3969 : }
3970 15 : linear_op = OMP_LINEAR_REF;
3971 15 : has_modifiers = true;
3972 15 : if (close_paren)
3973 : break;
3974 7 : continue;
3975 : }
3976 686 : close_paren = (gfc_match ("step ( %e ) )", &step)
3977 : == MATCH_YES);
3978 697 : if (close_paren
3979 686 : || gfc_match ("step ( %e ) , ", &step) == MATCH_YES)
3980 : {
3981 50 : if (has_step)
3982 : {
3983 : duplicate_step = true;
3984 : break;
3985 : }
3986 49 : has_modifiers = has_step = true;
3987 49 : if (close_paren)
3988 : break;
3989 11 : continue;
3990 : }
3991 636 : if (!has_modifiers
3992 636 : && gfc_match ("%e )", &step) == MATCH_YES)
3993 : {
3994 636 : if ((step->expr_type == EXPR_FUNCTION
3995 635 : || step->expr_type == EXPR_VARIABLE)
3996 31 : && strcmp (step->symtree->name, "step") == 0)
3997 : {
3998 1 : gfc_current_locus = old_loc;
3999 1 : gfc_match ("step (");
4000 1 : has_error = true;
4001 : }
4002 : break;
4003 : }
4004 : has_error = true;
4005 : break;
4006 : }
4007 61 : if (duplicate_mod || duplicate_step)
4008 : {
4009 3 : gfc_error ("Multiple %qs modifiers specified at %C",
4010 : duplicate_mod ? "linear" : "step");
4011 3 : has_error = true;
4012 : }
4013 696 : if (has_error)
4014 : {
4015 4 : gfc_free_omp_namelist (*head, OMP_LIST_LINEAR);
4016 4 : *head = NULL;
4017 4 : goto error;
4018 : }
4019 : }
4020 842 : if (step == NULL)
4021 : {
4022 130 : step = gfc_get_constant_expr (BT_INTEGER,
4023 : gfc_default_integer_kind,
4024 : &old_loc);
4025 130 : mpz_set_si (step->value.integer, 1);
4026 : }
4027 842 : (*head)->expr = step;
4028 842 : if (linear_op != OMP_LINEAR_DEFAULT || old_linear_modifier)
4029 188 : for (gfc_omp_namelist *n = *head; n; n = n->next)
4030 : {
4031 100 : n->u.linear.op = linear_op;
4032 100 : n->u.linear.old_modifier = old_linear_modifier;
4033 : }
4034 842 : continue;
4035 842 : }
4036 82 : if ((mask & OMP_CLAUSE_LINK)
4037 78 : && openacc
4038 86 : && (gfc_match_oacc_clause_link ("link (",
4039 : &c->lists[OMP_LIST_LINK])
4040 : == MATCH_YES))
4041 4 : continue;
4042 123 : else if ((mask & OMP_CLAUSE_LINK)
4043 74 : && !openacc
4044 144 : && (gfc_match_omp_to_link ("link (",
4045 : &c->lists[OMP_LIST_LINK])
4046 : == MATCH_YES))
4047 49 : continue;
4048 46 : if ((mask & OMP_CLAUSE_LOCAL)
4049 25 : && (gfc_match_omp_to_link ("local (", &c->lists[OMP_LIST_LOCAL])
4050 : == MATCH_YES))
4051 21 : continue;
4052 : break;
4053 5964 : case 'm':
4054 5964 : if ((mask & OMP_CLAUSE_MAP)
4055 5964 : && gfc_match ("map ( ") == MATCH_YES)
4056 : {
4057 5856 : locus old_loc2 = gfc_current_locus;
4058 5856 : int always_modifier = 0;
4059 5856 : int close_modifier = 0;
4060 5856 : int present_modifier = 0;
4061 5856 : int mapper_modifier = 0;
4062 5856 : int iterator_modifier = 0;
4063 5856 : gfc_namespace *ns_iter = NULL, *ns_curr = gfc_current_ns;
4064 5856 : locus second_always_locus = old_loc2;
4065 5856 : locus second_close_locus = old_loc2;
4066 5856 : locus second_mapper_locus = old_loc2;
4067 5856 : locus second_present_locus = old_loc2;
4068 5856 : char mapper_id[GFC_MAX_SYMBOL_LEN + 1] = { '\0' };
4069 5856 : locus second_iterator_locus = old_loc2;
4070 :
4071 6524 : for (;;)
4072 : {
4073 6190 : locus current_locus = gfc_current_locus;
4074 6190 : if (gfc_match ("always ") == MATCH_YES)
4075 : {
4076 148 : if (always_modifier++ == 1)
4077 5 : second_always_locus = current_locus;
4078 : }
4079 6042 : else if (gfc_match ("close ") == MATCH_YES)
4080 : {
4081 69 : if (close_modifier++ == 1)
4082 5 : second_close_locus = current_locus;
4083 : }
4084 5973 : else if (gfc_match ("present ") == MATCH_YES)
4085 : {
4086 67 : if (present_modifier++ == 1)
4087 4 : second_present_locus = current_locus;
4088 : }
4089 5906 : else if (gfc_match ("mapper ( ") == MATCH_YES)
4090 : {
4091 8 : if (mapper_modifier++ == 1)
4092 0 : second_mapper_locus = current_locus;
4093 8 : m = gfc_match (" %n ) ", mapper_id);
4094 8 : if (m != MATCH_YES)
4095 0 : goto error;
4096 8 : if (strcmp (mapper_id, "default") == 0)
4097 3 : mapper_id[0] = '\0';
4098 : }
4099 5898 : else if (gfc_match_iterator (&ns_iter, true) == MATCH_YES)
4100 : {
4101 42 : if (iterator_modifier++ == 1)
4102 1 : second_iterator_locus = current_locus;
4103 : }
4104 : else
4105 : break;
4106 334 : if (gfc_match (", ") != MATCH_YES)
4107 62 : gfc_warning (OPT_Wdeprecated_openmp,
4108 : "The specification of modifiers without "
4109 : "comma separators for the %<map%> clause "
4110 : "at %C has been deprecated since "
4111 : "OpenMP 5.2");
4112 334 : }
4113 :
4114 5856 : gfc_omp_map_op map_op = default_map_op;
4115 5856 : int always_present_modifier
4116 5856 : = always_modifier && present_modifier;
4117 :
4118 5856 : if (gfc_match ("alloc : ") == MATCH_YES)
4119 799 : map_op = (present_modifier ? OMP_MAP_PRESENT_ALLOC
4120 : : OMP_MAP_ALLOC);
4121 5057 : else if (gfc_match ("tofrom : ") == MATCH_YES)
4122 954 : map_op = (always_present_modifier ? OMP_MAP_ALWAYS_PRESENT_TOFROM
4123 950 : : present_modifier ? OMP_MAP_PRESENT_TOFROM
4124 945 : : always_modifier ? OMP_MAP_ALWAYS_TOFROM
4125 : : OMP_MAP_TOFROM);
4126 4103 : else if (gfc_match ("to : ") == MATCH_YES)
4127 1815 : map_op = (always_present_modifier ? OMP_MAP_ALWAYS_PRESENT_TO
4128 1809 : : present_modifier ? OMP_MAP_PRESENT_TO
4129 1797 : : always_modifier ? OMP_MAP_ALWAYS_TO
4130 : : OMP_MAP_TO);
4131 2288 : else if (gfc_match ("from : ") == MATCH_YES)
4132 1656 : map_op = (always_present_modifier ? OMP_MAP_ALWAYS_PRESENT_FROM
4133 1652 : : present_modifier ? OMP_MAP_PRESENT_FROM
4134 1647 : : always_modifier ? OMP_MAP_ALWAYS_FROM
4135 : : OMP_MAP_FROM);
4136 632 : else if (gfc_match ("release : ") == MATCH_YES)
4137 : map_op = OMP_MAP_RELEASE;
4138 578 : else if (gfc_match ("delete : ") == MATCH_YES)
4139 : map_op = OMP_MAP_DELETE;
4140 : else
4141 : {
4142 501 : gfc_current_locus = old_loc2;
4143 501 : always_modifier = 0;
4144 501 : close_modifier = 0;
4145 501 : mapper_modifier = 0;
4146 : }
4147 :
4148 1579 : if (always_modifier > 1)
4149 : {
4150 5 : gfc_error ("too many %<always%> modifiers at %L",
4151 : &second_always_locus);
4152 24 : break;
4153 : }
4154 5851 : if (close_modifier > 1)
4155 : {
4156 4 : gfc_error ("too many %<close%> modifiers at %L",
4157 : &second_close_locus);
4158 4 : break;
4159 : }
4160 5847 : if (present_modifier > 1)
4161 : {
4162 4 : gfc_error ("too many %<present%> modifiers at %L",
4163 : &second_present_locus);
4164 4 : break;
4165 : }
4166 5843 : if (mapper_modifier > 1)
4167 : {
4168 0 : gfc_error ("too many %<mapper%> modifiers at %L",
4169 : &second_mapper_locus);
4170 0 : break;
4171 : }
4172 5843 : if (iterator_modifier > 1)
4173 : {
4174 1 : gfc_error ("too many %<iterator%> modifiers at %L",
4175 : &second_iterator_locus);
4176 1 : break;
4177 : }
4178 :
4179 5842 : head = NULL;
4180 5842 : if (ns_iter)
4181 40 : gfc_current_ns = ns_iter;
4182 5842 : m = gfc_match_omp_variable_list ("", &c->lists[OMP_LIST_MAP],
4183 : false, NULL, &head, true, true);
4184 5842 : gfc_current_ns = ns_curr;
4185 5842 : if (m == MATCH_YES)
4186 : {
4187 5837 : gfc_omp_namelist *n;
4188 13257 : for (n = *head; n; n = n->next)
4189 : {
4190 7420 : n->u.map.op = map_op;
4191 7420 : if (mapper_id[0] != '\0')
4192 : {
4193 5 : n->u3.udm = gfc_get_omp_namelist_udm ();
4194 5 : n->u3.udm->requested_mapper_id
4195 5 : = gfc_get_string ("%s", mapper_id);
4196 : }
4197 7420 : n->u2.ns = ns_iter;
4198 7420 : if (ns_iter)
4199 42 : ns_iter->refs++;
4200 : }
4201 5837 : continue;
4202 5837 : }
4203 5 : gfc_current_locus = old_loc;
4204 5 : break;
4205 : }
4206 142 : if ((mask & OMP_CLAUSE_MERGEABLE)
4207 142 : && (m = gfc_match_boolean_clause (&bval, "mergeable",
4208 34 : c->mergeable || cfalse->mergeable)) != MATCH_NO)
4209 : {
4210 34 : if (m == MATCH_ERROR)
4211 0 : goto error;
4212 34 : if (bval)
4213 34 : c->mergeable = true;
4214 : else
4215 0 : cfalse->mergeable = true;
4216 34 : continue;
4217 : }
4218 143 : if ((mask & OMP_CLAUSE_MESSAGE)
4219 74 : && (m = gfc_match_dupl_check (!c->message, "message", true,
4220 : &c->message)) != MATCH_NO)
4221 : {
4222 74 : if (m == MATCH_ERROR)
4223 5 : goto error;
4224 69 : continue;
4225 : }
4226 : break;
4227 3037 : case 'n':
4228 3089 : if ((mask & OMP_CLAUSE_NO_CREATE)
4229 1343 : && gfc_match ("no_create ( ") == MATCH_YES
4230 3089 : && gfc_match_omp_map_clause (&c->lists[OMP_LIST_MAP],
4231 : OMP_MAP_IF_PRESENT, true,
4232 : allow_derived))
4233 52 : continue;
4234 2988 : if ((mask & OMP_CLAUSE_ASSUMPTIONS)
4235 3019 : && ((m = gfc_match_boolean_clause (&bval, "no_openmp_constructs",
4236 34 : (c->assume && c->assume->no_openmp_constructs)
4237 31 : || (cfalse->assume && cfalse->assume->no_openmp_constructs)))
4238 : != MATCH_NO))
4239 : {
4240 4 : if (m == MATCH_ERROR)
4241 1 : goto error;
4242 3 : if (bval)
4243 : {
4244 2 : if (c->assume == NULL)
4245 0 : c->assume = gfc_get_omp_assumptions ();
4246 2 : c->assume->no_openmp_constructs = true;
4247 : }
4248 : else
4249 : {
4250 1 : if (cfalse->assume == NULL)
4251 0 : cfalse->assume = gfc_get_omp_assumptions ();
4252 1 : cfalse->assume->no_openmp_constructs = true;
4253 : }
4254 3 : continue;
4255 : }
4256 2996 : if ((mask & OMP_CLAUSE_ASSUMPTIONS)
4257 3011 : && ((m = gfc_match_boolean_clause (&bval, "no_openmp_routines",
4258 30 : (c->assume && c->assume->no_openmp_routines)
4259 29 : || (cfalse->assume && cfalse->assume->no_openmp_routines)))
4260 : != MATCH_NO))
4261 : {
4262 15 : if (m == MATCH_ERROR)
4263 0 : goto error;
4264 15 : if (bval)
4265 : {
4266 14 : if (c->assume == NULL)
4267 12 : c->assume = gfc_get_omp_assumptions ();
4268 14 : c->assume->no_openmp_routines = true;
4269 : }
4270 : else
4271 : {
4272 1 : if (cfalse->assume == NULL)
4273 0 : cfalse->assume = gfc_get_omp_assumptions ();
4274 1 : cfalse->assume->no_openmp_routines = true;
4275 : }
4276 15 : continue;
4277 : }
4278 2972 : if ((mask & OMP_CLAUSE_ASSUMPTIONS)
4279 2981 : && ((m = gfc_match_boolean_clause (&bval, "no_openmp",
4280 15 : (c->assume && c->assume->no_openmp)
4281 13 : || (cfalse->assume && cfalse->assume->no_openmp)))
4282 : != MATCH_NO))
4283 : {
4284 6 : if (m == MATCH_ERROR)
4285 0 : goto error;
4286 6 : if (bval)
4287 : {
4288 5 : if (c->assume == NULL)
4289 5 : c->assume = gfc_get_omp_assumptions ();
4290 5 : c->assume->no_openmp = true;
4291 : }
4292 : else
4293 : {
4294 1 : if (cfalse->assume == NULL)
4295 1 : cfalse->assume = gfc_get_omp_assumptions ();
4296 1 : cfalse->assume->no_openmp = true;
4297 : }
4298 6 : continue;
4299 : }
4300 2968 : if ((mask & OMP_CLAUSE_ASSUMPTIONS)
4301 2969 : && ((m = gfc_match_boolean_clause (&bval, "no_parallelism",
4302 9 : (c->assume && c->assume->no_parallelism)
4303 9 : || (cfalse->assume && cfalse->assume->no_parallelism)))
4304 : != MATCH_NO))
4305 : {
4306 8 : if (m == MATCH_ERROR)
4307 0 : goto error;
4308 8 : if (bval)
4309 : {
4310 7 : if (c->assume == NULL)
4311 6 : c->assume = gfc_get_omp_assumptions ();
4312 7 : c->assume->no_parallelism = true;
4313 : }
4314 : else
4315 : {
4316 1 : if (cfalse->assume == NULL)
4317 0 : cfalse->assume = gfc_get_omp_assumptions ();
4318 1 : cfalse->assume->no_parallelism = true;
4319 : }
4320 8 : continue;
4321 : }
4322 :
4323 2962 : if ((mask & OMP_CLAUSE_NOVARIANTS)
4324 2952 : && (m = gfc_match_dupl_check (!c->novariants, "novariants", true,
4325 : &c->novariants))
4326 : != MATCH_NO)
4327 : {
4328 12 : if (m == MATCH_ERROR)
4329 2 : goto error;
4330 10 : continue;
4331 : }
4332 2953 : if ((mask & OMP_CLAUSE_NOCONTEXT)
4333 2940 : && (m = gfc_match_dupl_check (!c->nocontext, "nocontext", true,
4334 : &c->nocontext))
4335 : != MATCH_NO)
4336 : {
4337 15 : if (m == MATCH_ERROR)
4338 2 : goto error;
4339 13 : continue;
4340 : }
4341 2939 : if ((mask & OMP_CLAUSE_NOGROUP)
4342 3009 : && ((m = gfc_match_boolean_clause (&bval, "nogroup",
4343 84 : c->nogroup || cfalse->nogroup))
4344 : != MATCH_NO))
4345 : {
4346 14 : if (m == MATCH_ERROR)
4347 0 : goto error;
4348 14 : if (bval)
4349 14 : c->nogroup = true;
4350 : else
4351 0 : cfalse->nogroup = true;
4352 14 : continue;
4353 : }
4354 3061 : if ((mask & OMP_CLAUSE_NOHOST)
4355 2911 : && (m = gfc_match_dupl_check (!c->nohost, "nohost")) != MATCH_NO)
4356 : {
4357 151 : if (m == MATCH_ERROR)
4358 1 : goto error;
4359 150 : c->nohost = true;
4360 150 : continue;
4361 : }
4362 2802 : if ((mask & OMP_CLAUSE_NOTEMPORAL)
4363 2760 : && gfc_match_omp_variable_list ("nontemporal (",
4364 : &c->lists[OMP_LIST_NONTEMPORAL],
4365 : true) == MATCH_YES)
4366 42 : continue;
4367 2748 : if ((mask & OMP_CLAUSE_NOTINBRANCH)
4368 2751 : && (m = gfc_match_dupl_branch_clause (&bval, "notinbranch",
4369 33 : c->notinbranch || cfalse->notinbranch
4370 33 : || c->inbranch || cfalse->inbranch)) != MATCH_NO)
4371 : {
4372 33 : if (m == MATCH_ERROR)
4373 3 : goto error;
4374 30 : if (bval)
4375 27 : c->notinbranch = true;
4376 : else
4377 3 : cfalse->notinbranch = true;
4378 30 : continue;
4379 : }
4380 2818 : if ((mask & OMP_CLAUSE_NOWAIT)
4381 2685 : && (m = gfc_match_dupl_check (!c->nowait, "nowait")) != MATCH_NO)
4382 : {
4383 136 : if (m == MATCH_ERROR)
4384 3 : goto error;
4385 133 : c->nowait = true;
4386 133 : continue;
4387 : }
4388 3231 : if ((mask & OMP_CLAUSE_NUM_GANGS)
4389 2549 : && (m = gfc_match_dupl_check (!c->num_gangs_expr, "num_gangs",
4390 : true)) != MATCH_NO)
4391 : {
4392 686 : if (m == MATCH_ERROR)
4393 2 : goto error;
4394 684 : if (gfc_match (" %e )", &c->num_gangs_expr) != MATCH_YES)
4395 2 : goto error;
4396 682 : continue;
4397 : }
4398 1889 : if ((mask & OMP_CLAUSE_NUM_TASKS)
4399 1863 : && (m = gfc_match_dupl_check (!c->num_tasks, "num_tasks", true))
4400 : != MATCH_NO)
4401 : {
4402 26 : if (m == MATCH_ERROR)
4403 0 : goto error;
4404 26 : if (gfc_match ("strict : ") == MATCH_YES)
4405 1 : c->num_tasks_strict = true;
4406 26 : if (gfc_match (" %e )", &c->num_tasks) != MATCH_YES)
4407 0 : goto error;
4408 26 : continue;
4409 : }
4410 1837 : if ((mask & OMP_CLAUSE_NUM_TEAMS)
4411 1837 : && (m = gfc_match_dupl_check (!c->num_teams_list,
4412 : "num_teams", true)) != MATCH_NO)
4413 : {
4414 178 : if (m == MATCH_ERROR)
4415 20 : goto error;
4416 176 : gfc_expr *expr;
4417 176 : if (gfc_match ("dims ( %e ) : ", &expr) == MATCH_YES
4418 176 : && match_omp_oacc_expr_list (NULL, &c->num_teams_list,
4419 : false, true) == MATCH_YES)
4420 : {
4421 19 : int num = 0;
4422 19 : gfc_expr_list *el;
4423 55 : for (el = c->num_teams_list; el; el = el->next)
4424 36 : ++num;
4425 19 : if (!gfc_resolve_expr (expr)
4426 19 : || expr->ts.type != BT_INTEGER
4427 18 : || expr->rank != 0
4428 17 : || expr->expr_type != EXPR_CONSTANT
4429 34 : || mpz_sgn (expr->value.integer) <= 0)
4430 : {
4431 5 : gfc_error ("DIMS must be a constant positive integer "
4432 5 : "at %L", &expr->where);
4433 5 : goto error;
4434 : }
4435 14 : if (mpz_cmp_si (expr->value.integer, num) != 0)
4436 : {
4437 1 : gfc_error ("The number of arguments (%d) must be the same"
4438 : " as specified for DIMS at %L", num,
4439 : &expr->where);
4440 1 : goto error;
4441 : }
4442 13 : c->num_teams_dims = true;
4443 158 : continue;
4444 13 : }
4445 157 : else if (gfc_match ("%e ", &expr) == MATCH_YES)
4446 : {
4447 154 : c->num_teams_list = gfc_get_expr_list();
4448 154 : c->num_teams_list->expr = expr;
4449 154 : if (gfc_peek_ascii_char () == ':')
4450 : {
4451 31 : expr = NULL;
4452 31 : if (gfc_match (": %e ", &expr) == MATCH_YES)
4453 : {
4454 30 : c->num_teams_list->next = gfc_get_expr_list();
4455 30 : c->num_teams_list->next->expr = expr;
4456 30 : if (gfc_match (") ") == MATCH_YES)
4457 28 : continue;
4458 : }
4459 : }
4460 123 : else if (gfc_match (") ") == MATCH_YES)
4461 117 : continue;
4462 : }
4463 12 : gfc_error ("Expected either %<[lower-expr : ] upper-expr%> or "
4464 : "%<dims(N): expr-list%> at %C");
4465 12 : goto error;
4466 : }
4467 1659 : if ((mask & OMP_CLAUSE_NUM_THREADS)
4468 1659 : && (m = gfc_match_dupl_check (!c->num_threads_list,
4469 : "num_threads", true, NULL))
4470 : != MATCH_NO)
4471 : {
4472 1018 : int nstrict = 0, nrelaxed = 0, ndims = 0;
4473 1018 : bool fail = false;
4474 1018 : gfc_expr *dims = NULL;
4475 1018 : locus old_loc = gfc_current_locus;
4476 :
4477 1018 : if (m == MATCH_ERROR)
4478 27 : goto error;
4479 1068 : while (true)
4480 : {
4481 1042 : if (gfc_match ("strict ") == MATCH_YES)
4482 16 : nstrict++;
4483 1026 : else if (gfc_match ("relaxed ") == MATCH_YES)
4484 21 : nrelaxed++;
4485 1005 : else if (gfc_match ("dims ") == MATCH_YES)
4486 : {
4487 32 : ndims++;
4488 32 : if (dims)
4489 3 : gfc_free_expr (dims);
4490 32 : if (gfc_match ("( %e ) ", &dims) != MATCH_YES)
4491 : break;
4492 : }
4493 : else
4494 : {
4495 : fail = true;
4496 : break;
4497 : }
4498 68 : if (gfc_match (", ") == MATCH_YES)
4499 26 : continue;
4500 : break;
4501 : }
4502 1016 : if (gfc_match (" : ") == MATCH_YES)
4503 : {
4504 40 : if (nstrict + nrelaxed + ndims == 0 || fail)
4505 : {
4506 1 : gfc_error ("Expected STRICT, RELAXED or DIMS modifier at "
4507 : "%C");
4508 1 : goto error;
4509 : }
4510 39 : else if (nstrict + nrelaxed > 1)
4511 : {
4512 8 : gfc_error ("Only one STRICT or RELAXED modifier permitted"
4513 : " at %L", &old_loc);
4514 8 : goto error;
4515 : }
4516 31 : if (ndims > 1)
4517 : {
4518 3 : gfc_error ("Duplicated DIMS expression at %L",
4519 3 : &dims->where);
4520 3 : goto error;
4521 : }
4522 28 : if (nstrict || (dims && !nrelaxed))
4523 17 : c->num_threads_strict = true;
4524 : }
4525 : else
4526 : {
4527 976 : gfc_free_expr (dims);
4528 976 : dims = NULL;
4529 976 : gfc_current_locus = old_loc;
4530 : }
4531 :
4532 1004 : m = match_omp_oacc_expr_list (NULL, &c->num_threads_list, false,
4533 : true);
4534 1004 : if (m != MATCH_YES)
4535 : {
4536 7 : gfc_error ("Expected a list of integer expressions followed "
4537 : "by a %<)%> and optionally preceded by the STRICT,"
4538 : " RELAXED, or DIMS as modifiers and a colon at %C");
4539 7 : goto error;
4540 : }
4541 997 : if (dims)
4542 : {
4543 17 : int num = 0;
4544 17 : gfc_expr_list *el;
4545 46 : for (el = c->num_threads_list; el; el = el->next)
4546 29 : ++num;
4547 17 : if (!gfc_resolve_expr (dims)
4548 17 : || dims->ts.type != BT_INTEGER
4549 16 : || dims->rank != 0
4550 15 : || dims->expr_type != EXPR_CONSTANT
4551 30 : || mpz_sgn (dims->value.integer) <= 0)
4552 : {
4553 5 : gfc_error ("DIMS must be a constant positive integer "
4554 5 : "at %L", &dims->where);
4555 5 : goto error;
4556 : }
4557 12 : if (mpz_cmp_si (dims->value.integer, num) != 0)
4558 : {
4559 1 : gfc_error ("The number of arguments (%d) must be the same"
4560 : " as specified for DIMS at %L", num,
4561 : &dims->where);
4562 1 : goto error;
4563 : }
4564 11 : c->num_threads_dims = true;
4565 : }
4566 991 : continue;
4567 991 : }
4568 1240 : if ((mask & OMP_CLAUSE_NUM_WORKERS)
4569 641 : && (m = gfc_match_dupl_check (!c->num_workers_expr, "num_workers",
4570 : true, &c->num_workers_expr))
4571 : != MATCH_NO)
4572 : {
4573 603 : if (m == MATCH_ERROR)
4574 4 : goto error;
4575 599 : continue;
4576 : }
4577 : break;
4578 591 : case 'o':
4579 591 : if ((mask & OMP_CLAUSE_ORDERED)
4580 591 : && (m = gfc_match_dupl_check (!c->ordered, "ordered"))
4581 : != MATCH_NO)
4582 : {
4583 343 : if (m == MATCH_ERROR)
4584 0 : goto error;
4585 343 : gfc_expr *cexpr = NULL;
4586 343 : m = gfc_match (" ( %e )", &cexpr);
4587 :
4588 343 : c->ordered = true;
4589 343 : if (m == MATCH_YES)
4590 : {
4591 144 : int ordered = 0;
4592 144 : if (gfc_extract_int (cexpr, &ordered, -1))
4593 0 : ordered = 0;
4594 144 : else if (ordered <= 0)
4595 : {
4596 0 : gfc_error_now ("ORDERED clause argument not"
4597 : " constant positive integer at %C");
4598 0 : ordered = 0;
4599 : }
4600 144 : c->orderedc = ordered;
4601 144 : gfc_free_expr (cexpr);
4602 144 : continue;
4603 144 : }
4604 :
4605 199 : continue;
4606 199 : }
4607 482 : if ((mask & OMP_CLAUSE_ORDER)
4608 248 : && (m = gfc_match_dupl_check (!c->order_concurrent, "order", true))
4609 : != MATCH_NO)
4610 : {
4611 247 : if (m == MATCH_ERROR)
4612 10 : goto error;
4613 237 : if (gfc_match (" reproducible : concurrent )") == MATCH_YES)
4614 55 : c->order_reproducible = true;
4615 182 : else if (gfc_match (" concurrent )") == MATCH_YES)
4616 : ;
4617 50 : else if (gfc_match (" unconstrained : concurrent )") == MATCH_YES)
4618 47 : c->order_unconstrained = true;
4619 : else
4620 : {
4621 3 : gfc_error ("Expected ORDER(CONCURRENT) at %C "
4622 : "with optional %<reproducible%> or "
4623 : "%<unconstrained%> modifier");
4624 3 : goto error;
4625 : }
4626 234 : c->order_concurrent = true;
4627 234 : continue;
4628 : }
4629 : break;
4630 3108 : case 'p':
4631 3108 : if (mask & OMP_CLAUSE_PARTIAL)
4632 : {
4633 276 : if ((m = gfc_match_dupl_check (!c->partial, "partial"))
4634 : != MATCH_NO)
4635 : {
4636 276 : int expr;
4637 276 : if (m == MATCH_ERROR)
4638 0 : goto error;
4639 :
4640 276 : c->partial = -1;
4641 :
4642 276 : gfc_expr *cexpr = NULL;
4643 276 : m = gfc_match (" ( %e )", &cexpr);
4644 276 : if (m == MATCH_NO)
4645 : ;
4646 251 : else if (m == MATCH_YES
4647 251 : && !gfc_extract_int (cexpr, &expr, -1)
4648 502 : && expr > 0)
4649 247 : c->partial = expr;
4650 : else
4651 4 : gfc_error_now ("PARTIAL clause argument not constant "
4652 : "positive integer at %C");
4653 276 : gfc_free_expr (cexpr);
4654 276 : continue;
4655 276 : }
4656 : }
4657 2901 : if ((mask & OMP_CLAUSE_COPY)
4658 877 : && gfc_match ("pcopy ( ") == MATCH_YES
4659 2902 : && gfc_match_omp_map_clause (&c->lists[OMP_LIST_MAP],
4660 : OMP_MAP_TOFROM, true, allow_derived))
4661 69 : continue;
4662 2837 : if ((mask & OMP_CLAUSE_COPYIN)
4663 1911 : && gfc_match ("pcopyin ( ") == MATCH_YES
4664 2837 : && gfc_match_omp_map_clause (&c->lists[OMP_LIST_MAP],
4665 : OMP_MAP_TO, true, allow_derived))
4666 74 : continue;
4667 2762 : if ((mask & OMP_CLAUSE_COPYOUT)
4668 735 : && gfc_match ("pcopyout ( ") == MATCH_YES
4669 2762 : && gfc_match_omp_map_clause (&c->lists[OMP_LIST_MAP],
4670 : OMP_MAP_FROM, true, allow_derived))
4671 73 : continue;
4672 2631 : if ((mask & OMP_CLAUSE_CREATE)
4673 672 : && gfc_match ("pcreate ( ") == MATCH_YES
4674 2631 : && gfc_match_omp_map_clause (&c->lists[OMP_LIST_MAP],
4675 : OMP_MAP_ALLOC, true, allow_derived))
4676 15 : continue;
4677 3017 : if ((mask & OMP_CLAUSE_PRESENT)
4678 647 : && gfc_match ("present ( ") == MATCH_YES
4679 3019 : && gfc_match_omp_map_clause (&c->lists[OMP_LIST_MAP],
4680 : OMP_MAP_FORCE_PRESENT, false,
4681 : allow_derived))
4682 416 : continue;
4683 2208 : if ((mask & OMP_CLAUSE_COPY)
4684 231 : && gfc_match ("present_or_copy ( ") == MATCH_YES
4685 2208 : && gfc_match_omp_map_clause (&c->lists[OMP_LIST_MAP],
4686 : OMP_MAP_TOFROM, true,
4687 : allow_derived))
4688 23 : continue;
4689 2202 : if ((mask & OMP_CLAUSE_COPYIN)
4690 1310 : && gfc_match ("present_or_copyin ( ") == MATCH_YES
4691 2202 : && gfc_match_omp_map_clause (&c->lists[OMP_LIST_MAP],
4692 : OMP_MAP_TO, true, allow_derived))
4693 40 : continue;
4694 2157 : if ((mask & OMP_CLAUSE_COPYOUT)
4695 173 : && gfc_match ("present_or_copyout ( ") == MATCH_YES
4696 2157 : && gfc_match_omp_map_clause (&c->lists[OMP_LIST_MAP],
4697 : OMP_MAP_FROM, true, allow_derived))
4698 35 : continue;
4699 2115 : if ((mask & OMP_CLAUSE_CREATE)
4700 143 : && gfc_match ("present_or_create ( ") == MATCH_YES
4701 2115 : && gfc_match_omp_map_clause (&c->lists[OMP_LIST_MAP],
4702 : OMP_MAP_ALLOC, true, allow_derived))
4703 28 : continue;
4704 2094 : if ((mask & OMP_CLAUSE_PRIORITY)
4705 2059 : && (m = gfc_match_dupl_check (!c->priority, "priority", true,
4706 : &c->priority)) != MATCH_NO)
4707 : {
4708 35 : if (m == MATCH_ERROR)
4709 0 : goto error;
4710 35 : continue;
4711 : }
4712 3971 : if ((mask & OMP_CLAUSE_PRIVATE)
4713 2024 : && gfc_match_omp_variable_list ("private (",
4714 : &c->lists[OMP_LIST_PRIVATE],
4715 : true) == MATCH_YES)
4716 1947 : continue;
4717 141 : if ((mask & OMP_CLAUSE_PROC_BIND)
4718 141 : && (m = gfc_match_dupl_check ((c->proc_bind
4719 64 : == OMP_PROC_BIND_UNKNOWN),
4720 : "proc_bind", true)) != MATCH_NO)
4721 : {
4722 64 : if (m == MATCH_ERROR)
4723 0 : goto error;
4724 64 : if (gfc_match ("primary )") == MATCH_YES)
4725 1 : c->proc_bind = OMP_PROC_BIND_PRIMARY;
4726 63 : else if (gfc_match ("master )") == MATCH_YES)
4727 : {
4728 9 : gfc_warning (OPT_Wdeprecated_openmp,
4729 : "%<master%> affinity policy at %C deprecated "
4730 : "since OpenMP 5.1, use %<primary%>");
4731 9 : c->proc_bind = OMP_PROC_BIND_MASTER;
4732 : }
4733 54 : else if (gfc_match ("spread )") == MATCH_YES)
4734 53 : c->proc_bind = OMP_PROC_BIND_SPREAD;
4735 1 : else if (gfc_match ("close )") == MATCH_YES)
4736 1 : c->proc_bind = OMP_PROC_BIND_CLOSE;
4737 : else
4738 0 : goto error;
4739 64 : continue;
4740 : }
4741 : break;
4742 4614 : case 'r':
4743 5115 : if ((mask & OMP_CLAUSE_ATOMIC)
4744 5161 : && (m = gfc_match_dupl_atomic (&bval, "read",
4745 547 : c->atomic_op != GFC_OMP_ATOMIC_UNSET)) != MATCH_NO)
4746 : {
4747 501 : if (m == MATCH_ERROR)
4748 0 : goto error;
4749 501 : if (bval)
4750 493 : c->atomic_op = GFC_OMP_ATOMIC_READ;
4751 501 : continue;
4752 : }
4753 8171 : if ((mask & OMP_CLAUSE_REDUCTION)
4754 4113 : && gfc_match_omp_clause_reduction (pc, c, openacc,
4755 : allow_derived) == MATCH_YES)
4756 4058 : continue;
4757 74 : if ((mask & OMP_CLAUSE_MEMORDER)
4758 101 : && (m = gfc_match_dupl_memorder (&bval, "relaxed",
4759 46 : c->memorder != OMP_MEMORDER_UNSET)) != MATCH_NO)
4760 : {
4761 19 : if (m == MATCH_ERROR)
4762 0 : goto error;
4763 19 : if (bval)
4764 12 : c->memorder = OMP_MEMORDER_RELAXED;
4765 19 : continue;
4766 : }
4767 61 : if ((mask & OMP_CLAUSE_MEMORDER)
4768 63 : && (m = gfc_match_dupl_memorder (&bval, "release",
4769 27 : c->memorder != OMP_MEMORDER_UNSET)) != MATCH_NO)
4770 : {
4771 27 : if (m == MATCH_ERROR)
4772 2 : goto error;
4773 25 : if (bval)
4774 17 : c->memorder = OMP_MEMORDER_RELEASE;
4775 25 : continue;
4776 : }
4777 : break;
4778 3091 : case 's':
4779 3184 : if ((mask & OMP_CLAUSE_SAFELEN)
4780 3091 : && (m = gfc_match_dupl_check (!c->safelen_expr, "safelen",
4781 : true, &c->safelen_expr))
4782 : != MATCH_NO)
4783 : {
4784 93 : if (m == MATCH_ERROR)
4785 0 : goto error;
4786 93 : continue;
4787 : }
4788 2998 : if ((mask & OMP_CLAUSE_SCHEDULE)
4789 2998 : && (m = gfc_match_dupl_check (c->sched_kind == OMP_SCHED_NONE,
4790 : "schedule", true)) != MATCH_NO)
4791 : {
4792 809 : if (m == MATCH_ERROR)
4793 0 : goto error;
4794 809 : int nmodifiers = 0;
4795 809 : locus old_loc2 = gfc_current_locus;
4796 827 : do
4797 : {
4798 818 : if (gfc_match ("simd") == MATCH_YES)
4799 : {
4800 18 : c->sched_simd = true;
4801 18 : nmodifiers++;
4802 : }
4803 800 : else if (gfc_match ("monotonic") == MATCH_YES)
4804 : {
4805 30 : c->sched_monotonic = true;
4806 30 : nmodifiers++;
4807 : }
4808 770 : else if (gfc_match ("nonmonotonic") == MATCH_YES)
4809 : {
4810 35 : c->sched_nonmonotonic = true;
4811 35 : nmodifiers++;
4812 : }
4813 : else
4814 : {
4815 735 : if (nmodifiers)
4816 0 : gfc_current_locus = old_loc2;
4817 : break;
4818 : }
4819 92 : if (nmodifiers == 1
4820 83 : && gfc_match (" , ") == MATCH_YES)
4821 9 : continue;
4822 74 : else if (gfc_match (" : ") == MATCH_YES)
4823 : break;
4824 0 : gfc_current_locus = old_loc2;
4825 0 : break;
4826 : }
4827 : while (1);
4828 809 : if (gfc_match ("static") == MATCH_YES)
4829 425 : c->sched_kind = OMP_SCHED_STATIC;
4830 384 : else if (gfc_match ("dynamic") == MATCH_YES)
4831 164 : c->sched_kind = OMP_SCHED_DYNAMIC;
4832 220 : else if (gfc_match ("guided") == MATCH_YES)
4833 127 : c->sched_kind = OMP_SCHED_GUIDED;
4834 93 : else if (gfc_match ("runtime") == MATCH_YES)
4835 85 : c->sched_kind = OMP_SCHED_RUNTIME;
4836 8 : else if (gfc_match ("auto") == MATCH_YES)
4837 8 : c->sched_kind = OMP_SCHED_AUTO;
4838 809 : if (c->sched_kind != OMP_SCHED_NONE)
4839 : {
4840 809 : m = MATCH_NO;
4841 809 : if (c->sched_kind != OMP_SCHED_RUNTIME
4842 724 : && c->sched_kind != OMP_SCHED_AUTO)
4843 716 : m = gfc_match (" , %e )", &c->chunk_size);
4844 716 : if (m != MATCH_YES)
4845 299 : m = gfc_match_char (')');
4846 299 : if (m != MATCH_YES)
4847 0 : c->sched_kind = OMP_SCHED_NONE;
4848 : }
4849 809 : if (c->sched_kind != OMP_SCHED_NONE)
4850 809 : continue;
4851 : else
4852 0 : gfc_current_locus = old_loc;
4853 : }
4854 2372 : if ((mask & OMP_CLAUSE_SELF)
4855 335 : && !(mask & OMP_CLAUSE_HOST) /* OpenACC compute construct */
4856 2429 : && (m = gfc_match_dupl_check (!c->self_expr, "self"))
4857 : != MATCH_NO)
4858 : {
4859 186 : if (m == MATCH_ERROR)
4860 3 : goto error;
4861 183 : m = gfc_match (" ( %e )", &c->self_expr);
4862 183 : if (m == MATCH_ERROR)
4863 : {
4864 0 : gfc_current_locus = old_loc;
4865 0 : break;
4866 : }
4867 183 : else if (m == MATCH_NO)
4868 9 : c->self_expr = gfc_get_logical_expr (gfc_default_logical_kind,
4869 : NULL, true);
4870 183 : continue;
4871 : }
4872 2097 : if ((mask & OMP_CLAUSE_SELF)
4873 149 : && (mask & OMP_CLAUSE_HOST) /* OpenACC 'update' directive */
4874 95 : && gfc_match ("self ( ") == MATCH_YES
4875 2098 : && gfc_match_omp_map_clause (&c->lists[OMP_LIST_MAP],
4876 : OMP_MAP_FORCE_FROM, true,
4877 : /* allow_derived = */ true))
4878 94 : continue;
4879 2257 : if ((mask & OMP_CLAUSE_SEQ)
4880 1909 : && (m = gfc_match_dupl_check (!c->seq, "seq")) != MATCH_NO)
4881 : {
4882 348 : if (m == MATCH_ERROR)
4883 0 : goto error;
4884 348 : c->seq = true;
4885 348 : continue;
4886 : }
4887 1710 : if ((mask & OMP_CLAUSE_MEMORDER)
4888 1710 : && (m = gfc_match_dupl_memorder (&bval, "seq_cst",
4889 149 : c->memorder != OMP_MEMORDER_UNSET)) != MATCH_NO)
4890 : {
4891 149 : if (m == MATCH_ERROR)
4892 0 : goto error;
4893 149 : if (bval)
4894 143 : c->memorder = OMP_MEMORDER_SEQ_CST;
4895 149 : continue;
4896 : }
4897 2387 : if ((mask & OMP_CLAUSE_SHARED)
4898 1412 : && gfc_match_omp_variable_list ("shared (",
4899 : &c->lists[OMP_LIST_SHARED],
4900 : true) == MATCH_YES)
4901 975 : continue;
4902 437 : if ((mask & OMP_CLAUSE_SIMDLEN)
4903 437 : && (m = gfc_match_dupl_check (!c->simdlen_expr, "simdlen",
4904 : true)) != MATCH_NO)
4905 : {
4906 151 : if (m == MATCH_ERROR)
4907 0 : goto error;
4908 151 : if (gfc_match ("scaled ( ") == MATCH_YES)
4909 : {
4910 27 : old_loc = gfc_current_locus;
4911 27 : gfc_typespec ts;
4912 : /* This does not match 'type(integer)'; should it? */
4913 27 : if (gfc_match_type_spec (&ts) != MATCH_YES
4914 27 : || (ts.type != BT_INTEGER && ts.type != BT_UNSIGNED
4915 : && ts.type != BT_REAL && ts.type != BT_COMPLEX))
4916 : {
4917 2 : gfc_error ("Expected numerical type name at %L",
4918 : &old_loc);
4919 5 : goto error;
4920 : }
4921 25 : c->simdlen_type.type = ts.type;
4922 25 : c->simdlen_type.kind = ts.kind;
4923 25 : if (gfc_match (" , ") == MATCH_YES)
4924 : {
4925 17 : if (gfc_match_expr (&c->simdlen_divisor) != MATCH_YES)
4926 : {
4927 0 : gfc_error ("Expected divisor expression at %C");
4928 0 : goto error;
4929 : }
4930 : }
4931 25 : if (gfc_match (" ) ") != MATCH_YES)
4932 : {
4933 2 : gfc_error ("Expected %<)%> at %C");
4934 2 : goto error;
4935 : }
4936 23 : if (gfc_match (" : ") != MATCH_YES)
4937 : {
4938 1 : gfc_error ("Expected %<:%> at %C");
4939 1 : goto error;
4940 : }
4941 : }
4942 146 : if (gfc_match_expr (&c->simdlen_expr) != MATCH_YES)
4943 : {
4944 0 : gfc_error ("Expected length expression at %C");
4945 0 : goto error;
4946 : }
4947 146 : if (gfc_match (" ) ") != MATCH_YES)
4948 : {
4949 0 : gfc_error ("Expected %<)%> at %C");
4950 0 : goto error;
4951 : }
4952 146 : continue;
4953 146 : }
4954 312 : if ((mask & OMP_CLAUSE_SIMD)
4955 312 : && ((m = gfc_match_boolean_clause (&bval, "simd",
4956 26 : c->simd || cfalse->simd))
4957 : != MATCH_NO))
4958 : {
4959 26 : if (m == MATCH_ERROR)
4960 0 : goto error;
4961 26 : if (bval)
4962 24 : c->simd = true;
4963 : else
4964 2 : cfalse->simd = false;
4965 26 : continue;
4966 : }
4967 305 : if ((mask & OMP_CLAUSE_SEVERITY)
4968 260 : && (m = gfc_match_dupl_check (!c->severity, "severity", true))
4969 : != MATCH_NO)
4970 : {
4971 51 : if (m == MATCH_ERROR)
4972 2 : goto error;
4973 49 : if (gfc_match ("fatal )") == MATCH_YES)
4974 12 : c->severity = OMP_SEVERITY_FATAL;
4975 37 : else if (gfc_match ("warning )") == MATCH_YES)
4976 33 : c->severity = OMP_SEVERITY_WARNING;
4977 : else
4978 : {
4979 4 : gfc_error ("Expected FATAL or WARNING in SEVERITY clause "
4980 : "at %C");
4981 4 : goto error;
4982 : }
4983 45 : continue;
4984 : }
4985 209 : if ((mask & OMP_CLAUSE_SIZES)
4986 209 : && ((m = gfc_match_dupl_check (!c->sizes_list, "sizes"))
4987 : != MATCH_NO))
4988 : {
4989 203 : if (m == MATCH_ERROR)
4990 0 : goto error;
4991 203 : m = match_omp_oacc_expr_list (" (", &c->sizes_list, false, true);
4992 203 : if (m == MATCH_ERROR)
4993 7 : goto error;
4994 196 : if (m == MATCH_YES)
4995 195 : continue;
4996 1 : gfc_error ("Expected %<(%> after %qs at %C", "sizes");
4997 1 : goto error;
4998 : }
4999 : break;
5000 1288 : case 't':
5001 1353 : if ((mask & OMP_CLAUSE_TASK_REDUCTION)
5002 1288 : && gfc_match_omp_clause_reduction (pc, c, openacc,
5003 : allow_derived) == MATCH_YES)
5004 65 : continue;
5005 1223 : if ((mask & OMP_CLAUSE_THREAD_LIMIT)
5006 1223 : && (m = gfc_match_dupl_check (!c->thread_limit_list, "thread_limit",
5007 : true, NULL)) != MATCH_NO)
5008 : {
5009 133 : int nstrict = 0, nrelaxed = 0, ndims = 0;
5010 133 : bool fail = false;
5011 133 : gfc_expr *dims = NULL;
5012 133 : locus old_loc = gfc_current_locus;
5013 :
5014 133 : if (m == MATCH_ERROR)
5015 28 : goto error;
5016 179 : while (true)
5017 : {
5018 155 : if (gfc_match ("strict ") == MATCH_YES)
5019 15 : nstrict++;
5020 140 : else if (gfc_match ("relaxed ") == MATCH_YES)
5021 25 : nrelaxed++;
5022 115 : else if (gfc_match ("dims ") == MATCH_YES)
5023 : {
5024 31 : ndims++;
5025 31 : if (dims)
5026 3 : gfc_free_expr (dims);
5027 31 : if (gfc_match ("( %e ) ", &dims) != MATCH_YES)
5028 : break;
5029 : }
5030 : else
5031 : {
5032 : fail = true;
5033 : break;
5034 : }
5035 70 : if (gfc_match (", ") == MATCH_YES)
5036 24 : continue;
5037 : break;
5038 : }
5039 131 : if (gfc_match (" : ") == MATCH_YES)
5040 : {
5041 44 : if (nstrict + nrelaxed + ndims == 0 || fail)
5042 : {
5043 1 : gfc_error ("Expected STRICT, RELAXED or DIMS modifier at "
5044 : "%C");
5045 1 : goto error;
5046 : }
5047 43 : else if (nstrict + nrelaxed > 1)
5048 : {
5049 8 : gfc_error ("Only one STRICT or RELAXED modifier permitted"
5050 : " at %L", &old_loc);
5051 8 : goto error;
5052 : }
5053 35 : if (ndims > 1)
5054 : {
5055 3 : gfc_error ("Duplicated DIMS expression at %L",
5056 3 : &dims->where);
5057 3 : goto error;
5058 : }
5059 : }
5060 : else
5061 : {
5062 87 : gfc_free_expr (dims);
5063 87 : dims = NULL;
5064 87 : gfc_current_locus = old_loc;
5065 : }
5066 :
5067 119 : m = match_omp_oacc_expr_list (NULL, &c->thread_limit_list,
5068 : false, true);
5069 119 : if (m != MATCH_YES)
5070 : {
5071 7 : gfc_error ("Expected a list of integer expressions followed "
5072 : "by a %<)%> and optionally preceded by the STRICT,"
5073 : " RELAXED, or DIMS as modifiers and a colon at %C");
5074 7 : goto error;
5075 : }
5076 112 : c->thread_limit_strict = (nstrict != 0) || (dims && !nrelaxed);
5077 :
5078 112 : if (!dims && c->thread_limit_list->next)
5079 : {
5080 1 : gfc_error ("Without the DIM modifier, only a single integer "
5081 : "expression may be specified at %L",
5082 1 : &c->thread_limit_list->next->expr->where);
5083 1 : goto error;
5084 : }
5085 111 : else if (dims)
5086 : {
5087 16 : int num = 0;
5088 16 : gfc_expr_list *el;
5089 53 : for (el = c->thread_limit_list; el; el = el->next)
5090 37 : ++num;
5091 16 : if (!gfc_resolve_expr (dims)
5092 16 : || dims->ts.type != BT_INTEGER
5093 15 : || dims->rank != 0
5094 14 : || dims->expr_type != EXPR_CONSTANT
5095 28 : || mpz_sgn (dims->value.integer) <= 0)
5096 : {
5097 5 : gfc_error ("DIMS must be a constant positive integer "
5098 5 : "at %L", &dims->where);
5099 5 : goto error;
5100 : }
5101 11 : if (mpz_cmp_si (dims->value.integer, num) != 0)
5102 : {
5103 1 : gfc_error ("The number of arguments (%d) must be the same"
5104 : " as specified for DIMS at %L", num,
5105 : &dims->where);
5106 1 : goto error;
5107 : }
5108 10 : c->thread_limit_dims = true;
5109 : }
5110 105 : continue;
5111 105 : }
5112 1107 : if ((mask & OMP_CLAUSE_THREADS)
5113 1107 : && ((m = gfc_match_boolean_clause (&bval, "threads",
5114 17 : c->threads || cfalse->threads))
5115 : != MATCH_NO))
5116 : {
5117 17 : if (m == MATCH_ERROR)
5118 0 : goto error;
5119 17 : if (bval)
5120 15 : c->threads = true;
5121 : else
5122 2 : cfalse->threads = false;
5123 17 : continue;
5124 : }
5125 1270 : if ((mask & OMP_CLAUSE_TILE)
5126 221 : && !c->tile_list
5127 1294 : && match_omp_oacc_expr_list ("tile (", &c->tile_list,
5128 : true, false) == MATCH_YES)
5129 197 : continue;
5130 876 : if ((mask & OMP_CLAUSE_TO) && (mask & OMP_CLAUSE_LINK))
5131 : {
5132 : /* Declare target: 'to' is an alias for 'enter';
5133 : 'to' is deprecated since 5.2. */
5134 117 : m = gfc_match_omp_to_link ("to (", &c->lists[OMP_LIST_TO]);
5135 117 : if (m == MATCH_ERROR)
5136 0 : goto error;
5137 117 : if (m == MATCH_YES)
5138 : {
5139 117 : gfc_warning (OPT_Wdeprecated_openmp,
5140 : "%<to%> clause with %<declare target%> at %L "
5141 : "deprecated since OpenMP 5.2, use %<enter%>",
5142 : &old_loc);
5143 117 : continue;
5144 : }
5145 : }
5146 1487 : else if ((mask & OMP_CLAUSE_TO)
5147 759 : && gfc_match_motion_var_list ("to (", &c->lists[OMP_LIST_TO],
5148 : &head) == MATCH_YES)
5149 728 : continue;
5150 : break;
5151 1551 : case 'u':
5152 1609 : if ((mask & OMP_CLAUSE_UNIFORM)
5153 1551 : && gfc_match_omp_variable_list ("uniform (",
5154 : &c->lists[OMP_LIST_UNIFORM],
5155 : false) == MATCH_YES)
5156 58 : continue;
5157 1636 : if ((mask & OMP_CLAUSE_UNTIED)
5158 1636 : && ((m = gfc_match_boolean_clause (&bval, "untied",
5159 143 : c->untied || cfalse->untied))
5160 : != MATCH_NO))
5161 : {
5162 143 : if (m == MATCH_ERROR)
5163 0 : goto error;
5164 143 : if (bval)
5165 142 : c->untied = true;
5166 : else
5167 1 : cfalse->untied = true;
5168 143 : continue;
5169 : }
5170 1605 : if ((mask & OMP_CLAUSE_ATOMIC)
5171 1606 : && (m = gfc_match_dupl_atomic (&bval, "update",
5172 256 : c->atomic_op != GFC_OMP_ATOMIC_UNSET)) != MATCH_NO)
5173 : {
5174 256 : if (m == MATCH_ERROR)
5175 1 : goto error;
5176 255 : if (bval)
5177 249 : c->atomic_op = GFC_OMP_ATOMIC_UPDATE;
5178 255 : continue;
5179 : }
5180 1116 : if ((mask & OMP_CLAUSE_USE)
5181 1094 : && gfc_match_omp_variable_list ("use (",
5182 : &c->lists[OMP_LIST_USE],
5183 : true) == MATCH_YES)
5184 22 : continue;
5185 1132 : if ((mask & OMP_CLAUSE_USE_DEVICE)
5186 1072 : && gfc_match_omp_variable_list ("use_device (",
5187 : &c->lists[OMP_LIST_USE_DEVICE],
5188 : true) == MATCH_YES)
5189 60 : continue;
5190 1175 : if ((mask & OMP_CLAUSE_USE_DEVICE_PTR)
5191 1940 : && gfc_match_omp_variable_list
5192 928 : ("use_device_ptr (",
5193 : &c->lists[OMP_LIST_USE_DEVICE_PTR], false) == MATCH_YES)
5194 163 : continue;
5195 1614 : if ((mask & OMP_CLAUSE_USE_DEVICE_ADDR)
5196 1614 : && gfc_match_omp_variable_list
5197 765 : ("use_device_addr (", &c->lists[OMP_LIST_USE_DEVICE_ADDR],
5198 : false, NULL, NULL, true) == MATCH_YES)
5199 765 : continue;
5200 153 : if ((mask & OMP_CLAUSE_USES_ALLOCATORS)
5201 84 : && (gfc_match ("uses_allocators ( ") == MATCH_YES))
5202 : {
5203 78 : if (gfc_match_omp_clause_uses_allocators (c) != MATCH_YES)
5204 9 : goto error;
5205 69 : continue;
5206 : }
5207 : break;
5208 1570 : case 'v':
5209 : /* VECTOR_LENGTH must be matched before VECTOR, because the latter
5210 : doesn't unconditionally match '('. */
5211 2139 : if ((mask & OMP_CLAUSE_VECTOR_LENGTH)
5212 1570 : && (m = gfc_match_dupl_check (!c->vector_length_expr,
5213 : "vector_length", true,
5214 : &c->vector_length_expr))
5215 : != MATCH_NO)
5216 : {
5217 573 : if (m == MATCH_ERROR)
5218 4 : goto error;
5219 569 : continue;
5220 : }
5221 1989 : if ((mask & OMP_CLAUSE_VECTOR)
5222 997 : && (m = gfc_match_dupl_check (!c->vector, "vector")) != MATCH_NO)
5223 : {
5224 995 : if (m == MATCH_ERROR)
5225 0 : goto error;
5226 995 : c->vector = true;
5227 995 : m = match_oacc_clause_gwv (c, GOMP_DIM_VECTOR);
5228 995 : if (m == MATCH_ERROR)
5229 3 : goto error;
5230 992 : continue;
5231 : }
5232 : break;
5233 1505 : case 'w':
5234 1505 : if ((mask & OMP_CLAUSE_WAIT)
5235 1505 : && gfc_match ("wait") == MATCH_YES)
5236 : {
5237 192 : m = match_omp_oacc_expr_list (" (", &c->wait_list, false, false);
5238 192 : if (m == MATCH_ERROR)
5239 9 : goto error;
5240 183 : else if (m == MATCH_NO)
5241 : {
5242 47 : gfc_expr *expr
5243 47 : = gfc_get_constant_expr (BT_INTEGER,
5244 : gfc_default_integer_kind,
5245 : &gfc_current_locus);
5246 47 : mpz_set_si (expr->value.integer, GOMP_ASYNC_NOVAL);
5247 47 : gfc_expr_list **expr_list = &c->wait_list;
5248 56 : while (*expr_list)
5249 9 : expr_list = &(*expr_list)->next;
5250 47 : *expr_list = gfc_get_expr_list ();
5251 47 : (*expr_list)->expr = expr;
5252 47 : needs_space = true;
5253 : }
5254 183 : continue;
5255 183 : }
5256 1330 : if ((mask & OMP_CLAUSE_WEAK)
5257 1759 : && ((m = gfc_match_boolean_clause (&bval, "weak",
5258 446 : c->weak || cfalse->weak))
5259 : != MATCH_NO))
5260 : {
5261 18 : if (m == MATCH_ERROR)
5262 1 : goto error;
5263 17 : if (bval)
5264 14 : c->weak = true;
5265 : else
5266 3 : cfalse->weak = true;
5267 17 : continue;
5268 : }
5269 2156 : if ((mask & OMP_CLAUSE_WORKER)
5270 1295 : && (m = gfc_match_dupl_check (!c->worker, "worker")) != MATCH_NO)
5271 : {
5272 864 : if (m == MATCH_ERROR)
5273 0 : goto error;
5274 864 : c->worker = true;
5275 864 : m = match_oacc_clause_gwv (c, GOMP_DIM_WORKER);
5276 864 : if (m == MATCH_ERROR)
5277 3 : goto error;
5278 861 : continue;
5279 : }
5280 856 : if ((mask & OMP_CLAUSE_ATOMIC)
5281 859 : && (m = gfc_match_dupl_atomic (&bval, "write",
5282 428 : c->atomic_op != GFC_OMP_ATOMIC_UNSET)) != MATCH_NO)
5283 : {
5284 428 : if (m == MATCH_ERROR)
5285 3 : goto error;
5286 425 : if (bval)
5287 418 : c->atomic_op = GFC_OMP_ATOMIC_WRITE;
5288 425 : continue;
5289 : }
5290 : break;
5291 : }
5292 : break;
5293 47140 : }
5294 :
5295 35271 : end:
5296 35271 : if (cfalse)
5297 21403 : gfc_free_omp_clauses (cfalse);
5298 35271 : if (error || gfc_match_omp_eos () != MATCH_YES)
5299 : {
5300 669 : if (!gfc_error_flag_test ())
5301 152 : gfc_error ("Failed to match clause at %C");
5302 669 : gfc_free_omp_clauses (c);
5303 669 : return MATCH_ERROR;
5304 : }
5305 :
5306 34602 : *cp = c;
5307 34602 : return MATCH_YES;
5308 :
5309 368 : error:
5310 368 : error = true;
5311 368 : goto end;
5312 : }
5313 :
5314 :
5315 : #define OACC_PARALLEL_CLAUSES \
5316 : (omp_mask (OMP_CLAUSE_IF) | OMP_CLAUSE_ASYNC | OMP_CLAUSE_NUM_GANGS \
5317 : | OMP_CLAUSE_NUM_WORKERS | OMP_CLAUSE_VECTOR_LENGTH | OMP_CLAUSE_REDUCTION \
5318 : | OMP_CLAUSE_COPY | OMP_CLAUSE_COPYIN | OMP_CLAUSE_COPYOUT \
5319 : | OMP_CLAUSE_CREATE | OMP_CLAUSE_NO_CREATE | OMP_CLAUSE_PRESENT \
5320 : | OMP_CLAUSE_DEVICEPTR | OMP_CLAUSE_PRIVATE | OMP_CLAUSE_FIRSTPRIVATE \
5321 : | OMP_CLAUSE_DEFAULT | OMP_CLAUSE_WAIT | OMP_CLAUSE_ATTACH \
5322 : | OMP_CLAUSE_SELF)
5323 : #define OACC_KERNELS_CLAUSES \
5324 : (omp_mask (OMP_CLAUSE_IF) | OMP_CLAUSE_ASYNC | OMP_CLAUSE_NUM_GANGS \
5325 : | OMP_CLAUSE_NUM_WORKERS | OMP_CLAUSE_VECTOR_LENGTH | OMP_CLAUSE_DEVICEPTR \
5326 : | OMP_CLAUSE_COPY | OMP_CLAUSE_COPYIN | OMP_CLAUSE_COPYOUT \
5327 : | OMP_CLAUSE_CREATE | OMP_CLAUSE_NO_CREATE | OMP_CLAUSE_PRESENT \
5328 : | OMP_CLAUSE_DEFAULT | OMP_CLAUSE_WAIT | OMP_CLAUSE_ATTACH \
5329 : | OMP_CLAUSE_SELF)
5330 : #define OACC_SERIAL_CLAUSES \
5331 : (omp_mask (OMP_CLAUSE_IF) | OMP_CLAUSE_ASYNC | OMP_CLAUSE_REDUCTION \
5332 : | OMP_CLAUSE_COPY | OMP_CLAUSE_COPYIN | OMP_CLAUSE_COPYOUT \
5333 : | OMP_CLAUSE_CREATE | OMP_CLAUSE_NO_CREATE | OMP_CLAUSE_PRESENT \
5334 : | OMP_CLAUSE_DEVICEPTR | OMP_CLAUSE_PRIVATE | OMP_CLAUSE_FIRSTPRIVATE \
5335 : | OMP_CLAUSE_DEFAULT | OMP_CLAUSE_WAIT | OMP_CLAUSE_ATTACH \
5336 : | OMP_CLAUSE_SELF)
5337 : #define OACC_DATA_CLAUSES \
5338 : (omp_mask (OMP_CLAUSE_IF) | OMP_CLAUSE_DEVICEPTR | OMP_CLAUSE_COPY \
5339 : | OMP_CLAUSE_COPYIN | OMP_CLAUSE_COPYOUT | OMP_CLAUSE_CREATE \
5340 : | OMP_CLAUSE_NO_CREATE | OMP_CLAUSE_PRESENT | OMP_CLAUSE_ATTACH \
5341 : | OMP_CLAUSE_DEFAULT)
5342 : #define OACC_LOOP_CLAUSES \
5343 : (omp_mask (OMP_CLAUSE_COLLAPSE) | OMP_CLAUSE_GANG | OMP_CLAUSE_WORKER \
5344 : | OMP_CLAUSE_VECTOR | OMP_CLAUSE_SEQ | OMP_CLAUSE_INDEPENDENT \
5345 : | OMP_CLAUSE_PRIVATE | OMP_CLAUSE_REDUCTION | OMP_CLAUSE_AUTO \
5346 : | OMP_CLAUSE_TILE)
5347 : #define OACC_PARALLEL_LOOP_CLAUSES \
5348 : (OACC_LOOP_CLAUSES | OACC_PARALLEL_CLAUSES)
5349 : #define OACC_KERNELS_LOOP_CLAUSES \
5350 : (OACC_LOOP_CLAUSES | OACC_KERNELS_CLAUSES)
5351 : #define OACC_SERIAL_LOOP_CLAUSES \
5352 : (OACC_LOOP_CLAUSES | OACC_SERIAL_CLAUSES)
5353 : #define OACC_HOST_DATA_CLAUSES \
5354 : (omp_mask (OMP_CLAUSE_USE_DEVICE) \
5355 : | OMP_CLAUSE_IF \
5356 : | OMP_CLAUSE_IF_PRESENT)
5357 : #define OACC_DECLARE_CLAUSES \
5358 : (omp_mask (OMP_CLAUSE_COPY) | OMP_CLAUSE_COPYIN | OMP_CLAUSE_COPYOUT \
5359 : | OMP_CLAUSE_CREATE | OMP_CLAUSE_DEVICEPTR | OMP_CLAUSE_DEVICE_RESIDENT \
5360 : | OMP_CLAUSE_PRESENT \
5361 : | OMP_CLAUSE_LINK)
5362 : #define OACC_UPDATE_CLAUSES \
5363 : (omp_mask (OMP_CLAUSE_IF) | OMP_CLAUSE_ASYNC | OMP_CLAUSE_HOST \
5364 : | OMP_CLAUSE_DEVICE | OMP_CLAUSE_WAIT | OMP_CLAUSE_IF_PRESENT \
5365 : | OMP_CLAUSE_SELF)
5366 : #define OACC_ENTER_DATA_CLAUSES \
5367 : (omp_mask (OMP_CLAUSE_IF) | OMP_CLAUSE_ASYNC | OMP_CLAUSE_WAIT \
5368 : | OMP_CLAUSE_COPYIN | OMP_CLAUSE_CREATE | OMP_CLAUSE_ATTACH)
5369 : #define OACC_EXIT_DATA_CLAUSES \
5370 : (omp_mask (OMP_CLAUSE_IF) | OMP_CLAUSE_ASYNC | OMP_CLAUSE_WAIT \
5371 : | OMP_CLAUSE_COPYOUT | OMP_CLAUSE_DELETE | OMP_CLAUSE_FINALIZE \
5372 : | OMP_CLAUSE_DETACH)
5373 : #define OACC_WAIT_CLAUSES \
5374 : omp_mask (OMP_CLAUSE_ASYNC) | OMP_CLAUSE_IF
5375 : #define OACC_ROUTINE_CLAUSES \
5376 : (omp_mask (OMP_CLAUSE_GANG) | OMP_CLAUSE_WORKER | OMP_CLAUSE_VECTOR \
5377 : | OMP_CLAUSE_SEQ \
5378 : | OMP_CLAUSE_NOHOST)
5379 : #define OACC_INIT_CLAUSES \
5380 : (omp_mask (OMP_CLAUSE_IF) | OMP_CLAUSE_DEVICE_NUM | OMP_CLAUSE_DEVICE_TYPE)
5381 : #define OACC_SHUTDOWN_CLAUSES \
5382 : (omp_mask (OMP_CLAUSE_IF) | OMP_CLAUSE_DEVICE_NUM | OMP_CLAUSE_DEVICE_TYPE)
5383 : #define OACC_SET_CLAUSES \
5384 : (omp_mask (OMP_CLAUSE_IF) | OMP_CLAUSE_DEVICE_NUM | OMP_CLAUSE_DEVICE_TYPE)
5385 :
5386 :
5387 : static match
5388 12198 : match_acc (gfc_exec_op op, const omp_mask mask)
5389 : {
5390 12198 : gfc_omp_clauses *c;
5391 12198 : if (gfc_match_omp_clauses (&c, mask, false, false, true) != MATCH_YES)
5392 : return MATCH_ERROR;
5393 11969 : new_st.op = op;
5394 11969 : new_st.ext.omp_clauses = c;
5395 11969 : return MATCH_YES;
5396 : }
5397 :
5398 : match
5399 1378 : gfc_match_oacc_parallel_loop (void)
5400 : {
5401 1378 : return match_acc (EXEC_OACC_PARALLEL_LOOP, OACC_PARALLEL_LOOP_CLAUSES);
5402 : }
5403 :
5404 :
5405 : match
5406 2974 : gfc_match_oacc_parallel (void)
5407 : {
5408 2974 : return match_acc (EXEC_OACC_PARALLEL, OACC_PARALLEL_CLAUSES);
5409 : }
5410 :
5411 :
5412 : match
5413 129 : gfc_match_oacc_kernels_loop (void)
5414 : {
5415 129 : return match_acc (EXEC_OACC_KERNELS_LOOP, OACC_KERNELS_LOOP_CLAUSES);
5416 : }
5417 :
5418 :
5419 : match
5420 906 : gfc_match_oacc_kernels (void)
5421 : {
5422 906 : return match_acc (EXEC_OACC_KERNELS, OACC_KERNELS_CLAUSES);
5423 : }
5424 :
5425 :
5426 : match
5427 230 : gfc_match_oacc_serial_loop (void)
5428 : {
5429 230 : return match_acc (EXEC_OACC_SERIAL_LOOP, OACC_SERIAL_LOOP_CLAUSES);
5430 : }
5431 :
5432 :
5433 : match
5434 359 : gfc_match_oacc_serial (void)
5435 : {
5436 359 : return match_acc (EXEC_OACC_SERIAL, OACC_SERIAL_CLAUSES);
5437 : }
5438 :
5439 :
5440 : match
5441 689 : gfc_match_oacc_data (void)
5442 : {
5443 689 : return match_acc (EXEC_OACC_DATA, OACC_DATA_CLAUSES);
5444 : }
5445 :
5446 :
5447 : match
5448 65 : gfc_match_oacc_host_data (void)
5449 : {
5450 65 : return match_acc (EXEC_OACC_HOST_DATA, OACC_HOST_DATA_CLAUSES);
5451 : }
5452 :
5453 :
5454 : match
5455 3585 : gfc_match_oacc_loop (void)
5456 : {
5457 3585 : return match_acc (EXEC_OACC_LOOP, OACC_LOOP_CLAUSES);
5458 : }
5459 :
5460 :
5461 : match
5462 178 : gfc_match_oacc_declare (void)
5463 : {
5464 178 : gfc_omp_clauses *c;
5465 178 : gfc_omp_namelist *n;
5466 178 : gfc_namespace *ns = gfc_current_ns;
5467 178 : gfc_oacc_declare *new_oc;
5468 178 : bool module_var = false;
5469 178 : locus where = gfc_current_locus;
5470 :
5471 178 : if (gfc_match_omp_clauses (&c, OACC_DECLARE_CLAUSES, false, false, true)
5472 : != MATCH_YES)
5473 : return MATCH_ERROR;
5474 :
5475 262 : for (n = c->lists[OMP_LIST_DEVICE_RESIDENT]; n != NULL; n = n->next)
5476 90 : n->sym->attr.oacc_declare_device_resident = 1;
5477 :
5478 192 : for (n = c->lists[OMP_LIST_LINK]; n != NULL; n = n->next)
5479 20 : n->sym->attr.oacc_declare_link = 1;
5480 :
5481 318 : for (n = c->lists[OMP_LIST_MAP]; n != NULL; n = n->next)
5482 : {
5483 156 : gfc_symbol *s = n->sym;
5484 :
5485 156 : if (gfc_current_ns->proc_name
5486 156 : && gfc_current_ns->proc_name->attr.flavor == FL_MODULE)
5487 : {
5488 52 : if (n->u.map.op != OMP_MAP_ALLOC && n->u.map.op != OMP_MAP_TO)
5489 : {
5490 6 : gfc_error ("Invalid clause in module with !$ACC DECLARE at %L",
5491 : &where);
5492 6 : return MATCH_ERROR;
5493 : }
5494 :
5495 : module_var = true;
5496 : }
5497 :
5498 150 : if (s->attr.use_assoc)
5499 : {
5500 0 : gfc_error ("Variable is USE-associated with !$ACC DECLARE at %L",
5501 : &where);
5502 0 : return MATCH_ERROR;
5503 : }
5504 :
5505 150 : if ((s->result == s && s->ns->contained != gfc_current_ns)
5506 150 : || ((s->attr.flavor == FL_UNKNOWN || s->attr.flavor == FL_VARIABLE)
5507 135 : && s->ns != gfc_current_ns))
5508 : {
5509 2 : gfc_error ("Variable %qs shall be declared in the same scoping unit "
5510 : "as !$ACC DECLARE at %L", s->name, &where);
5511 2 : return MATCH_ERROR;
5512 : }
5513 :
5514 148 : if ((s->attr.dimension || s->attr.codimension)
5515 76 : && s->attr.dummy && s->as->type != AS_EXPLICIT)
5516 : {
5517 2 : gfc_error ("Assumed-size dummy array with !$ACC DECLARE at %L",
5518 : &where);
5519 2 : return MATCH_ERROR;
5520 : }
5521 :
5522 146 : switch (n->u.map.op)
5523 : {
5524 49 : case OMP_MAP_FORCE_ALLOC:
5525 49 : case OMP_MAP_ALLOC:
5526 49 : s->attr.oacc_declare_create = 1;
5527 49 : break;
5528 :
5529 63 : case OMP_MAP_FORCE_TO:
5530 63 : case OMP_MAP_TO:
5531 63 : s->attr.oacc_declare_copyin = 1;
5532 63 : break;
5533 :
5534 1 : case OMP_MAP_FORCE_DEVICEPTR:
5535 1 : s->attr.oacc_declare_deviceptr = 1;
5536 1 : break;
5537 :
5538 : default:
5539 : break;
5540 : }
5541 : }
5542 :
5543 162 : new_oc = gfc_get_oacc_declare ();
5544 162 : new_oc->next = ns->oacc_declare;
5545 162 : new_oc->module_var = module_var;
5546 162 : new_oc->clauses = c;
5547 162 : new_oc->loc = gfc_current_locus;
5548 162 : ns->oacc_declare = new_oc;
5549 :
5550 162 : return MATCH_YES;
5551 : }
5552 :
5553 :
5554 : match
5555 760 : gfc_match_oacc_update (void)
5556 : {
5557 760 : gfc_omp_clauses *c;
5558 760 : locus here = gfc_current_locus;
5559 :
5560 760 : if (gfc_match_omp_clauses (&c, OACC_UPDATE_CLAUSES, false, false, true)
5561 : != MATCH_YES)
5562 : return MATCH_ERROR;
5563 :
5564 756 : if (!c->lists[OMP_LIST_MAP])
5565 : {
5566 1 : gfc_error ("%<acc update%> must contain at least one "
5567 : "%<device%> or %<host%> or %<self%> clause at %L", &here);
5568 1 : return MATCH_ERROR;
5569 : }
5570 :
5571 755 : new_st.op = EXEC_OACC_UPDATE;
5572 755 : new_st.ext.omp_clauses = c;
5573 755 : return MATCH_YES;
5574 : }
5575 :
5576 :
5577 : match
5578 877 : gfc_match_oacc_enter_data (void)
5579 : {
5580 877 : return match_acc (EXEC_OACC_ENTER_DATA, OACC_ENTER_DATA_CLAUSES);
5581 : }
5582 :
5583 :
5584 : match
5585 612 : gfc_match_oacc_exit_data (void)
5586 : {
5587 612 : return match_acc (EXEC_OACC_EXIT_DATA, OACC_EXIT_DATA_CLAUSES);
5588 : }
5589 :
5590 :
5591 : match
5592 202 : gfc_match_oacc_wait (void)
5593 : {
5594 202 : gfc_omp_clauses *c = gfc_get_omp_clauses ();
5595 202 : gfc_expr_list *wait_list = NULL, *el;
5596 202 : bool space = true;
5597 202 : match m;
5598 :
5599 202 : m = match_omp_oacc_expr_list (" (", &wait_list, true, false);
5600 202 : if (m == MATCH_ERROR)
5601 : return m;
5602 196 : else if (m == MATCH_YES)
5603 126 : space = false;
5604 :
5605 196 : if (gfc_match_omp_clauses (&c, OACC_WAIT_CLAUSES, space, space, true)
5606 : == MATCH_ERROR)
5607 : return MATCH_ERROR;
5608 :
5609 184 : if (wait_list)
5610 261 : for (el = wait_list; el; el = el->next)
5611 : {
5612 140 : if (el->expr == NULL)
5613 : {
5614 2 : gfc_error ("Invalid argument to !$ACC WAIT at %C");
5615 2 : return MATCH_ERROR;
5616 : }
5617 :
5618 138 : if (!gfc_resolve_expr (el->expr)
5619 138 : || el->expr->ts.type != BT_INTEGER || el->expr->rank != 0)
5620 : {
5621 3 : gfc_error ("WAIT clause at %L requires a scalar INTEGER expression",
5622 3 : &el->expr->where);
5623 :
5624 3 : return MATCH_ERROR;
5625 : }
5626 : }
5627 179 : c->wait_list = wait_list;
5628 179 : new_st.op = EXEC_OACC_WAIT;
5629 179 : new_st.ext.omp_clauses = c;
5630 179 : return MATCH_YES;
5631 : }
5632 :
5633 :
5634 : match
5635 97 : gfc_match_oacc_cache (void)
5636 : {
5637 97 : bool readonly = false;
5638 97 : gfc_omp_clauses *c = gfc_get_omp_clauses ();
5639 : /* The OpenACC cache directive explicitly only allows "array elements or
5640 : subarrays", which we're currently not checking here. Either check this
5641 : after the call of gfc_match_omp_variable_list, or add something like a
5642 : only_sections variant next to its allow_sections parameter. */
5643 97 : match m = gfc_match (" ( ");
5644 97 : if (m != MATCH_YES)
5645 : {
5646 0 : gfc_free_omp_clauses(c);
5647 0 : return m;
5648 : }
5649 :
5650 97 : if (gfc_match ("readonly : ") == MATCH_YES)
5651 8 : readonly = true;
5652 :
5653 97 : gfc_omp_namelist **head = NULL;
5654 97 : m = gfc_match_omp_variable_list ("", &c->lists[OMP_LIST_CACHE], true,
5655 : NULL, &head, true);
5656 97 : if (m != MATCH_YES)
5657 : {
5658 2 : gfc_free_omp_clauses(c);
5659 2 : return m;
5660 : }
5661 :
5662 95 : if (readonly)
5663 24 : for (gfc_omp_namelist *n = *head; n; n = n->next)
5664 16 : n->u.map.readonly = true;
5665 :
5666 95 : if (gfc_current_state() != COMP_DO
5667 56 : && gfc_current_state() != COMP_DO_CONCURRENT)
5668 : {
5669 2 : gfc_error ("ACC CACHE directive must be inside of loop %C");
5670 2 : gfc_free_omp_clauses(c);
5671 2 : return MATCH_ERROR;
5672 : }
5673 :
5674 93 : new_st.op = EXEC_OACC_CACHE;
5675 93 : new_st.ext.omp_clauses = c;
5676 93 : return MATCH_YES;
5677 : }
5678 :
5679 : match
5680 134 : gfc_match_oacc_init (void)
5681 : {
5682 134 : return match_acc (EXEC_OACC_INIT, OACC_INIT_CLAUSES);
5683 : }
5684 :
5685 : match
5686 130 : gfc_match_oacc_shutdown (void)
5687 : {
5688 130 : return match_acc (EXEC_OACC_SHUTDOWN, OACC_SHUTDOWN_CLAUSES);
5689 : }
5690 :
5691 : match
5692 130 : gfc_match_oacc_set (void)
5693 : {
5694 130 : return match_acc (EXEC_OACC_SET, OACC_SET_CLAUSES);
5695 : }
5696 :
5697 : /* Determine the OpenACC 'routine' directive's level of parallelism. */
5698 :
5699 : static oacc_routine_lop
5700 734 : gfc_oacc_routine_lop (gfc_omp_clauses *clauses)
5701 : {
5702 734 : oacc_routine_lop ret = OACC_ROUTINE_LOP_SEQ;
5703 :
5704 734 : if (clauses)
5705 : {
5706 584 : unsigned n_lop_clauses = 0;
5707 :
5708 584 : if (clauses->gang)
5709 : {
5710 164 : ++n_lop_clauses;
5711 164 : ret = OACC_ROUTINE_LOP_GANG;
5712 : }
5713 584 : if (clauses->worker)
5714 : {
5715 114 : ++n_lop_clauses;
5716 114 : ret = OACC_ROUTINE_LOP_WORKER;
5717 : }
5718 584 : if (clauses->vector)
5719 : {
5720 116 : ++n_lop_clauses;
5721 116 : ret = OACC_ROUTINE_LOP_VECTOR;
5722 : }
5723 584 : if (clauses->seq)
5724 : {
5725 206 : ++n_lop_clauses;
5726 206 : ret = OACC_ROUTINE_LOP_SEQ;
5727 : }
5728 :
5729 584 : if (n_lop_clauses > 1)
5730 47 : ret = OACC_ROUTINE_LOP_ERROR;
5731 : }
5732 :
5733 734 : return ret;
5734 : }
5735 :
5736 : match
5737 698 : gfc_match_oacc_routine (void)
5738 : {
5739 698 : locus old_loc;
5740 698 : match m;
5741 698 : gfc_intrinsic_sym *isym = NULL;
5742 698 : gfc_symbol *sym = NULL;
5743 698 : gfc_omp_clauses *c = NULL;
5744 698 : gfc_oacc_routine_name *n = NULL;
5745 698 : oacc_routine_lop lop = OACC_ROUTINE_LOP_NONE;
5746 698 : bool nohost;
5747 :
5748 698 : old_loc = gfc_current_locus;
5749 :
5750 698 : m = gfc_match (" (");
5751 :
5752 698 : if (gfc_current_ns->proc_name
5753 696 : && gfc_current_ns->proc_name->attr.if_source == IFSRC_IFBODY
5754 90 : && m == MATCH_YES)
5755 : {
5756 3 : gfc_error ("Only the !$ACC ROUTINE form without "
5757 : "list is allowed in interface block at %C");
5758 3 : goto cleanup;
5759 : }
5760 :
5761 608 : if (m == MATCH_YES)
5762 : {
5763 295 : char buffer[GFC_MAX_SYMBOL_LEN + 1];
5764 :
5765 295 : m = gfc_match_name (buffer);
5766 295 : if (m == MATCH_YES)
5767 : {
5768 294 : gfc_symtree *st = NULL;
5769 :
5770 : /* First look for an intrinsic symbol. */
5771 294 : isym = gfc_find_function (buffer);
5772 294 : if (!isym)
5773 294 : isym = gfc_find_subroutine (buffer);
5774 : /* If no intrinsic symbol found, search the current namespace. */
5775 294 : if (!isym)
5776 276 : st = gfc_find_symtree (gfc_current_ns->sym_root, buffer);
5777 276 : if (st)
5778 : {
5779 270 : sym = st->n.sym;
5780 : /* If the name in a 'routine' directive refers to the containing
5781 : subroutine or function, then make sure that we'll later handle
5782 : this accordingly. */
5783 270 : if (gfc_current_ns->proc_name != NULL
5784 270 : && strcmp (sym->name, gfc_current_ns->proc_name->name) == 0)
5785 294 : sym = NULL;
5786 : }
5787 :
5788 294 : if (isym == NULL && st == NULL)
5789 : {
5790 6 : gfc_error ("Invalid NAME %qs in !$ACC ROUTINE ( NAME ) at %C",
5791 : buffer);
5792 6 : gfc_current_locus = old_loc;
5793 9 : return MATCH_ERROR;
5794 : }
5795 : }
5796 : else
5797 : {
5798 1 : gfc_error ("Syntax error in !$ACC ROUTINE ( NAME ) at %C");
5799 1 : gfc_current_locus = old_loc;
5800 1 : return MATCH_ERROR;
5801 : }
5802 :
5803 288 : if (gfc_match_char (')') != MATCH_YES)
5804 : {
5805 2 : gfc_error ("Syntax error in !$ACC ROUTINE ( NAME ) at %C, expecting"
5806 : " %<)%> after NAME");
5807 2 : gfc_current_locus = old_loc;
5808 2 : return MATCH_ERROR;
5809 : }
5810 : }
5811 :
5812 686 : if (gfc_match_omp_eos () != MATCH_YES
5813 686 : && (gfc_match_omp_clauses (&c, OACC_ROUTINE_CLAUSES, false, false, true)
5814 : != MATCH_YES))
5815 : return MATCH_ERROR;
5816 :
5817 683 : lop = gfc_oacc_routine_lop (c);
5818 683 : if (lop == OACC_ROUTINE_LOP_ERROR)
5819 : {
5820 47 : gfc_error ("Multiple loop axes specified for routine at %C");
5821 47 : goto cleanup;
5822 : }
5823 636 : nohost = c ? c->nohost : false;
5824 :
5825 636 : if (isym != NULL)
5826 : {
5827 : /* Diagnose any OpenACC 'routine' directive that doesn't match the
5828 : (implicit) one with a 'seq' clause. */
5829 16 : if (c && (c->gang || c->worker || c->vector))
5830 : {
5831 10 : gfc_error ("Intrinsic symbol specified in !$ACC ROUTINE ( NAME )"
5832 : " at %C marked with incompatible GANG, WORKER, or VECTOR"
5833 : " clause");
5834 10 : goto cleanup;
5835 : }
5836 : /* ..., and no 'nohost' clause. */
5837 6 : if (nohost)
5838 : {
5839 2 : gfc_error ("Intrinsic symbol specified in !$ACC ROUTINE ( NAME )"
5840 : " at %C marked with incompatible NOHOST clause");
5841 2 : goto cleanup;
5842 : }
5843 : }
5844 620 : else if (sym != NULL)
5845 : {
5846 151 : bool add = true;
5847 :
5848 : /* For a repeated OpenACC 'routine' directive, diagnose if it doesn't
5849 : match the first one. */
5850 151 : for (gfc_oacc_routine_name *n_p = gfc_current_ns->oacc_routine_names;
5851 346 : n_p;
5852 195 : n_p = n_p->next)
5853 235 : if (n_p->sym == sym)
5854 : {
5855 51 : add = false;
5856 51 : bool nohost_p = n_p->clauses ? n_p->clauses->nohost : false;
5857 51 : if (lop != gfc_oacc_routine_lop (n_p->clauses)
5858 51 : || nohost != nohost_p)
5859 : {
5860 40 : gfc_error ("!$ACC ROUTINE already applied at %C");
5861 40 : goto cleanup;
5862 : }
5863 : }
5864 :
5865 111 : if (add)
5866 : {
5867 100 : sym->attr.oacc_routine_lop = lop;
5868 100 : sym->attr.oacc_routine_nohost = nohost;
5869 :
5870 100 : n = gfc_get_oacc_routine_name ();
5871 100 : n->sym = sym;
5872 100 : n->clauses = c;
5873 100 : n->next = gfc_current_ns->oacc_routine_names;
5874 100 : n->loc = old_loc;
5875 100 : gfc_current_ns->oacc_routine_names = n;
5876 : }
5877 : }
5878 469 : else if (gfc_current_ns->proc_name)
5879 : {
5880 : /* For a repeated OpenACC 'routine' directive, diagnose if it doesn't
5881 : match the first one. */
5882 468 : oacc_routine_lop lop_p = gfc_current_ns->proc_name->attr.oacc_routine_lop;
5883 468 : bool nohost_p = gfc_current_ns->proc_name->attr.oacc_routine_nohost;
5884 468 : if (lop_p != OACC_ROUTINE_LOP_NONE
5885 86 : && (lop != lop_p
5886 86 : || nohost != nohost_p))
5887 : {
5888 56 : gfc_error ("!$ACC ROUTINE already applied at %C");
5889 56 : goto cleanup;
5890 : }
5891 :
5892 412 : if (!gfc_add_omp_declare_target (&gfc_current_ns->proc_name->attr,
5893 : gfc_current_ns->proc_name->name,
5894 : &old_loc))
5895 1 : goto cleanup;
5896 411 : gfc_current_ns->proc_name->attr.oacc_routine_lop = lop;
5897 411 : gfc_current_ns->proc_name->attr.oacc_routine_nohost = nohost;
5898 : }
5899 : else
5900 : /* Something has gone wrong, possibly a syntax error. */
5901 1 : goto cleanup;
5902 :
5903 526 : if (gfc_pure (NULL) && c && (c->gang || c->worker || c->vector))
5904 : {
5905 6 : gfc_error ("!$ACC ROUTINE with GANG, WORKER, or VECTOR clause is not "
5906 : "permitted in PURE procedure at %C");
5907 6 : goto cleanup;
5908 : }
5909 :
5910 :
5911 520 : if (n)
5912 100 : n->clauses = c;
5913 420 : else if (gfc_current_ns->oacc_routine)
5914 0 : gfc_current_ns->oacc_routine_clauses = c;
5915 :
5916 520 : new_st.op = EXEC_OACC_ROUTINE;
5917 520 : new_st.ext.omp_clauses = c;
5918 520 : return MATCH_YES;
5919 :
5920 166 : cleanup:
5921 166 : gfc_current_locus = old_loc;
5922 166 : return MATCH_ERROR;
5923 : }
5924 :
5925 :
5926 : #define OMP_PARALLEL_CLAUSES \
5927 : (omp_mask (OMP_CLAUSE_PRIVATE) | OMP_CLAUSE_FIRSTPRIVATE \
5928 : | OMP_CLAUSE_SHARED | OMP_CLAUSE_COPYIN | OMP_CLAUSE_REDUCTION \
5929 : | OMP_CLAUSE_IF | OMP_CLAUSE_NUM_THREADS | OMP_CLAUSE_DEFAULT \
5930 : | OMP_CLAUSE_PROC_BIND | OMP_CLAUSE_ALLOCATE | OMP_CLAUSE_MESSAGE \
5931 : | OMP_CLAUSE_SEVERITY)
5932 : #define OMP_DECLARE_SIMD_CLAUSES \
5933 : (omp_mask (OMP_CLAUSE_SIMDLEN) | OMP_CLAUSE_LINEAR \
5934 : | OMP_CLAUSE_UNIFORM | OMP_CLAUSE_ALIGNED | OMP_CLAUSE_INBRANCH \
5935 : | OMP_CLAUSE_NOTINBRANCH)
5936 : #define OMP_DO_CLAUSES \
5937 : (omp_mask (OMP_CLAUSE_PRIVATE) | OMP_CLAUSE_FIRSTPRIVATE \
5938 : | OMP_CLAUSE_LASTPRIVATE | OMP_CLAUSE_REDUCTION \
5939 : | OMP_CLAUSE_SCHEDULE | OMP_CLAUSE_ORDERED | OMP_CLAUSE_COLLAPSE \
5940 : | OMP_CLAUSE_LINEAR | OMP_CLAUSE_ORDER | OMP_CLAUSE_ALLOCATE \
5941 : | OMP_CLAUSE_NOWAIT)
5942 : #define OMP_LOOP_CLAUSES \
5943 : (omp_mask (OMP_CLAUSE_BIND) | OMP_CLAUSE_COLLAPSE | OMP_CLAUSE_ORDER \
5944 : | OMP_CLAUSE_PRIVATE | OMP_CLAUSE_LASTPRIVATE | OMP_CLAUSE_REDUCTION)
5945 :
5946 : #define OMP_SCOPE_CLAUSES \
5947 : (omp_mask (OMP_CLAUSE_PRIVATE) |OMP_CLAUSE_FIRSTPRIVATE \
5948 : | OMP_CLAUSE_REDUCTION | OMP_CLAUSE_ALLOCATE | OMP_CLAUSE_NOWAIT)
5949 : #define OMP_SECTIONS_CLAUSES \
5950 : (omp_mask (OMP_CLAUSE_PRIVATE) | OMP_CLAUSE_FIRSTPRIVATE \
5951 : | OMP_CLAUSE_LASTPRIVATE | OMP_CLAUSE_REDUCTION \
5952 : | OMP_CLAUSE_ALLOCATE | OMP_CLAUSE_NOWAIT)
5953 : #define OMP_SIMD_CLAUSES \
5954 : (omp_mask (OMP_CLAUSE_PRIVATE) | OMP_CLAUSE_LASTPRIVATE \
5955 : | OMP_CLAUSE_REDUCTION | OMP_CLAUSE_COLLAPSE | OMP_CLAUSE_SAFELEN \
5956 : | OMP_CLAUSE_LINEAR | OMP_CLAUSE_ALIGNED | OMP_CLAUSE_SIMDLEN \
5957 : | OMP_CLAUSE_IF | OMP_CLAUSE_ORDER | OMP_CLAUSE_NOTEMPORAL)
5958 : #define OMP_TASK_CLAUSES \
5959 : (omp_mask (OMP_CLAUSE_PRIVATE) | OMP_CLAUSE_FIRSTPRIVATE \
5960 : | OMP_CLAUSE_SHARED | OMP_CLAUSE_IF | OMP_CLAUSE_DEFAULT \
5961 : | OMP_CLAUSE_UNTIED | OMP_CLAUSE_FINAL | OMP_CLAUSE_MERGEABLE \
5962 : | OMP_CLAUSE_DEPEND | OMP_CLAUSE_PRIORITY | OMP_CLAUSE_IN_REDUCTION \
5963 : | OMP_CLAUSE_DETACH | OMP_CLAUSE_AFFINITY | OMP_CLAUSE_ALLOCATE)
5964 : #define OMP_TASKLOOP_CLAUSES \
5965 : (omp_mask (OMP_CLAUSE_PRIVATE) | OMP_CLAUSE_FIRSTPRIVATE \
5966 : | OMP_CLAUSE_LASTPRIVATE | OMP_CLAUSE_SHARED | OMP_CLAUSE_IF \
5967 : | OMP_CLAUSE_DEFAULT | OMP_CLAUSE_UNTIED | OMP_CLAUSE_FINAL \
5968 : | OMP_CLAUSE_MERGEABLE | OMP_CLAUSE_PRIORITY | OMP_CLAUSE_GRAINSIZE \
5969 : | OMP_CLAUSE_NUM_TASKS | OMP_CLAUSE_COLLAPSE | OMP_CLAUSE_NOGROUP \
5970 : | OMP_CLAUSE_REDUCTION | OMP_CLAUSE_IN_REDUCTION | OMP_CLAUSE_ALLOCATE)
5971 : #define OMP_TASKGROUP_CLAUSES \
5972 : (omp_mask (OMP_CLAUSE_TASK_REDUCTION) | OMP_CLAUSE_ALLOCATE)
5973 : #define OMP_TARGET_CLAUSES \
5974 : (omp_mask (OMP_CLAUSE_DEVICE) | OMP_CLAUSE_MAP | OMP_CLAUSE_IF \
5975 : | OMP_CLAUSE_DEPEND | OMP_CLAUSE_NOWAIT | OMP_CLAUSE_PRIVATE \
5976 : | OMP_CLAUSE_FIRSTPRIVATE | OMP_CLAUSE_DEFAULTMAP \
5977 : | OMP_CLAUSE_IS_DEVICE_PTR | OMP_CLAUSE_IN_REDUCTION \
5978 : | OMP_CLAUSE_THREAD_LIMIT | OMP_CLAUSE_ALLOCATE \
5979 : | OMP_CLAUSE_HAS_DEVICE_ADDR | OMP_CLAUSE_USES_ALLOCATORS \
5980 : | OMP_CLAUSE_DYN_GROUPPRIVATE | OMP_CLAUSE_DEVICE_TYPE \
5981 : | OMP_CLAUSE_MESSAGE)
5982 : #define OMP_TARGET_DATA_CLAUSES \
5983 : (omp_mask (OMP_CLAUSE_DEVICE) | OMP_CLAUSE_MAP | OMP_CLAUSE_IF \
5984 : | OMP_CLAUSE_USE_DEVICE_PTR | OMP_CLAUSE_USE_DEVICE_ADDR)
5985 : #define OMP_TARGET_ENTER_DATA_CLAUSES \
5986 : (omp_mask (OMP_CLAUSE_DEVICE) | OMP_CLAUSE_MAP | OMP_CLAUSE_IF \
5987 : | OMP_CLAUSE_DEPEND | OMP_CLAUSE_NOWAIT)
5988 : #define OMP_TARGET_EXIT_DATA_CLAUSES \
5989 : (omp_mask (OMP_CLAUSE_DEVICE) | OMP_CLAUSE_MAP | OMP_CLAUSE_IF \
5990 : | OMP_CLAUSE_DEPEND | OMP_CLAUSE_NOWAIT)
5991 : #define OMP_TARGET_UPDATE_CLAUSES \
5992 : (omp_mask (OMP_CLAUSE_DEVICE) | OMP_CLAUSE_IF | OMP_CLAUSE_TO \
5993 : | OMP_CLAUSE_FROM | OMP_CLAUSE_DEPEND | OMP_CLAUSE_NOWAIT)
5994 : #define OMP_TEAMS_CLAUSES \
5995 : (omp_mask (OMP_CLAUSE_NUM_TEAMS) | OMP_CLAUSE_THREAD_LIMIT \
5996 : | OMP_CLAUSE_DEFAULT | OMP_CLAUSE_PRIVATE | OMP_CLAUSE_FIRSTPRIVATE \
5997 : | OMP_CLAUSE_SHARED | OMP_CLAUSE_REDUCTION | OMP_CLAUSE_ALLOCATE \
5998 : | OMP_CLAUSE_MESSAGE)
5999 : #define OMP_DISTRIBUTE_CLAUSES \
6000 : (omp_mask (OMP_CLAUSE_PRIVATE) | OMP_CLAUSE_FIRSTPRIVATE \
6001 : | OMP_CLAUSE_LASTPRIVATE | OMP_CLAUSE_COLLAPSE | OMP_CLAUSE_DIST_SCHEDULE \
6002 : | OMP_CLAUSE_ORDER | OMP_CLAUSE_ALLOCATE)
6003 : #define OMP_SINGLE_CLAUSES \
6004 : (omp_mask (OMP_CLAUSE_PRIVATE) | OMP_CLAUSE_FIRSTPRIVATE \
6005 : | OMP_CLAUSE_ALLOCATE | OMP_CLAUSE_NOWAIT | OMP_CLAUSE_COPYPRIVATE)
6006 : #define OMP_ORDERED_CLAUSES \
6007 : (omp_mask (OMP_CLAUSE_THREADS) | OMP_CLAUSE_SIMD)
6008 : #define OMP_DECLARE_TARGET_CLAUSES \
6009 : (omp_mask (OMP_CLAUSE_ENTER) | OMP_CLAUSE_LINK | OMP_CLAUSE_DEVICE_TYPE \
6010 : | OMP_CLAUSE_TO | OMP_CLAUSE_INDIRECT | OMP_CLAUSE_LOCAL)
6011 : #define OMP_ATOMIC_CLAUSES \
6012 : (omp_mask (OMP_CLAUSE_ATOMIC) | OMP_CLAUSE_CAPTURE | OMP_CLAUSE_HINT \
6013 : | OMP_CLAUSE_MEMORDER | OMP_CLAUSE_COMPARE | OMP_CLAUSE_FAIL \
6014 : | OMP_CLAUSE_WEAK)
6015 : #define OMP_MASKED_CLAUSES \
6016 : (omp_mask (OMP_CLAUSE_FILTER))
6017 : #define OMP_ERROR_CLAUSES \
6018 : (omp_mask (OMP_CLAUSE_AT) | OMP_CLAUSE_MESSAGE | OMP_CLAUSE_SEVERITY)
6019 : #define OMP_WORKSHARE_CLAUSES \
6020 : omp_mask (OMP_CLAUSE_NOWAIT)
6021 : #define OMP_UNROLL_CLAUSES \
6022 : (omp_mask (OMP_CLAUSE_FULL) | OMP_CLAUSE_PARTIAL)
6023 : #define OMP_TILE_CLAUSES \
6024 : (omp_mask (OMP_CLAUSE_SIZES))
6025 : #define OMP_ALLOCATORS_CLAUSES \
6026 : omp_mask (OMP_CLAUSE_ALLOCATE)
6027 : #define OMP_INTEROP_CLAUSES \
6028 : (omp_mask (OMP_CLAUSE_DEPEND) | OMP_CLAUSE_NOWAIT | OMP_CLAUSE_DEVICE \
6029 : | OMP_CLAUSE_INIT | OMP_CLAUSE_DESTROY | OMP_CLAUSE_USE)
6030 : #define OMP_DISPATCH_CLAUSES \
6031 : (omp_mask (OMP_CLAUSE_DEVICE) | OMP_CLAUSE_DEPEND | OMP_CLAUSE_NOVARIANTS \
6032 : | OMP_CLAUSE_NOCONTEXT | OMP_CLAUSE_IS_DEVICE_PTR | OMP_CLAUSE_NOWAIT \
6033 : | OMP_CLAUSE_HAS_DEVICE_ADDR | OMP_CLAUSE_INTEROP)
6034 :
6035 :
6036 : static match
6037 17433 : match_omp (gfc_exec_op op, const omp_mask mask)
6038 : {
6039 17433 : gfc_omp_clauses *c;
6040 17433 : if (gfc_match_omp_clauses (&c, mask, false, true, false,
6041 : op == EXEC_OMP_TARGET) != MATCH_YES)
6042 : return MATCH_ERROR;
6043 17075 : new_st.op = op;
6044 17075 : new_st.ext.omp_clauses = c;
6045 17075 : return MATCH_YES;
6046 : }
6047 :
6048 : /* Handles both declarative and (deprecated) executable ALLOCATE directive;
6049 : accepts optional list (for executable) and common blocks.
6050 : If no variables have been provided, the single omp namelist has sym == NULL.
6051 :
6052 : Note that the executable ALLOCATE directive permits structure elements only
6053 : in OpenMP 5.0 and 5.1 but not longer in 5.2. See also the comment on the
6054 : 'omp allocators' directive below. The accidental change was reverted for
6055 : OpenMP TR12, permitting them again. See also gfc_match_omp_allocators.
6056 :
6057 : Hence, structure elements are rejected for now, also to make resolving
6058 : OMP_LIST_ALLOCATE simpler (check for duplicates, same symbol in
6059 : Fortran allocate stmt). TODO: Permit structure elements. */
6060 :
6061 : match
6062 274 : gfc_match_omp_allocate (void)
6063 : {
6064 274 : match m;
6065 274 : gfc_omp_namelist *vars = NULL;
6066 274 : gfc_expr *align = NULL;
6067 274 : gfc_expr *allocator = NULL;
6068 274 : locus loc = gfc_current_locus;
6069 :
6070 274 : m = gfc_match_omp_variable_list (" (", &vars, true, NULL, NULL, true, true,
6071 : NULL, true);
6072 :
6073 274 : if (m == MATCH_ERROR)
6074 : return m;
6075 :
6076 502 : while (true)
6077 : {
6078 502 : gfc_gobble_whitespace ();
6079 502 : if (gfc_match_omp_eos () == MATCH_YES)
6080 : break;
6081 234 : gfc_match (", "); /* optionally */
6082 234 : if ((m = gfc_match_dupl_check (!align, "align", true, &align))
6083 : != MATCH_NO)
6084 : {
6085 62 : if (m == MATCH_ERROR)
6086 1 : goto error;
6087 61 : continue;
6088 : }
6089 172 : if ((m = gfc_match_dupl_check (!allocator, "allocator",
6090 : true, &allocator)) != MATCH_NO)
6091 : {
6092 171 : if (m == MATCH_ERROR)
6093 1 : goto error;
6094 170 : continue;
6095 : }
6096 1 : gfc_error ("Expected ALIGN or ALLOCATOR clause at %C");
6097 1 : return MATCH_ERROR;
6098 : }
6099 541 : for (gfc_omp_namelist *n = vars; n; n = n->next)
6100 276 : if (n->expr)
6101 : {
6102 3 : if ((n->expr->ref && n->expr->ref->type == REF_COMPONENT)
6103 3 : || (n->expr->ref->next && n->expr->ref->type == REF_COMPONENT))
6104 1 : gfc_error ("Sorry, structure-element list item at %L in ALLOCATE "
6105 : "directive is not yet supported", &n->expr->where);
6106 : else
6107 2 : gfc_error ("Unexpected expression as list item at %L in ALLOCATE "
6108 : "directive", &n->expr->where);
6109 :
6110 3 : gfc_free_omp_namelist (vars, OMP_LIST_ALLOCATE);
6111 3 : goto error;
6112 : }
6113 :
6114 265 : new_st.op = EXEC_OMP_ALLOCATE;
6115 265 : new_st.ext.omp_clauses = gfc_get_omp_clauses ();
6116 265 : if (vars == NULL)
6117 : {
6118 27 : vars = gfc_get_omp_namelist ();
6119 27 : vars->where = loc;
6120 27 : vars->u.align = align;
6121 27 : vars->u2.allocator = allocator;
6122 27 : new_st.ext.omp_clauses->lists[OMP_LIST_ALLOCATE] = vars;
6123 : }
6124 : else
6125 : {
6126 238 : new_st.ext.omp_clauses->lists[OMP_LIST_ALLOCATE] = vars;
6127 511 : for (; vars; vars = vars->next)
6128 : {
6129 273 : vars->u.align = (align) ? gfc_copy_expr (align) : NULL;
6130 273 : vars->u2.allocator = allocator;
6131 : }
6132 238 : gfc_free_expr (align);
6133 : }
6134 : return MATCH_YES;
6135 :
6136 5 : error:
6137 5 : gfc_free_expr (align);
6138 5 : gfc_free_expr (allocator);
6139 5 : return MATCH_ERROR;
6140 : }
6141 :
6142 : /* In line with OpenMP 5.2 derived-type components are rejected.
6143 : See also comment before gfc_match_omp_allocate. */
6144 :
6145 : match
6146 26 : gfc_match_omp_allocators (void)
6147 : {
6148 26 : return match_omp (EXEC_OMP_ALLOCATORS, OMP_ALLOCATORS_CLAUSES);
6149 : }
6150 :
6151 :
6152 : match
6153 25 : gfc_match_omp_assume (void)
6154 : {
6155 25 : gfc_omp_clauses *c;
6156 25 : locus loc = gfc_current_locus;
6157 32 : if ((gfc_match_omp_clauses (&c, omp_mask (OMP_CLAUSE_ASSUMPTIONS), false)
6158 : != MATCH_YES)
6159 25 : || (omp_verify_merge_absent_contains (ST_OMP_ASSUME, c->assume, NULL,
6160 : &loc) != MATCH_YES))
6161 : return MATCH_ERROR;
6162 18 : new_st.op = EXEC_OMP_ASSUME;
6163 18 : new_st.ext.omp_clauses = c;
6164 18 : return MATCH_YES;
6165 : }
6166 :
6167 :
6168 : match
6169 38 : gfc_match_omp_assumes (void)
6170 : {
6171 38 : gfc_omp_clauses *c;
6172 38 : locus loc = gfc_current_locus;
6173 38 : if (!gfc_current_ns->proc_name
6174 37 : || (gfc_current_ns->proc_name->attr.flavor != FL_MODULE
6175 23 : && !gfc_current_ns->proc_name->attr.subroutine
6176 10 : && !gfc_current_ns->proc_name->attr.function))
6177 : {
6178 2 : gfc_error ("!$OMP ASSUMES at %C must be in the specification part of a "
6179 : "subprogram or module");
6180 2 : return MATCH_ERROR;
6181 : }
6182 46 : if ((gfc_match_omp_clauses (&c, omp_mask (OMP_CLAUSE_ASSUMPTIONS), false)
6183 : != MATCH_YES)
6184 65 : || (omp_verify_merge_absent_contains (ST_OMP_ASSUMES, c->assume,
6185 29 : gfc_current_ns->omp_assumes, &loc)
6186 : != MATCH_YES))
6187 : return MATCH_ERROR;
6188 26 : if (gfc_current_ns->omp_assumes == NULL)
6189 : {
6190 23 : gfc_current_ns->omp_assumes = c->assume;
6191 23 : c->assume = NULL;
6192 : }
6193 3 : else if (gfc_current_ns->omp_assumes && c->assume)
6194 : {
6195 3 : gfc_current_ns->omp_assumes->no_openmp |= c->assume->no_openmp;
6196 3 : gfc_current_ns->omp_assumes->no_openmp_routines
6197 3 : |= c->assume->no_openmp_routines;
6198 3 : gfc_current_ns->omp_assumes->no_openmp_constructs
6199 3 : |= c->assume->no_openmp_constructs;
6200 3 : gfc_current_ns->omp_assumes->no_parallelism |= c->assume->no_parallelism;
6201 3 : if (gfc_current_ns->omp_assumes->holds && c->assume->holds)
6202 : {
6203 : gfc_expr_list *el = gfc_current_ns->omp_assumes->holds;
6204 1 : for ( ; el->next ; el = el->next)
6205 : ;
6206 1 : el->next = c->assume->holds;
6207 1 : }
6208 2 : else if (c->assume->holds)
6209 1 : gfc_current_ns->omp_assumes->holds = c->assume->holds;
6210 3 : c->assume->holds = NULL;
6211 : }
6212 26 : gfc_free_omp_clauses (c);
6213 26 : return MATCH_YES;
6214 : }
6215 :
6216 :
6217 : match
6218 168 : gfc_match_omp_critical (void)
6219 : {
6220 168 : char n[GFC_MAX_SYMBOL_LEN+1];
6221 168 : gfc_omp_clauses *c = NULL;
6222 :
6223 168 : if (gfc_match (" ( %n )", n) != MATCH_YES)
6224 117 : n[0] = '\0';
6225 :
6226 168 : if (gfc_match_omp_clauses (&c, omp_mask (OMP_CLAUSE_HINT), false,
6227 168 : /* needs_space = */ n[0] == '\0') != MATCH_YES)
6228 : return MATCH_ERROR;
6229 :
6230 166 : new_st.op = EXEC_OMP_CRITICAL;
6231 166 : new_st.ext.omp_clauses = c;
6232 166 : if (n[0])
6233 51 : c->critical_name = xstrdup (n);
6234 : return MATCH_YES;
6235 : }
6236 :
6237 :
6238 : match
6239 166 : gfc_match_omp_end_critical (void)
6240 : {
6241 166 : char n[GFC_MAX_SYMBOL_LEN+1];
6242 :
6243 166 : if (gfc_match (" ( %n )", n) != MATCH_YES)
6244 115 : n[0] = '\0';
6245 166 : if (gfc_match_omp_eos () != MATCH_YES)
6246 : {
6247 1 : gfc_error ("Unexpected junk after $OMP CRITICAL statement at %C");
6248 1 : return MATCH_ERROR;
6249 : }
6250 :
6251 165 : new_st.op = EXEC_OMP_END_CRITICAL;
6252 165 : new_st.ext.omp_name = n[0] ? xstrdup (n) : NULL;
6253 165 : return MATCH_YES;
6254 : }
6255 :
6256 : /* depobj(depobj) depend(dep-type:loc)|destroy|update(dep-type)
6257 : dep-type = in/out/inout/mutexinoutset/depobj/source/sink
6258 : depend: !source, !sink
6259 : update: !source, !sink, !depobj
6260 : locator = exactly one list item .*/
6261 : match
6262 128 : gfc_match_omp_depobj (void)
6263 : {
6264 128 : gfc_omp_clauses *c = NULL;
6265 128 : gfc_expr *depobj;
6266 :
6267 128 : if (gfc_match (" ( %v ) ", &depobj) != MATCH_YES)
6268 : {
6269 2 : gfc_error ("Expected %<( depobj )%> at %C");
6270 2 : return MATCH_ERROR;
6271 : }
6272 126 : gfc_match (", "); /* optionally */
6273 126 : if (gfc_match ("update ( ") == MATCH_YES)
6274 : {
6275 12 : c = gfc_get_omp_clauses ();
6276 12 : if (gfc_match ("inoutset )") == MATCH_YES)
6277 2 : c->depobj_update = OMP_DEPEND_INOUTSET;
6278 10 : else if (gfc_match ("inout )") == MATCH_YES)
6279 1 : c->depobj_update = OMP_DEPEND_INOUT;
6280 9 : else if (gfc_match ("in )") == MATCH_YES)
6281 2 : c->depobj_update = OMP_DEPEND_IN;
6282 7 : else if (gfc_match ("out )") == MATCH_YES)
6283 2 : c->depobj_update = OMP_DEPEND_OUT;
6284 5 : else if (gfc_match ("mutexinoutset )") == MATCH_YES)
6285 2 : c->depobj_update = OMP_DEPEND_MUTEXINOUTSET;
6286 : else
6287 : {
6288 3 : gfc_error ("Expected IN, OUT, INOUT, INOUTSET or MUTEXINOUTSET "
6289 : "followed by %<)%> at %C");
6290 3 : goto error;
6291 : }
6292 : }
6293 114 : else if (gfc_match ("destroy ") == MATCH_YES)
6294 : {
6295 18 : gfc_expr *destroyobj = NULL;
6296 18 : c = gfc_get_omp_clauses ();
6297 18 : c->destroy = true;
6298 :
6299 18 : if (gfc_match (" ( %v ) ", &destroyobj) == MATCH_YES)
6300 : {
6301 3 : if (destroyobj->symtree != depobj->symtree)
6302 2 : gfc_warning (OPT_Wopenmp, "The same depend object should be used as"
6303 : " DEPOBJ argument at %L and as DESTROY argument at %L",
6304 : &depobj->where, &destroyobj->where);
6305 3 : gfc_free_expr (destroyobj);
6306 : }
6307 : }
6308 96 : else if (gfc_match_omp_clauses (&c, omp_mask (OMP_CLAUSE_DEPEND), false, false)
6309 : != MATCH_YES)
6310 2 : goto error;
6311 :
6312 121 : if (c->depobj_update == OMP_DEPEND_UNSET && !c->destroy)
6313 : {
6314 94 : if (!c->doacross_source && !c->lists[OMP_LIST_DEPEND])
6315 : {
6316 1 : gfc_error ("Expected DEPEND, UPDATE, or DESTROY clause at %C");
6317 1 : goto error;
6318 : }
6319 93 : if (c->lists[OMP_LIST_DEPEND]->u.depend_doacross_op == OMP_DEPEND_DEPOBJ)
6320 : {
6321 1 : gfc_error ("DEPEND clause at %L of OMP DEPOBJ construct shall not "
6322 : "have dependence-type DEPOBJ",
6323 : c->lists[OMP_LIST_DEPEND]
6324 : ? &c->lists[OMP_LIST_DEPEND]->where : &gfc_current_locus);
6325 1 : goto error;
6326 : }
6327 92 : if (c->lists[OMP_LIST_DEPEND]->next)
6328 : {
6329 1 : gfc_error ("DEPEND clause at %L of OMP DEPOBJ construct shall have "
6330 : "only a single locator",
6331 : &c->lists[OMP_LIST_DEPEND]->next->where);
6332 1 : goto error;
6333 : }
6334 : }
6335 :
6336 118 : c->depobj = depobj;
6337 118 : new_st.op = EXEC_OMP_DEPOBJ;
6338 118 : new_st.ext.omp_clauses = c;
6339 118 : return MATCH_YES;
6340 :
6341 8 : error:
6342 8 : gfc_free_expr (depobj);
6343 8 : gfc_free_omp_clauses (c);
6344 8 : return MATCH_ERROR;
6345 : }
6346 :
6347 : match
6348 160 : gfc_match_omp_dispatch (void)
6349 : {
6350 160 : return match_omp (EXEC_OMP_DISPATCH, OMP_DISPATCH_CLAUSES);
6351 : }
6352 :
6353 : match
6354 57 : gfc_match_omp_distribute (void)
6355 : {
6356 57 : return match_omp (EXEC_OMP_DISTRIBUTE, OMP_DISTRIBUTE_CLAUSES);
6357 : }
6358 :
6359 :
6360 : match
6361 47 : gfc_match_omp_distribute_parallel_do (void)
6362 : {
6363 47 : return match_omp (EXEC_OMP_DISTRIBUTE_PARALLEL_DO,
6364 47 : (OMP_DISTRIBUTE_CLAUSES | OMP_PARALLEL_CLAUSES
6365 47 : | OMP_DO_CLAUSES)
6366 47 : & ~(omp_mask (OMP_CLAUSE_ORDERED)
6367 47 : | OMP_CLAUSE_LINEAR | OMP_CLAUSE_NOWAIT));
6368 : }
6369 :
6370 :
6371 : match
6372 34 : gfc_match_omp_distribute_parallel_do_simd (void)
6373 : {
6374 34 : return match_omp (EXEC_OMP_DISTRIBUTE_PARALLEL_DO_SIMD,
6375 34 : (OMP_DISTRIBUTE_CLAUSES | OMP_PARALLEL_CLAUSES
6376 34 : | OMP_DO_CLAUSES | OMP_SIMD_CLAUSES)
6377 34 : & ~(omp_mask (OMP_CLAUSE_ORDERED) | OMP_CLAUSE_NOWAIT));
6378 : }
6379 :
6380 :
6381 : match
6382 52 : gfc_match_omp_distribute_simd (void)
6383 : {
6384 52 : return match_omp (EXEC_OMP_DISTRIBUTE_SIMD,
6385 52 : OMP_DISTRIBUTE_CLAUSES | OMP_SIMD_CLAUSES);
6386 : }
6387 :
6388 :
6389 : match
6390 1255 : gfc_match_omp_do (void)
6391 : {
6392 1255 : return match_omp (EXEC_OMP_DO, OMP_DO_CLAUSES);
6393 : }
6394 :
6395 :
6396 : match
6397 139 : gfc_match_omp_do_simd (void)
6398 : {
6399 139 : return match_omp (EXEC_OMP_DO_SIMD, OMP_DO_CLAUSES | OMP_SIMD_CLAUSES);
6400 : }
6401 :
6402 :
6403 : match
6404 70 : gfc_match_omp_loop (void)
6405 : {
6406 70 : return match_omp (EXEC_OMP_LOOP, OMP_LOOP_CLAUSES);
6407 : }
6408 :
6409 :
6410 : match
6411 35 : gfc_match_omp_teams_loop (void)
6412 : {
6413 35 : return match_omp (EXEC_OMP_TEAMS_LOOP, OMP_TEAMS_CLAUSES | OMP_LOOP_CLAUSES);
6414 : }
6415 :
6416 :
6417 : match
6418 18 : gfc_match_omp_target_teams_loop (void)
6419 : {
6420 18 : return match_omp (EXEC_OMP_TARGET_TEAMS_LOOP,
6421 18 : OMP_TARGET_CLAUSES | OMP_TEAMS_CLAUSES | OMP_LOOP_CLAUSES);
6422 : }
6423 :
6424 :
6425 : match
6426 31 : gfc_match_omp_parallel_loop (void)
6427 : {
6428 31 : return match_omp (EXEC_OMP_PARALLEL_LOOP,
6429 31 : OMP_PARALLEL_CLAUSES | OMP_LOOP_CLAUSES);
6430 : }
6431 :
6432 :
6433 : match
6434 16 : gfc_match_omp_target_parallel_loop (void)
6435 : {
6436 16 : return match_omp (EXEC_OMP_TARGET_PARALLEL_LOOP,
6437 16 : (OMP_TARGET_CLAUSES | OMP_PARALLEL_CLAUSES
6438 16 : | OMP_LOOP_CLAUSES));
6439 : }
6440 :
6441 :
6442 : match
6443 104 : gfc_match_omp_error (void)
6444 : {
6445 104 : locus loc = gfc_current_locus;
6446 104 : match m = match_omp (EXEC_OMP_ERROR, OMP_ERROR_CLAUSES);
6447 104 : if (m != MATCH_YES)
6448 : return m;
6449 :
6450 85 : gfc_omp_clauses *c = new_st.ext.omp_clauses;
6451 85 : if (c->severity == OMP_SEVERITY_UNSET)
6452 48 : c->severity = OMP_SEVERITY_FATAL;
6453 85 : if (new_st.ext.omp_clauses->at == OMP_AT_EXECUTION)
6454 : return MATCH_YES;
6455 37 : if (c->message
6456 37 : && (!gfc_resolve_expr (c->message)
6457 16 : || c->message->ts.type != BT_CHARACTER
6458 14 : || c->message->ts.kind != gfc_default_character_kind
6459 13 : || c->message->rank != 0))
6460 : {
6461 4 : gfc_error ("MESSAGE clause at %L requires a scalar default-kind "
6462 : "CHARACTER expression",
6463 4 : &new_st.ext.omp_clauses->message->where);
6464 4 : return MATCH_ERROR;
6465 : }
6466 33 : if (c->message && !gfc_is_constant_expr (c->message))
6467 : {
6468 2 : gfc_error ("Constant character expression required in MESSAGE clause "
6469 2 : "at %L", &new_st.ext.omp_clauses->message->where);
6470 2 : return MATCH_ERROR;
6471 : }
6472 31 : if (c->message)
6473 : {
6474 10 : const char *msg = G_("$OMP ERROR encountered at %L: %s");
6475 10 : gcc_assert (c->message->expr_type == EXPR_CONSTANT);
6476 10 : gfc_charlen_t slen = c->message->value.character.length;
6477 10 : int i = gfc_validate_kind (BT_CHARACTER, gfc_default_character_kind,
6478 : false);
6479 10 : size_t size = slen * gfc_character_kinds[i].bit_size / 8;
6480 10 : unsigned char *s = XCNEWVAR (unsigned char, size + 1);
6481 10 : gfc_encode_character (gfc_default_character_kind, slen,
6482 10 : c->message->value.character.string,
6483 : (unsigned char *) s, size);
6484 10 : s[size] = '\0';
6485 10 : if (c->severity == OMP_SEVERITY_WARNING)
6486 6 : gfc_warning_now (0, msg, &loc, s);
6487 : else
6488 4 : gfc_error_now (msg, &loc, s);
6489 10 : free (s);
6490 : }
6491 : else
6492 : {
6493 21 : const char *msg = G_("$OMP ERROR encountered at %L");
6494 21 : if (c->severity == OMP_SEVERITY_WARNING)
6495 7 : gfc_warning_now (0, msg, &loc);
6496 : else
6497 14 : gfc_error_now (msg, &loc);
6498 : }
6499 : return MATCH_YES;
6500 : }
6501 :
6502 : match
6503 100 : gfc_match_omp_flush (void)
6504 : {
6505 100 : gfc_omp_namelist *list = NULL;
6506 100 : gfc_omp_clauses *c = NULL;
6507 100 : gfc_gobble_whitespace ();
6508 100 : enum gfc_omp_memorder mo = OMP_MEMORDER_UNSET;
6509 100 : if (gfc_match_omp_variable_list (" (", &list, true) == MATCH_ERROR)
6510 : return MATCH_ERROR;
6511 : match m = MATCH_YES;
6512 150 : while (gfc_match_omp_eos () != MATCH_YES)
6513 : {
6514 59 : gfc_gobble_whitespace ();
6515 59 : gfc_match (", "); /* optionally */
6516 59 : enum gfc_omp_memorder mo2 = OMP_MEMORDER_UNSET;
6517 59 : bool bval = false;
6518 59 : locus loc = gfc_current_locus;
6519 59 : if ((m = gfc_match_dupl_memorder (&bval, "seq_cst",
6520 : mo != OMP_MEMORDER_UNSET)) != MATCH_NO)
6521 : mo2 = OMP_MEMORDER_SEQ_CST;
6522 48 : else if ((m = gfc_match_dupl_memorder (&bval, "acq_rel",
6523 : mo != OMP_MEMORDER_UNSET))
6524 : != MATCH_NO)
6525 : mo2 = OMP_MEMORDER_ACQ_REL;
6526 35 : else if ((m = gfc_match_dupl_memorder (&bval, "release",
6527 : mo != OMP_MEMORDER_UNSET))
6528 : != MATCH_NO)
6529 : mo2 = OMP_MEMORDER_RELEASE;
6530 24 : else if ((m = gfc_match_dupl_memorder (&bval, "acquire",
6531 : mo != OMP_MEMORDER_UNSET))
6532 : != MATCH_NO)
6533 : mo2 = OMP_MEMORDER_ACQUIRE;
6534 12 : else if ((m = gfc_match_dupl_memorder (&bval, "relaxed",
6535 : mo != OMP_MEMORDER_UNSET))
6536 : != MATCH_NO)
6537 : {
6538 10 : if (m == MATCH_YES && bval)
6539 : {
6540 : /* relaxed only permitted with 'false'. */
6541 2 : gfc_current_locus = loc;
6542 2 : m = MATCH_NO;
6543 2 : break;
6544 : }
6545 : }
6546 : else
6547 : break;
6548 55 : if (m == MATCH_ERROR)
6549 5 : return MATCH_ERROR;
6550 50 : if (bval)
6551 18 : mo = mo2;
6552 : }
6553 95 : if (m == MATCH_NO)
6554 : {
6555 4 : gfc_error ("Expected SEQ_CST, AQC_REL, RELEASE, or ACQUIRE at %C");
6556 4 : gfc_free_omp_namelist (list, OMP_LIST_NONE);
6557 4 : return MATCH_ERROR;
6558 : }
6559 91 : if (list && mo != OMP_MEMORDER_UNSET)
6560 : {
6561 1 : gfc_error ("List specified together with memory order clause in FLUSH "
6562 : "directive at %C");
6563 1 : gfc_free_omp_namelist (list, OMP_LIST_NONE);
6564 1 : return MATCH_ERROR;
6565 : }
6566 90 : if (gfc_match_omp_eos () != MATCH_YES)
6567 : {
6568 0 : gfc_error ("Unexpected junk after $OMP FLUSH statement at %C");
6569 0 : gfc_free_omp_namelist (list, OMP_LIST_NONE);
6570 0 : return MATCH_ERROR;
6571 : }
6572 90 : if (mo != OMP_MEMORDER_UNSET)
6573 : {
6574 16 : c = gfc_get_omp_clauses ();
6575 16 : c->memorder = mo;
6576 : }
6577 90 : new_st.op = EXEC_OMP_FLUSH;
6578 90 : new_st.ext.omp_namelist = list;
6579 90 : new_st.ext.omp_clauses = c;
6580 90 : return MATCH_YES;
6581 : }
6582 :
6583 :
6584 : match
6585 208 : gfc_match_omp_declare_simd (void)
6586 : {
6587 208 : locus where = gfc_current_locus;
6588 208 : gfc_symbol *proc_name;
6589 208 : gfc_omp_clauses *c;
6590 208 : gfc_omp_declare_simd *ods;
6591 208 : bool needs_space = false;
6592 :
6593 208 : switch (gfc_match (" ( "))
6594 : {
6595 145 : case MATCH_YES:
6596 145 : if (gfc_match_symbol (&proc_name, /* host assoc = */ true) != MATCH_YES
6597 145 : || gfc_match (" ) ") != MATCH_YES)
6598 : return MATCH_ERROR;
6599 : break;
6600 63 : case MATCH_NO: proc_name = NULL; needs_space = true; break;
6601 : case MATCH_ERROR: return MATCH_ERROR;
6602 : }
6603 :
6604 208 : if (gfc_match_omp_clauses (&c, OMP_DECLARE_SIMD_CLAUSES, false,
6605 : needs_space) != MATCH_YES)
6606 : return MATCH_ERROR;
6607 :
6608 199 : if (gfc_current_ns->is_block_data)
6609 : {
6610 1 : gfc_free_omp_clauses (c);
6611 1 : return MATCH_YES;
6612 : }
6613 :
6614 198 : ods = gfc_get_omp_declare_simd ();
6615 198 : ods->where = where;
6616 198 : ods->proc_name = proc_name;
6617 198 : ods->clauses = c;
6618 198 : ods->next = gfc_current_ns->omp_declare_simd;
6619 198 : gfc_current_ns->omp_declare_simd = ods;
6620 198 : return MATCH_YES;
6621 : }
6622 :
6623 :
6624 : /* Find a matching "!$omp declare mapper" for typespec TS in symtree ST. */
6625 :
6626 : gfc_omp_udm *
6627 37 : gfc_omp_udm_find (gfc_symtree *st, gfc_typespec *ts)
6628 : {
6629 37 : gfc_omp_udm *omp_udm;
6630 :
6631 37 : if (st == NULL)
6632 : return NULL;
6633 :
6634 14 : gfc_symbol *dt = (ts->type == BT_CLASS
6635 0 : ? CLASS_DATA (ts->u.derived)->ts.u.derived
6636 : : ts->u.derived);
6637 15 : for (omp_udm = st->n.omp_udm; omp_udm; omp_udm = omp_udm->next)
6638 : {
6639 5 : if (dt == omp_udm->ts.u.derived)
6640 : return omp_udm;
6641 : /* Special case for comparing derived types across namespaces. If the
6642 : true names and module names are the same and the module name is
6643 : nonnull, then they are equal. */
6644 1 : if (dt->module && omp_udm->ts.u.derived->module
6645 1 : && strcmp (dt->name, omp_udm->ts.u.derived->name) == 0
6646 1 : && strcmp (dt->module, omp_udm->ts.u.derived->module) == 0)
6647 : return omp_udm;
6648 : }
6649 :
6650 : return NULL;
6651 : }
6652 :
6653 :
6654 : /* Match !$omp declare mapper([ mapper-identifier : ] type :: var) clauses-list */
6655 :
6656 : match
6657 35 : gfc_match_omp_declare_mapper (void)
6658 : {
6659 35 : match m;
6660 35 : gfc_typespec ts;
6661 35 : char mapper_id[GFC_MAX_SYMBOL_LEN + 1];
6662 35 : char var[GFC_MAX_SYMBOL_LEN + 1];
6663 35 : gfc_namespace *mapper_ns = NULL;
6664 35 : gfc_symtree *var_st;
6665 35 : gfc_symtree *st;
6666 35 : gfc_omp_udm *omp_udm = NULL, *prev_udm = NULL;
6667 35 : locus where = gfc_current_locus;
6668 :
6669 35 : if (gfc_match_char ('(') != MATCH_YES)
6670 : {
6671 1 : gfc_error ("Expected %<(%> at %C");
6672 1 : return MATCH_ERROR;
6673 : }
6674 :
6675 34 : locus old_locus = gfc_current_locus;
6676 :
6677 34 : m = gfc_match (" %n : ", mapper_id);
6678 :
6679 34 : if (m == MATCH_ERROR)
6680 : return MATCH_ERROR;
6681 :
6682 : /* As a special case, a mapper named "default" and an unnamed mapper are
6683 : both the default mapper for a given type. */
6684 34 : if (strcmp (mapper_id, "default") == 0)
6685 0 : mapper_id[0] = '\0';
6686 :
6687 34 : if (gfc_peek_ascii_char () == ':')
6688 : {
6689 : /* If we see '::', the user did not name the mapper, and instead we just
6690 : saw the type. So backtrack and try parsing as a type instead. */
6691 15 : mapper_id[0] = '\0';
6692 15 : gfc_current_locus = old_locus;
6693 : }
6694 34 : old_locus = gfc_current_locus;
6695 :
6696 34 : m = gfc_match_type_spec (&ts);
6697 34 : if (m != MATCH_YES)
6698 : {
6699 4 : gfc_error ("Expected either a type name at %L or a map-type "
6700 : "identifier, a colon, or a type name", &old_locus);
6701 4 : return MATCH_ERROR;
6702 : }
6703 :
6704 30 : if (ts.type != BT_DERIVED)
6705 : {
6706 1 : gfc_error ("!$OMP DECLARE MAPPER with non-derived type at %L", &old_locus);
6707 1 : return MATCH_ERROR;
6708 : }
6709 :
6710 29 : if (gfc_match (" :: ") != MATCH_YES)
6711 : {
6712 0 : gfc_error ("Expected %<::%> at %C");
6713 0 : return MATCH_ERROR;
6714 : }
6715 :
6716 29 : if (gfc_match_name (var) != MATCH_YES)
6717 : {
6718 1 : gfc_error ("Expected variable name at %C");
6719 1 : return MATCH_ERROR;
6720 : }
6721 :
6722 28 : if (gfc_match_char (')') != MATCH_YES)
6723 : {
6724 2 : gfc_error ("Expected %<)%> at %C");
6725 2 : return MATCH_ERROR;
6726 : }
6727 :
6728 26 : st = gfc_find_symtree (gfc_current_ns->omp_udm_root, mapper_id);
6729 :
6730 : /* Now we need to set up a new namespace, and create a new sym_tree for our
6731 : dummy variable so we can use it in the following list of mapping
6732 : clauses. */
6733 :
6734 26 : gfc_current_ns = mapper_ns = gfc_get_namespace (gfc_current_ns, 1);
6735 26 : mapper_ns->proc_name = mapper_ns->parent->proc_name;
6736 26 : mapper_ns->omp_udm_ns = 1;
6737 :
6738 26 : gfc_get_sym_tree (var, mapper_ns, &var_st, false);
6739 26 : var_st->n.sym->ts = ts;
6740 26 : var_st->n.sym->attr.omp_udm_artificial_var = 1;
6741 26 : var_st->n.sym->attr.flavor = FL_VARIABLE;
6742 26 : gfc_commit_symbols ();
6743 :
6744 26 : gfc_omp_clauses *clauses = NULL;
6745 :
6746 26 : m = gfc_match_omp_clauses (&clauses, omp_mask (OMP_CLAUSE_MAP), false, false,
6747 : false, false, OMP_MAP_UNSET);
6748 26 : if (m != MATCH_YES)
6749 1 : goto failure;
6750 :
6751 25 : omp_udm = gfc_get_omp_udm ();
6752 25 : omp_udm->next = NULL;
6753 25 : omp_udm->where = where;
6754 25 : omp_udm->mapper_id = gfc_get_string ("%s", mapper_id);
6755 25 : omp_udm->ts = ts;
6756 25 : omp_udm->var_sym = var_st->n.sym;
6757 25 : omp_udm->mapper_ns = mapper_ns;
6758 25 : omp_udm->clauses = clauses;
6759 :
6760 25 : gfc_current_ns = mapper_ns->parent;
6761 :
6762 25 : prev_udm = gfc_omp_udm_find (st, &ts);
6763 25 : if (prev_udm)
6764 : {
6765 2 : if (mapper_id[0])
6766 1 : gfc_error ("Redefinition of !$OMP DECLARE MAPPER at %L for type %qs with id %qs",
6767 : &where, gfc_typename (&ts), mapper_id);
6768 : else
6769 1 : gfc_error ("Redefinition of !$OMP DECLARE MAPPER at %L for type %qs",
6770 : &where, gfc_typename (&ts));
6771 2 : inform (gfc_get_location (&prev_udm->where),
6772 : "Previous !$OMP DECLARE MAPPER here");
6773 2 : return MATCH_ERROR;
6774 : }
6775 23 : else if (st)
6776 : {
6777 0 : omp_udm->next = st->n.omp_udm;
6778 0 : st->n.omp_udm = omp_udm;
6779 : }
6780 : else
6781 : {
6782 23 : st = gfc_new_symtree (&gfc_current_ns->omp_udm_root, mapper_id);
6783 23 : st->n.omp_udm = omp_udm;
6784 : }
6785 :
6786 : return MATCH_YES;
6787 :
6788 1 : failure:
6789 1 : if (mapper_ns)
6790 1 : gfc_current_ns = mapper_ns->parent;
6791 1 : gfc_free_omp_udm (omp_udm);
6792 :
6793 1 : return MATCH_ERROR;
6794 : }
6795 :
6796 : /* For 'declare reduction', matches either the combiner or initializer
6797 : expression, either can be an assignment of 'omp_sym1 = ...'
6798 : or a subroutine call, i.e. 'subroutine-name(argument-list)'. */
6799 :
6800 : static bool
6801 935 : match_udr_expr (gfc_symtree *omp_sym1, gfc_symtree *omp_sym2)
6802 : {
6803 935 : match m;
6804 935 : locus old_loc = gfc_current_locus;
6805 935 : char sname[GFC_MAX_SYMBOL_LEN + 1];
6806 935 : gfc_symbol *sym;
6807 935 : gfc_namespace *ns = gfc_current_ns;
6808 935 : gfc_expr *lvalue = NULL, *rvalue = NULL;
6809 935 : gfc_symtree *st;
6810 935 : gfc_actual_arglist *arglist;
6811 :
6812 935 : m = gfc_match (" %v =", &lvalue);
6813 935 : if (m != MATCH_YES)
6814 210 : gfc_current_locus = old_loc;
6815 : else
6816 : {
6817 725 : m = gfc_match (" %e )", &rvalue);
6818 725 : if (m == MATCH_YES)
6819 : {
6820 715 : ns->code = gfc_get_code (EXEC_ASSIGN);
6821 715 : ns->code->expr1 = lvalue;
6822 715 : ns->code->expr2 = rvalue;
6823 715 : ns->code->loc = old_loc;
6824 715 : return true;
6825 : }
6826 :
6827 10 : gfc_current_locus = old_loc;
6828 10 : gfc_free_expr (lvalue);
6829 : }
6830 :
6831 220 : m = gfc_match (" %n", sname);
6832 220 : if (m != MATCH_YES)
6833 4 : goto syntax;
6834 :
6835 216 : if (strcmp (sname, omp_sym1->name) == 0
6836 203 : || strcmp (sname, omp_sym2->name) == 0)
6837 14 : goto syntax;
6838 :
6839 202 : gfc_current_ns = ns->parent;
6840 202 : if (gfc_get_ha_sym_tree (sname, &st))
6841 0 : goto syntax;
6842 :
6843 202 : sym = st->n.sym;
6844 202 : if (sym->attr.flavor != FL_PROCEDURE
6845 74 : && sym->attr.flavor != FL_UNKNOWN)
6846 1 : goto syntax;
6847 :
6848 201 : if (!sym->attr.generic
6849 191 : && !sym->attr.subroutine
6850 73 : && !sym->attr.function)
6851 : {
6852 73 : if (!(sym->attr.external && !sym->attr.referenced))
6853 : {
6854 : /* ...create a symbol in this scope... */
6855 73 : if (sym->ns != gfc_current_ns
6856 73 : && gfc_get_sym_tree (sname, NULL, &st, false) == 1)
6857 0 : goto syntax;
6858 :
6859 73 : if (sym != st->n.sym)
6860 73 : sym = st->n.sym;
6861 : }
6862 :
6863 : /* ...and then to try to make the symbol into a subroutine. */
6864 73 : if (!gfc_add_subroutine (&sym->attr, sym->name, NULL))
6865 0 : goto syntax;
6866 : }
6867 :
6868 201 : gfc_set_sym_referenced (sym);
6869 201 : gfc_gobble_whitespace ();
6870 201 : if (gfc_peek_ascii_char () != '(')
6871 6 : goto syntax;
6872 :
6873 195 : gfc_current_ns = ns;
6874 195 : m = gfc_match_actual_arglist (1, &arglist);
6875 195 : if (m != MATCH_YES)
6876 0 : goto syntax;
6877 :
6878 195 : if (gfc_match_char (')') != MATCH_YES)
6879 0 : goto syntax;
6880 :
6881 195 : gfc_clear_error ();
6882 195 : ns->code = gfc_get_code (EXEC_CALL);
6883 195 : ns->code->symtree = st;
6884 195 : ns->code->ext.actual = arglist;
6885 195 : ns->code->loc = old_loc;
6886 195 : return true;
6887 25 : syntax:
6888 25 : gfc_clear_error ();
6889 25 : gfc_error ("Expected either %<%s = expr%> or %<subroutine-name(argument-list)"
6890 : "%> followed by %<)%> at %L", omp_sym1->name, &old_loc);
6891 25 : return false;
6892 : }
6893 :
6894 : static bool
6895 1217 : gfc_omp_udr_predef (gfc_omp_reduction_op rop, const char *name,
6896 : gfc_typespec *ts, const char **n)
6897 : {
6898 1217 : if (!gfc_numeric_ts (ts) && ts->type != BT_LOGICAL)
6899 : return false;
6900 :
6901 675 : switch (rop)
6902 : {
6903 19 : case OMP_REDUCTION_PLUS:
6904 19 : case OMP_REDUCTION_MINUS:
6905 19 : case OMP_REDUCTION_TIMES:
6906 19 : return ts->type != BT_LOGICAL;
6907 12 : case OMP_REDUCTION_AND:
6908 12 : case OMP_REDUCTION_OR:
6909 12 : case OMP_REDUCTION_EQV:
6910 12 : case OMP_REDUCTION_NEQV:
6911 12 : return ts->type == BT_LOGICAL;
6912 643 : case OMP_REDUCTION_USER:
6913 643 : if (name[0] != '.' && (ts->type == BT_INTEGER || ts->type == BT_REAL))
6914 : {
6915 571 : gfc_symbol *sym;
6916 :
6917 571 : gfc_find_symbol (name, NULL, 1, &sym);
6918 571 : if (sym != NULL)
6919 : {
6920 94 : if (sym->attr.intrinsic)
6921 0 : *n = sym->name;
6922 94 : else if ((sym->attr.flavor != FL_UNKNOWN
6923 82 : && sym->attr.flavor != FL_PROCEDURE)
6924 70 : || sym->attr.external
6925 55 : || sym->attr.generic
6926 55 : || sym->attr.entry
6927 55 : || sym->attr.result
6928 55 : || sym->attr.dummy
6929 55 : || sym->attr.subroutine
6930 51 : || sym->attr.pointer
6931 51 : || sym->attr.target
6932 51 : || sym->attr.cray_pointer
6933 51 : || sym->attr.cray_pointee
6934 51 : || (sym->attr.proc != PROC_UNKNOWN
6935 1 : && sym->attr.proc != PROC_INTRINSIC)
6936 50 : || sym->attr.if_source != IFSRC_UNKNOWN
6937 50 : || sym == sym->ns->proc_name)
6938 44 : *n = NULL;
6939 : else
6940 50 : *n = sym->name;
6941 : }
6942 : else
6943 477 : *n = name;
6944 571 : if (*n
6945 527 : && (strcmp (*n, "max") == 0 || strcmp (*n, "min") == 0))
6946 56 : return true;
6947 533 : else if (*n
6948 489 : && ts->type == BT_INTEGER
6949 403 : && (strcmp (*n, "iand") == 0
6950 397 : || strcmp (*n, "ior") == 0
6951 391 : || strcmp (*n, "ieor") == 0))
6952 : return true;
6953 : }
6954 : break;
6955 : default:
6956 : break;
6957 : }
6958 : return false;
6959 : }
6960 :
6961 : gfc_omp_udr *
6962 673 : gfc_omp_udr_find (gfc_symtree *st, gfc_typespec *ts)
6963 : {
6964 673 : gfc_omp_udr *omp_udr;
6965 :
6966 673 : if (st == NULL)
6967 : return NULL;
6968 :
6969 112 : gfc_symbol *dt = NULL;
6970 112 : if (ts->type == BT_DERIVED || ts->type == BT_CLASS)
6971 25 : dt = (ts->type == BT_CLASS
6972 0 : ? CLASS_DATA (ts->u.derived)->ts.u.derived : ts->u.derived);
6973 260 : for (omp_udr = st->n.omp_udr; omp_udr; omp_udr = omp_udr->next)
6974 161 : if (omp_udr->ts.type == ts->type
6975 91 : || (dt && omp_udr->ts.type == BT_DERIVED))
6976 : {
6977 70 : if (dt && omp_udr->ts.type == BT_DERIVED)
6978 : {
6979 15 : gfc_symbol *dtu = omp_udr->ts.u.derived;
6980 15 : if (dt == dtu)
6981 : return omp_udr;
6982 : /* Special case for comparing derived types across namespaces. If
6983 : the true names and module names are the same and the module name
6984 : is nonnull, then they are equal. */
6985 7 : if (dt->module && dtu->module
6986 1 : && strcmp (dt->name, dtu->name) == 0
6987 1 : && strcmp (dt->module, dtu->module) == 0)
6988 : return omp_udr;
6989 : }
6990 55 : else if (omp_udr->ts.kind == ts->kind)
6991 : {
6992 20 : if (omp_udr->ts.type == BT_CHARACTER)
6993 : {
6994 17 : if (omp_udr->ts.u.cl->length == NULL
6995 15 : || ts->u.cl->length == NULL)
6996 : return omp_udr;
6997 15 : if (omp_udr->ts.u.cl->length->expr_type != EXPR_CONSTANT)
6998 : return omp_udr;
6999 15 : if (ts->u.cl->length->expr_type != EXPR_CONSTANT)
7000 : return omp_udr;
7001 15 : if (omp_udr->ts.u.cl->length->ts.type != BT_INTEGER)
7002 : return omp_udr;
7003 15 : if (ts->u.cl->length->ts.type != BT_INTEGER)
7004 : return omp_udr;
7005 15 : if (gfc_compare_expr (omp_udr->ts.u.cl->length,
7006 : ts->u.cl->length, INTRINSIC_EQ) != 0)
7007 15 : continue;
7008 : }
7009 : return omp_udr;
7010 : }
7011 : }
7012 : return NULL;
7013 : }
7014 :
7015 : match
7016 594 : gfc_match_omp_declare_reduction (void)
7017 : {
7018 594 : match m;
7019 594 : gfc_intrinsic_op op;
7020 594 : char name[GFC_MAX_SYMBOL_LEN + 3];
7021 594 : auto_vec<gfc_typespec, 5> tss;
7022 594 : gfc_typespec ts;
7023 594 : unsigned int i;
7024 594 : gfc_symtree *st;
7025 594 : locus where = gfc_current_locus;
7026 594 : locus end_loc = gfc_current_locus;
7027 594 : bool end_loc_set = false;
7028 594 : gfc_omp_reduction_op rop = OMP_REDUCTION_NONE;
7029 :
7030 594 : if (gfc_match_char ('(') != MATCH_YES)
7031 : {
7032 4 : gfc_error ("Expected %<(%> at %C");
7033 4 : return MATCH_ERROR;
7034 : }
7035 :
7036 590 : m = gfc_match (" %o : ", &op);
7037 590 : if (m == MATCH_ERROR)
7038 : return MATCH_ERROR;
7039 590 : if (m == MATCH_YES)
7040 : {
7041 142 : snprintf (name, sizeof name, "operator %s", gfc_op2string (op));
7042 142 : rop = (gfc_omp_reduction_op) op;
7043 : }
7044 : else
7045 : {
7046 448 : m = gfc_match_defined_op_name (name + 1, 1);
7047 448 : if (m == MATCH_ERROR)
7048 : return MATCH_ERROR;
7049 447 : if (m == MATCH_YES)
7050 : {
7051 41 : name[0] = '.';
7052 41 : strcat (name, ".");
7053 41 : if (gfc_match (" : ") != MATCH_YES)
7054 : {
7055 0 : gfc_error ("Expected %<:%> at %C");
7056 0 : return MATCH_ERROR;
7057 : }
7058 : }
7059 : else
7060 : {
7061 406 : if (gfc_match (" %n : ", name) != MATCH_YES)
7062 : {
7063 4 : gfc_error ("Expected an identfifier or operator as reduction "
7064 : "identifier followed by a colon at %C");
7065 4 : return MATCH_ERROR;
7066 : }
7067 : }
7068 : rop = OMP_REDUCTION_USER;
7069 : }
7070 :
7071 585 : m = gfc_match_type_spec (&ts);
7072 585 : if (m != MATCH_YES)
7073 : {
7074 4 : gfc_error ("Expected type spec at %C");
7075 4 : return MATCH_ERROR;
7076 : }
7077 : /* Treat len=: the same as len=*. */
7078 581 : if (ts.type == BT_CHARACTER)
7079 61 : ts.deferred = false;
7080 581 : tss.safe_push (ts);
7081 :
7082 1203 : while (gfc_match_char (',') == MATCH_YES)
7083 : {
7084 42 : m = gfc_match_type_spec (&ts);
7085 42 : if (m != MATCH_YES)
7086 : {
7087 1 : gfc_error ("Expected type spec at %C");
7088 1 : return MATCH_ERROR;
7089 : }
7090 41 : tss.safe_push (ts);
7091 : }
7092 580 : if (gfc_match_char (':') != MATCH_YES)
7093 : {
7094 6 : gfc_error ("Expected %<:%> or %<,%> at %C");
7095 6 : return MATCH_ERROR;
7096 : }
7097 :
7098 574 : st = gfc_find_symtree (gfc_current_ns->omp_udr_root, name);
7099 1699 : for (i = 0; i < tss.length (); i++)
7100 : {
7101 610 : gfc_symtree *omp_out, *omp_in;
7102 610 : gfc_symtree *omp_priv = NULL, *omp_orig = NULL;
7103 610 : gfc_namespace *combiner_ns, *initializer_ns = NULL;
7104 610 : gfc_omp_udr *prev_udr, *omp_udr;
7105 610 : const char *predef_name = NULL;
7106 :
7107 610 : omp_udr = gfc_get_omp_udr ();
7108 610 : omp_udr->name = gfc_get_string ("%s", name);
7109 610 : omp_udr->rop = rop;
7110 610 : omp_udr->ts = tss[i];
7111 610 : omp_udr->where = where;
7112 :
7113 610 : gfc_current_ns = combiner_ns = gfc_get_namespace (gfc_current_ns, 1);
7114 610 : combiner_ns->proc_name = combiner_ns->parent->proc_name;
7115 :
7116 610 : gfc_get_sym_tree ("omp_out", combiner_ns, &omp_out, false);
7117 610 : gfc_get_sym_tree ("omp_in", combiner_ns, &omp_in, false);
7118 610 : combiner_ns->omp_udr_ns = 1;
7119 610 : omp_out->n.sym->ts = tss[i];
7120 610 : omp_in->n.sym->ts = tss[i];
7121 610 : omp_out->n.sym->attr.omp_udr_artificial_var = 1;
7122 610 : omp_in->n.sym->attr.omp_udr_artificial_var = 1;
7123 610 : omp_out->n.sym->attr.flavor = FL_VARIABLE;
7124 610 : omp_in->n.sym->attr.flavor = FL_VARIABLE;
7125 610 : gfc_commit_symbols ();
7126 610 : omp_udr->combiner_ns = combiner_ns;
7127 610 : omp_udr->omp_out = omp_out->n.sym;
7128 610 : omp_udr->omp_in = omp_in->n.sym;
7129 :
7130 610 : locus old_loc = gfc_current_locus;
7131 :
7132 610 : if (!match_udr_expr (omp_out, omp_in))
7133 : {
7134 19 : syntax:
7135 59 : gfc_current_ns = combiner_ns->parent;
7136 59 : gfc_undo_symbols ();
7137 59 : gfc_free_omp_udr (omp_udr);
7138 59 : return MATCH_ERROR;
7139 : }
7140 591 : gfc_match_char (','); /* optionally */
7141 591 : if (gfc_match (" initializer ( ") == MATCH_YES)
7142 : {
7143 325 : gfc_current_ns = combiner_ns->parent;
7144 325 : initializer_ns = gfc_get_namespace (gfc_current_ns, 1);
7145 325 : gfc_current_ns = initializer_ns;
7146 325 : initializer_ns->proc_name = initializer_ns->parent->proc_name;
7147 :
7148 325 : gfc_get_sym_tree ("omp_priv", initializer_ns, &omp_priv, false);
7149 325 : gfc_get_sym_tree ("omp_orig", initializer_ns, &omp_orig, false);
7150 325 : initializer_ns->omp_udr_ns = 1;
7151 325 : omp_priv->n.sym->ts = tss[i];
7152 325 : omp_orig->n.sym->ts = tss[i];
7153 325 : omp_priv->n.sym->attr.omp_udr_artificial_var = 1;
7154 325 : omp_orig->n.sym->attr.omp_udr_artificial_var = 1;
7155 325 : omp_priv->n.sym->attr.flavor = FL_VARIABLE;
7156 325 : omp_orig->n.sym->attr.flavor = FL_VARIABLE;
7157 325 : gfc_commit_symbols ();
7158 325 : omp_udr->initializer_ns = initializer_ns;
7159 325 : omp_udr->omp_priv = omp_priv->n.sym;
7160 325 : omp_udr->omp_orig = omp_orig->n.sym;
7161 :
7162 325 : if (!match_udr_expr (omp_priv, omp_orig))
7163 6 : goto syntax;
7164 : }
7165 :
7166 585 : gfc_current_ns = combiner_ns->parent;
7167 585 : if (!end_loc_set)
7168 : {
7169 549 : end_loc_set = true;
7170 549 : end_loc = gfc_current_locus;
7171 : }
7172 585 : gfc_current_locus = old_loc;
7173 :
7174 585 : prev_udr = gfc_omp_udr_find (st, &tss[i]);
7175 585 : if (gfc_omp_udr_predef (rop, name, &tss[i], &predef_name)
7176 : /* Don't error on !$omp declare reduction (min : integer : ...)
7177 : just yet, there could be integer :: min afterwards,
7178 : making it valid. When the UDR is resolved, we'll get
7179 : to it again. */
7180 585 : && (rop != OMP_REDUCTION_USER || name[0] == '.'))
7181 : {
7182 27 : if (predef_name)
7183 0 : gfc_error_now ("Redefinition of predefined %qs in "
7184 : "!$OMP DECLARE REDUCTION at %L",
7185 : predef_name, &where);
7186 : else
7187 27 : gfc_error_now ("Redefinition of predefined %qs in "
7188 : "!$OMP DECLARE REDUCTION at %L", name, &where);
7189 27 : goto syntax;
7190 : }
7191 558 : else if (prev_udr)
7192 : {
7193 7 : gfc_error_now ("Redefinition of %qs in !$OMP DECLARE REDUCTION at %L",
7194 : name, &where);
7195 7 : inform (gfc_get_location (&prev_udr->where),
7196 : "Previous !$OMP DECLARE REDUCTION");
7197 7 : goto syntax;
7198 : }
7199 551 : else if (st)
7200 : {
7201 98 : omp_udr->next = st->n.omp_udr;
7202 98 : st->n.omp_udr = omp_udr;
7203 : }
7204 : else
7205 : {
7206 453 : st = gfc_new_symtree (&gfc_current_ns->omp_udr_root, name);
7207 453 : st->n.omp_udr = omp_udr;
7208 : }
7209 : }
7210 :
7211 515 : if (end_loc_set)
7212 : {
7213 515 : gfc_current_locus = end_loc;
7214 515 : if (gfc_match_omp_eos () != MATCH_YES)
7215 : {
7216 4 : gfc_error ("Unexpected junk at %C");
7217 4 : return MATCH_ERROR;
7218 : }
7219 : return MATCH_YES;
7220 : }
7221 : return MATCH_ERROR;
7222 594 : }
7223 :
7224 :
7225 : match
7226 490 : gfc_match_omp_declare_target (void)
7227 : {
7228 490 : locus old_loc;
7229 490 : match m;
7230 490 : gfc_omp_clauses *c = NULL;
7231 490 : enum gfc_omp_list_type list;
7232 490 : gfc_omp_namelist *n;
7233 490 : gfc_symbol *s;
7234 :
7235 490 : old_loc = gfc_current_locus;
7236 :
7237 490 : if (gfc_current_ns->proc_name
7238 490 : && gfc_match_omp_eos () == MATCH_YES)
7239 : {
7240 138 : if (!gfc_add_omp_declare_target (&gfc_current_ns->proc_name->attr,
7241 138 : gfc_current_ns->proc_name->name,
7242 : &old_loc))
7243 0 : goto cleanup;
7244 : return MATCH_YES;
7245 : }
7246 :
7247 352 : if (gfc_current_ns->proc_name
7248 352 : && gfc_current_ns->proc_name->attr.if_source == IFSRC_IFBODY)
7249 : {
7250 2 : gfc_error ("Only the !$OMP DECLARE TARGET form without "
7251 : "clauses is allowed in interface block at %C");
7252 2 : goto cleanup;
7253 : }
7254 :
7255 350 : m = gfc_match (" (");
7256 350 : if (m == MATCH_YES)
7257 : {
7258 86 : c = gfc_get_omp_clauses ();
7259 86 : gfc_current_locus = old_loc;
7260 86 : m = gfc_match_omp_to_link (" (", &c->lists[OMP_LIST_ENTER]);
7261 86 : if (m != MATCH_YES)
7262 0 : goto syntax;
7263 86 : if (gfc_match_omp_eos () != MATCH_YES)
7264 : {
7265 0 : gfc_error ("Unexpected junk after !$OMP DECLARE TARGET at %C");
7266 0 : goto cleanup;
7267 : }
7268 : }
7269 264 : else if (gfc_match_omp_clauses (&c, OMP_DECLARE_TARGET_CLAUSES, false)
7270 : != MATCH_YES)
7271 : return MATCH_ERROR;
7272 :
7273 344 : gfc_buffer_error (false);
7274 :
7275 344 : static const enum gfc_omp_list_type to_enter_link_lists[]
7276 : = { OMP_LIST_TO, OMP_LIST_ENTER, OMP_LIST_LINK, OMP_LIST_LOCAL };
7277 1720 : for (size_t listn = 0; listn < ARRAY_SIZE (to_enter_link_lists)
7278 1720 : && (list = to_enter_link_lists[listn], true); ++listn)
7279 1941 : for (n = c->lists[list]; n; n = n->next)
7280 565 : if (n->sym)
7281 523 : n->sym->mark = 0;
7282 42 : else if (n->u.common->head)
7283 42 : n->u.common->head->mark = 0;
7284 :
7285 344 : if (c->device_type == OMP_DEVICE_TYPE_UNSET)
7286 276 : c->device_type = OMP_DEVICE_TYPE_ANY;
7287 1720 : for (size_t listn = 0; listn < ARRAY_SIZE (to_enter_link_lists)
7288 1720 : && (list = to_enter_link_lists[listn], true); ++listn)
7289 1941 : for (n = c->lists[list]; n; n = n->next)
7290 565 : if (n->sym)
7291 : {
7292 523 : if (n->sym->attr.in_common)
7293 1 : gfc_error_now ("OMP DECLARE TARGET variable at %L is an "
7294 : "element of a COMMON block", &n->where);
7295 522 : else if (n->sym->attr.omp_groupprivate && list != OMP_LIST_LOCAL)
7296 12 : gfc_error_now ("List item %qs at %L should not appear in the %qs "
7297 : "clause, as it was previously specified in a "
7298 : "GROUPPRIVATE directive", n->sym->name, &n->where,
7299 : list == OMP_LIST_LINK
7300 5 : ? "link" : list == OMP_LIST_TO ? "to" : "enter");
7301 515 : else if (n->sym->mark)
7302 11 : gfc_error_now ("Variable at %L mentioned multiple times in "
7303 : "clauses of the same OMP DECLARE TARGET directive",
7304 : &n->where);
7305 504 : else if ((list != OMP_LIST_LINK
7306 471 : && n->sym->attr.omp_declare_target_link)
7307 469 : || (list != OMP_LIST_LOCAL
7308 488 : && n->sym->attr.omp_declare_target_local))
7309 10 : gfc_error_now ("OMP DECLARE TARGET variable at %L previously "
7310 : "mentioned in %s clause and later in %s clause",
7311 : &n->where,
7312 5 : n->sym->attr.omp_declare_target_link ? "LINK"
7313 : : "LOCAL",
7314 : (list == OMP_LIST_LOCAL ? "LOCAL"
7315 : : list == OMP_LIST_LINK ? "LINK"
7316 : : list == OMP_LIST_TO ? "TO" : "ENTER"));
7317 499 : else if (n->sym->attr.omp_declare_target
7318 15 : && (list == OMP_LIST_LINK || list == OMP_LIST_LOCAL))
7319 3 : gfc_error_now ("OMP DECLARE TARGET variable at %L previously "
7320 : "mentioned in TO or ENTER clause and later in "
7321 : "%s clause", &n->where,
7322 : list == OMP_LIST_LINK ? "LINK" : "LOCAL");
7323 : else
7324 : {
7325 497 : if (list == OMP_LIST_TO || list == OMP_LIST_ENTER)
7326 453 : gfc_add_omp_declare_target (&n->sym->attr, n->sym->name,
7327 : &n->sym->declared_at);
7328 497 : if (list == OMP_LIST_LINK)
7329 31 : gfc_add_omp_declare_target_link (&n->sym->attr, n->sym->name,
7330 31 : &n->sym->declared_at);
7331 497 : if (list == OMP_LIST_LOCAL)
7332 13 : gfc_add_omp_declare_target_local (&n->sym->attr, n->sym->name,
7333 13 : &n->sym->declared_at);
7334 : }
7335 523 : if (n->sym->attr.omp_device_type != OMP_DEVICE_TYPE_UNSET
7336 43 : && n->sym->attr.omp_device_type != c->device_type)
7337 : {
7338 12 : const char *dt = "any";
7339 12 : if (n->sym->attr.omp_device_type == OMP_DEVICE_TYPE_NOHOST)
7340 : dt = "nohost";
7341 8 : else if (n->sym->attr.omp_device_type == OMP_DEVICE_TYPE_HOST)
7342 4 : dt = "host";
7343 12 : if (n->sym->attr.omp_groupprivate)
7344 1 : gfc_error_now ("List item %qs at %L set in previous OMP "
7345 : "GROUPPRIVATE directive to the different "
7346 : "DEVICE_TYPE %qs", n->sym->name, &n->where, dt);
7347 : else
7348 11 : gfc_error_now ("List item %qs at %L set in previous OMP "
7349 : "DECLARE TARGET directive to the different "
7350 : "DEVICE_TYPE %qs", n->sym->name, &n->where, dt);
7351 : }
7352 523 : n->sym->attr.omp_device_type = c->device_type;
7353 523 : if (c->indirect && c->device_type != OMP_DEVICE_TYPE_ANY)
7354 : {
7355 1 : gfc_error_now ("DEVICE_TYPE must be ANY when used with INDIRECT "
7356 : "at %L", &n->where);
7357 1 : c->indirect = 0;
7358 : }
7359 523 : n->sym->attr.omp_declare_target_indirect = c->indirect;
7360 523 : if (list == OMP_LIST_LINK && c->device_type == OMP_DEVICE_TYPE_NOHOST)
7361 3 : gfc_error_now ("List item %qs at %L set with NOHOST specified may "
7362 : "not appear in a LINK clause", n->sym->name,
7363 : &n->where);
7364 523 : n->sym->mark = 1;
7365 : }
7366 : else /* common block */
7367 : {
7368 42 : if (n->u.common->omp_groupprivate && list != OMP_LIST_LOCAL)
7369 7 : gfc_error_now ("Common block %</%s/%> at %L not appear in the %qs "
7370 : "clause as it was previously specified in a "
7371 : "GROUPPRIVATE directive",
7372 7 : n->u.common->name, &n->where,
7373 : list == OMP_LIST_LINK
7374 5 : ? "link" : list == OMP_LIST_TO ? "to" : "enter");
7375 35 : else if (n->u.common->head && n->u.common->head->mark)
7376 4 : gfc_error_now ("Common block %</%s/%> at %L mentioned multiple "
7377 : "times in clauses of the same OMP DECLARE TARGET "
7378 4 : "directive", n->u.common->name, &n->where);
7379 31 : else if ((n->u.common->omp_declare_target_link
7380 27 : || n->u.common->omp_declare_target_local)
7381 : && list != OMP_LIST_LINK
7382 6 : && list != OMP_LIST_LOCAL)
7383 2 : gfc_error_now ("Common block %</%s/%> at %L previously mentioned "
7384 : "in %s clause and later in %s clause",
7385 1 : n->u.common->name, &n->where,
7386 : n->u.common->omp_declare_target_link ? "LINK"
7387 : : "LOCAL",
7388 : list == OMP_LIST_TO ? "TO" : "ENTER");
7389 30 : else if (n->u.common->omp_declare_target
7390 4 : && (list == OMP_LIST_LINK || list == OMP_LIST_LOCAL))
7391 1 : gfc_error_now ("Common block %</%s/%> at %L previously mentioned "
7392 : "in TO or ENTER clause and later in %s clause",
7393 1 : n->u.common->name, &n->where,
7394 : list == OMP_LIST_LINK ? "LINK" : "LOCAL");
7395 42 : if (n->u.common->omp_device_type != OMP_DEVICE_TYPE_UNSET
7396 21 : && n->u.common->omp_device_type != c->device_type)
7397 : {
7398 1 : const char *dt = "any";
7399 1 : if (n->u.common->omp_device_type == OMP_DEVICE_TYPE_NOHOST)
7400 : dt = "nohost";
7401 0 : else if (n->u.common->omp_device_type == OMP_DEVICE_TYPE_HOST)
7402 0 : dt = "host";
7403 1 : if (n->u.common->omp_groupprivate)
7404 1 : gfc_error_now ("Common block %</%s/%> at %L set in previous OMP "
7405 : "GROUPPRIVATE directive to the different "
7406 1 : "DEVICE_TYPE %qs", n->u.common->name, &n->where,
7407 : dt);
7408 : else
7409 0 : gfc_error_now ("Common block %</%s/%> at %L set in previous OMP "
7410 : "DECLARE TARGET directive to the different "
7411 0 : "DEVICE_TYPE %qs", n->u.common->name, &n->where,
7412 : dt);
7413 : }
7414 42 : n->u.common->omp_device_type = c->device_type;
7415 :
7416 42 : if (c->indirect && c->device_type != OMP_DEVICE_TYPE_ANY)
7417 : {
7418 0 : gfc_error_now ("DEVICE_TYPE must be ANY when used with INDIRECT "
7419 : "at %L", &n->where);
7420 0 : c->indirect = 0;
7421 : }
7422 42 : if (list == OMP_LIST_LINK && c->device_type == OMP_DEVICE_TYPE_NOHOST)
7423 1 : gfc_error_now ("Common block %</%s/%> at %L set with NOHOST "
7424 : "specified may not appear in a LINK clause",
7425 1 : n->u.common->name, &n->where);
7426 :
7427 42 : if (list == OMP_LIST_TO || list == OMP_LIST_ENTER)
7428 21 : n->u.common->omp_declare_target = 1;
7429 42 : if (list == OMP_LIST_LINK)
7430 15 : n->u.common->omp_declare_target_link = 1;
7431 42 : if (list == OMP_LIST_LOCAL)
7432 6 : n->u.common->omp_declare_target_local = 1;
7433 :
7434 112 : for (s = n->u.common->head; s; s = s->common_next)
7435 : {
7436 70 : s->mark = 1;
7437 70 : if (list == OMP_LIST_TO || list == OMP_LIST_ENTER)
7438 33 : gfc_add_omp_declare_target (&s->attr, s->name, &n->where);
7439 70 : if (list == OMP_LIST_LINK)
7440 31 : gfc_add_omp_declare_target_link (&s->attr, s->name, &n->where);
7441 70 : if (list == OMP_LIST_LOCAL)
7442 6 : gfc_add_omp_declare_target_local (&s->attr, s->name, &n->where);
7443 70 : s->attr.omp_device_type = c->device_type;
7444 70 : s->attr.omp_declare_target_indirect = c->indirect;
7445 : }
7446 : }
7447 344 : if ((c->device_type || c->indirect)
7448 344 : && !c->lists[OMP_LIST_ENTER]
7449 161 : && !c->lists[OMP_LIST_TO]
7450 56 : && !c->lists[OMP_LIST_LINK]
7451 17 : && !c->lists[OMP_LIST_LOCAL])
7452 2 : gfc_warning_now (OPT_Wopenmp,
7453 : "OMP DECLARE TARGET directive at %L with only "
7454 : "DEVICE_TYPE or INDIRECT clauses is ignored",
7455 : &old_loc);
7456 :
7457 344 : gfc_buffer_error (true);
7458 :
7459 344 : if (c)
7460 344 : gfc_free_omp_clauses (c);
7461 : return MATCH_YES;
7462 :
7463 0 : syntax:
7464 0 : gfc_error ("Syntax error in !$OMP DECLARE TARGET list at %C");
7465 :
7466 2 : cleanup:
7467 2 : gfc_current_locus = old_loc;
7468 2 : if (c)
7469 0 : gfc_free_omp_clauses (c);
7470 : return MATCH_ERROR;
7471 : }
7472 :
7473 : /* Skip over and ignore trait-property-extensions.
7474 :
7475 : trait-property-extension :
7476 : trait-property-name
7477 : identifier (trait-property-extension[, trait-property-extension[, ...]])
7478 : constant integer expression
7479 : */
7480 :
7481 : static match gfc_ignore_trait_property_extension_list (void);
7482 :
7483 : static match
7484 7 : gfc_ignore_trait_property_extension (void)
7485 : {
7486 7 : char buf[GFC_MAX_SYMBOL_LEN + 1];
7487 7 : gfc_expr *expr;
7488 :
7489 : /* Identifier form of trait-property name, possibly followed by
7490 : a list of (recursive) trait-property-extensions. */
7491 7 : if (gfc_match_name (buf) == MATCH_YES)
7492 : {
7493 0 : if (gfc_match (" (") == MATCH_YES)
7494 0 : return gfc_ignore_trait_property_extension_list ();
7495 : return MATCH_YES;
7496 : }
7497 :
7498 : /* Literal constant. */
7499 7 : if (gfc_match_literal_constant (&expr, 0) == MATCH_YES)
7500 : return MATCH_YES;
7501 :
7502 : /* FIXME: constant integer expressions. */
7503 0 : gfc_error ("Expected trait-property-extension at %C");
7504 0 : return MATCH_ERROR;
7505 : }
7506 :
7507 : static match
7508 5 : gfc_ignore_trait_property_extension_list (void)
7509 : {
7510 9 : while (1)
7511 : {
7512 7 : if (gfc_ignore_trait_property_extension () != MATCH_YES)
7513 : return MATCH_ERROR;
7514 7 : if (gfc_match (" ,") == MATCH_YES)
7515 2 : continue;
7516 5 : if (gfc_match (" )") == MATCH_YES)
7517 : return MATCH_YES;
7518 0 : gfc_error ("expected %<)%> at %C");
7519 0 : return MATCH_ERROR;
7520 : }
7521 : }
7522 :
7523 :
7524 : match
7525 110 : gfc_match_omp_interop (void)
7526 : {
7527 110 : return match_omp (EXEC_OMP_INTEROP, OMP_INTEROP_CLAUSES);
7528 : }
7529 :
7530 :
7531 : /* OpenMP 5.0:
7532 :
7533 : trait-selector:
7534 : trait-selector-name[([trait-score:]trait-property[,trait-property[,...]])]
7535 :
7536 : trait-score:
7537 : score(score-expression) */
7538 :
7539 : static match
7540 662 : gfc_match_omp_context_selector (gfc_omp_set_selector *oss)
7541 : {
7542 803 : do
7543 : {
7544 803 : char selector[GFC_MAX_SYMBOL_LEN + 1];
7545 :
7546 803 : if (gfc_match_name (selector) != MATCH_YES)
7547 : {
7548 2 : gfc_error ("expected trait selector name at %C");
7549 39 : return MATCH_ERROR;
7550 : }
7551 :
7552 801 : gfc_omp_selector *os = gfc_get_omp_selector ();
7553 801 : if (oss->code == OMP_TRAIT_SET_CONSTRUCT
7554 351 : && !strcmp (selector, "do"))
7555 48 : os->code = OMP_TRAIT_CONSTRUCT_FOR;
7556 753 : else if (oss->code == OMP_TRAIT_SET_CONSTRUCT
7557 303 : && !strcmp (selector, "for"))
7558 1 : os->code = OMP_TRAIT_INVALID;
7559 : else
7560 752 : os->code = omp_lookup_ts_code (oss->code, selector);
7561 801 : os->next = oss->trait_selectors;
7562 801 : oss->trait_selectors = os;
7563 :
7564 801 : if (os->code == OMP_TRAIT_INVALID)
7565 : {
7566 18 : gfc_warning (OPT_Wopenmp,
7567 : "unknown selector %qs for context selector set %qs "
7568 : "at %C",
7569 18 : selector, omp_tss_map[oss->code]);
7570 18 : if (gfc_match (" (") == MATCH_YES
7571 18 : && gfc_ignore_trait_property_extension_list () != MATCH_YES)
7572 : return MATCH_ERROR;
7573 18 : if (gfc_match (" ,") == MATCH_YES)
7574 1 : continue;
7575 623 : break;
7576 : }
7577 :
7578 783 : enum omp_tp_type property_kind = omp_ts_map[os->code].tp_type;
7579 783 : bool allow_score = omp_ts_map[os->code].allow_score;
7580 :
7581 783 : if (gfc_match (" (") == MATCH_YES)
7582 : {
7583 451 : if (property_kind == OMP_TRAIT_PROPERTY_NONE)
7584 : {
7585 6 : gfc_error ("selector %qs does not accept any properties at %C",
7586 : selector);
7587 6 : return MATCH_ERROR;
7588 : }
7589 :
7590 445 : if (gfc_match (" score") == MATCH_YES)
7591 : {
7592 63 : if (!allow_score)
7593 : {
7594 10 : gfc_error ("%<score%> cannot be specified in traits "
7595 : "in the %qs trait-selector-set at %C",
7596 10 : omp_tss_map[oss->code]);
7597 10 : return MATCH_ERROR;
7598 : }
7599 53 : if (gfc_match (" (") != MATCH_YES)
7600 : {
7601 0 : gfc_error ("expected %<(%> at %C");
7602 0 : return MATCH_ERROR;
7603 : }
7604 53 : if (gfc_match_expr (&os->score) != MATCH_YES)
7605 : return MATCH_ERROR;
7606 :
7607 52 : if (gfc_match (" )") != MATCH_YES)
7608 : {
7609 0 : gfc_error ("expected %<)%> at %C");
7610 0 : return MATCH_ERROR;
7611 : }
7612 :
7613 52 : if (gfc_match (" :") != MATCH_YES)
7614 : {
7615 0 : gfc_error ("expected : at %C");
7616 0 : return MATCH_ERROR;
7617 : }
7618 : }
7619 :
7620 434 : gfc_omp_trait_property *otp = gfc_get_omp_trait_property ();
7621 434 : otp->property_kind = property_kind;
7622 434 : otp->next = os->properties;
7623 434 : os->properties = otp;
7624 :
7625 434 : switch (property_kind)
7626 : {
7627 25 : case OMP_TRAIT_PROPERTY_ID:
7628 25 : {
7629 25 : char buf[GFC_MAX_SYMBOL_LEN + 1];
7630 25 : if (gfc_match_name (buf) == MATCH_YES)
7631 : {
7632 24 : otp->name = XNEWVEC (char, strlen (buf) + 1);
7633 24 : strcpy (otp->name, buf);
7634 : }
7635 : else
7636 : {
7637 1 : gfc_error ("expected identifier at %C");
7638 1 : free (otp);
7639 1 : os->properties = nullptr;
7640 1 : return MATCH_ERROR;
7641 : }
7642 : }
7643 24 : break;
7644 294 : case OMP_TRAIT_PROPERTY_NAME_LIST:
7645 347 : do
7646 : {
7647 294 : char buf[GFC_MAX_SYMBOL_LEN + 1];
7648 294 : if (gfc_match_name (buf) == MATCH_YES)
7649 : {
7650 172 : otp->name = XNEWVEC (char, strlen (buf) + 1);
7651 172 : strcpy (otp->name, buf);
7652 172 : otp->is_name = true;
7653 : }
7654 122 : else if (gfc_match_literal_constant (&otp->expr, 0)
7655 : != MATCH_YES
7656 122 : || otp->expr->ts.type != BT_CHARACTER)
7657 : {
7658 5 : gfc_error ("expected identifier or string literal "
7659 : "at %C");
7660 5 : free (otp);
7661 5 : os->properties = nullptr;
7662 5 : return MATCH_ERROR;
7663 : }
7664 :
7665 289 : if (gfc_match (" ,") == MATCH_YES)
7666 : {
7667 53 : otp = gfc_get_omp_trait_property ();
7668 53 : otp->property_kind = property_kind;
7669 53 : otp->next = os->properties;
7670 53 : os->properties = otp;
7671 : }
7672 : else
7673 : break;
7674 53 : }
7675 : while (1);
7676 236 : break;
7677 145 : case OMP_TRAIT_PROPERTY_DEV_NUM_EXPR:
7678 145 : case OMP_TRAIT_PROPERTY_BOOL_EXPR:
7679 145 : if (gfc_match_expr (&otp->expr) != MATCH_YES)
7680 : {
7681 3 : gfc_error ("expected expression at %C");
7682 3 : free (otp);
7683 3 : os->properties = nullptr;
7684 3 : return MATCH_ERROR;
7685 : }
7686 : break;
7687 23 : case OMP_TRAIT_PROPERTY_CLAUSE_LIST:
7688 23 : {
7689 23 : if (os->code == OMP_TRAIT_CONSTRUCT_SIMD)
7690 : {
7691 23 : gfc_matching_omp_context_selector = true;
7692 23 : if (gfc_match_omp_clauses (&otp->clauses,
7693 23 : OMP_DECLARE_SIMD_CLAUSES,
7694 : true, false, false)
7695 : != MATCH_YES)
7696 : {
7697 1 : gfc_matching_omp_context_selector = false;
7698 1 : gfc_error ("expected simd clause at %C");
7699 1 : return MATCH_ERROR;
7700 : }
7701 22 : gfc_matching_omp_context_selector = false;
7702 : }
7703 0 : else if (os->code == OMP_TRAIT_IMPLEMENTATION_REQUIRES)
7704 : {
7705 : /* FIXME: The "requires" selector was added in OpenMP 5.1.
7706 : Currently only the now-deprecated syntax
7707 : from OpenMP 5.0 is supported.
7708 : TODO: When implementing, update modules.cc as well. */
7709 0 : sorry_at (gfc_get_location (&gfc_current_locus),
7710 : "%<requires%> selector is not supported yet");
7711 0 : return MATCH_ERROR;
7712 : }
7713 : else
7714 0 : gcc_unreachable ();
7715 22 : break;
7716 : }
7717 0 : default:
7718 0 : gcc_unreachable ();
7719 : }
7720 :
7721 424 : if (gfc_match (" )") != MATCH_YES)
7722 : {
7723 2 : gfc_error ("expected %<)%> at %C");
7724 2 : return MATCH_ERROR;
7725 : }
7726 : }
7727 332 : else if (property_kind != OMP_TRAIT_PROPERTY_NONE
7728 332 : && property_kind != OMP_TRAIT_PROPERTY_CLAUSE_LIST
7729 8 : && property_kind != OMP_TRAIT_PROPERTY_EXTENSION)
7730 : {
7731 8 : if (gfc_match (" (") != MATCH_YES)
7732 : {
7733 8 : gfc_error ("expected %<(%> at %C");
7734 8 : return MATCH_ERROR;
7735 : }
7736 : }
7737 :
7738 746 : if (gfc_match (" ,") != MATCH_YES)
7739 : break;
7740 : }
7741 : while (1);
7742 :
7743 623 : return MATCH_YES;
7744 : }
7745 :
7746 : /* OpenMP 5.0:
7747 :
7748 : trait-set-selector[,trait-set-selector[,...]]
7749 :
7750 : trait-set-selector:
7751 : trait-set-selector-name = { trait-selector[, trait-selector[, ...]] }
7752 :
7753 : trait-set-selector-name:
7754 : constructor
7755 : device
7756 : implementation
7757 : user */
7758 :
7759 : static match
7760 600 : gfc_match_omp_context_selector_specification (gfc_omp_set_selector **oss_head)
7761 : {
7762 740 : do
7763 : {
7764 670 : match m;
7765 670 : char buf[GFC_MAX_SYMBOL_LEN + 1];
7766 670 : enum omp_tss_code set = OMP_TRAIT_SET_INVALID;
7767 :
7768 670 : m = gfc_match_name (buf);
7769 670 : if (m == MATCH_YES)
7770 668 : set = omp_lookup_tss_code (buf);
7771 :
7772 668 : if (set == OMP_TRAIT_SET_INVALID)
7773 : {
7774 5 : gfc_error ("expected context selector set name at %C");
7775 47 : return MATCH_ERROR;
7776 : }
7777 :
7778 665 : m = gfc_match (" =");
7779 665 : if (m != MATCH_YES)
7780 : {
7781 1 : gfc_error ("expected %<=%> at %C");
7782 1 : return MATCH_ERROR;
7783 : }
7784 :
7785 664 : m = gfc_match (" {");
7786 664 : if (m != MATCH_YES)
7787 : {
7788 2 : gfc_error ("expected %<{%> at %C");
7789 2 : return MATCH_ERROR;
7790 : }
7791 :
7792 662 : gfc_omp_set_selector *oss = gfc_get_omp_set_selector ();
7793 662 : oss->next = *oss_head;
7794 662 : oss->code = set;
7795 662 : *oss_head = oss;
7796 :
7797 662 : if (gfc_match_omp_context_selector (oss) != MATCH_YES)
7798 : return MATCH_ERROR;
7799 :
7800 623 : m = gfc_match (" }");
7801 623 : if (m != MATCH_YES)
7802 : {
7803 0 : gfc_error ("expected %<}%> at %C");
7804 0 : return MATCH_ERROR;
7805 : }
7806 :
7807 623 : m = gfc_match (" ,");
7808 623 : if (m != MATCH_YES)
7809 : break;
7810 70 : }
7811 : while (1);
7812 :
7813 553 : return MATCH_YES;
7814 : }
7815 :
7816 :
7817 : match
7818 434 : gfc_match_omp_declare_variant (void)
7819 : {
7820 434 : char buf[GFC_MAX_SYMBOL_LEN + 1];
7821 :
7822 434 : if (gfc_match (" (") != MATCH_YES)
7823 : {
7824 2 : gfc_error ("expected %<(%> at %C");
7825 2 : return MATCH_ERROR;
7826 : }
7827 :
7828 432 : gfc_symtree *base_proc_st, *variant_proc_st;
7829 432 : if (gfc_match_name (buf) != MATCH_YES)
7830 : {
7831 2 : gfc_error ("expected name at %C");
7832 2 : return MATCH_ERROR;
7833 : }
7834 :
7835 430 : if (gfc_get_ha_sym_tree (buf, &base_proc_st))
7836 : return MATCH_ERROR;
7837 :
7838 430 : if (gfc_match (" :") == MATCH_YES)
7839 : {
7840 16 : if (gfc_match_name (buf) != MATCH_YES)
7841 : {
7842 0 : gfc_error ("expected variant name at %C");
7843 0 : return MATCH_ERROR;
7844 : }
7845 :
7846 16 : if (gfc_get_ha_sym_tree (buf, &variant_proc_st))
7847 : return MATCH_ERROR;
7848 : }
7849 : else
7850 : {
7851 : /* Base procedure not specified. */
7852 414 : variant_proc_st = base_proc_st;
7853 414 : base_proc_st = NULL;
7854 : }
7855 :
7856 430 : gfc_omp_declare_variant *odv;
7857 430 : odv = gfc_get_omp_declare_variant ();
7858 430 : odv->where = gfc_current_locus;
7859 430 : odv->variant_proc_symtree = variant_proc_st;
7860 430 : odv->adjust_args_list = NULL;
7861 430 : odv->base_proc_symtree = base_proc_st;
7862 430 : odv->next = NULL;
7863 430 : odv->error_p = false;
7864 :
7865 : /* Add the new declare variant to the end of the list. */
7866 430 : gfc_omp_declare_variant **prev_next = &gfc_current_ns->omp_declare_variant;
7867 597 : while (*prev_next)
7868 167 : prev_next = &((*prev_next)->next);
7869 430 : *prev_next = odv;
7870 :
7871 430 : if (gfc_match (" )") != MATCH_YES)
7872 : {
7873 1 : gfc_error ("expected %<)%> at %C");
7874 1 : return MATCH_ERROR;
7875 : }
7876 :
7877 429 : bool has_match = false, has_adjust_args = false, has_append_args = false;
7878 429 : bool error_p = false;
7879 429 : locus adjust_args_loc;
7880 429 : locus append_args_loc;
7881 :
7882 429 : gfc_gobble_whitespace ();
7883 429 : gfc_match_char (',');
7884 647 : for (;;)
7885 : {
7886 538 : gfc_gobble_whitespace ();
7887 :
7888 538 : enum clause
7889 : {
7890 : clause_match,
7891 : clause_adjust_args,
7892 : clause_append_args
7893 : } ccode;
7894 :
7895 538 : if (gfc_match ("match") == MATCH_YES)
7896 : ccode = clause_match;
7897 119 : else if (gfc_match ("adjust_args") == MATCH_YES)
7898 : {
7899 532 : ccode = clause_adjust_args;
7900 : adjust_args_loc = gfc_current_locus;
7901 : }
7902 38 : else if (gfc_match ("append_args") == MATCH_YES)
7903 : {
7904 532 : ccode = clause_append_args;
7905 : append_args_loc = gfc_current_locus;
7906 : }
7907 : else
7908 : {
7909 : error_p = true;
7910 : break;
7911 : }
7912 :
7913 532 : if (gfc_match (" ( ") != MATCH_YES)
7914 : {
7915 1 : gfc_error ("expected %<(%> at %C");
7916 1 : return MATCH_ERROR;
7917 : }
7918 :
7919 531 : if (ccode == clause_match)
7920 : {
7921 418 : if (has_match)
7922 : {
7923 1 : gfc_error ("%qs clause at %L specified more than once",
7924 : "match", &gfc_current_locus);
7925 1 : return MATCH_ERROR;
7926 : }
7927 417 : has_match = true;
7928 417 : if (gfc_match_omp_context_selector_specification (&odv->set_selectors)
7929 : != MATCH_YES)
7930 : return MATCH_ERROR;
7931 377 : if (gfc_match (" )") != MATCH_YES)
7932 : {
7933 0 : gfc_error ("expected %<)%> at %C");
7934 0 : return MATCH_ERROR;
7935 : }
7936 : }
7937 113 : else if (ccode == clause_adjust_args)
7938 : {
7939 81 : has_adjust_args = true;
7940 81 : bool need_device_ptr_p = false;
7941 81 : bool need_device_addr_p = false;
7942 81 : if (gfc_match ("nothing ") == MATCH_YES)
7943 : ;
7944 58 : else if (gfc_match ("need_device_ptr ") == MATCH_YES)
7945 : need_device_ptr_p = true;
7946 9 : else if (gfc_match ("need_device_addr ") == MATCH_YES)
7947 : need_device_addr_p = true;
7948 : else
7949 : {
7950 2 : gfc_error ("expected %<nothing%>, %<need_device_ptr%> or "
7951 : "%<need_device_addr%> at %C");
7952 2 : return MATCH_ERROR;
7953 : }
7954 79 : if (gfc_match (": ") != MATCH_YES)
7955 : {
7956 1 : gfc_error ("expected %<:%> at %C");
7957 1 : return MATCH_ERROR;
7958 : }
7959 : gfc_omp_namelist *tail = NULL;
7960 : bool need_range = false, have_range = false;
7961 125 : while (true)
7962 : {
7963 125 : gfc_omp_namelist *p = gfc_get_omp_namelist ();
7964 125 : p->where = gfc_current_locus;
7965 125 : p->u.adj_args.need_ptr = need_device_ptr_p;
7966 125 : p->u.adj_args.need_addr = need_device_addr_p;
7967 125 : if (tail)
7968 : {
7969 47 : tail->next = p;
7970 47 : tail = tail->next;
7971 : }
7972 : else
7973 : {
7974 78 : gfc_omp_namelist **q = &odv->adjust_args_list;
7975 78 : if (*q)
7976 : {
7977 50 : for (; (*q)->next; q = &(*q)->next)
7978 : ;
7979 28 : (*q)->next = p;
7980 : }
7981 : else
7982 50 : *q = p;
7983 : tail = p;
7984 : }
7985 125 : if (gfc_match (": ") == MATCH_YES)
7986 : {
7987 2 : if (have_range)
7988 : {
7989 0 : gfc_error ("unexpected %<:%> at %C");
7990 2 : return MATCH_ERROR;
7991 : }
7992 2 : p->u.adj_args.range_start = have_range = true;
7993 2 : need_range = false;
7994 47 : continue;
7995 : }
7996 123 : if (have_range && gfc_match (", ") == MATCH_YES)
7997 : {
7998 1 : have_range = false;
7999 1 : continue;
8000 : }
8001 122 : if (have_range && gfc_match (") ") == MATCH_YES)
8002 : break;
8003 121 : locus saved_loc = gfc_current_locus;
8004 :
8005 : /* Without ranges, only arg names or integer literals permitted;
8006 : handle literals here as gfc_match_expr simplifies the expr. */
8007 121 : if (gfc_match_literal_constant (&p->expr, true) == MATCH_YES)
8008 : {
8009 17 : gfc_gobble_whitespace ();
8010 17 : char c = gfc_peek_ascii_char ();
8011 17 : if (c != ')' && c != ',' && c != ':')
8012 : {
8013 1 : gfc_free_expr (p->expr);
8014 1 : p->expr = NULL;
8015 1 : gfc_current_locus = saved_loc;
8016 : }
8017 : }
8018 121 : if (!p->expr && gfc_match ("omp_num_args") == MATCH_YES)
8019 : {
8020 6 : if (!have_range)
8021 3 : p->u.adj_args.range_start = need_range = true;
8022 : else
8023 : need_range = false;
8024 :
8025 6 : locus saved_loc2 = gfc_current_locus;
8026 6 : gfc_gobble_whitespace ();
8027 6 : char c = gfc_peek_ascii_char ();
8028 6 : if (c == '+' || c == '-')
8029 : {
8030 5 : if (gfc_match ("+ %e", &p->expr) == MATCH_YES)
8031 1 : p->u.adj_args.omp_num_args_plus = true;
8032 4 : else if (gfc_match ("- %e", &p->expr) == MATCH_YES)
8033 4 : p->u.adj_args.omp_num_args_minus = true;
8034 0 : else if (!gfc_error_check ())
8035 : {
8036 0 : gfc_error ("expected constant integer expression "
8037 : "at %C");
8038 0 : p->u.adj_args.error_p = true;
8039 0 : return MATCH_ERROR;
8040 : }
8041 5 : p->where = gfc_get_location_range (&saved_loc, 1,
8042 : &saved_loc, 1,
8043 : &gfc_current_locus);
8044 : }
8045 : else
8046 : {
8047 1 : p->where = gfc_get_location_range (&saved_loc, 1,
8048 : &saved_loc, 1,
8049 : &saved_loc2);
8050 1 : p->u.adj_args.omp_num_args_plus = true;
8051 : }
8052 : }
8053 115 : else if (!p->expr)
8054 : {
8055 99 : match m = gfc_match_expr (&p->expr);
8056 99 : if (m != MATCH_YES)
8057 : {
8058 1 : gfc_error ("expected dummy parameter name, "
8059 : "%<omp_num_args%> or constant positive integer"
8060 : " at %C");
8061 1 : p->u.adj_args.error_p = true;
8062 1 : return MATCH_ERROR;
8063 : }
8064 98 : if (p->expr->expr_type == EXPR_CONSTANT && !have_range)
8065 98 : need_range = true; /* Constant expr but not literal. */
8066 98 : p->where = p->expr->where;
8067 : }
8068 : else
8069 16 : p->where = p->expr->where;
8070 120 : gfc_gobble_whitespace ();
8071 120 : match m = gfc_match (": ");
8072 120 : if (need_range && m != MATCH_YES)
8073 : {
8074 1 : gfc_error ("expected %<:%> at %C");
8075 1 : return MATCH_ERROR;
8076 : }
8077 119 : if (m == MATCH_YES)
8078 : {
8079 6 : p->u.adj_args.range_start = have_range = true;
8080 6 : need_range = false;
8081 6 : continue;
8082 : }
8083 113 : need_range = have_range = false;
8084 113 : if (gfc_match (", ") == MATCH_YES)
8085 38 : continue;
8086 75 : if (gfc_match (") ") == MATCH_YES)
8087 : break;
8088 : }
8089 : }
8090 32 : else if (ccode == clause_append_args)
8091 : {
8092 32 : if (has_append_args)
8093 : {
8094 1 : gfc_error ("%qs clause at %L specified more than once",
8095 : "append_args", &gfc_current_locus);
8096 1 : return MATCH_ERROR;
8097 : }
8098 56 : has_append_args = true;
8099 : gfc_omp_namelist *append_args_last = NULL;
8100 81 : do
8101 : {
8102 56 : gfc_gobble_whitespace ();
8103 56 : if (gfc_match ("interop ") != MATCH_YES)
8104 : {
8105 0 : gfc_error ("expected %<interop%> at %C");
8106 3 : return MATCH_ERROR;
8107 : }
8108 56 : if (gfc_match ("( ") != MATCH_YES)
8109 : {
8110 0 : gfc_error ("expected %<(%> at %C");
8111 0 : return MATCH_ERROR;
8112 : }
8113 :
8114 56 : bool target, targetsync;
8115 56 : char *type_str = NULL;
8116 56 : int type_str_len;
8117 56 : locus loc = gfc_current_locus;
8118 56 : if (gfc_parser_omp_clause_init_modifiers (target, targetsync,
8119 : &type_str, type_str_len,
8120 : false) == MATCH_ERROR)
8121 : return MATCH_ERROR;
8122 :
8123 54 : gfc_omp_namelist *n = gfc_get_omp_namelist();
8124 54 : n->where = loc;
8125 54 : n->u.init.target = target;
8126 54 : n->u.init.targetsync = targetsync;
8127 54 : n->u.init.len = type_str_len;
8128 54 : n->u2.init_interop = type_str;
8129 54 : if (odv->append_args_list)
8130 : {
8131 25 : append_args_last->next = n;
8132 25 : append_args_last = n;
8133 : }
8134 : else
8135 29 : append_args_last = odv->append_args_list = n;
8136 :
8137 54 : gfc_gobble_whitespace ();
8138 54 : if (gfc_match_char (',') == MATCH_YES)
8139 25 : continue;
8140 29 : if (gfc_match_char (')') == MATCH_YES)
8141 : break;
8142 1 : gfc_error ("Expected %<,%> or %<)%> at %C");
8143 1 : return MATCH_ERROR;
8144 25 : }
8145 : while (true);
8146 : }
8147 481 : gfc_gobble_whitespace ();
8148 481 : if (gfc_match_omp_eos () == MATCH_YES)
8149 : break;
8150 109 : gfc_match_char (',');
8151 109 : }
8152 :
8153 378 : if (error_p || (!has_match && !has_adjust_args && !has_append_args))
8154 : {
8155 6 : gfc_error ("expected %<match%>, %<adjust_args%> or %<append_args%> at %C");
8156 6 : return MATCH_ERROR;
8157 : }
8158 :
8159 372 : if (!has_match)
8160 : {
8161 3 : gfc_error ("expected %<match%> clause at %C");
8162 3 : return MATCH_ERROR;
8163 : }
8164 :
8165 : return MATCH_YES;
8166 : }
8167 :
8168 :
8169 : static match
8170 167 : match_omp_metadirective (bool begin_p)
8171 : {
8172 167 : locus old_loc = gfc_current_locus;
8173 167 : gfc_omp_variant *variants_head;
8174 167 : gfc_omp_variant **next_variant = &variants_head;
8175 167 : bool default_seen = false;
8176 :
8177 : /* Parse the context selectors. */
8178 681 : for (;;)
8179 : {
8180 424 : bool default_p = false;
8181 424 : gfc_omp_set_selector *selectors = NULL;
8182 :
8183 424 : gfc_gobble_whitespace ();
8184 424 : if (gfc_match_eos () == MATCH_YES)
8185 : break;
8186 275 : gfc_match_char (',');
8187 275 : gfc_gobble_whitespace ();
8188 :
8189 275 : locus variant_locus = gfc_current_locus;
8190 :
8191 275 : if (gfc_match ("default ( ") == MATCH_YES)
8192 : {
8193 82 : default_p = true;
8194 82 : gfc_warning (OPT_Wdeprecated_openmp,
8195 : "%<default%> clause with metadirective at %L "
8196 : "deprecated since OpenMP 5.2", &variant_locus);
8197 : }
8198 193 : else if (gfc_match ("otherwise ( ") == MATCH_YES)
8199 : default_p = true;
8200 185 : else if (gfc_match ("when ( ") != MATCH_YES)
8201 : {
8202 1 : gfc_error ("expected %<when%>, %<otherwise%>, or %<default%> at %C");
8203 1 : gfc_current_locus = old_loc;
8204 18 : return MATCH_ERROR;
8205 : }
8206 90 : if (default_p && default_seen)
8207 : {
8208 3 : gfc_error ("too many %<otherwise%> or %<default%> clauses "
8209 : "in %<metadirective%> at %C");
8210 3 : gfc_current_locus = old_loc;
8211 3 : return MATCH_ERROR;
8212 : }
8213 271 : else if (default_seen)
8214 : {
8215 1 : gfc_error ("%<otherwise%> or %<default%> clause "
8216 : "must appear last in %<metadirective%> at %C");
8217 1 : gfc_current_locus = old_loc;
8218 1 : return MATCH_ERROR;
8219 : }
8220 :
8221 270 : if (!default_p)
8222 : {
8223 183 : if (gfc_match_omp_context_selector_specification (&selectors)
8224 : != MATCH_YES)
8225 : return MATCH_ERROR;
8226 :
8227 176 : if (gfc_match (" : ") != MATCH_YES)
8228 : {
8229 1 : gfc_error ("expected %<:%> at %C");
8230 1 : gfc_current_locus = old_loc;
8231 1 : return MATCH_ERROR;
8232 : }
8233 :
8234 175 : gfc_commit_symbols ();
8235 : }
8236 :
8237 262 : gfc_matching_omp_context_selector = true;
8238 262 : gfc_statement directive = match_omp_directive ();
8239 262 : gfc_matching_omp_context_selector = false;
8240 :
8241 262 : if (is_omp_declarative_stmt (directive))
8242 0 : sorry_at (gfc_get_location (&gfc_current_locus),
8243 : "declarative directive variants are not supported");
8244 :
8245 262 : if (gfc_error_flag_test ())
8246 : {
8247 2 : gfc_current_locus = old_loc;
8248 2 : return MATCH_ERROR;
8249 : }
8250 :
8251 260 : if (gfc_match (" )") != MATCH_YES)
8252 : {
8253 0 : gfc_error ("Expected %<)%> at %C");
8254 0 : gfc_current_locus = old_loc;
8255 0 : return MATCH_ERROR;
8256 : }
8257 :
8258 260 : gfc_commit_symbols ();
8259 :
8260 260 : if (begin_p
8261 260 : && directive != ST_NONE
8262 260 : && gfc_omp_end_stmt (directive) == ST_NONE)
8263 : {
8264 3 : gfc_error ("variant directive used in OMP BEGIN METADIRECTIVE "
8265 : "at %C must have a corresponding end directive");
8266 3 : gfc_current_locus = old_loc;
8267 3 : return MATCH_ERROR;
8268 : }
8269 :
8270 257 : if (default_p)
8271 : default_seen = true;
8272 :
8273 257 : gfc_omp_variant *omv = gfc_get_omp_variant ();
8274 257 : omv->selectors = selectors;
8275 257 : omv->stmt = directive;
8276 257 : omv->where = variant_locus;
8277 :
8278 257 : if (directive == ST_NONE)
8279 : {
8280 : /* The directive was a 'nothing' directive. */
8281 15 : omv->code = gfc_get_code (EXEC_CONTINUE);
8282 15 : omv->code->ext.omp_clauses = NULL;
8283 : }
8284 : else
8285 : {
8286 242 : omv->code = gfc_get_code (new_st.op);
8287 242 : omv->code->ext.omp_clauses = new_st.ext.omp_clauses;
8288 : /* Prevent the OpenMP clauses from being freed via NEW_ST. */
8289 242 : new_st.ext.omp_clauses = NULL;
8290 : }
8291 :
8292 257 : *next_variant = omv;
8293 257 : next_variant = &omv->next;
8294 257 : }
8295 :
8296 149 : if (gfc_match_omp_eos () != MATCH_YES)
8297 : {
8298 0 : gfc_error ("Unexpected junk after OMP METADIRECTIVE at %C");
8299 0 : gfc_current_locus = old_loc;
8300 0 : return MATCH_ERROR;
8301 : }
8302 :
8303 : /* Add a 'default (nothing)' clause if no default is explicitly given. */
8304 149 : if (!default_seen)
8305 : {
8306 71 : gfc_omp_variant *omv = gfc_get_omp_variant ();
8307 71 : omv->stmt = ST_NONE;
8308 71 : omv->code = gfc_get_code (EXEC_CONTINUE);
8309 71 : omv->code->ext.omp_clauses = NULL;
8310 71 : omv->where = old_loc;
8311 71 : omv->selectors = NULL;
8312 :
8313 71 : *next_variant = omv;
8314 71 : next_variant = &omv->next;
8315 : }
8316 :
8317 149 : new_st.op = EXEC_OMP_METADIRECTIVE;
8318 149 : new_st.ext.omp_variants = variants_head;
8319 :
8320 149 : return MATCH_YES;
8321 : }
8322 :
8323 : match
8324 47 : gfc_match_omp_begin_metadirective (void)
8325 : {
8326 47 : return match_omp_metadirective (true);
8327 : }
8328 :
8329 : match
8330 120 : gfc_match_omp_metadirective (void)
8331 : {
8332 120 : return match_omp_metadirective (false);
8333 : }
8334 :
8335 : /* Match 'omp threadprivate' or 'omp groupprivate'. */
8336 : static match
8337 262 : gfc_match_omp_thread_group_private (bool is_groupprivate)
8338 : {
8339 262 : locus old_loc;
8340 262 : char n[GFC_MAX_SYMBOL_LEN+1];
8341 262 : gfc_symbol *sym;
8342 262 : match m;
8343 262 : gfc_symtree *st;
8344 262 : struct sym_loc_t { gfc_symbol *sym; gfc_common_head *com; locus loc; };
8345 262 : auto_vec<sym_loc_t> syms;
8346 :
8347 262 : old_loc = gfc_current_locus;
8348 :
8349 262 : m = gfc_match (" ( ");
8350 262 : if (m != MATCH_YES)
8351 : return m;
8352 :
8353 372 : for (;;)
8354 : {
8355 317 : locus sym_loc = gfc_current_locus;
8356 317 : m = gfc_match_symbol (&sym, 0);
8357 317 : switch (m)
8358 : {
8359 212 : case MATCH_YES:
8360 212 : if (sym->attr.in_common)
8361 0 : gfc_error_now ("%qs variable at %L is an element of a COMMON block",
8362 : is_groupprivate ? "groupprivate" : "threadprivate",
8363 : &sym_loc);
8364 212 : else if (!is_groupprivate
8365 212 : && !gfc_add_threadprivate (&sym->attr, sym->name, &sym_loc))
8366 16 : goto cleanup;
8367 210 : else if (is_groupprivate)
8368 : {
8369 33 : if (!gfc_add_omp_groupprivate (&sym->attr, sym->name, &sym_loc))
8370 4 : goto cleanup;
8371 29 : syms.safe_push ({sym, nullptr, sym_loc});
8372 : }
8373 206 : goto next_item;
8374 : case MATCH_NO:
8375 : break;
8376 0 : case MATCH_ERROR:
8377 0 : goto cleanup;
8378 : }
8379 :
8380 105 : m = gfc_match (" / %n /", n);
8381 105 : if (m == MATCH_ERROR)
8382 0 : goto cleanup;
8383 105 : if (m == MATCH_NO || n[0] == '\0')
8384 0 : goto syntax;
8385 :
8386 105 : st = gfc_find_symtree (gfc_current_ns->common_root, n);
8387 105 : if (st == NULL)
8388 : {
8389 2 : gfc_error ("COMMON block /%s/ not found at %L", n, &sym_loc);
8390 2 : goto cleanup;
8391 : }
8392 103 : syms.safe_push ({nullptr, st->n.common, sym_loc});
8393 103 : if (is_groupprivate)
8394 30 : st->n.common->omp_groupprivate = 1;
8395 : else
8396 73 : st->n.common->threadprivate = 1;
8397 236 : for (sym = st->n.common->head; sym; sym = sym->common_next)
8398 141 : if (!is_groupprivate
8399 141 : && !gfc_add_threadprivate (&sym->attr, sym->name, &sym_loc))
8400 3 : goto cleanup;
8401 138 : else if (is_groupprivate
8402 138 : && !gfc_add_omp_groupprivate (&sym->attr, sym->name, &sym_loc))
8403 5 : goto cleanup;
8404 :
8405 95 : next_item:
8406 301 : if (gfc_match_char (')') == MATCH_YES)
8407 : break;
8408 55 : if (gfc_match_char (',') != MATCH_YES)
8409 0 : goto syntax;
8410 55 : }
8411 :
8412 246 : if (is_groupprivate)
8413 : {
8414 42 : gfc_omp_clauses *c;
8415 42 : m = gfc_match_omp_clauses (&c, omp_mask (OMP_CLAUSE_DEVICE_TYPE), false, false);
8416 42 : if (m == MATCH_ERROR)
8417 0 : return MATCH_ERROR;
8418 :
8419 42 : if (c->device_type == OMP_DEVICE_TYPE_UNSET)
8420 19 : c->device_type = OMP_DEVICE_TYPE_ANY;
8421 :
8422 92 : for (size_t i = 0; i < syms.length (); i++)
8423 50 : if (syms[i].sym)
8424 : {
8425 27 : sym_loc_t &n = syms[i];
8426 27 : if (n.sym->attr.in_common)
8427 0 : gfc_error_now ("Variable %qs at %L is an element of a COMMON "
8428 : "block", n.sym->name, &n.loc);
8429 27 : else if (n.sym->attr.omp_declare_target
8430 26 : || n.sym->attr.omp_declare_target_link)
8431 2 : gfc_error_now ("List item %qs at %L implies OMP DECLARE TARGET "
8432 : "with the LOCAL clause, but it has been specified"
8433 : " with a different clause before",
8434 : n.sym->name, &n.loc);
8435 27 : if (n.sym->attr.omp_device_type != OMP_DEVICE_TYPE_UNSET
8436 5 : && n.sym->attr.omp_device_type != c->device_type)
8437 : {
8438 2 : const char *dt = "any";
8439 2 : if (n.sym->attr.omp_device_type == OMP_DEVICE_TYPE_HOST)
8440 : dt = "host";
8441 0 : else if (n.sym->attr.omp_device_type == OMP_DEVICE_TYPE_NOHOST)
8442 0 : dt = "nohost";
8443 2 : gfc_error_now ("List item %qs at %L set in previous OMP DECLARE "
8444 : "TARGET directive to the different DEVICE_TYPE %qs",
8445 : n.sym->name, &n.loc, dt);
8446 : }
8447 27 : gfc_add_omp_declare_target_local (&n.sym->attr, n.sym->name,
8448 : &n.loc);
8449 27 : n.sym->attr.omp_device_type = c->device_type;
8450 : }
8451 : else /* Common block. */
8452 : {
8453 23 : sym_loc_t &n = syms[i];
8454 23 : if (n.com->omp_declare_target
8455 22 : || n.com->omp_declare_target_link)
8456 2 : gfc_error_now ("List item %</%s/%> at %L implies OMP DECLARE "
8457 : "TARGET with the LOCAL clause, but it has been "
8458 : "specified with a different clause before",
8459 2 : n.com->name, &n.loc);
8460 23 : if (n.com->omp_device_type != OMP_DEVICE_TYPE_UNSET
8461 5 : && n.com->omp_device_type != c->device_type)
8462 : {
8463 2 : const char *dt = "any";
8464 2 : if (n.com->omp_device_type == OMP_DEVICE_TYPE_HOST)
8465 : dt = "host";
8466 0 : else if (n.com->omp_device_type == OMP_DEVICE_TYPE_NOHOST)
8467 0 : dt = "nohost";
8468 2 : gfc_error_now ("List item %qs at %L set in previous OMP DECLARE"
8469 : " TARGET directive to the different DEVICE_TYPE "
8470 2 : "%qs", n.com->name, &n.loc, dt);
8471 : }
8472 23 : n.com->omp_declare_target_local = 1;
8473 23 : n.com->omp_device_type = c->device_type;
8474 46 : for (gfc_symbol *s = n.com->head; s; s = s->common_next)
8475 : {
8476 23 : gfc_add_omp_declare_target_local (&s->attr, s->name, &n.loc);
8477 23 : s->attr.omp_device_type = c->device_type;
8478 : }
8479 : }
8480 42 : free (c);
8481 : }
8482 :
8483 246 : if (gfc_match_omp_eos () != MATCH_YES)
8484 : {
8485 0 : gfc_error ("Unexpected junk after OMP %s at %C",
8486 : is_groupprivate ? "GROUPPRIVATE" : "THREADPRIVATE");
8487 0 : goto cleanup;
8488 : }
8489 :
8490 : return MATCH_YES;
8491 :
8492 0 : syntax:
8493 0 : gfc_error ("Syntax error in !$OMP %s list at %C",
8494 : is_groupprivate ? "GROUPPRIVATE" : "THREADPRIVATE");
8495 :
8496 16 : cleanup:
8497 16 : gfc_current_locus = old_loc;
8498 16 : return MATCH_ERROR;
8499 262 : }
8500 :
8501 :
8502 : match
8503 51 : gfc_match_omp_groupprivate (void)
8504 : {
8505 51 : return gfc_match_omp_thread_group_private (true);
8506 : }
8507 :
8508 :
8509 : match
8510 211 : gfc_match_omp_threadprivate (void)
8511 : {
8512 211 : return gfc_match_omp_thread_group_private (false);
8513 : }
8514 :
8515 :
8516 : match
8517 2215 : gfc_match_omp_parallel (void)
8518 : {
8519 2215 : return match_omp (EXEC_OMP_PARALLEL, OMP_PARALLEL_CLAUSES);
8520 : }
8521 :
8522 :
8523 : match
8524 1203 : gfc_match_omp_parallel_do (void)
8525 : {
8526 1203 : return match_omp (EXEC_OMP_PARALLEL_DO,
8527 1203 : (OMP_PARALLEL_CLAUSES | OMP_DO_CLAUSES)
8528 1203 : & ~(omp_mask (OMP_CLAUSE_NOWAIT)));
8529 : }
8530 :
8531 :
8532 : match
8533 298 : gfc_match_omp_parallel_do_simd (void)
8534 : {
8535 298 : return match_omp (EXEC_OMP_PARALLEL_DO_SIMD,
8536 298 : (OMP_PARALLEL_CLAUSES | OMP_DO_CLAUSES | OMP_SIMD_CLAUSES)
8537 298 : & ~(omp_mask (OMP_CLAUSE_NOWAIT)));
8538 : }
8539 :
8540 :
8541 : match
8542 14 : gfc_match_omp_parallel_masked (void)
8543 : {
8544 14 : return match_omp (EXEC_OMP_PARALLEL_MASKED,
8545 14 : OMP_PARALLEL_CLAUSES | OMP_MASKED_CLAUSES);
8546 : }
8547 :
8548 : match
8549 10 : gfc_match_omp_parallel_masked_taskloop (void)
8550 : {
8551 10 : return match_omp (EXEC_OMP_PARALLEL_MASKED_TASKLOOP,
8552 10 : (OMP_PARALLEL_CLAUSES | OMP_MASKED_CLAUSES
8553 10 : | OMP_TASKLOOP_CLAUSES)
8554 10 : & ~(omp_mask (OMP_CLAUSE_IN_REDUCTION)));
8555 : }
8556 :
8557 : match
8558 13 : gfc_match_omp_parallel_masked_taskloop_simd (void)
8559 : {
8560 13 : return match_omp (EXEC_OMP_PARALLEL_MASKED_TASKLOOP_SIMD,
8561 13 : (OMP_PARALLEL_CLAUSES | OMP_MASKED_CLAUSES
8562 13 : | OMP_TASKLOOP_CLAUSES | OMP_SIMD_CLAUSES)
8563 13 : & ~(omp_mask (OMP_CLAUSE_IN_REDUCTION)));
8564 : }
8565 :
8566 : match
8567 14 : gfc_match_omp_parallel_master (void)
8568 : {
8569 14 : gfc_warning (OPT_Wdeprecated_openmp,
8570 : "%<master%> construct at %C deprecated since OpenMP 5.1, use "
8571 : "%<masked%>");
8572 14 : return match_omp (EXEC_OMP_PARALLEL_MASTER, OMP_PARALLEL_CLAUSES);
8573 : }
8574 :
8575 : match
8576 16 : gfc_match_omp_parallel_master_taskloop (void)
8577 : {
8578 16 : gfc_warning (OPT_Wdeprecated_openmp,
8579 : "%<master%> construct at %C deprecated since OpenMP 5.1, "
8580 : "use %<masked%>");
8581 16 : return match_omp (EXEC_OMP_PARALLEL_MASTER_TASKLOOP,
8582 16 : (OMP_PARALLEL_CLAUSES | OMP_TASKLOOP_CLAUSES)
8583 16 : & ~(omp_mask (OMP_CLAUSE_IN_REDUCTION)));
8584 : }
8585 :
8586 : match
8587 21 : gfc_match_omp_parallel_master_taskloop_simd (void)
8588 : {
8589 21 : gfc_warning (OPT_Wdeprecated_openmp,
8590 : "%<master%> construct at %C deprecated since OpenMP 5.1, "
8591 : "use %<masked%>");
8592 21 : return match_omp (EXEC_OMP_PARALLEL_MASTER_TASKLOOP_SIMD,
8593 21 : (OMP_PARALLEL_CLAUSES | OMP_TASKLOOP_CLAUSES
8594 21 : | OMP_SIMD_CLAUSES)
8595 21 : & ~(omp_mask (OMP_CLAUSE_IN_REDUCTION)));
8596 : }
8597 :
8598 : match
8599 59 : gfc_match_omp_parallel_sections (void)
8600 : {
8601 59 : return match_omp (EXEC_OMP_PARALLEL_SECTIONS,
8602 59 : (OMP_PARALLEL_CLAUSES | OMP_SECTIONS_CLAUSES)
8603 59 : & ~(omp_mask (OMP_CLAUSE_NOWAIT)));
8604 : }
8605 :
8606 :
8607 : match
8608 56 : gfc_match_omp_parallel_workshare (void)
8609 : {
8610 56 : return match_omp (EXEC_OMP_PARALLEL_WORKSHARE, OMP_PARALLEL_CLAUSES);
8611 : }
8612 :
8613 : void
8614 50799 : gfc_check_omp_requires (gfc_namespace *ns, int ref_omp_requires)
8615 : {
8616 50799 : const char *msg = G_("Program unit at %L has OpenMP device "
8617 : "constructs/routines but does not set !$OMP REQUIRES %s "
8618 : "but other program units do");
8619 50799 : if (ns->omp_target_seen
8620 1304 : && (ns->omp_requires & OMP_REQ_TARGET_MASK)
8621 1304 : != (ref_omp_requires & OMP_REQ_TARGET_MASK))
8622 : {
8623 6 : gcc_assert (ns->proc_name);
8624 6 : if ((ref_omp_requires & OMP_REQ_REVERSE_OFFLOAD)
8625 5 : && !(ns->omp_requires & OMP_REQ_REVERSE_OFFLOAD))
8626 4 : gfc_error (msg, &ns->proc_name->declared_at, "REVERSE_OFFLOAD");
8627 6 : if ((ref_omp_requires & OMP_REQ_UNIFIED_ADDRESS)
8628 1 : && !(ns->omp_requires & OMP_REQ_UNIFIED_ADDRESS))
8629 1 : gfc_error (msg, &ns->proc_name->declared_at, "UNIFIED_ADDRESS");
8630 6 : if ((ref_omp_requires & OMP_REQ_UNIFIED_SHARED_MEMORY)
8631 4 : && !(ns->omp_requires & OMP_REQ_UNIFIED_SHARED_MEMORY))
8632 2 : gfc_error (msg, &ns->proc_name->declared_at, "UNIFIED_SHARED_MEMORY");
8633 6 : if ((ref_omp_requires & OMP_REQ_SELF_MAPS)
8634 1 : && !(ns->omp_requires & OMP_REQ_UNIFIED_SHARED_MEMORY))
8635 1 : gfc_error (msg, &ns->proc_name->declared_at, "SELF_MAPS");
8636 : }
8637 50799 : }
8638 :
8639 : bool
8640 138 : gfc_omp_requires_add_clause (gfc_omp_requires_kind clause,
8641 : const char *clause_name, locus *loc,
8642 : const char *module_name)
8643 : {
8644 138 : gfc_namespace *prog_unit = gfc_current_ns;
8645 162 : while (prog_unit->parent)
8646 : {
8647 26 : if (gfc_state_stack->previous
8648 26 : && gfc_state_stack->previous->state == COMP_INTERFACE)
8649 : break;
8650 : /* A submodule namespace may have its parent set to the ancestor module
8651 : for host-association purposes. Do not escape the submodule boundary:
8652 : the submodule itself is the program unit for OMP REQUIRES purposes. */
8653 25 : if (prog_unit->proc_name
8654 25 : && prog_unit->proc_name->attr.flavor == FL_MODULE)
8655 : break;
8656 24 : prog_unit = prog_unit->parent;
8657 : }
8658 :
8659 : /* Requires added after use. */
8660 138 : if (prog_unit->omp_target_seen
8661 24 : && (clause & OMP_REQ_TARGET_MASK)
8662 24 : && !(prog_unit->omp_requires & clause))
8663 : {
8664 0 : if (module_name)
8665 0 : gfc_error ("!$OMP REQUIRES clause %qs specified via module %qs use "
8666 : "at %L comes after using a device construct/routine",
8667 : clause_name, module_name, loc);
8668 : else
8669 0 : gfc_error ("!$OMP REQUIRES clause %qs specified at %L comes after "
8670 : "using a device construct/routine", clause_name, loc);
8671 : return false;
8672 : }
8673 :
8674 : /* Overriding atomic_default_mem_order clause value. */
8675 138 : if ((clause & OMP_REQ_ATOMIC_MEM_ORDER_MASK)
8676 34 : && (prog_unit->omp_requires & OMP_REQ_ATOMIC_MEM_ORDER_MASK)
8677 6 : && (prog_unit->omp_requires & OMP_REQ_ATOMIC_MEM_ORDER_MASK)
8678 6 : != (int) clause)
8679 : {
8680 3 : const char *other;
8681 3 : switch (prog_unit->omp_requires & OMP_REQ_ATOMIC_MEM_ORDER_MASK)
8682 : {
8683 : case OMP_REQ_ATOMIC_MEM_ORDER_SEQ_CST: other = "seq_cst"; break;
8684 0 : case OMP_REQ_ATOMIC_MEM_ORDER_ACQ_REL: other = "acq_rel"; break;
8685 1 : case OMP_REQ_ATOMIC_MEM_ORDER_ACQUIRE: other = "acquire"; break;
8686 1 : case OMP_REQ_ATOMIC_MEM_ORDER_RELAXED: other = "relaxed"; break;
8687 0 : case OMP_REQ_ATOMIC_MEM_ORDER_RELEASE: other = "release"; break;
8688 0 : default: gcc_unreachable ();
8689 : }
8690 :
8691 3 : if (module_name)
8692 0 : gfc_error ("!$OMP REQUIRES clause %<atomic_default_mem_order(%s)%> "
8693 : "specified via module %qs use at %L overrides a previous "
8694 : "%<atomic_default_mem_order(%s)%> (which might be through "
8695 : "using a module)", clause_name, module_name, loc, other);
8696 : else
8697 3 : gfc_error ("!$OMP REQUIRES clause %<atomic_default_mem_order(%s)%> "
8698 : "specified at %L overrides a previous "
8699 : "%<atomic_default_mem_order(%s)%> (which might be through "
8700 : "using a module)", clause_name, loc, other);
8701 : return false;
8702 : }
8703 :
8704 : /* Requires via module not at program-unit level and not repeating clause. */
8705 135 : if (prog_unit != gfc_current_ns && !(prog_unit->omp_requires & clause))
8706 : {
8707 0 : if (clause & OMP_REQ_ATOMIC_MEM_ORDER_MASK)
8708 0 : gfc_error ("!$OMP REQUIRES clause %<atomic_default_mem_order(%s)%> "
8709 : "specified via module %qs use at %L but same clause is "
8710 : "not specified for the program unit", clause_name,
8711 : module_name, loc);
8712 : else
8713 0 : gfc_error ("!$OMP REQUIRES clause %qs specified via module %qs use at "
8714 : "%L but same clause is not specified for the program unit",
8715 : clause_name, module_name, loc);
8716 : return false;
8717 : }
8718 :
8719 135 : if (!gfc_state_stack->previous
8720 127 : || gfc_state_stack->previous->state != COMP_INTERFACE)
8721 134 : prog_unit->omp_requires |= clause;
8722 : return true;
8723 : }
8724 :
8725 : match
8726 110 : gfc_match_omp_requires (void)
8727 : {
8728 110 : static const char *clauses[] = {"reverse_offload",
8729 : "unified_address",
8730 : "unified_shared_memory",
8731 : "self_maps",
8732 : "dynamic_allocators",
8733 : "atomic_default_mem_order"};
8734 110 : const char *clause = NULL;
8735 110 : int requires_clauses = 0;
8736 110 : int seen_clauses = 0;
8737 110 : bool first = true;
8738 110 : locus old_loc;
8739 :
8740 : /* A submodule's namespace may have its parent pointer set to the ancestor
8741 : module namespace for host-association purposes. The submodule spec part
8742 : is still a valid program-unit spec part for OMP REQUIRES. Only reject
8743 : the directive when we are genuinely nested inside a procedure. */
8744 110 : if (gfc_current_ns->parent
8745 8 : && !(gfc_current_ns->proc_name
8746 8 : && gfc_current_ns->proc_name->attr.flavor == FL_MODULE)
8747 7 : && (!gfc_state_stack->previous
8748 7 : || gfc_state_stack->previous->state != COMP_INTERFACE))
8749 : {
8750 6 : gfc_error ("!$OMP REQUIRES at %C must appear in the specification part "
8751 : "of a program unit");
8752 6 : return MATCH_ERROR;
8753 : }
8754 :
8755 : /* Specifying '<clause>(.false.)' in this directive does not affect requirements
8756 : set in another 'requires' directive in the same compilation unit; however,
8757 : specifying it multiple times in the same directive is disallowed. */
8758 336 : while (true)
8759 : {
8760 220 : bool bval;
8761 220 : match m;
8762 220 : old_loc = gfc_current_locus;
8763 220 : gfc_omp_requires_kind requires_clause = OMP_REQ_NONE;
8764 220 : if (gfc_match_char (',') != MATCH_YES
8765 220 : && (first && gfc_match_space () != MATCH_YES))
8766 17 : goto error;
8767 220 : first = false;
8768 220 : gfc_gobble_whitespace ();
8769 220 : old_loc = gfc_current_locus;
8770 :
8771 220 : if (gfc_match_omp_eos () != MATCH_NO)
8772 : break;
8773 133 : if ((m = gfc_match_boolean_clause (&bval, clauses[0],
8774 133 : seen_clauses & OMP_REQ_REVERSE_OFFLOAD)) != MATCH_NO)
8775 : {
8776 40 : if (m == MATCH_ERROR)
8777 2 : goto error;
8778 38 : clause = clauses[0];
8779 38 : seen_clauses |= OMP_REQ_REVERSE_OFFLOAD;
8780 38 : if (bval)
8781 : requires_clause = OMP_REQ_REVERSE_OFFLOAD;
8782 : }
8783 93 : else if ((m = gfc_match_boolean_clause (&bval, clauses[1],
8784 93 : seen_clauses & OMP_REQ_UNIFIED_ADDRESS)) != MATCH_NO)
8785 : {
8786 14 : if (m == MATCH_ERROR)
8787 2 : goto error;
8788 12 : clause = clauses[1];
8789 12 : seen_clauses |= OMP_REQ_UNIFIED_ADDRESS;
8790 12 : if (bval)
8791 : requires_clause = OMP_REQ_UNIFIED_ADDRESS;
8792 : }
8793 79 : else if ((m = gfc_match_boolean_clause (&bval, clauses[2],
8794 79 : seen_clauses & OMP_REQ_UNIFIED_SHARED_MEMORY))
8795 : != MATCH_NO)
8796 : {
8797 17 : if (m == MATCH_ERROR)
8798 1 : goto error;
8799 16 : clause = clauses[2];
8800 16 : seen_clauses |= OMP_REQ_UNIFIED_SHARED_MEMORY;
8801 16 : if (bval)
8802 : requires_clause = OMP_REQ_UNIFIED_SHARED_MEMORY;
8803 : }
8804 62 : else if ((m = gfc_match_boolean_clause (&bval, clauses[3],
8805 62 : seen_clauses & OMP_REQ_SELF_MAPS)) != MATCH_NO)
8806 : {
8807 19 : if (m == MATCH_ERROR)
8808 4 : goto error;
8809 15 : clause = clauses[3];
8810 15 : seen_clauses |= OMP_REQ_SELF_MAPS;
8811 15 : if (bval)
8812 : requires_clause = OMP_REQ_SELF_MAPS;
8813 : }
8814 43 : else if ((m = gfc_match_boolean_clause (&bval, clauses[4],
8815 43 : seen_clauses & OMP_REQ_DYNAMIC_ALLOCATORS)) != MATCH_NO)
8816 : {
8817 11 : if (m == MATCH_ERROR)
8818 1 : goto error;
8819 10 : clause = clauses[4];
8820 10 : seen_clauses |= OMP_REQ_DYNAMIC_ALLOCATORS;
8821 10 : if (bval)
8822 : requires_clause = OMP_REQ_DYNAMIC_ALLOCATORS;
8823 : }
8824 32 : else if ((m = gfc_match_dupl_check (
8825 32 : !(seen_clauses & OMP_REQ_ATOMIC_MEM_ORDER_MASK),
8826 : clauses[5], true)) != MATCH_NO)
8827 : {
8828 31 : if (m == MATCH_ERROR)
8829 1 : goto error;
8830 30 : seen_clauses |= OMP_REQ_ATOMIC_MEM_ORDER_MASK;
8831 30 : if (gfc_match (" seq_cst )") == MATCH_YES)
8832 : {
8833 : clause = "seq_cst";
8834 : requires_clause = OMP_REQ_ATOMIC_MEM_ORDER_SEQ_CST;
8835 : }
8836 18 : else if (gfc_match (" acq_rel )") == MATCH_YES)
8837 : {
8838 : clause = "acq_rel";
8839 : requires_clause = OMP_REQ_ATOMIC_MEM_ORDER_ACQ_REL;
8840 : }
8841 12 : else if (gfc_match (" acquire )") == MATCH_YES)
8842 : {
8843 : clause = "acquire";
8844 : requires_clause = OMP_REQ_ATOMIC_MEM_ORDER_ACQUIRE;
8845 : }
8846 9 : else if (gfc_match (" relaxed )") == MATCH_YES)
8847 : {
8848 : clause = "relaxed";
8849 : requires_clause = OMP_REQ_ATOMIC_MEM_ORDER_RELAXED;
8850 : }
8851 5 : else if (gfc_match (" release )") == MATCH_YES)
8852 : {
8853 : clause = "release";
8854 : requires_clause = OMP_REQ_ATOMIC_MEM_ORDER_RELEASE;
8855 : }
8856 : else
8857 : {
8858 2 : gfc_error ("Expected ACQ_REL, ACQUIRE, RELAXED, RELEASE or "
8859 : "SEQ_CST for ATOMIC_DEFAULT_MEM_ORDER clause at %C");
8860 2 : goto error;
8861 : }
8862 : }
8863 : else
8864 1 : goto error;
8865 :
8866 : if (requires_clause != OMP_REQ_NONE
8867 107 : && !gfc_omp_requires_add_clause (requires_clause, clause, &old_loc, NULL))
8868 3 : goto error;
8869 116 : requires_clauses |= requires_clause;
8870 116 : }
8871 :
8872 87 : if (requires_clauses == 0)
8873 2 : goto error;
8874 : return MATCH_YES;
8875 :
8876 19 : error:
8877 19 : if (!gfc_error_flag_test ())
8878 3 : gfc_error ("Expected UNIFIED_ADDRESS, UNIFIED_SHARED_MEMORY, SELF_MAPS, "
8879 : "DYNAMIC_ALLOCATORS, REVERSE_OFFLOAD, or "
8880 : "ATOMIC_DEFAULT_MEM_ORDER clause at %L", &old_loc);
8881 : return MATCH_ERROR;
8882 : }
8883 :
8884 :
8885 : match
8886 51 : gfc_match_omp_scan (void)
8887 : {
8888 51 : bool incl;
8889 51 : gfc_omp_clauses *c = gfc_get_omp_clauses ();
8890 51 : gfc_gobble_whitespace ();
8891 51 : gfc_match (", "); /* optionally */
8892 51 : if ((incl = (gfc_match ("inclusive") == MATCH_YES))
8893 51 : || gfc_match ("exclusive") == MATCH_YES)
8894 : {
8895 70 : if (gfc_match_omp_variable_list (" (", &c->lists[incl ? OMP_LIST_SCAN_IN
8896 : : OMP_LIST_SCAN_EX],
8897 : false) != MATCH_YES)
8898 : {
8899 0 : gfc_free_omp_clauses (c);
8900 0 : return MATCH_ERROR;
8901 : }
8902 : }
8903 : else
8904 : {
8905 1 : gfc_error ("Expected INCLUSIVE or EXCLUSIVE clause at %C");
8906 1 : gfc_free_omp_clauses (c);
8907 1 : return MATCH_ERROR;
8908 : }
8909 50 : if (gfc_match_omp_eos () != MATCH_YES)
8910 : {
8911 1 : gfc_error ("Unexpected junk after !$OMP SCAN at %C");
8912 1 : gfc_free_omp_clauses (c);
8913 1 : return MATCH_ERROR;
8914 : }
8915 :
8916 49 : new_st.op = EXEC_OMP_SCAN;
8917 49 : new_st.ext.omp_clauses = c;
8918 49 : return MATCH_YES;
8919 : }
8920 :
8921 :
8922 : match
8923 58 : gfc_match_omp_scope (void)
8924 : {
8925 58 : return match_omp (EXEC_OMP_SCOPE, OMP_SCOPE_CLAUSES);
8926 : }
8927 :
8928 :
8929 : match
8930 82 : gfc_match_omp_sections (void)
8931 : {
8932 82 : return match_omp (EXEC_OMP_SECTIONS, OMP_SECTIONS_CLAUSES);
8933 : }
8934 :
8935 :
8936 : match
8937 805 : gfc_match_omp_simd (void)
8938 : {
8939 805 : return match_omp (EXEC_OMP_SIMD, OMP_SIMD_CLAUSES);
8940 : }
8941 :
8942 :
8943 : match
8944 574 : gfc_match_omp_single (void)
8945 : {
8946 574 : return match_omp (EXEC_OMP_SINGLE, OMP_SINGLE_CLAUSES);
8947 : }
8948 :
8949 :
8950 : match
8951 2260 : gfc_match_omp_target (void)
8952 : {
8953 2260 : return match_omp (EXEC_OMP_TARGET, OMP_TARGET_CLAUSES);
8954 : }
8955 :
8956 :
8957 : match
8958 1401 : gfc_match_omp_target_data (void)
8959 : {
8960 1401 : return match_omp (EXEC_OMP_TARGET_DATA, OMP_TARGET_DATA_CLAUSES);
8961 : }
8962 :
8963 :
8964 : match
8965 472 : gfc_match_omp_target_enter_data (void)
8966 : {
8967 472 : return match_omp (EXEC_OMP_TARGET_ENTER_DATA, OMP_TARGET_ENTER_DATA_CLAUSES);
8968 : }
8969 :
8970 :
8971 : match
8972 367 : gfc_match_omp_target_exit_data (void)
8973 : {
8974 367 : return match_omp (EXEC_OMP_TARGET_EXIT_DATA, OMP_TARGET_EXIT_DATA_CLAUSES);
8975 : }
8976 :
8977 :
8978 : match
8979 29 : gfc_match_omp_target_parallel (void)
8980 : {
8981 29 : return match_omp (EXEC_OMP_TARGET_PARALLEL,
8982 29 : (OMP_TARGET_CLAUSES | OMP_PARALLEL_CLAUSES)
8983 29 : & ~(omp_mask (OMP_CLAUSE_COPYIN)));
8984 : }
8985 :
8986 :
8987 : match
8988 81 : gfc_match_omp_target_parallel_do (void)
8989 : {
8990 81 : return match_omp (EXEC_OMP_TARGET_PARALLEL_DO,
8991 81 : (OMP_TARGET_CLAUSES | OMP_PARALLEL_CLAUSES
8992 81 : | OMP_DO_CLAUSES) & ~(omp_mask (OMP_CLAUSE_COPYIN)));
8993 : }
8994 :
8995 :
8996 : match
8997 20 : gfc_match_omp_target_parallel_do_simd (void)
8998 : {
8999 20 : return match_omp (EXEC_OMP_TARGET_PARALLEL_DO_SIMD,
9000 20 : (OMP_TARGET_CLAUSES | OMP_PARALLEL_CLAUSES | OMP_DO_CLAUSES
9001 20 : | OMP_SIMD_CLAUSES) & ~(omp_mask (OMP_CLAUSE_COPYIN)));
9002 : }
9003 :
9004 :
9005 : match
9006 34 : gfc_match_omp_target_simd (void)
9007 : {
9008 34 : return match_omp (EXEC_OMP_TARGET_SIMD,
9009 34 : OMP_TARGET_CLAUSES | OMP_SIMD_CLAUSES);
9010 : }
9011 :
9012 :
9013 : match
9014 77 : gfc_match_omp_target_teams (void)
9015 : {
9016 77 : return match_omp (EXEC_OMP_TARGET_TEAMS,
9017 77 : OMP_TARGET_CLAUSES | OMP_TEAMS_CLAUSES);
9018 : }
9019 :
9020 :
9021 : match
9022 19 : gfc_match_omp_target_teams_distribute (void)
9023 : {
9024 19 : return match_omp (EXEC_OMP_TARGET_TEAMS_DISTRIBUTE,
9025 19 : OMP_TARGET_CLAUSES | OMP_TEAMS_CLAUSES
9026 19 : | OMP_DISTRIBUTE_CLAUSES);
9027 : }
9028 :
9029 :
9030 : match
9031 66 : gfc_match_omp_target_teams_distribute_parallel_do (void)
9032 : {
9033 66 : return match_omp (EXEC_OMP_TARGET_TEAMS_DISTRIBUTE_PARALLEL_DO,
9034 66 : (OMP_TARGET_CLAUSES | OMP_TEAMS_CLAUSES
9035 66 : | OMP_DISTRIBUTE_CLAUSES | OMP_PARALLEL_CLAUSES
9036 66 : | OMP_DO_CLAUSES)
9037 66 : & ~(omp_mask (OMP_CLAUSE_ORDERED))
9038 66 : & ~(omp_mask (OMP_CLAUSE_LINEAR)));
9039 : }
9040 :
9041 :
9042 : match
9043 36 : gfc_match_omp_target_teams_distribute_parallel_do_simd (void)
9044 : {
9045 36 : return match_omp (EXEC_OMP_TARGET_TEAMS_DISTRIBUTE_PARALLEL_DO_SIMD,
9046 36 : (OMP_TARGET_CLAUSES | OMP_TEAMS_CLAUSES
9047 36 : | OMP_DISTRIBUTE_CLAUSES | OMP_PARALLEL_CLAUSES
9048 36 : | OMP_DO_CLAUSES | OMP_SIMD_CLAUSES)
9049 36 : & ~(omp_mask (OMP_CLAUSE_ORDERED)));
9050 : }
9051 :
9052 :
9053 : match
9054 21 : gfc_match_omp_target_teams_distribute_simd (void)
9055 : {
9056 21 : return match_omp (EXEC_OMP_TARGET_TEAMS_DISTRIBUTE_SIMD,
9057 21 : OMP_TARGET_CLAUSES | OMP_TEAMS_CLAUSES
9058 21 : | OMP_DISTRIBUTE_CLAUSES | OMP_SIMD_CLAUSES);
9059 : }
9060 :
9061 :
9062 : match
9063 1727 : gfc_match_omp_target_update (void)
9064 : {
9065 1727 : return match_omp (EXEC_OMP_TARGET_UPDATE, OMP_TARGET_UPDATE_CLAUSES);
9066 : }
9067 :
9068 :
9069 : match
9070 1184 : gfc_match_omp_task (void)
9071 : {
9072 1184 : return match_omp (EXEC_OMP_TASK, OMP_TASK_CLAUSES);
9073 : }
9074 :
9075 :
9076 : match
9077 72 : gfc_match_omp_taskloop (void)
9078 : {
9079 72 : return match_omp (EXEC_OMP_TASKLOOP, OMP_TASKLOOP_CLAUSES);
9080 : }
9081 :
9082 :
9083 : match
9084 40 : gfc_match_omp_taskloop_simd (void)
9085 : {
9086 40 : return match_omp (EXEC_OMP_TASKLOOP_SIMD,
9087 40 : OMP_TASKLOOP_CLAUSES | OMP_SIMD_CLAUSES);
9088 : }
9089 :
9090 :
9091 : match
9092 149 : gfc_match_omp_taskwait (void)
9093 : {
9094 149 : if (gfc_match_omp_eos () == MATCH_YES)
9095 : {
9096 135 : new_st.op = EXEC_OMP_TASKWAIT;
9097 135 : new_st.ext.omp_clauses = NULL;
9098 135 : return MATCH_YES;
9099 : }
9100 14 : return match_omp (EXEC_OMP_TASKWAIT,
9101 14 : omp_mask (OMP_CLAUSE_DEPEND) | OMP_CLAUSE_NOWAIT);
9102 : }
9103 :
9104 :
9105 : match
9106 10 : gfc_match_omp_taskyield (void)
9107 : {
9108 10 : if (gfc_match_omp_eos () != MATCH_YES)
9109 : {
9110 0 : gfc_error ("Unexpected junk after TASKYIELD clause at %C");
9111 0 : return MATCH_ERROR;
9112 : }
9113 10 : new_st.op = EXEC_OMP_TASKYIELD;
9114 10 : new_st.ext.omp_clauses = NULL;
9115 10 : return MATCH_YES;
9116 : }
9117 :
9118 :
9119 : match
9120 223 : gfc_match_omp_teams (void)
9121 : {
9122 223 : return match_omp (EXEC_OMP_TEAMS, OMP_TEAMS_CLAUSES);
9123 : }
9124 :
9125 :
9126 : match
9127 22 : gfc_match_omp_teams_distribute (void)
9128 : {
9129 22 : return match_omp (EXEC_OMP_TEAMS_DISTRIBUTE,
9130 22 : OMP_TEAMS_CLAUSES | OMP_DISTRIBUTE_CLAUSES);
9131 : }
9132 :
9133 :
9134 : match
9135 41 : gfc_match_omp_teams_distribute_parallel_do (void)
9136 : {
9137 41 : return match_omp (EXEC_OMP_TEAMS_DISTRIBUTE_PARALLEL_DO,
9138 41 : (OMP_TEAMS_CLAUSES | OMP_DISTRIBUTE_CLAUSES
9139 41 : | OMP_PARALLEL_CLAUSES | OMP_DO_CLAUSES)
9140 41 : & ~(omp_mask (OMP_CLAUSE_ORDERED)
9141 41 : | OMP_CLAUSE_LINEAR | OMP_CLAUSE_NOWAIT));
9142 : }
9143 :
9144 :
9145 : match
9146 63 : gfc_match_omp_teams_distribute_parallel_do_simd (void)
9147 : {
9148 63 : return match_omp (EXEC_OMP_TEAMS_DISTRIBUTE_PARALLEL_DO_SIMD,
9149 63 : (OMP_TEAMS_CLAUSES | OMP_DISTRIBUTE_CLAUSES
9150 63 : | OMP_PARALLEL_CLAUSES | OMP_DO_CLAUSES
9151 63 : | OMP_SIMD_CLAUSES)
9152 63 : & ~(omp_mask (OMP_CLAUSE_ORDERED) | OMP_CLAUSE_NOWAIT));
9153 : }
9154 :
9155 :
9156 : match
9157 44 : gfc_match_omp_teams_distribute_simd (void)
9158 : {
9159 44 : return match_omp (EXEC_OMP_TEAMS_DISTRIBUTE_SIMD,
9160 44 : OMP_TEAMS_CLAUSES | OMP_DISTRIBUTE_CLAUSES
9161 44 : | OMP_SIMD_CLAUSES);
9162 : }
9163 :
9164 : match
9165 203 : gfc_match_omp_tile (void)
9166 : {
9167 203 : return match_omp (EXEC_OMP_TILE, OMP_TILE_CLAUSES);
9168 : }
9169 :
9170 : match
9171 424 : gfc_match_omp_unroll (void)
9172 : {
9173 424 : return match_omp (EXEC_OMP_UNROLL, OMP_UNROLL_CLAUSES);
9174 : }
9175 :
9176 : match
9177 39 : gfc_match_omp_workshare (void)
9178 : {
9179 39 : return match_omp (EXEC_OMP_WORKSHARE, OMP_WORKSHARE_CLAUSES);
9180 : }
9181 :
9182 :
9183 : match
9184 55 : gfc_match_omp_masked (void)
9185 : {
9186 55 : return match_omp (EXEC_OMP_MASKED, OMP_MASKED_CLAUSES);
9187 : }
9188 :
9189 : match
9190 10 : gfc_match_omp_masked_taskloop (void)
9191 : {
9192 10 : return match_omp (EXEC_OMP_MASKED_TASKLOOP,
9193 10 : OMP_MASKED_CLAUSES | OMP_TASKLOOP_CLAUSES);
9194 : }
9195 :
9196 : match
9197 16 : gfc_match_omp_masked_taskloop_simd (void)
9198 : {
9199 16 : return match_omp (EXEC_OMP_MASKED_TASKLOOP_SIMD,
9200 16 : (OMP_MASKED_CLAUSES | OMP_TASKLOOP_CLAUSES
9201 16 : | OMP_SIMD_CLAUSES));
9202 : }
9203 :
9204 : match
9205 111 : gfc_match_omp_master (void)
9206 : {
9207 111 : gfc_warning (OPT_Wdeprecated_openmp,
9208 : "%<master%> construct at %C deprecated since OpenMP 5.1, "
9209 : "use %<masked%>");
9210 111 : if (gfc_match_omp_eos () != MATCH_YES)
9211 : {
9212 1 : gfc_error ("Unexpected junk after $OMP MASTER statement at %C");
9213 1 : return MATCH_ERROR;
9214 : }
9215 110 : new_st.op = EXEC_OMP_MASTER;
9216 110 : new_st.ext.omp_clauses = NULL;
9217 110 : return MATCH_YES;
9218 : }
9219 :
9220 : match
9221 16 : gfc_match_omp_master_taskloop (void)
9222 : {
9223 16 : gfc_warning (OPT_Wdeprecated_openmp,
9224 : "%<master%> construct at %C deprecated since OpenMP 5.1, "
9225 : "use %<masked%>");
9226 16 : return match_omp (EXEC_OMP_MASTER_TASKLOOP, OMP_TASKLOOP_CLAUSES);
9227 : }
9228 :
9229 : match
9230 21 : gfc_match_omp_master_taskloop_simd (void)
9231 : {
9232 21 : gfc_warning (OPT_Wdeprecated_openmp,
9233 : "%<master%> construct at %C deprecated since OpenMP 5.1, use "
9234 : "%<masked%>");
9235 21 : return match_omp (EXEC_OMP_MASTER_TASKLOOP_SIMD,
9236 21 : OMP_TASKLOOP_CLAUSES | OMP_SIMD_CLAUSES);
9237 : }
9238 :
9239 : match
9240 239 : gfc_match_omp_ordered (void)
9241 : {
9242 239 : return match_omp (EXEC_OMP_ORDERED, OMP_ORDERED_CLAUSES);
9243 : }
9244 :
9245 : match
9246 24 : gfc_match_omp_nothing (void)
9247 : {
9248 24 : if (gfc_match_omp_eos () != MATCH_YES)
9249 : {
9250 1 : gfc_error ("Unexpected junk after $OMP NOTHING statement at %C");
9251 1 : return MATCH_ERROR;
9252 : }
9253 : /* Will use ST_NONE; therefore, no EXEC_OMP_ is needed. */
9254 : return MATCH_YES;
9255 : }
9256 :
9257 : match
9258 317 : gfc_match_omp_ordered_depend (void)
9259 : {
9260 317 : return match_omp (EXEC_OMP_ORDERED, omp_mask (OMP_CLAUSE_DOACROSS));
9261 : }
9262 :
9263 :
9264 : /* omp atomic [clause-list]
9265 : - atomic-clause: read | write | update
9266 : - capture
9267 : - memory-order-clause: seq_cst | acq_rel | release | acquire | relaxed
9268 : - hint(hint-expr)
9269 : - OpenMP 5.1: compare | fail (seq_cst | acquire | relaxed ) | weak
9270 : */
9271 :
9272 : match
9273 2188 : gfc_match_omp_atomic (void)
9274 : {
9275 2188 : gfc_omp_clauses *c;
9276 2188 : locus loc = gfc_current_locus;
9277 :
9278 2188 : if (gfc_match_omp_clauses (&c, OMP_ATOMIC_CLAUSES, false, true) != MATCH_YES)
9279 : return MATCH_ERROR;
9280 :
9281 2166 : if (c->atomic_op == GFC_OMP_ATOMIC_UNSET)
9282 1013 : c->atomic_op = GFC_OMP_ATOMIC_UPDATE;
9283 :
9284 2166 : if (c->capture && c->atomic_op != GFC_OMP_ATOMIC_UPDATE)
9285 3 : gfc_error ("!$OMP ATOMIC at %L with %s clause is incompatible with "
9286 : "READ or WRITE", &loc, "CAPTURE");
9287 2166 : if (c->compare && c->atomic_op != GFC_OMP_ATOMIC_UPDATE)
9288 3 : gfc_error ("!$OMP ATOMIC at %L with %s clause is incompatible with "
9289 : "READ or WRITE", &loc, "COMPARE");
9290 2166 : if (c->fail != OMP_MEMORDER_UNSET && c->atomic_op != GFC_OMP_ATOMIC_UPDATE)
9291 2 : gfc_error ("!$OMP ATOMIC at %L with %s clause is incompatible with "
9292 : "READ or WRITE", &loc, "FAIL");
9293 2166 : if (c->weak && !c->compare)
9294 : {
9295 5 : gfc_error ("!$OMP ATOMIC at %L with %s clause requires %s clause", &loc,
9296 : "WEAK", "COMPARE");
9297 5 : c->weak = false;
9298 : }
9299 :
9300 2166 : if (c->memorder == OMP_MEMORDER_UNSET)
9301 : {
9302 1975 : gfc_namespace *prog_unit = gfc_current_ns;
9303 1975 : while (prog_unit->parent
9304 2537 : && !(prog_unit->proc_name
9305 562 : && prog_unit->proc_name->attr.flavor == FL_MODULE))
9306 562 : prog_unit = prog_unit->parent;
9307 1975 : switch (prog_unit->omp_requires & OMP_REQ_ATOMIC_MEM_ORDER_MASK)
9308 : {
9309 1942 : case 0:
9310 1942 : case OMP_REQ_ATOMIC_MEM_ORDER_RELAXED:
9311 1942 : c->memorder = OMP_MEMORDER_RELAXED;
9312 1942 : break;
9313 7 : case OMP_REQ_ATOMIC_MEM_ORDER_SEQ_CST:
9314 7 : c->memorder = OMP_MEMORDER_SEQ_CST;
9315 7 : break;
9316 16 : case OMP_REQ_ATOMIC_MEM_ORDER_ACQ_REL:
9317 16 : if (c->capture)
9318 5 : c->memorder = OMP_MEMORDER_ACQ_REL;
9319 11 : else if (c->atomic_op == GFC_OMP_ATOMIC_READ)
9320 3 : c->memorder = OMP_MEMORDER_ACQUIRE;
9321 : else
9322 8 : c->memorder = OMP_MEMORDER_RELEASE;
9323 : break;
9324 5 : case OMP_REQ_ATOMIC_MEM_ORDER_ACQUIRE:
9325 5 : if (c->atomic_op == GFC_OMP_ATOMIC_WRITE)
9326 : {
9327 1 : gfc_error ("!$OMP ATOMIC WRITE at %L incompatible with "
9328 : "ACQUIRES clause implicitly provided by a "
9329 : "REQUIRES directive", &loc);
9330 1 : c->memorder = OMP_MEMORDER_SEQ_CST;
9331 : }
9332 : else
9333 4 : c->memorder = OMP_MEMORDER_ACQUIRE;
9334 : break;
9335 5 : case OMP_REQ_ATOMIC_MEM_ORDER_RELEASE:
9336 5 : if (c->atomic_op == GFC_OMP_ATOMIC_READ)
9337 : {
9338 1 : gfc_error ("!$OMP ATOMIC READ at %L incompatible with "
9339 : "RELEASE clause implicitly provided by a "
9340 : "REQUIRES directive", &loc);
9341 1 : c->memorder = OMP_MEMORDER_SEQ_CST;
9342 : }
9343 : else
9344 4 : c->memorder = OMP_MEMORDER_RELEASE;
9345 : break;
9346 0 : default:
9347 0 : gcc_unreachable ();
9348 : }
9349 : }
9350 : else
9351 191 : switch (c->atomic_op)
9352 : {
9353 31 : case GFC_OMP_ATOMIC_READ:
9354 31 : if (c->memorder == OMP_MEMORDER_RELEASE)
9355 : {
9356 1 : gfc_error ("!$OMP ATOMIC READ at %L incompatible with "
9357 : "RELEASE clause", &loc);
9358 1 : c->memorder = OMP_MEMORDER_SEQ_CST;
9359 : }
9360 30 : else if (c->memorder == OMP_MEMORDER_ACQ_REL)
9361 1 : c->memorder = OMP_MEMORDER_ACQUIRE;
9362 : break;
9363 37 : case GFC_OMP_ATOMIC_WRITE:
9364 37 : if (c->memorder == OMP_MEMORDER_ACQUIRE)
9365 : {
9366 1 : gfc_error ("!$OMP ATOMIC WRITE at %L incompatible with "
9367 : "ACQUIRE clause", &loc);
9368 1 : c->memorder = OMP_MEMORDER_SEQ_CST;
9369 : }
9370 36 : else if (c->memorder == OMP_MEMORDER_ACQ_REL)
9371 3 : c->memorder = OMP_MEMORDER_RELEASE;
9372 : break;
9373 : default:
9374 : break;
9375 : }
9376 2166 : gfc_error_check ();
9377 2166 : new_st.ext.omp_clauses = c;
9378 2166 : new_st.op = EXEC_OMP_ATOMIC;
9379 2166 : return MATCH_YES;
9380 : }
9381 :
9382 :
9383 : /* acc atomic [ read | write | update | capture] */
9384 :
9385 : match
9386 552 : gfc_match_oacc_atomic (void)
9387 : {
9388 552 : gfc_omp_clauses *c = gfc_get_omp_clauses ();
9389 552 : c->atomic_op = GFC_OMP_ATOMIC_UPDATE;
9390 552 : c->memorder = OMP_MEMORDER_RELAXED;
9391 552 : gfc_gobble_whitespace ();
9392 552 : if (gfc_match ("update") == MATCH_YES)
9393 : ;
9394 373 : else if (gfc_match ("read") == MATCH_YES)
9395 17 : c->atomic_op = GFC_OMP_ATOMIC_READ;
9396 356 : else if (gfc_match ("write") == MATCH_YES)
9397 13 : c->atomic_op = GFC_OMP_ATOMIC_WRITE;
9398 343 : else if (gfc_match ("capture") == MATCH_YES)
9399 319 : c->capture = true;
9400 552 : gfc_gobble_whitespace ();
9401 552 : if (gfc_match_omp_eos () != MATCH_YES)
9402 : {
9403 9 : gfc_error ("Unexpected junk after !$ACC ATOMIC statement at %C");
9404 9 : gfc_free_omp_clauses (c);
9405 9 : return MATCH_ERROR;
9406 : }
9407 543 : new_st.ext.omp_clauses = c;
9408 543 : new_st.op = EXEC_OACC_ATOMIC;
9409 543 : return MATCH_YES;
9410 : }
9411 :
9412 :
9413 : match
9414 614 : gfc_match_omp_barrier (void)
9415 : {
9416 614 : if (gfc_match_omp_eos () != MATCH_YES)
9417 : {
9418 0 : gfc_error ("Unexpected junk after $OMP BARRIER statement at %C");
9419 0 : return MATCH_ERROR;
9420 : }
9421 614 : new_st.op = EXEC_OMP_BARRIER;
9422 614 : new_st.ext.omp_clauses = NULL;
9423 614 : return MATCH_YES;
9424 : }
9425 :
9426 :
9427 : match
9428 188 : gfc_match_omp_taskgroup (void)
9429 : {
9430 188 : return match_omp (EXEC_OMP_TASKGROUP, OMP_TASKGROUP_CLAUSES);
9431 : }
9432 :
9433 :
9434 : static enum gfc_omp_cancel_kind
9435 502 : gfc_match_omp_cancel_kind (void)
9436 : {
9437 502 : if (gfc_match (" , ") != MATCH_YES
9438 502 : && gfc_match_space () != MATCH_YES)
9439 : return OMP_CANCEL_UNKNOWN;
9440 502 : if (gfc_match ("parallel") == MATCH_YES)
9441 : return OMP_CANCEL_PARALLEL;
9442 352 : if (gfc_match ("sections") == MATCH_YES)
9443 : return OMP_CANCEL_SECTIONS;
9444 253 : if (gfc_match ("do") == MATCH_YES)
9445 : return OMP_CANCEL_DO;
9446 123 : if (gfc_match ("taskgroup") == MATCH_YES)
9447 121 : return OMP_CANCEL_TASKGROUP;
9448 : return OMP_CANCEL_UNKNOWN;
9449 : }
9450 :
9451 :
9452 : match
9453 324 : gfc_match_omp_cancel (void)
9454 : {
9455 324 : gfc_omp_clauses *c;
9456 324 : enum gfc_omp_cancel_kind kind = gfc_match_omp_cancel_kind ();
9457 324 : if (kind == OMP_CANCEL_UNKNOWN)
9458 : return MATCH_ERROR;
9459 324 : if (gfc_match_omp_clauses (&c, omp_mask (OMP_CLAUSE_IF), false) != MATCH_YES)
9460 : return MATCH_ERROR;
9461 321 : c->cancel = kind;
9462 321 : new_st.op = EXEC_OMP_CANCEL;
9463 321 : new_st.ext.omp_clauses = c;
9464 321 : return MATCH_YES;
9465 : }
9466 :
9467 :
9468 : match
9469 178 : gfc_match_omp_cancellation_point (void)
9470 : {
9471 178 : gfc_omp_clauses *c;
9472 178 : enum gfc_omp_cancel_kind kind = gfc_match_omp_cancel_kind ();
9473 178 : if (kind == OMP_CANCEL_UNKNOWN)
9474 : {
9475 2 : gfc_error ("Expected construct-type PARALLEL, SECTIONS, DO or TASKGROUP "
9476 : "in $OMP CANCELLATION POINT statement at %C");
9477 2 : return MATCH_ERROR;
9478 : }
9479 176 : if (gfc_match_omp_eos () != MATCH_YES)
9480 : {
9481 0 : gfc_error ("Unexpected junk after $OMP CANCELLATION POINT statement "
9482 : "at %C");
9483 0 : return MATCH_ERROR;
9484 : }
9485 176 : c = gfc_get_omp_clauses ();
9486 176 : c->cancel = kind;
9487 176 : new_st.op = EXEC_OMP_CANCELLATION_POINT;
9488 176 : new_st.ext.omp_clauses = c;
9489 176 : return MATCH_YES;
9490 : }
9491 :
9492 :
9493 : match
9494 2743 : gfc_match_omp_end_nowait (void)
9495 : {
9496 2743 : bool nowait = false;
9497 2743 : if (gfc_match ("% nowait ") == MATCH_YES
9498 2743 : || gfc_match (" , nowait ") == MATCH_YES)
9499 : nowait = true;
9500 2743 : if (gfc_match_omp_eos () != MATCH_YES)
9501 : {
9502 4 : if (nowait)
9503 3 : gfc_error ("Unexpected junk after NOWAIT clause at %C");
9504 : else
9505 1 : gfc_error ("Unexpected junk at %C");
9506 : return MATCH_ERROR;
9507 : }
9508 2739 : new_st.op = EXEC_OMP_END_NOWAIT;
9509 2739 : new_st.ext.omp_bool = nowait;
9510 2739 : return MATCH_YES;
9511 : }
9512 :
9513 :
9514 : match
9515 570 : gfc_match_omp_end_single (void)
9516 : {
9517 570 : gfc_omp_clauses *c;
9518 570 : if (gfc_match_omp_clauses (&c, omp_mask (OMP_CLAUSE_COPYPRIVATE)
9519 : | OMP_CLAUSE_NOWAIT, false)
9520 : != MATCH_YES)
9521 : return MATCH_ERROR;
9522 570 : new_st.op = EXEC_OMP_END_SINGLE;
9523 570 : new_st.ext.omp_clauses = c;
9524 570 : return MATCH_YES;
9525 : }
9526 :
9527 :
9528 : static bool
9529 37154 : oacc_is_loop (gfc_code *code)
9530 : {
9531 37154 : return code->op == EXEC_OACC_PARALLEL_LOOP
9532 : || code->op == EXEC_OACC_KERNELS_LOOP
9533 20099 : || code->op == EXEC_OACC_SERIAL_LOOP
9534 13457 : || code->op == EXEC_OACC_LOOP;
9535 : }
9536 :
9537 : static bool
9538 5974 : resolve_scalar_int_expr (gfc_expr *expr, const char *clause)
9539 : {
9540 5974 : if (!gfc_resolve_expr (expr)
9541 5974 : || expr->ts.type != BT_INTEGER
9542 11879 : || expr->rank != 0)
9543 : {
9544 87 : gfc_error ("%s clause at %L requires a scalar INTEGER expression",
9545 : clause, &expr->where);
9546 87 : return false;
9547 : }
9548 : return true;
9549 : }
9550 :
9551 : /* Require that EXPR is a scalar constant integer expression; it shall be a
9552 : positive number: If WARN is true, a warning is printed if constant and
9553 : not positive. If WARN is false, an error is printed if it is either not
9554 : constant or not positive. CLAUSE is used in the diagnostic output. */
9555 :
9556 : static void
9557 4495 : resolve_positive_int_expr (gfc_expr *expr, const char *clause, bool warn)
9558 : {
9559 4495 : if (!resolve_scalar_int_expr (expr, clause))
9560 : return;
9561 4460 : if (warn
9562 3664 : && expr->expr_type == EXPR_CONSTANT
9563 3265 : && mpz_sgn (expr->value.integer) <= 0)
9564 30 : gfc_warning ((flag_openmp || flag_openmp_simd) ? OPT_Wopenmp : 0,
9565 : "INTEGER expression of %s clause at %L must be positive",
9566 : clause, &expr->where);
9567 : else if (!warn
9568 796 : && (expr->expr_type != EXPR_CONSTANT
9569 781 : || mpz_sgn (expr->value.integer) <= 0))
9570 36 : gfc_error ("INTEGER expression of %s clause at %L must be positive and "
9571 : "constant", clause, &expr->where);
9572 : }
9573 :
9574 : /* Require that EXPR is a scalar constant integer expression; it shall be a
9575 : nonnegative number: If WARN is true, a warning is printed if constant and
9576 : negative. If WARN is false, an error is printed if it is either not constant
9577 : or negative. CLAUSE is used in the diagnostic output. */
9578 :
9579 : static void
9580 91 : resolve_nonnegative_int_expr (gfc_expr *expr, const char *clause, bool warn)
9581 : {
9582 91 : if (!resolve_scalar_int_expr (expr, clause))
9583 : return;
9584 84 : if (warn
9585 84 : && expr->expr_type == EXPR_CONSTANT
9586 32 : && mpz_sgn (expr->value.integer) < 0)
9587 8 : gfc_warning ((flag_openmp || flag_openmp_simd) ? OPT_Wopenmp : 0,
9588 : "INTEGER expression of %s clause at %L must be non-negative",
9589 : clause, &expr->where);
9590 : else if (!warn
9591 0 : && (expr->expr_type != EXPR_CONSTANT
9592 0 : || mpz_sgn (expr->value.integer) < 0))
9593 0 : gfc_error ("INTEGER expression of %s clause at %L must be non-negtive and "
9594 : "constant", clause, &expr->where);
9595 : }
9596 :
9597 : /* Emits error when symbol is pointer, cray pointer or cray pointee
9598 : of derived of polymorphic type. */
9599 :
9600 : static void
9601 98 : check_symbol_not_pointer (gfc_symbol *sym, locus loc, const char *name)
9602 : {
9603 98 : if (sym->ts.type == BT_DERIVED && sym->attr.cray_pointer)
9604 0 : gfc_error ("Cray pointer object %qs of derived type in %s clause at %L",
9605 : sym->name, name, &loc);
9606 98 : if (sym->ts.type == BT_DERIVED && sym->attr.cray_pointee)
9607 0 : gfc_error ("Cray pointee object %qs of derived type in %s clause at %L",
9608 : sym->name, name, &loc);
9609 :
9610 98 : if ((sym->ts.type == BT_ASSUMED && sym->attr.pointer)
9611 98 : || (sym->ts.type == BT_CLASS && CLASS_DATA (sym)
9612 0 : && CLASS_DATA (sym)->attr.pointer))
9613 0 : gfc_error ("POINTER object %qs of polymorphic type in %s clause at %L",
9614 : sym->name, name, &loc);
9615 98 : if ((sym->ts.type == BT_ASSUMED && sym->attr.cray_pointer)
9616 98 : || (sym->ts.type == BT_CLASS && CLASS_DATA (sym)
9617 0 : && CLASS_DATA (sym)->attr.cray_pointer))
9618 0 : gfc_error ("Cray pointer object %qs of polymorphic type in %s clause at %L",
9619 : sym->name, name, &loc);
9620 98 : if ((sym->ts.type == BT_ASSUMED && sym->attr.cray_pointee)
9621 98 : || (sym->ts.type == BT_CLASS && CLASS_DATA (sym)
9622 0 : && CLASS_DATA (sym)->attr.cray_pointee))
9623 0 : gfc_error ("Cray pointee object %qs of polymorphic type in %s clause at %L",
9624 : sym->name, name, &loc);
9625 98 : }
9626 :
9627 : /* Emits error when symbol represents assumed size/rank array. */
9628 :
9629 : static void
9630 14844 : check_array_not_assumed (gfc_symbol *sym, locus loc, const char *name)
9631 : {
9632 14844 : if (sym->as && sym->as->type == AS_ASSUMED_SIZE)
9633 13 : gfc_error ("Assumed size array %qs in %s clause at %L",
9634 : sym->name, name, &loc);
9635 14844 : if (sym->as && sym->as->type == AS_ASSUMED_RANK)
9636 11 : gfc_error ("Assumed rank array %qs in %s clause at %L",
9637 : sym->name, name, &loc);
9638 14844 : }
9639 :
9640 : static void
9641 5850 : resolve_oacc_data_clauses (gfc_symbol *sym, locus loc, const char *name)
9642 : {
9643 0 : check_array_not_assumed (sym, loc, name);
9644 0 : }
9645 :
9646 : static void
9647 65 : resolve_oacc_deviceptr_clause (gfc_symbol *sym, locus loc, const char *name)
9648 : {
9649 65 : if (sym->attr.pointer
9650 64 : || (sym->ts.type == BT_CLASS && CLASS_DATA (sym)
9651 0 : && CLASS_DATA (sym)->attr.class_pointer))
9652 1 : gfc_error ("POINTER object %qs in %s clause at %L",
9653 : sym->name, name, &loc);
9654 65 : if (sym->attr.cray_pointer
9655 63 : || (sym->ts.type == BT_CLASS && CLASS_DATA (sym)
9656 0 : && CLASS_DATA (sym)->attr.cray_pointer))
9657 2 : gfc_error ("Cray pointer object %qs in %s clause at %L",
9658 : sym->name, name, &loc);
9659 65 : if (sym->attr.cray_pointee
9660 63 : || (sym->ts.type == BT_CLASS && CLASS_DATA (sym)
9661 0 : && CLASS_DATA (sym)->attr.cray_pointee))
9662 2 : gfc_error ("Cray pointee object %qs in %s clause at %L",
9663 : sym->name, name, &loc);
9664 65 : if (sym->attr.allocatable
9665 64 : || (sym->ts.type == BT_CLASS && CLASS_DATA (sym)
9666 0 : && CLASS_DATA (sym)->attr.allocatable))
9667 1 : gfc_error ("ALLOCATABLE object %qs in %s clause at %L",
9668 : sym->name, name, &loc);
9669 65 : if (sym->attr.value)
9670 1 : gfc_error ("VALUE object %qs in %s clause at %L",
9671 : sym->name, name, &loc);
9672 65 : check_array_not_assumed (sym, loc, name);
9673 65 : }
9674 :
9675 :
9676 : struct resolve_omp_udr_callback_data
9677 : {
9678 : gfc_symbol *sym1, *sym2;
9679 : };
9680 :
9681 :
9682 : static int
9683 1413 : resolve_omp_udr_callback (gfc_expr **e, int *, void *data)
9684 : {
9685 1413 : struct resolve_omp_udr_callback_data *rcd
9686 : = (struct resolve_omp_udr_callback_data *) data;
9687 1413 : if ((*e)->expr_type == EXPR_VARIABLE
9688 801 : && ((*e)->symtree->n.sym == rcd->sym1
9689 255 : || (*e)->symtree->n.sym == rcd->sym2))
9690 : {
9691 801 : gfc_ref *ref = gfc_get_ref ();
9692 801 : ref->type = REF_ARRAY;
9693 801 : ref->u.ar.where = (*e)->where;
9694 801 : ref->u.ar.as = (*e)->symtree->n.sym->as;
9695 801 : ref->u.ar.type = AR_FULL;
9696 801 : ref->u.ar.dimen = 0;
9697 801 : ref->next = (*e)->ref;
9698 801 : (*e)->ref = ref;
9699 : }
9700 1413 : return 0;
9701 : }
9702 :
9703 :
9704 : static int
9705 3008 : resolve_omp_udr_callback2 (gfc_expr **e, int *, void *)
9706 : {
9707 3008 : if ((*e)->expr_type == EXPR_FUNCTION
9708 360 : && (*e)->value.function.isym == NULL)
9709 : {
9710 174 : gfc_symbol *sym = (*e)->symtree->n.sym;
9711 174 : if (!sym->attr.intrinsic
9712 174 : && sym->attr.if_source == IFSRC_UNKNOWN)
9713 4 : gfc_error ("Implicitly declared function %s used in "
9714 : "!$OMP DECLARE REDUCTION at %L", sym->name, &(*e)->where);
9715 : }
9716 3008 : return 0;
9717 : }
9718 :
9719 :
9720 : static gfc_code *
9721 802 : resolve_omp_udr_clause (gfc_omp_namelist *n, gfc_namespace *ns,
9722 : gfc_symbol *sym1, gfc_symbol *sym2)
9723 : {
9724 802 : gfc_code *copy;
9725 802 : gfc_symbol sym1_copy, sym2_copy;
9726 :
9727 802 : if (ns->code->op == EXEC_ASSIGN)
9728 : {
9729 630 : copy = gfc_get_code (EXEC_ASSIGN);
9730 630 : copy->expr1 = gfc_copy_expr (ns->code->expr1);
9731 630 : copy->expr2 = gfc_copy_expr (ns->code->expr2);
9732 : }
9733 : else
9734 : {
9735 172 : copy = gfc_get_code (EXEC_CALL);
9736 172 : copy->symtree = ns->code->symtree;
9737 172 : copy->ext.actual = gfc_copy_actual_arglist (ns->code->ext.actual);
9738 : }
9739 802 : copy->loc = ns->code->loc;
9740 802 : sym1_copy = *sym1;
9741 802 : sym2_copy = *sym2;
9742 802 : *sym1 = *n->sym;
9743 802 : *sym2 = *n->sym;
9744 802 : sym1->name = sym1_copy.name;
9745 802 : sym2->name = sym2_copy.name;
9746 802 : ns->proc_name = ns->parent->proc_name;
9747 802 : if (n->sym->attr.dimension)
9748 : {
9749 348 : struct resolve_omp_udr_callback_data rcd;
9750 348 : rcd.sym1 = sym1;
9751 348 : rcd.sym2 = sym2;
9752 348 : gfc_code_walker (©, gfc_dummy_code_callback,
9753 : resolve_omp_udr_callback, &rcd);
9754 : }
9755 802 : gfc_resolve_code (copy, gfc_current_ns);
9756 802 : if (copy->op == EXEC_CALL && copy->resolved_isym == NULL)
9757 : {
9758 172 : gfc_symbol *sym = copy->resolved_sym;
9759 172 : if (sym
9760 170 : && !sym->attr.intrinsic
9761 170 : && sym->attr.if_source == IFSRC_UNKNOWN)
9762 4 : gfc_error ("Implicitly declared subroutine %s used in "
9763 : "!$OMP DECLARE REDUCTION at %L", sym->name,
9764 : ©->loc);
9765 : }
9766 802 : gfc_code_walker (©, gfc_dummy_code_callback,
9767 : resolve_omp_udr_callback2, NULL);
9768 802 : *sym1 = sym1_copy;
9769 802 : *sym2 = sym2_copy;
9770 802 : return copy;
9771 : }
9772 :
9773 : /* Assume that a constant expression in the range 1 (omp_default_mem_alloc)
9774 : to GOMP_OMP_PREDEF_ALLOC_MAX, or GOMP_OMPX_PREDEF_ALLOC_MIN to
9775 : GOMP_OMPX_PREDEF_ALLOC_MAX is fine. The original symbol name is already
9776 : lost during matching via gfc_match_expr. */
9777 : static bool
9778 130 : is_predefined_allocator (gfc_expr *expr)
9779 : {
9780 130 : return (gfc_resolve_expr (expr)
9781 129 : && expr->rank == 0
9782 124 : && expr->ts.type == BT_INTEGER
9783 119 : && expr->ts.kind == gfc_c_intptr_kind
9784 114 : && expr->expr_type == EXPR_CONSTANT
9785 239 : && ((mpz_sgn (expr->value.integer) > 0
9786 107 : && mpz_cmp_si (expr->value.integer,
9787 : GOMP_OMP_PREDEF_ALLOC_MAX) <= 0)
9788 4 : || (mpz_cmp_si (expr->value.integer,
9789 : GOMP_OMPX_PREDEF_ALLOC_MIN) >= 0
9790 1 : && mpz_cmp_si (expr->value.integer,
9791 130 : GOMP_OMPX_PREDEF_ALLOC_MAX) <= 0)));
9792 : }
9793 :
9794 : /* Resolve declarative ALLOCATE statement. Note: Common block vars only appear
9795 : as /block/ not individual, which is ensured during parsing. */
9796 :
9797 : void
9798 62 : gfc_resolve_omp_allocate (gfc_namespace *ns, gfc_omp_namelist *list)
9799 : {
9800 278 : for (gfc_omp_namelist *n = list; n; n = n->next)
9801 : {
9802 216 : if (n->sym->attr.result || n->sym->result == n->sym)
9803 : {
9804 1 : gfc_error ("Unexpected function-result variable %qs at %L in "
9805 : "declarative !$OMP ALLOCATE", n->sym->name, &n->where);
9806 30 : continue;
9807 : }
9808 215 : if (ns->omp_allocate->sym->attr.proc_pointer)
9809 : {
9810 0 : gfc_error ("Procedure pointer %qs not supported with !$OMP "
9811 : "ALLOCATE at %L", n->sym->name, &n->where);
9812 0 : continue;
9813 : }
9814 215 : if (n->sym->attr.flavor != FL_VARIABLE)
9815 : {
9816 3 : gfc_error ("Argument %qs at %L to declarative !$OMP ALLOCATE "
9817 : "directive must be a variable", n->sym->name,
9818 : &n->where);
9819 3 : continue;
9820 : }
9821 212 : if (ns != n->sym->ns || n->sym->attr.use_assoc || n->sym->attr.imported)
9822 : {
9823 8 : gfc_error ("Argument %qs at %L to declarative !$OMP ALLOCATE shall be"
9824 : " in the same scope as the variable declaration",
9825 : n->sym->name, &n->where);
9826 8 : continue;
9827 : }
9828 204 : if (n->sym->attr.dummy)
9829 : {
9830 3 : gfc_error ("Unexpected dummy argument %qs as argument at %L to "
9831 : "declarative !$OMP ALLOCATE", n->sym->name, &n->where);
9832 3 : continue;
9833 : }
9834 201 : if (n->sym->attr.codimension)
9835 : {
9836 0 : gfc_error ("Unexpected coarray argument %qs as argument at %L to "
9837 : "declarative !$OMP ALLOCATE", n->sym->name, &n->where);
9838 0 : continue;
9839 : }
9840 201 : if (n->sym->attr.omp_allocate)
9841 : {
9842 5 : if (n->sym->attr.in_common)
9843 : {
9844 1 : gfc_error ("Duplicated common block %</%s/%> in !$OMP ALLOCATE "
9845 1 : "at %L", n->sym->common_head->name, &n->where);
9846 3 : while (n->next && n->next->sym
9847 3 : && n->sym->common_head == n->next->sym->common_head)
9848 : n = n->next;
9849 : }
9850 : else
9851 4 : gfc_error ("Duplicated variable %qs in !$OMP ALLOCATE at %L",
9852 : n->sym->name, &n->where);
9853 5 : continue;
9854 : }
9855 : /* For 'equivalence(a,b)', a 'union_type {<type> a,b} equiv.0' is created
9856 : with a value expression for 'a' as 'equiv.0.a' (likewise for b); while
9857 : this can be handled, EQUIVALENCE is marked as obsolescent since Fortran
9858 : 2018 and also not widely used. However, it could be supported,
9859 : if needed. */
9860 196 : if (n->sym->attr.in_equivalence)
9861 : {
9862 2 : gfc_error ("Sorry, EQUIVALENCE object %qs not supported with !$OMP "
9863 : "ALLOCATE at %L", n->sym->name, &n->where);
9864 2 : continue;
9865 : }
9866 : /* Similar for Cray pointer/pointee - they could be implemented but as
9867 : common vendor extension but nowadays rarely used and requiring
9868 : -fcray-pointer, there is no need to support them. */
9869 194 : if (n->sym->attr.cray_pointer || n->sym->attr.cray_pointee)
9870 : {
9871 2 : gfc_error ("Sorry, Cray pointers and pointees such as %qs are not "
9872 : "supported with !$OMP ALLOCATE at %L",
9873 : n->sym->name, &n->where);
9874 2 : continue;
9875 : }
9876 192 : n->sym->attr.omp_allocate = 1;
9877 192 : if ((n->sym->ts.type == BT_CLASS && n->sym->attr.class_ok
9878 0 : && CLASS_DATA (n->sym)->attr.allocatable)
9879 192 : || (n->sym->ts.type != BT_CLASS && n->sym->attr.allocatable))
9880 1 : gfc_error ("Unexpected allocatable variable %qs at %L in declarative "
9881 : "!$OMP ALLOCATE directive", n->sym->name, &n->where);
9882 191 : else if ((n->sym->ts.type == BT_CLASS && n->sym->attr.class_ok
9883 0 : && CLASS_DATA (n->sym)->attr.class_pointer)
9884 191 : || (n->sym->ts.type != BT_CLASS && n->sym->attr.pointer))
9885 1 : gfc_error ("Unexpected pointer variable %qs at %L in declarative "
9886 : "!$OMP ALLOCATE directive", n->sym->name, &n->where);
9887 192 : HOST_WIDE_INT alignment = 0;
9888 198 : if (n->u.align
9889 192 : && (!gfc_resolve_expr (n->u.align)
9890 27 : || n->u.align->ts.type != BT_INTEGER
9891 26 : || n->u.align->rank != 0
9892 24 : || n->u.align->expr_type != EXPR_CONSTANT
9893 23 : || gfc_extract_hwi (n->u.align, &alignment)
9894 23 : || !pow2p_hwi (alignment)))
9895 : {
9896 6 : gfc_error ("ALIGN requires a scalar positive constant integer "
9897 : "alignment expression at %L that is a power of two",
9898 6 : &n->u.align->where);
9899 6 : while (n->sym->attr.in_common && n->next && n->next->sym
9900 6 : && n->sym->common_head == n->next->sym->common_head)
9901 : n = n->next;
9902 6 : continue;
9903 : }
9904 186 : if (n->sym->attr.in_common || n->sym->attr.save || n->sym->ns->save_all
9905 63 : || (n->sym->ns->proc_name
9906 63 : && (n->sym->ns->proc_name->attr.flavor == FL_PROGRAM
9907 55 : || n->sym->ns->proc_name->attr.flavor == FL_MODULE
9908 55 : || n->sym->ns->proc_name->attr.flavor == FL_BLOCK_DATA)))
9909 : {
9910 131 : bool com = n->sym->attr.in_common;
9911 131 : if (!n->u2.allocator)
9912 1 : gfc_error ("An ALLOCATOR clause is required as the list item "
9913 : "%<%s%s%s%> at %L has the SAVE attribute", com ? "/" : "",
9914 0 : com ? n->sym->common_head->name : n->sym->name,
9915 : com ? "/" : "", &n->where);
9916 130 : else if (!is_predefined_allocator (n->u2.allocator))
9917 24 : gfc_error ("Predefined allocator required in ALLOCATOR clause at %L"
9918 : " as the list item %<%s%s%s%> at %L has the SAVE attribute",
9919 24 : &n->u2.allocator->where, com ? "/" : "",
9920 24 : com ? n->sym->common_head->name : n->sym->name,
9921 : com ? "/" : "", &n->where);
9922 : /* Static variables may not use omp_cgroup_mem_alloc (6),
9923 : omp_pteam_mem_alloc (7), or omp_thread_mem_alloc (8). */
9924 106 : else if (mpz_cmp_si (n->u2.allocator->value.integer,
9925 : 6 /* cgroup */) >= 0
9926 34 : && mpz_cmp_si (n->u2.allocator->value.integer,
9927 : 8 /* thread */) <= 0)
9928 : {
9929 33 : STATIC_ASSERT (GOMP_OMP_PREDEF_ALLOC_CGROUP == 6);
9930 33 : STATIC_ASSERT (GOMP_OMP_PREDEF_ALLOC_PTEAM == 7);
9931 33 : STATIC_ASSERT (GOMP_OMP_PREDEF_ALLOC_THREAD == 8);
9932 33 : const char *alloc_name[] = {"omp_cgroup_mem_alloc",
9933 : "omp_pteam_mem_alloc",
9934 : "omp_thread_mem_alloc" };
9935 33 : gfc_error ("Predefined allocator %qs in ALLOCATOR clause at %L, "
9936 : "used for list item %<%s%s%s%> at %L, may not be used"
9937 : " for static variables",
9938 33 : alloc_name[mpz_get_ui (n->u2.allocator->value.integer)
9939 33 : - 6 /* cgroup */], &n->u2.allocator->where,
9940 : com ? "/" : "",
9941 33 : com ? n->sym->common_head->name : n->sym->name,
9942 : com ? "/" : "", &n->where);
9943 : }
9944 67 : while (n->sym->attr.in_common && n->next && n->next->sym
9945 186 : && n->sym->common_head == n->next->sym->common_head)
9946 : n = n->next;
9947 : }
9948 55 : else if (n->u2.allocator
9949 55 : && (!gfc_resolve_expr (n->u2.allocator)
9950 20 : || n->u2.allocator->ts.type != BT_INTEGER
9951 19 : || n->u2.allocator->rank != 0
9952 18 : || n->u2.allocator->ts.kind != gfc_c_intptr_kind))
9953 3 : gfc_error ("Expected integer expression of the "
9954 : "%<omp_allocator_handle_kind%> kind at %L",
9955 3 : &n->u2.allocator->where);
9956 : }
9957 62 : }
9958 :
9959 : /* Resolve ASSUME's and ASSUMES' assumption clauses. Note that absent/contains
9960 : is handled during parse time in omp_verify_merge_absent_contains. */
9961 :
9962 : void
9963 34 : gfc_resolve_omp_assumptions (gfc_omp_assumptions *assume)
9964 : {
9965 54 : for (gfc_expr_list *el = assume->holds; el; el = el->next)
9966 20 : if (!gfc_resolve_expr (el->expr)
9967 20 : || el->expr->ts.type != BT_LOGICAL
9968 38 : || el->expr->rank != 0)
9969 4 : gfc_error ("HOLDS expression at %L must be a scalar logical expression",
9970 4 : &el->expr->where);
9971 34 : }
9972 :
9973 :
9974 : /* Resolve the OpenMP ALLOCATE clauses. */
9975 :
9976 : static void
9977 33190 : resolve_omp_allocate_clauses (gfc_code *code, gfc_omp_clauses *omp_clauses,
9978 : gfc_namespace *ns)
9979 : {
9980 33190 : gfc_omp_namelist *n;
9981 33190 : enum gfc_omp_list_type list;
9982 :
9983 33190 : if (!omp_clauses->lists[OMP_LIST_ALLOCATE])
9984 : return;
9985 795 : for (n = omp_clauses->lists[OMP_LIST_ALLOCATE]; n; n = n->next)
9986 : {
9987 515 : if (n->u2.allocator
9988 515 : && (!gfc_resolve_expr (n->u2.allocator)
9989 290 : || n->u2.allocator->ts.type != BT_INTEGER
9990 288 : || n->u2.allocator->rank != 0
9991 287 : || n->u2.allocator->ts.kind != gfc_c_intptr_kind))
9992 : {
9993 8 : gfc_error ("Expected integer expression of the "
9994 : "%<omp_allocator_handle_kind%> kind at %L",
9995 8 : &n->u2.allocator->where);
9996 28 : break;
9997 : }
9998 507 : if (!n->u.align)
9999 399 : continue;
10000 108 : HOST_WIDE_INT alignment = 0;
10001 108 : if (!gfc_resolve_expr (n->u.align)
10002 108 : || n->u.align->ts.type != BT_INTEGER
10003 105 : || n->u.align->rank != 0
10004 102 : || n->u.align->expr_type != EXPR_CONSTANT
10005 99 : || gfc_extract_hwi (n->u.align, &alignment)
10006 99 : || alignment <= 0
10007 207 : || !pow2p_hwi (alignment))
10008 : {
10009 12 : gfc_error ("ALIGN requires a scalar positive constant integer "
10010 : "alignment expression at %L that is a power of two",
10011 12 : &n->u.align->where);
10012 12 : break;
10013 : }
10014 : }
10015 :
10016 : /* Check for 2 things here.
10017 : 1. There is no duplication of variable in allocate clause.
10018 : 2. Variable in allocate clause are also present in some
10019 : privatization clase (non-composite case). */
10020 815 : for (n = omp_clauses->lists[OMP_LIST_ALLOCATE]; n; n = n->next)
10021 515 : if (n->sym)
10022 489 : n->sym->mark = 0;
10023 :
10024 : gfc_omp_namelist *prev = NULL;
10025 815 : for (n = omp_clauses->lists[OMP_LIST_ALLOCATE]; n; )
10026 : {
10027 515 : if (n->sym == NULL)
10028 : {
10029 26 : n = n->next;
10030 26 : continue;
10031 : }
10032 489 : if (n->sym->mark == 1)
10033 : {
10034 3 : gfc_warning (OPT_Wopenmp, "%qs appears more than once in "
10035 : "%<allocate%> at %L" , n->sym->name, &n->where);
10036 : /* We have already seen this variable so it is a duplicate.
10037 : Remove it. */
10038 3 : if (prev != NULL && prev->next == n)
10039 : {
10040 3 : prev->next = n->next;
10041 3 : n->next = NULL;
10042 3 : gfc_free_omp_namelist (n, OMP_LIST_ALLOCATE);
10043 3 : n = prev->next;
10044 : }
10045 3 : continue;
10046 : }
10047 486 : n->sym->mark = 1;
10048 486 : prev = n;
10049 486 : n = n->next;
10050 : }
10051 :
10052 : /* Non-composite constructs. */
10053 300 : if (code && code->op < EXEC_OMP_DO_SIMD)
10054 : {
10055 4760 : for (list = OMP_LIST_FIRST; list < OMP_LIST_NUM;
10056 4641 : list = gfc_omp_list_type (list + 1))
10057 4641 : switch (list)
10058 : {
10059 1071 : case OMP_LIST_PRIVATE:
10060 1071 : case OMP_LIST_FIRSTPRIVATE:
10061 1071 : case OMP_LIST_LASTPRIVATE:
10062 1071 : case OMP_LIST_REDUCTION:
10063 1071 : case OMP_LIST_REDUCTION_INSCAN:
10064 1071 : case OMP_LIST_REDUCTION_TASK:
10065 1071 : case OMP_LIST_IN_REDUCTION:
10066 1071 : case OMP_LIST_TASK_REDUCTION:
10067 1071 : case OMP_LIST_LINEAR:
10068 1370 : for (n = omp_clauses->lists[list]; n; n = n->next)
10069 299 : n->sym->mark = 0;
10070 : break;
10071 : default:
10072 : break;
10073 : }
10074 :
10075 410 : for (n = omp_clauses->lists[OMP_LIST_ALLOCATE]; n; n = n->next)
10076 291 : if (n->sym->mark == 1)
10077 4 : gfc_error ("%qs specified in %<allocate%> clause at %L but not "
10078 : "in an explicit privatization clause",
10079 : n->sym->name, &n->where);
10080 : }
10081 71 : if (!(code
10082 300 : && (code->op == EXEC_OMP_ALLOCATORS || code->op == EXEC_OMP_ALLOCATE)
10083 73 : && code->block
10084 72 : && code->block->next
10085 71 : && code->block->next->op == EXEC_ALLOCATE))
10086 : return;
10087 :
10088 68 : if (code->op == EXEC_OMP_ALLOCATE)
10089 49 : gfc_warning (OPT_Wdeprecated_openmp,
10090 : "The use of one or more %<allocate%> directives with "
10091 : "an associated %<allocate%> statement at %L is "
10092 : "deprecated since OpenMP 5.2, use an %<allocators%> "
10093 : "directive", &code->loc);
10094 68 : gfc_alloc *a;
10095 68 : gfc_omp_namelist *n_null = NULL;
10096 68 : bool missing_allocator = false;
10097 68 : gfc_symbol *missing_allocator_sym = NULL;
10098 161 : for (n = omp_clauses->lists[OMP_LIST_ALLOCATE]; n; n = n->next)
10099 : {
10100 93 : if (n->u2.allocator == NULL)
10101 : {
10102 77 : if (!missing_allocator_sym)
10103 59 : missing_allocator_sym = n->sym;
10104 : missing_allocator = true;
10105 : }
10106 93 : if (n->sym == NULL)
10107 : {
10108 26 : n_null = n;
10109 26 : continue;
10110 : }
10111 67 : if (n->sym->attr.codimension)
10112 2 : gfc_error ("Unexpected coarray %qs in %<allocate%> at %L",
10113 : n->sym->name, &n->where);
10114 103 : for (a = code->block->next->ext.alloc.list; a; a = a->next)
10115 101 : if (a->expr->expr_type == EXPR_VARIABLE
10116 101 : && a->expr->symtree->n.sym == n->sym)
10117 : {
10118 65 : gfc_ref *ref;
10119 82 : for (ref = a->expr->ref; ref; ref = ref->next)
10120 17 : if (ref->type == REF_COMPONENT)
10121 : break;
10122 : if (ref == NULL)
10123 : break;
10124 : }
10125 67 : if (a == NULL)
10126 2 : gfc_error ("%qs specified in %<allocate%> at %L but not "
10127 : "in the associated ALLOCATE statement",
10128 2 : n->sym->name, &n->where);
10129 : }
10130 : /* If there is an ALLOCATE directive without list argument, a
10131 : namelist with its allocator/align clauses and n->sym = NULL is
10132 : created during parsing; here, we add all not otherwise specified
10133 : items from the Fortran allocate to that list.
10134 : For an ALLOCATORS directive, not listed items use the normal
10135 : Fortran way.
10136 : The behavior of an ALLOCATE directive that does not list all
10137 : arguments but there is no directive without list argument is not
10138 : well specified. Thus, we reject such code below. In OpenMP 5.2
10139 : the executable ALLOCATE directive is deprecated and in 6.0
10140 : deleted such that no spec clarification is to be expected. */
10141 125 : for (a = code->block->next->ext.alloc.list; a; a = a->next)
10142 89 : if (a->expr->expr_type == EXPR_VARIABLE)
10143 : {
10144 154 : for (n = omp_clauses->lists[OMP_LIST_ALLOCATE]; n; n = n->next)
10145 122 : if (a->expr->symtree->n.sym == n->sym)
10146 : {
10147 57 : gfc_ref *ref;
10148 72 : for (ref = a->expr->ref; ref; ref = ref->next)
10149 15 : if (ref->type == REF_COMPONENT)
10150 : break;
10151 : if (ref == NULL)
10152 : break;
10153 : }
10154 89 : if (n == NULL && n_null == NULL)
10155 : {
10156 : /* OK for ALLOCATORS but for ALLOCATE: Unspecified whether
10157 : that should use the default allocator of OpenMP or the
10158 : Fortran allocator. Thus, just reject it. */
10159 7 : if (code->op == EXEC_OMP_ALLOCATE)
10160 1 : gfc_error ("%qs listed in %<allocate%> statement at %L "
10161 : "but it is neither explicitly in listed in "
10162 : "the %<!$OMP ALLOCATE%> directive nor exists"
10163 : " a directive without argument list",
10164 1 : a->expr->symtree->n.sym->name,
10165 : &a->expr->where);
10166 : break;
10167 : }
10168 82 : if (n == NULL)
10169 : {
10170 25 : if (a->expr->symtree->n.sym->attr.codimension)
10171 1 : gfc_error ("Unexpected coarray %qs in %<allocate%> at "
10172 : "%L, implicitly listed in %<!$OMP ALLOCATE%>"
10173 : " at %L", a->expr->symtree->n.sym->name,
10174 : &a->expr->where, &n_null->where);
10175 : break;
10176 : }
10177 : }
10178 68 : gfc_namespace *prog_unit = ns;
10179 87 : while (prog_unit->parent)
10180 : prog_unit = prog_unit->parent;
10181 : gfc_namespace *fn_ns = ns;
10182 72 : while (fn_ns)
10183 : {
10184 70 : if (ns->proc_name
10185 70 : && (ns->proc_name->attr.subroutine
10186 6 : || ns->proc_name->attr.function))
10187 : break;
10188 4 : fn_ns = fn_ns->parent;
10189 : }
10190 68 : if (missing_allocator
10191 58 : && !(prog_unit->omp_requires & OMP_REQ_DYNAMIC_ALLOCATORS)
10192 58 : && ((fn_ns && fn_ns->proc_name->attr.omp_declare_target)
10193 55 : || omp_clauses->contained_in_target_construct))
10194 : {
10195 6 : if (code->op == EXEC_OMP_ALLOCATORS)
10196 2 : gfc_error ("ALLOCATORS directive at %L inside a target region "
10197 : "must specify an ALLOCATOR modifier for %qs",
10198 : &code->loc, missing_allocator_sym->name);
10199 4 : else if (missing_allocator_sym)
10200 2 : gfc_error ("ALLOCATE directive at %L inside a target region "
10201 : "must specify an ALLOCATOR clause for %qs",
10202 : &code->loc, missing_allocator_sym->name);
10203 : else
10204 2 : gfc_error ("ALLOCATE directive at %L inside a target region "
10205 : "must specify an ALLOCATOR clause", &code->loc);
10206 : }
10207 : }
10208 :
10209 :
10210 : /* Diagnose list items that appear multiple times in OpenMP or OpenACC clauses,
10211 : unless permitted by the specification. */
10212 :
10213 : static void
10214 33190 : check_omp_clauses_dupl_syms (gfc_code *code, gfc_omp_clauses *omp_clauses,
10215 : bool openacc)
10216 : {
10217 33190 : gfc_omp_namelist *n;
10218 33190 : enum gfc_omp_list_type list;
10219 :
10220 : /* Check that no symbol appears on multiple clauses, except that
10221 : a symbol can appear on both firstprivate and lastprivate. */
10222 1327600 : for (list = OMP_LIST_FIRST; list < OMP_LIST_NUM;
10223 1294410 : list = gfc_omp_list_type (list + 1))
10224 1340291 : for (n = omp_clauses->lists[list]; n; n = n->next)
10225 : {
10226 45881 : if (!n->sym) /* omp_all_memory. */
10227 47 : continue;
10228 45834 : n->sym->mark = 0;
10229 45834 : n->sym->comp_mark = 0;
10230 45834 : n->sym->data_mark = 0;
10231 45834 : n->sym->dev_mark = 0;
10232 45834 : n->sym->gen_mark = 0;
10233 45834 : n->sym->reduc_mark = 0;
10234 : }
10235 1327600 : for (list = OMP_LIST_FIRST; list < OMP_LIST_NUM;
10236 1294410 : list = gfc_omp_list_type (list + 1))
10237 1294410 : if (list != OMP_LIST_FIRSTPRIVATE
10238 1294410 : && list != OMP_LIST_LASTPRIVATE
10239 1294410 : && list != OMP_LIST_ALIGNED
10240 1194840 : && list != OMP_LIST_DEPEND
10241 1194840 : && list != OMP_LIST_FROM
10242 1128460 : && list != OMP_LIST_TO
10243 1128460 : && list != OMP_LIST_INTEROP
10244 1062080 : && (list != OMP_LIST_REDUCTION || !openacc)
10245 1049085 : && list != OMP_LIST_ALLOCATE)
10246 1050861 : for (n = omp_clauses->lists[list]; n; n = n->next)
10247 : {
10248 34966 : bool component_ref_p = false;
10249 :
10250 : /* Allow multiple components of the same (e.g. derived-type)
10251 : variable here. Duplicate components are detected elsewhere. */
10252 34966 : if (n->expr && n->expr->expr_type == EXPR_VARIABLE)
10253 16021 : for (gfc_ref *ref = n->expr->ref; ref; ref = ref->next)
10254 9744 : if (ref->type == REF_COMPONENT)
10255 3197 : component_ref_p = true;
10256 34966 : if ((list == OMP_LIST_IS_DEVICE_PTR
10257 34966 : || list == OMP_LIST_HAS_DEVICE_ADDR)
10258 314 : && !component_ref_p)
10259 : {
10260 314 : if (n->sym->gen_mark
10261 312 : || n->sym->dev_mark
10262 311 : || n->sym->reduc_mark
10263 311 : || n->sym->mark)
10264 5 : gfc_error ("Symbol %qs present on multiple clauses at %L",
10265 : n->sym->name, &n->where);
10266 : else
10267 309 : n->sym->dev_mark = 1;
10268 : }
10269 34652 : else if ((list == OMP_LIST_USE_DEVICE_PTR
10270 34652 : || list == OMP_LIST_USE_DEVICE_ADDR
10271 34652 : || list == OMP_LIST_PRIVATE
10272 : || list == OMP_LIST_SHARED)
10273 12861 : && !component_ref_p)
10274 : {
10275 12861 : if (n->sym->gen_mark || n->sym->dev_mark || n->sym->reduc_mark)
10276 13 : gfc_error ("Symbol %qs present on multiple clauses at %L",
10277 : n->sym->name, &n->where);
10278 : else
10279 : {
10280 12848 : n->sym->gen_mark = 1;
10281 : /* Set both generic and device bits if we have
10282 : use_device_*(x) or shared(x). This allows us to diagnose
10283 : "map(x) private(x)" below. */
10284 12848 : if (list != OMP_LIST_PRIVATE)
10285 3456 : n->sym->dev_mark = 1;
10286 : }
10287 : }
10288 21791 : else if ((list == OMP_LIST_REDUCTION
10289 21791 : || list == OMP_LIST_REDUCTION_TASK
10290 19329 : || list == OMP_LIST_REDUCTION_INSCAN
10291 19329 : || list == OMP_LIST_IN_REDUCTION
10292 19116 : || list == OMP_LIST_TASK_REDUCTION)
10293 2675 : && !component_ref_p)
10294 : {
10295 : /* Attempts to mix reduction types are diagnosed below. */
10296 2675 : if (n->sym->gen_mark || n->sym->dev_mark)
10297 2 : gfc_error ("Symbol %qs present on multiple clauses at %L",
10298 : n->sym->name, &n->where);
10299 2675 : n->sym->reduc_mark = 1;
10300 : }
10301 19116 : else if ((!component_ref_p && n->sym->comp_mark)
10302 19115 : || (component_ref_p && n->sym->mark))
10303 : {
10304 42 : if (openacc)
10305 3 : gfc_error ("Symbol %qs has mixed component and non-component "
10306 3 : "accesses at %L", n->sym->name, &n->where);
10307 : }
10308 19074 : else if ((openacc || list != OMP_LIST_MAP) && n->sym->mark)
10309 88 : gfc_error ("Symbol %qs present on multiple clauses at %L",
10310 : n->sym->name, &n->where);
10311 : else
10312 : {
10313 18986 : if (component_ref_p)
10314 2473 : n->sym->comp_mark = 1;
10315 : else
10316 16513 : n->sym->mark = 1;
10317 : }
10318 : }
10319 :
10320 : /* Detect specifically the case where we have "map(x) private(x)" and raise
10321 : an error. If we have "...simd" combined directives though, the "private"
10322 : applies to the simd part, so this is permitted though. */
10323 42590 : for (n = omp_clauses->lists[OMP_LIST_PRIVATE]; n; n = n->next)
10324 9400 : if (n->sym->mark
10325 6 : && n->sym->gen_mark
10326 6 : && !n->sym->dev_mark
10327 6 : && !n->sym->reduc_mark
10328 5 : && code->op != EXEC_OMP_TARGET_SIMD
10329 : && code->op != EXEC_OMP_TARGET_PARALLEL_DO_SIMD
10330 : && code->op != EXEC_OMP_TARGET_TEAMS_DISTRIBUTE_SIMD
10331 : && code->op != EXEC_OMP_TARGET_TEAMS_DISTRIBUTE_PARALLEL_DO_SIMD)
10332 1 : gfc_error ("Symbol %qs present on multiple clauses at %L",
10333 : n->sym->name, &n->where);
10334 :
10335 : gcc_assert (OMP_LIST_LASTPRIVATE == OMP_LIST_FIRSTPRIVATE + 1);
10336 99570 : for (list = OMP_LIST_FIRSTPRIVATE; list <= OMP_LIST_LASTPRIVATE;
10337 66380 : list = gfc_omp_list_type (list + 1))
10338 70607 : for (n = omp_clauses->lists[list]; n; n = n->next)
10339 4227 : if (n->sym->data_mark || n->sym->gen_mark || n->sym->dev_mark)
10340 : {
10341 9 : gfc_error ("Symbol %qs present on multiple clauses at %L",
10342 : n->sym->name, &n->where);
10343 9 : n->sym->data_mark = n->sym->gen_mark = n->sym->dev_mark = 0;
10344 : }
10345 4218 : else if (n->sym->mark
10346 18 : && code->op != EXEC_OMP_TARGET_TEAMS
10347 : && code->op != EXEC_OMP_TARGET_TEAMS_DISTRIBUTE
10348 : && code->op != EXEC_OMP_TARGET_TEAMS_LOOP
10349 : && code->op != EXEC_OMP_TARGET_TEAMS_DISTRIBUTE_SIMD
10350 : && code->op != EXEC_OMP_TARGET_TEAMS_DISTRIBUTE_PARALLEL_DO
10351 : && code->op != EXEC_OMP_TARGET_PARALLEL
10352 : && code->op != EXEC_OMP_TARGET_PARALLEL_DO
10353 : && code->op != EXEC_OMP_TARGET_PARALLEL_LOOP
10354 : && code->op != EXEC_OMP_TARGET_PARALLEL_DO_SIMD
10355 : && code->op != EXEC_OMP_TARGET_TEAMS_DISTRIBUTE_PARALLEL_DO_SIMD)
10356 7 : gfc_error ("Symbol %qs present on both data and map clauses "
10357 : "at %L", n->sym->name, &n->where);
10358 :
10359 35109 : for (n = omp_clauses->lists[OMP_LIST_FIRSTPRIVATE]; n; n = n->next)
10360 : {
10361 1919 : if (n->sym->data_mark || n->sym->gen_mark || n->sym->dev_mark)
10362 7 : gfc_error ("Symbol %qs present on multiple clauses at %L",
10363 : n->sym->name, &n->where);
10364 : else
10365 1912 : n->sym->data_mark = 1;
10366 : }
10367 :
10368 : /* LASTPRIVATE clauses. */
10369 35498 : for (n = omp_clauses->lists[OMP_LIST_LASTPRIVATE]; n; n = n->next)
10370 2308 : n->sym->data_mark = 0;
10371 35498 : for (n = omp_clauses->lists[OMP_LIST_LASTPRIVATE]; n; n = n->next)
10372 : {
10373 2308 : if (n->sym->data_mark || n->sym->gen_mark || n->sym->dev_mark)
10374 0 : gfc_error ("Symbol %qs present on multiple clauses at %L",
10375 : n->sym->name, &n->where);
10376 : else
10377 2308 : n->sym->data_mark = 1;
10378 : }
10379 :
10380 : /* ALIGNED clauses. */
10381 33340 : for (n = omp_clauses->lists[OMP_LIST_ALIGNED]; n; n = n->next)
10382 150 : n->sym->mark = 0;
10383 :
10384 33340 : for (n = omp_clauses->lists[OMP_LIST_ALIGNED]; n; n = n->next)
10385 : {
10386 150 : if (n->sym->mark)
10387 0 : gfc_error ("Symbol %qs present on multiple clauses at %L",
10388 : n->sym->name, &n->where);
10389 : else
10390 150 : n->sym->mark = 1;
10391 : }
10392 :
10393 : /* FROM and TO clauses. */
10394 33960 : for (n = omp_clauses->lists[OMP_LIST_TO]; n; n = n->next)
10395 770 : n->sym->mark = 0;
10396 34225 : for (n = omp_clauses->lists[OMP_LIST_FROM]; n; n = n->next)
10397 1035 : if (n->expr == NULL)
10398 1017 : n->sym->mark = 1;
10399 33960 : for (n = omp_clauses->lists[OMP_LIST_TO]; n; n = n->next)
10400 : {
10401 770 : if (n->expr == NULL && n->sym->mark)
10402 0 : gfc_error ("Symbol %qs present on both FROM and TO clauses at %L",
10403 : n->sym->name, &n->where);
10404 : else
10405 770 : n->sym->mark = 1;
10406 : }
10407 :
10408 : /* OpenACC reductions. */
10409 33190 : if (openacc)
10410 : {
10411 15131 : for (n = omp_clauses->lists[OMP_LIST_REDUCTION]; n; n = n->next)
10412 2136 : n->sym->mark = 0;
10413 15131 : for (n = omp_clauses->lists[OMP_LIST_REDUCTION]; n; n = n->next)
10414 : {
10415 2136 : if (n->sym->mark)
10416 0 : gfc_error ("Symbol %qs present on multiple clauses at %L",
10417 : n->sym->name, &n->where);
10418 : else
10419 2136 : n->sym->mark = 1;
10420 :
10421 : /* OpenACC does not support reductions on arrays. */
10422 2136 : if (n->sym->as)
10423 71 : gfc_error ("Array %qs is not permitted in reduction at %L",
10424 : n->sym->name, &n->where);
10425 : }
10426 : }
10427 33190 : }
10428 :
10429 : /* OpenMP/OpenACC: Resolve the list item of a MAP, TO, FROM, CACHE, AFFINITY
10430 : or DEPEND clause. */
10431 :
10432 : static void
10433 20963 : resolve_omp_clauses_aff_dep_map_cache (gfc_code *code,
10434 : gfc_omp_namelist *n,
10435 : const char *name,
10436 : enum gfc_omp_list_type list,
10437 : gfc_omp_clauses *omp_clauses,
10438 : bool openacc)
10439 : {
10440 20963 : gcc_checking_assert (list == OMP_LIST_AFFINITY || list == OMP_LIST_DEPEND
10441 : || list == OMP_LIST_MAP || list == OMP_LIST_TO
10442 : || list == OMP_LIST_FROM || list == OMP_LIST_CACHE);
10443 :
10444 20963 : if (list != OMP_LIST_CACHE && n->u2.ns && !n->u2.ns->resolved)
10445 : {
10446 109 : n->u2.ns->resolved = 1;
10447 109 : for (gfc_symbol *sym = n->u2.ns->omp_affinity_iterators;
10448 235 : sym; sym = sym->tlink)
10449 : {
10450 126 : gfc_constructor *c;
10451 126 : c = gfc_constructor_first (sym->value->value.constructor);
10452 126 : if (!gfc_resolve_expr (c->expr)
10453 126 : || c->expr->ts.type != BT_INTEGER
10454 250 : || c->expr->rank != 0)
10455 2 : gfc_error ("Scalar integer expression for range begin expected "
10456 2 : "at %L", &c->expr->where);
10457 126 : c = gfc_constructor_next (c);
10458 126 : if (!gfc_resolve_expr (c->expr)
10459 126 : || c->expr->ts.type != BT_INTEGER
10460 250 : || c->expr->rank != 0)
10461 2 : gfc_error ("Scalar integer expression for range end expected at %L",
10462 2 : &c->expr->where);
10463 126 : c = gfc_constructor_next (c);
10464 126 : if (c && (!gfc_resolve_expr (c->expr)
10465 16 : || c->expr->ts.type != BT_INTEGER
10466 14 : || c->expr->rank != 0))
10467 2 : gfc_error ("Scalar integer expression for range step expected "
10468 2 : "at %L", &c->expr->where);
10469 124 : else if (c
10470 14 : && c->expr->expr_type == EXPR_CONSTANT
10471 12 : && mpz_cmp_si (c->expr->value.integer, 0) == 0)
10472 2 : gfc_error ("Nonzero range step expected at %L", &c->expr->where);
10473 : }
10474 : }
10475 20862 : if (list == OMP_LIST_DEPEND)
10476 : {
10477 1964 : if (n->u.depend_doacross_op == OMP_DEPEND_SINK_FIRST
10478 : || n->u.depend_doacross_op == OMP_DOACROSS_SINK_FIRST
10479 1964 : || n->u.depend_doacross_op == OMP_DOACROSS_SINK)
10480 : {
10481 1233 : if (omp_clauses->doacross_source)
10482 : {
10483 0 : gfc_error ("Dependence-type SINK used together with SOURCE on "
10484 : "the same construct at %L", &n->where);
10485 0 : omp_clauses->doacross_source = false;
10486 : }
10487 1233 : else if (n->expr)
10488 : {
10489 571 : if (!gfc_resolve_expr (n->expr)
10490 571 : || n->expr->ts.type != BT_INTEGER
10491 1142 : || n->expr->rank != 0)
10492 0 : gfc_error ("SINK addend not a constant integer at %L",
10493 : &n->where);
10494 : }
10495 1233 : if (n->sym == NULL
10496 4 : && (n->expr == NULL
10497 3 : || mpz_cmp_si (n->expr->value.integer, -1) != 0))
10498 2 : gfc_error ("omp_cur_iteration at %L requires %<-1%> as "
10499 : "logical offset", &n->where);
10500 : return;
10501 : }
10502 731 : if (n->u.depend_doacross_op == OMP_DEPEND_DEPOBJ
10503 38 : && !n->expr
10504 22 : && (n->sym->ts.type != BT_INTEGER
10505 22 : || n->sym->ts.kind != 2 * gfc_index_integer_kind
10506 22 : || n->sym->attr.dimension))
10507 0 : gfc_error ("Locator %qs at %L in DEPEND clause of depobj type shall be "
10508 : "a scalar integer of OMP_DEPEND_KIND kind",
10509 : n->sym->name, &n->where);
10510 731 : else if (n->u.depend_doacross_op == OMP_DEPEND_DEPOBJ
10511 38 : && n->expr
10512 747 : && (!gfc_resolve_expr (n->expr)
10513 16 : || n->expr->ts.type != BT_INTEGER
10514 16 : || n->expr->ts.kind != 2 * gfc_index_integer_kind
10515 16 : || n->expr->rank != 0))
10516 0 : gfc_error ("Locator at %L in DEPEND clause of depobj type shall be a "
10517 0 : "scalar integer of OMP_DEPEND_KIND kind", &n->expr->where);
10518 : }
10519 19730 : gfc_ref *lastref = NULL, *lastslice = NULL;
10520 19730 : bool resolved = false;
10521 19730 : if (n->expr)
10522 : {
10523 6546 : lastref = n->expr->ref;
10524 6546 : resolved = gfc_resolve_expr (n->expr);
10525 :
10526 : /* Look through component refs to find last array reference. */
10527 6546 : if (resolved)
10528 : {
10529 16585 : for (gfc_ref *ref = n->expr->ref; ref; ref = ref->next)
10530 10057 : if (ref->type == REF_COMPONENT
10531 : || ref->type == REF_SUBSTRING
10532 10057 : || ref->type == REF_INQUIRY)
10533 : lastref = ref;
10534 6799 : else if (ref->type == REF_ARRAY)
10535 : {
10536 14290 : for (int i = 0; i < ref->u.ar.dimen; i++)
10537 7491 : if (ref->u.ar.dimen_type[i] == DIMEN_RANGE)
10538 6277 : lastslice = ref;
10539 : lastref = ref;
10540 : }
10541 :
10542 : /* The "!$acc cache" directive allows rectangular subarrays to be
10543 : specified, with some restrictions on the form of bounds (not
10544 : implemented). Only raise an error here if we're really sure the
10545 : array isn't contiguous. An expression such as arr(-n:n,-n:n)
10546 : could be contiguous even if it looks like it may not be. */
10547 6528 : if (code
10548 6502 : && code->op != EXEC_OACC_UPDATE
10549 5720 : && list != OMP_LIST_CACHE
10550 5720 : && list != OMP_LIST_DEPEND
10551 5398 : && !gfc_is_simply_contiguous (n->expr, false, true)
10552 1517 : && gfc_is_not_contiguous (n->expr)
10553 6541 : && !(lastslice && (lastslice->next
10554 3 : || lastslice->type != REF_ARRAY)))
10555 3 : gfc_error ("Array is not contiguous at %L", &n->where);
10556 : }
10557 : }
10558 19730 : if (list == OMP_LIST_MAP
10559 17058 : && (n->sym->attr.omp_groupprivate
10560 17057 : || n->sym->attr.omp_declare_target_local))
10561 2 : gfc_error ("%qs argument to MAP clause at %L must not be a device-local "
10562 : "variable, including GROUPPRIVATE", n->sym->name, &n->where);
10563 19730 : if (openacc
10564 19730 : && list == OMP_LIST_MAP
10565 9571 : && (n->u.map.op == OMP_MAP_ATTACH || n->u.map.op == OMP_MAP_DETACH))
10566 : {
10567 117 : symbol_attribute attr;
10568 117 : if (n->expr)
10569 99 : attr = gfc_expr_attr (n->expr);
10570 : else
10571 18 : attr = n->sym->attr;
10572 117 : if (!attr.pointer && !attr.allocatable)
10573 7 : gfc_error ("%qs clause argument must be ALLOCATABLE or a POINTER at %L",
10574 7 : (n->u.map.op == OMP_MAP_ATTACH) ? "attach" : "detach",
10575 : &n->where);
10576 : }
10577 19730 : if (lastref
10578 13196 : || (n->expr && (!resolved || n->expr->expr_type != EXPR_VARIABLE)))
10579 : {
10580 6546 : if (!lastslice && lastref && lastref->type == REF_SUBSTRING)
10581 11 : gfc_error ("Unexpected substring reference in %s clause at %L",
10582 : name, &n->where);
10583 6535 : else if (!lastslice && lastref && lastref->type == REF_INQUIRY)
10584 : {
10585 12 : gcc_assert (lastref->u.i == INQUIRY_RE || lastref->u.i == INQUIRY_IM);
10586 12 : gfc_error ("Unexpected complex-parts designator reference in %s "
10587 : "clause at %L", name, &n->where);
10588 : }
10589 6523 : else if (!resolved
10590 6505 : || n->expr->expr_type != EXPR_VARIABLE
10591 6493 : || (lastslice
10592 5615 : && (lastslice->next || lastslice->type != REF_ARRAY)))
10593 46 : gfc_error ("%qs in %s clause at %L is not a proper array section",
10594 46 : n->sym->name, name, &n->where);
10595 : else if (lastslice)
10596 : {
10597 : int i;
10598 : gfc_array_ref *ar = &lastslice->u.ar;
10599 11873 : for (i = 0; i < ar->dimen; i++)
10600 6275 : if (ar->stride[i] && code && code->op != EXEC_OACC_UPDATE)
10601 : {
10602 1 : gfc_error ("Stride should not be specified for array section "
10603 : "in %s clause at %L", name, &n->where);
10604 1 : break;
10605 : }
10606 6274 : else if (ar->dimen_type[i] != DIMEN_ELEMENT
10607 6274 : && ar->dimen_type[i] != DIMEN_RANGE)
10608 : {
10609 0 : gfc_error ("%qs in %s clause at %L is not a proper array "
10610 0 : "section", n->sym->name, name, &n->where);
10611 0 : break;
10612 : }
10613 6274 : else if ((list == OMP_LIST_DEPEND || list == OMP_LIST_AFFINITY)
10614 161 : && ar->start[i]
10615 133 : && ar->start[i]->expr_type == EXPR_CONSTANT
10616 97 : && ar->end[i]
10617 72 : && ar->end[i]->expr_type == EXPR_CONSTANT
10618 72 : && mpz_cmp (ar->start[i]->value.integer,
10619 72 : ar->end[i]->value.integer) > 0)
10620 : {
10621 0 : gfc_error ("%qs in %s clause at %L is a zero size array "
10622 0 : "section", n->sym->name,
10623 : list == OMP_LIST_DEPEND ? "DEPEND" : "AFFINITY",
10624 : &n->where);
10625 0 : break;
10626 : }
10627 : }
10628 : }
10629 13184 : else if (openacc)
10630 : {
10631 5915 : if (list == OMP_LIST_MAP && n->u.map.op == OMP_MAP_FORCE_DEVICEPTR)
10632 65 : resolve_oacc_deviceptr_clause (n->sym, n->where, name);
10633 : else
10634 5850 : resolve_oacc_data_clauses (n->sym, n->where, name);
10635 : }
10636 7269 : else if (list != OMP_LIST_DEPEND
10637 6775 : && n->sym->as
10638 3340 : && n->sym->as->type == AS_ASSUMED_SIZE)
10639 5 : gfc_error ("Assumed size array %qs in %s clause at %L",
10640 : n->sym->name, name, &n->where);
10641 19730 : if (code && list == OMP_LIST_MAP && !openacc)
10642 7442 : switch (code->op)
10643 : {
10644 6161 : case EXEC_OMP_TARGET:
10645 6161 : case EXEC_OMP_TARGET_PARALLEL:
10646 6161 : case EXEC_OMP_TARGET_PARALLEL_DO:
10647 6161 : case EXEC_OMP_TARGET_PARALLEL_DO_SIMD:
10648 6161 : case EXEC_OMP_TARGET_PARALLEL_LOOP:
10649 6161 : case EXEC_OMP_TARGET_SIMD:
10650 6161 : case EXEC_OMP_TARGET_TEAMS:
10651 6161 : case EXEC_OMP_TARGET_TEAMS_DISTRIBUTE:
10652 6161 : case EXEC_OMP_TARGET_TEAMS_DISTRIBUTE_PARALLEL_DO:
10653 6161 : case EXEC_OMP_TARGET_TEAMS_DISTRIBUTE_PARALLEL_DO_SIMD:
10654 6161 : case EXEC_OMP_TARGET_TEAMS_DISTRIBUTE_SIMD:
10655 6161 : case EXEC_OMP_TARGET_TEAMS_LOOP:
10656 6161 : case EXEC_OMP_TARGET_DATA:
10657 6161 : switch (n->u.map.op)
10658 : {
10659 : case OMP_MAP_TO:
10660 : case OMP_MAP_ALWAYS_TO:
10661 : case OMP_MAP_PRESENT_TO:
10662 : case OMP_MAP_ALWAYS_PRESENT_TO:
10663 : case OMP_MAP_FROM:
10664 : case OMP_MAP_ALWAYS_FROM:
10665 : case OMP_MAP_PRESENT_FROM:
10666 : case OMP_MAP_ALWAYS_PRESENT_FROM:
10667 : case OMP_MAP_TOFROM:
10668 : case OMP_MAP_ALWAYS_TOFROM:
10669 : case OMP_MAP_PRESENT_TOFROM:
10670 : case OMP_MAP_ALWAYS_PRESENT_TOFROM:
10671 : case OMP_MAP_ALLOC:
10672 : case OMP_MAP_PRESENT_ALLOC:
10673 : break;
10674 2 : default:
10675 2 : gfc_error ("TARGET%s with map-type other than TO, "
10676 : "FROM, TOFROM, or ALLOC on MAP clause "
10677 : "at %L",
10678 : code->op == EXEC_OMP_TARGET_DATA
10679 : ? " DATA" : "", &n->where);
10680 2 : break;
10681 : }
10682 : break;
10683 701 : case EXEC_OMP_TARGET_ENTER_DATA:
10684 701 : switch (n->u.map.op)
10685 : {
10686 : case OMP_MAP_TO:
10687 : case OMP_MAP_ALWAYS_TO:
10688 : case OMP_MAP_PRESENT_TO:
10689 : case OMP_MAP_ALWAYS_PRESENT_TO:
10690 : case OMP_MAP_ALLOC:
10691 : case OMP_MAP_PRESENT_ALLOC:
10692 : break;
10693 181 : case OMP_MAP_TOFROM:
10694 181 : n->u.map.op = OMP_MAP_TO;
10695 181 : break;
10696 3 : case OMP_MAP_ALWAYS_TOFROM:
10697 3 : n->u.map.op = OMP_MAP_ALWAYS_TO;
10698 3 : break;
10699 2 : case OMP_MAP_PRESENT_TOFROM:
10700 2 : n->u.map.op = OMP_MAP_PRESENT_TO;
10701 2 : break;
10702 2 : case OMP_MAP_ALWAYS_PRESENT_TOFROM:
10703 2 : n->u.map.op = OMP_MAP_ALWAYS_PRESENT_TO;
10704 2 : break;
10705 2 : default:
10706 2 : gfc_error ("TARGET ENTER DATA with map-type other "
10707 : "than TO, TOFROM or ALLOC on MAP clause "
10708 : "at %L", &n->where);
10709 2 : break;
10710 : }
10711 : break;
10712 580 : case EXEC_OMP_TARGET_EXIT_DATA:
10713 580 : switch (n->u.map.op)
10714 : {
10715 : case OMP_MAP_FROM:
10716 : case OMP_MAP_ALWAYS_FROM:
10717 : case OMP_MAP_PRESENT_FROM:
10718 : case OMP_MAP_ALWAYS_PRESENT_FROM:
10719 : case OMP_MAP_RELEASE:
10720 : case OMP_MAP_DELETE:
10721 : break;
10722 134 : case OMP_MAP_TOFROM:
10723 134 : n->u.map.op = OMP_MAP_FROM;
10724 134 : break;
10725 1 : case OMP_MAP_ALWAYS_TOFROM:
10726 1 : n->u.map.op = OMP_MAP_ALWAYS_FROM;
10727 1 : break;
10728 0 : case OMP_MAP_PRESENT_TOFROM:
10729 0 : n->u.map.op = OMP_MAP_PRESENT_FROM;
10730 0 : break;
10731 0 : case OMP_MAP_ALWAYS_PRESENT_TOFROM:
10732 0 : n->u.map.op = OMP_MAP_ALWAYS_PRESENT_FROM;
10733 0 : break;
10734 2 : default:
10735 2 : gfc_error ("TARGET EXIT DATA with map-type other "
10736 : "than FROM, TOFROM, RELEASE, or DELETE on "
10737 : "MAP clause at %L", &n->where);
10738 2 : break;
10739 : }
10740 : break;
10741 : default:
10742 : break;
10743 : }
10744 19730 : if (list == OMP_LIST_MAP || list == OMP_LIST_TO || list == OMP_LIST_FROM)
10745 : {
10746 18863 : gfc_typespec *ts = n->expr ? &n->expr->ts : &n->sym->ts;
10747 :
10748 18863 : if (ts->type == BT_DERIVED || ts->type == BT_CLASS)
10749 : {
10750 10 : const char *mapper_id = (n->u3.udm
10751 1002 : ? n->u3.udm->requested_mapper_id : "");
10752 1002 : gfc_omp_udm *udm = gfc_find_omp_udm (gfc_current_ns, mapper_id, ts);
10753 1002 : if (mapper_id[0] != '\0' && !udm)
10754 1 : gfc_error ("User-defined mapper %qs not found at %L",
10755 : mapper_id, &n->where);
10756 997 : else if (udm)
10757 : {
10758 27 : if (!n->u3.udm)
10759 : {
10760 18 : gcc_assert (mapper_id[0] == '\0');
10761 18 : n->u3.udm = gfc_get_omp_namelist_udm ();
10762 18 : n->u3.udm->requested_mapper_id = mapper_id;
10763 : }
10764 27 : n->u3.udm->resolved_udm = udm;
10765 : }
10766 : }
10767 : }
10768 :
10769 19730 : if (list != OMP_LIST_DEPEND)
10770 : {
10771 18999 : n->sym->attr.referenced = 1;
10772 18999 : if (n->sym->attr.threadprivate)
10773 1 : gfc_error ("THREADPRIVATE object %qs in %s clause at %L",
10774 : n->sym->name, name, &n->where);
10775 18999 : if (n->sym->attr.cray_pointee)
10776 14 : gfc_error ("Cray pointee %qs in %s clause at %L",
10777 : n->sym->name, name, &n->where);
10778 : }
10779 : }
10780 :
10781 : /* OpenMP directive resolving routines. */
10782 :
10783 : static void
10784 33190 : resolve_omp_clauses (gfc_code *code, gfc_omp_clauses *omp_clauses,
10785 : gfc_namespace *ns, bool openacc = false)
10786 : {
10787 33190 : gfc_omp_namelist *n, *last;
10788 33190 : gfc_expr_list *el;
10789 33190 : enum gfc_omp_list_type list;
10790 33190 : int ifc;
10791 33190 : bool if_without_mod = false;
10792 33190 : gfc_omp_linear_op linear_op = OMP_LINEAR_DEFAULT;
10793 33190 : static const char *clause_names[]
10794 : = { "PRIVATE", "FIRSTPRIVATE", "LASTPRIVATE", "COPYPRIVATE", "SHARED",
10795 : "COPYIN", "UNIFORM", "AFFINITY", "ALIGNED", "LINEAR", "DEPEND", "MAP",
10796 : "TO", "FROM", "INCLUSIVE", "EXCLUSIVE",
10797 : "REDUCTION", "REDUCTION" /*inscan*/, "REDUCTION" /*task*/,
10798 : "IN_REDUCTION", "TASK_REDUCTION",
10799 : "DEVICE_RESIDENT", "LINK", "LOCAL", "USE_DEVICE",
10800 : "CACHE", "IS_DEVICE_PTR", "USE_DEVICE_PTR", "USE_DEVICE_ADDR",
10801 : "NONTEMPORAL", "ALLOCATE", "HAS_DEVICE_ADDR", "ENTER",
10802 : "USES_ALLOCATORS", "INIT", "USE", "DESTROY", "INTEROP", "ADJUST_ARGS" };
10803 33190 : STATIC_ASSERT (ARRAY_SIZE (clause_names) == OMP_LIST_NUM);
10804 :
10805 33190 : if (omp_clauses == NULL)
10806 : return;
10807 :
10808 33190 : if (ns == NULL)
10809 32705 : ns = gfc_current_ns;
10810 :
10811 33190 : check_omp_clauses_dupl_syms (code, omp_clauses, openacc);
10812 :
10813 33190 : if (omp_clauses->orderedc && omp_clauses->orderedc < omp_clauses->collapse)
10814 0 : gfc_error ("ORDERED clause parameter is less than COLLAPSE at %L",
10815 : &code->loc);
10816 33190 : if (omp_clauses->order_concurrent && omp_clauses->ordered)
10817 4 : gfc_error ("ORDER clause must not be used together with ORDERED at %L",
10818 : &code->loc);
10819 33190 : if (omp_clauses->if_expr)
10820 : {
10821 1299 : gfc_expr *expr = omp_clauses->if_expr;
10822 1299 : if (!gfc_resolve_expr (expr)
10823 1299 : || expr->ts.type != BT_LOGICAL || expr->rank != 0)
10824 16 : gfc_error ("IF clause at %L requires a scalar LOGICAL expression",
10825 : &expr->where);
10826 : if_without_mod = true;
10827 : }
10828 365090 : for (ifc = 0; ifc < OMP_IF_LAST; ifc++)
10829 331900 : if (omp_clauses->if_exprs[ifc])
10830 : {
10831 141 : gfc_expr *expr = omp_clauses->if_exprs[ifc];
10832 141 : bool ok = true;
10833 141 : if (!gfc_resolve_expr (expr)
10834 141 : || expr->ts.type != BT_LOGICAL || expr->rank != 0)
10835 0 : gfc_error ("IF clause at %L requires a scalar LOGICAL expression",
10836 : &expr->where);
10837 141 : else if (if_without_mod)
10838 : {
10839 1 : gfc_error ("IF clause without modifier at %L used together with "
10840 : "IF clauses with modifiers",
10841 1 : &omp_clauses->if_expr->where);
10842 1 : if_without_mod = false;
10843 : }
10844 : else
10845 140 : switch (code->op)
10846 : {
10847 13 : case EXEC_OMP_CANCEL:
10848 13 : ok = ifc == OMP_IF_CANCEL;
10849 13 : break;
10850 :
10851 16 : case EXEC_OMP_PARALLEL:
10852 16 : case EXEC_OMP_PARALLEL_DO:
10853 16 : case EXEC_OMP_PARALLEL_LOOP:
10854 16 : case EXEC_OMP_PARALLEL_MASKED:
10855 16 : case EXEC_OMP_PARALLEL_MASTER:
10856 16 : case EXEC_OMP_PARALLEL_SECTIONS:
10857 16 : case EXEC_OMP_PARALLEL_WORKSHARE:
10858 16 : case EXEC_OMP_DISTRIBUTE_PARALLEL_DO:
10859 16 : case EXEC_OMP_TEAMS_DISTRIBUTE_PARALLEL_DO:
10860 16 : ok = ifc == OMP_IF_PARALLEL;
10861 16 : break;
10862 :
10863 28 : case EXEC_OMP_PARALLEL_DO_SIMD:
10864 28 : case EXEC_OMP_DISTRIBUTE_PARALLEL_DO_SIMD:
10865 28 : case EXEC_OMP_TEAMS_DISTRIBUTE_PARALLEL_DO_SIMD:
10866 28 : ok = ifc == OMP_IF_PARALLEL || ifc == OMP_IF_SIMD;
10867 28 : break;
10868 :
10869 8 : case EXEC_OMP_PARALLEL_MASKED_TASKLOOP:
10870 8 : case EXEC_OMP_PARALLEL_MASTER_TASKLOOP:
10871 8 : ok = ifc == OMP_IF_PARALLEL || ifc == OMP_IF_TASKLOOP;
10872 8 : break;
10873 :
10874 12 : case EXEC_OMP_PARALLEL_MASKED_TASKLOOP_SIMD:
10875 12 : case EXEC_OMP_PARALLEL_MASTER_TASKLOOP_SIMD:
10876 12 : ok = (ifc == OMP_IF_PARALLEL
10877 12 : || ifc == OMP_IF_TASKLOOP
10878 : || ifc == OMP_IF_SIMD);
10879 : break;
10880 :
10881 0 : case EXEC_OMP_SIMD:
10882 0 : case EXEC_OMP_DO_SIMD:
10883 0 : case EXEC_OMP_DISTRIBUTE_SIMD:
10884 0 : case EXEC_OMP_TEAMS_DISTRIBUTE_SIMD:
10885 0 : ok = ifc == OMP_IF_SIMD;
10886 0 : break;
10887 :
10888 1 : case EXEC_OMP_TASK:
10889 1 : ok = ifc == OMP_IF_TASK;
10890 1 : break;
10891 :
10892 5 : case EXEC_OMP_TASKLOOP:
10893 5 : case EXEC_OMP_MASKED_TASKLOOP:
10894 5 : case EXEC_OMP_MASTER_TASKLOOP:
10895 5 : ok = ifc == OMP_IF_TASKLOOP;
10896 5 : break;
10897 :
10898 20 : case EXEC_OMP_TASKLOOP_SIMD:
10899 20 : case EXEC_OMP_MASKED_TASKLOOP_SIMD:
10900 20 : case EXEC_OMP_MASTER_TASKLOOP_SIMD:
10901 20 : ok = ifc == OMP_IF_TASKLOOP || ifc == OMP_IF_SIMD;
10902 20 : break;
10903 :
10904 5 : case EXEC_OMP_TARGET:
10905 5 : case EXEC_OMP_TARGET_TEAMS:
10906 5 : case EXEC_OMP_TARGET_TEAMS_DISTRIBUTE:
10907 5 : case EXEC_OMP_TARGET_TEAMS_LOOP:
10908 5 : ok = ifc == OMP_IF_TARGET;
10909 5 : break;
10910 :
10911 4 : case EXEC_OMP_TARGET_TEAMS_DISTRIBUTE_SIMD:
10912 4 : case EXEC_OMP_TARGET_SIMD:
10913 4 : ok = ifc == OMP_IF_TARGET || ifc == OMP_IF_SIMD;
10914 4 : break;
10915 :
10916 2 : case EXEC_OMP_TARGET_DATA:
10917 2 : ok = ifc == OMP_IF_TARGET_DATA;
10918 2 : break;
10919 :
10920 2 : case EXEC_OMP_TARGET_UPDATE:
10921 2 : ok = ifc == OMP_IF_TARGET_UPDATE;
10922 2 : break;
10923 :
10924 2 : case EXEC_OMP_TARGET_ENTER_DATA:
10925 2 : ok = ifc == OMP_IF_TARGET_ENTER_DATA;
10926 2 : break;
10927 :
10928 2 : case EXEC_OMP_TARGET_EXIT_DATA:
10929 2 : ok = ifc == OMP_IF_TARGET_EXIT_DATA;
10930 2 : break;
10931 :
10932 10 : case EXEC_OMP_TARGET_TEAMS_DISTRIBUTE_PARALLEL_DO:
10933 10 : case EXEC_OMP_TARGET_PARALLEL:
10934 10 : case EXEC_OMP_TARGET_PARALLEL_DO:
10935 10 : case EXEC_OMP_TARGET_PARALLEL_LOOP:
10936 10 : ok = ifc == OMP_IF_TARGET || ifc == OMP_IF_PARALLEL;
10937 10 : break;
10938 :
10939 10 : case EXEC_OMP_TARGET_PARALLEL_DO_SIMD:
10940 10 : case EXEC_OMP_TARGET_TEAMS_DISTRIBUTE_PARALLEL_DO_SIMD:
10941 10 : ok = (ifc == OMP_IF_TARGET
10942 10 : || ifc == OMP_IF_PARALLEL
10943 : || ifc == OMP_IF_SIMD);
10944 : break;
10945 :
10946 : default:
10947 : ok = false;
10948 : break;
10949 : }
10950 119 : if (!ok)
10951 : {
10952 2 : static const char *ifs[] = {
10953 : "CANCEL",
10954 : "PARALLEL",
10955 : "SIMD",
10956 : "TASK",
10957 : "TASKLOOP",
10958 : "TARGET",
10959 : "TARGET DATA",
10960 : "TARGET UPDATE",
10961 : "TARGET ENTER DATA",
10962 : "TARGET EXIT DATA"
10963 : };
10964 2 : gfc_error ("IF clause modifier %s at %L not appropriate for "
10965 : "the current OpenMP construct", ifs[ifc], &expr->where);
10966 : }
10967 : }
10968 :
10969 33190 : if (omp_clauses->self_expr)
10970 : {
10971 177 : gfc_expr *expr = omp_clauses->self_expr;
10972 177 : if (!gfc_resolve_expr (expr)
10973 177 : || expr->ts.type != BT_LOGICAL || expr->rank != 0)
10974 6 : gfc_error ("SELF clause at %L requires a scalar LOGICAL expression",
10975 : &expr->where);
10976 : }
10977 :
10978 33190 : if (omp_clauses->final_expr)
10979 : {
10980 64 : gfc_expr *expr = omp_clauses->final_expr;
10981 64 : if (!gfc_resolve_expr (expr)
10982 64 : || expr->ts.type != BT_LOGICAL || expr->rank != 0)
10983 0 : gfc_error ("FINAL clause at %L requires a scalar LOGICAL expression",
10984 : &expr->where);
10985 : }
10986 33190 : if (omp_clauses->novariants)
10987 : {
10988 9 : gfc_expr *expr = omp_clauses->novariants;
10989 18 : if (!gfc_resolve_expr (expr) || expr->ts.type != BT_LOGICAL
10990 17 : || expr->rank != 0)
10991 1 : gfc_error (
10992 : "NOVARIANTS clause at %L requires a scalar LOGICAL expression",
10993 : &expr->where);
10994 33190 : if_without_mod = true;
10995 : }
10996 33190 : if (omp_clauses->nocontext)
10997 : {
10998 12 : gfc_expr *expr = omp_clauses->nocontext;
10999 24 : if (!gfc_resolve_expr (expr) || expr->ts.type != BT_LOGICAL
11000 23 : || expr->rank != 0)
11001 1 : gfc_error (
11002 : "NOCONTEXT clause at %L requires a scalar LOGICAL expression",
11003 : &expr->where);
11004 33190 : if_without_mod = true;
11005 : }
11006 :
11007 34206 : for (el = omp_clauses->num_threads_list; el; el = el->next)
11008 1016 : resolve_positive_int_expr (el->expr, "NUM_THREADS", true);
11009 :
11010 33190 : if (omp_clauses->dyn_groupprivate)
11011 14 : resolve_nonnegative_int_expr (omp_clauses->dyn_groupprivate,
11012 : "DYN_GROUPPRIVATE", true);
11013 33190 : if (omp_clauses->chunk_size)
11014 : {
11015 510 : gfc_expr *expr = omp_clauses->chunk_size;
11016 510 : if (!gfc_resolve_expr (expr)
11017 510 : || expr->ts.type != BT_INTEGER || expr->rank != 0)
11018 0 : gfc_error ("SCHEDULE clause's chunk_size at %L requires "
11019 : "a scalar INTEGER expression", &expr->where);
11020 510 : else if (expr->expr_type == EXPR_CONSTANT
11021 : && expr->ts.type == BT_INTEGER
11022 485 : && mpz_sgn (expr->value.integer) <= 0)
11023 2 : gfc_warning (OPT_Wopenmp, "INTEGER expression of SCHEDULE clause's "
11024 : "chunk_size at %L must be positive", &expr->where);
11025 : }
11026 33190 : if (omp_clauses->sched_kind != OMP_SCHED_NONE
11027 891 : && omp_clauses->sched_nonmonotonic)
11028 : {
11029 34 : if (omp_clauses->sched_monotonic)
11030 2 : gfc_error ("Both MONOTONIC and NONMONOTONIC schedule modifiers "
11031 : "specified at %L", &code->loc);
11032 32 : else if (omp_clauses->ordered)
11033 4 : gfc_error ("NONMONOTONIC schedule modifier specified with ORDERED "
11034 : "clause at %L", &code->loc);
11035 : }
11036 :
11037 33190 : if (omp_clauses->depobj
11038 33190 : && (!gfc_resolve_expr (omp_clauses->depobj)
11039 118 : || omp_clauses->depobj->ts.type != BT_INTEGER
11040 117 : || omp_clauses->depobj->ts.kind != 2 * gfc_index_integer_kind
11041 116 : || omp_clauses->depobj->rank != 0))
11042 4 : gfc_error ("DEPOBJ in DEPOBJ construct at %L shall be a scalar integer "
11043 4 : "of OMP_DEPEND_KIND kind", &omp_clauses->depobj->where);
11044 :
11045 : /* Check that list items are variables. */
11046 1327600 : for (list = OMP_LIST_FIRST; list < OMP_LIST_NUM;
11047 1294410 : list = gfc_omp_list_type (list + 1))
11048 1340291 : for (n = omp_clauses->lists[list]; n; n = n->next)
11049 : {
11050 45881 : if (!n->sym) /* omp_all_memory. */
11051 47 : continue;
11052 45834 : if (n->sym->attr.flavor == FL_VARIABLE
11053 277 : || n->sym->attr.proc_pointer
11054 236 : || (!code
11055 0 : && !ns->omp_udm_ns
11056 0 : && (!n->sym->attr.dummy || n->sym->ns != ns)))
11057 : {
11058 45598 : if (!code
11059 322 : && !ns->omp_udm_ns
11060 277 : && (!n->sym->attr.dummy || n->sym->ns != ns))
11061 0 : gfc_error ("Variable %qs is not a dummy argument at %L",
11062 : n->sym->name, &n->where);
11063 45598 : continue;
11064 : }
11065 236 : if (n->sym->attr.flavor == FL_PROCEDURE
11066 153 : && n->sym->result == n->sym
11067 138 : && n->sym->attr.function)
11068 : {
11069 138 : if (ns->proc_name == n->sym
11070 44 : || (ns->parent && ns->parent->proc_name == n->sym))
11071 101 : continue;
11072 37 : if (ns->proc_name->attr.entry_master)
11073 : {
11074 32 : gfc_entry_list *el = ns->entries;
11075 51 : for (; el; el = el->next)
11076 51 : if (el->sym == n->sym)
11077 : break;
11078 32 : if (el)
11079 32 : continue;
11080 : }
11081 5 : if (ns->parent
11082 3 : && ns->parent->proc_name->attr.entry_master)
11083 : {
11084 2 : gfc_entry_list *el = ns->parent->entries;
11085 3 : for (; el; el = el->next)
11086 3 : if (el->sym == n->sym)
11087 : break;
11088 2 : if (el)
11089 2 : continue;
11090 : }
11091 : }
11092 101 : if (list == OMP_LIST_MAP
11093 18 : && n->sym->attr.flavor == FL_PARAMETER)
11094 : {
11095 : /* OpenACC since 3.4 permits for Fortran named constants, but
11096 : permits removing then as optimization is not needed and such
11097 : ignore them. Likewise below for FIRSTPRIVATE. */
11098 12 : if (openacc)
11099 10 : gfc_warning (OPT_Wsurprising, "Clause for object %qs at %L is "
11100 : "ignored as parameters need not be copied",
11101 : n->sym->name, &n->where);
11102 : else
11103 2 : gfc_error ("Object %qs is not a variable at %L; parameters"
11104 : " cannot be and need not be mapped", n->sym->name,
11105 : &n->where);
11106 : }
11107 89 : else if (openacc && n->sym->attr.flavor == FL_PARAMETER)
11108 9 : gfc_warning (OPT_Wsurprising, "Clause for object %qs at %L is ignored"
11109 : " as it is a parameter", n->sym->name, &n->where);
11110 80 : else if (list != OMP_LIST_USES_ALLOCATORS)
11111 30 : gfc_error ("Object %qs is not a variable at %L", n->sym->name,
11112 : &n->where);
11113 : }
11114 :
11115 33190 : if (omp_clauses->lists[OMP_LIST_REDUCTION_INSCAN])
11116 : {
11117 69 : locus *loc = &omp_clauses->lists[OMP_LIST_REDUCTION_INSCAN]->where;
11118 69 : if (code->op != EXEC_OMP_DO
11119 : && code->op != EXEC_OMP_SIMD
11120 : && code->op != EXEC_OMP_DO_SIMD
11121 : && code->op != EXEC_OMP_PARALLEL_DO
11122 : && code->op != EXEC_OMP_PARALLEL_DO_SIMD)
11123 23 : gfc_error ("%<inscan%> REDUCTION clause on construct other than DO, "
11124 : "SIMD, DO SIMD, PARALLEL DO, PARALLEL DO SIMD at %L",
11125 : loc);
11126 69 : if (omp_clauses->ordered)
11127 2 : gfc_error ("ORDERED clause specified together with %<inscan%> "
11128 : "REDUCTION clause at %L", loc);
11129 69 : if (omp_clauses->sched_kind != OMP_SCHED_NONE)
11130 3 : gfc_error ("SCHEDULE clause specified together with %<inscan%> "
11131 : "REDUCTION clause at %L", loc);
11132 : }
11133 :
11134 33190 : if (code
11135 32908 : && code->op == EXEC_OMP_INTEROP
11136 63 : && omp_clauses->lists[OMP_LIST_DEPEND])
11137 : {
11138 12 : if (!omp_clauses->lists[OMP_LIST_INIT]
11139 5 : && !omp_clauses->lists[OMP_LIST_USE]
11140 1 : && !omp_clauses->lists[OMP_LIST_DESTROY])
11141 : {
11142 1 : gfc_error ("DEPEND clause at %L requires action clause with "
11143 : "%<targetsync%> interop-type",
11144 : &omp_clauses->lists[OMP_LIST_DEPEND]->where);
11145 : }
11146 22 : for (n = omp_clauses->lists[OMP_LIST_INIT]; n; n = n->next)
11147 12 : if (!n->u.init.targetsync)
11148 : {
11149 2 : gfc_error ("DEPEND clause at %L requires %<targetsync%> "
11150 : "interop-type, lacking it for %qs at %L",
11151 2 : &omp_clauses->lists[OMP_LIST_DEPEND]->where,
11152 2 : n->sym->name, &n->where);
11153 2 : break;
11154 : }
11155 : }
11156 32908 : if (code && (code->op == EXEC_OMP_INTEROP || code->op == EXEC_OMP_DISPATCH))
11157 1085 : for (list = OMP_LIST_INIT; list <= OMP_LIST_INTEROP;
11158 868 : list = gfc_omp_list_type (list + 1))
11159 1123 : for (n = omp_clauses->lists[list]; n; n = n->next)
11160 : {
11161 255 : if (n->sym->ts.type != BT_INTEGER
11162 252 : || n->sym->ts.kind != gfc_index_integer_kind
11163 248 : || n->sym->attr.dimension
11164 243 : || n->sym->attr.flavor != FL_VARIABLE)
11165 16 : gfc_error ("%qs at %L in %qs clause must be a scalar integer "
11166 : "variable of %<omp_interop_kind%> kind", n->sym->name,
11167 : &n->where, clause_names[list]);
11168 255 : if (list != OMP_LIST_USE && list != OMP_LIST_INTEROP
11169 109 : && n->sym->attr.intent == INTENT_IN)
11170 2 : gfc_error ("%qs at %L in %qs clause must be definable",
11171 : n->sym->name, &n->where, clause_names[list]);
11172 : }
11173 :
11174 33190 : resolve_omp_allocate_clauses (code, omp_clauses, ns);
11175 :
11176 33190 : bool has_inscan = false, has_notinscan = false;
11177 1360790 : for (enum gfc_omp_list_type list = OMP_LIST_FIRST; list < OMP_LIST_NUM;
11178 1294410 : list = gfc_omp_list_type (list + 1))
11179 1294410 : if ((n = omp_clauses->lists[list]) != NULL)
11180 : {
11181 29339 : const char *name = clause_names[list];
11182 :
11183 29339 : switch (list)
11184 : {
11185 : case OMP_LIST_COPYIN:
11186 267 : for (; n != NULL; n = n->next)
11187 : {
11188 170 : if (!n->sym->attr.threadprivate)
11189 0 : gfc_error ("Non-THREADPRIVATE object %qs in COPYIN clause"
11190 : " at %L", n->sym->name, &n->where);
11191 : }
11192 : break;
11193 83 : case OMP_LIST_COPYPRIVATE:
11194 83 : if (omp_clauses->nowait)
11195 6 : gfc_error ("NOWAIT clause must not be used with COPYPRIVATE "
11196 : "clause at %L", &n->where);
11197 376 : for (; n != NULL; n = n->next)
11198 : {
11199 293 : if (n->sym->as && n->sym->as->type == AS_ASSUMED_SIZE)
11200 0 : gfc_error ("Assumed size array %qs in COPYPRIVATE clause "
11201 : "at %L", n->sym->name, &n->where);
11202 293 : if (n->sym->attr.pointer && n->sym->attr.intent == INTENT_IN)
11203 1 : gfc_error ("INTENT(IN) POINTER %qs in COPYPRIVATE clause "
11204 : "at %L", n->sym->name, &n->where);
11205 : }
11206 : break;
11207 : case OMP_LIST_SHARED:
11208 2604 : for (; n != NULL; n = n->next)
11209 : {
11210 1642 : if (n->sym->attr.threadprivate)
11211 0 : gfc_error ("THREADPRIVATE object %qs in SHARED clause at "
11212 : "%L", n->sym->name, &n->where);
11213 1642 : if (n->sym->attr.cray_pointee)
11214 1 : gfc_error ("Cray pointee %qs in SHARED clause at %L",
11215 : n->sym->name, &n->where);
11216 1642 : if (n->sym->attr.associate_var)
11217 8 : gfc_error ("Associate name %qs in SHARED clause at %L",
11218 8 : n->sym->attr.select_type_temporary
11219 4 : ? n->sym->assoc->target->symtree->n.sym->name
11220 : : n->sym->name, &n->where);
11221 1642 : if (omp_clauses->detach
11222 1 : && n->sym == omp_clauses->detach->symtree->n.sym)
11223 1 : gfc_error ("DETACH event handle %qs in SHARED clause at %L",
11224 : n->sym->name, &n->where);
11225 : }
11226 : break;
11227 : case OMP_LIST_ALIGNED:
11228 256 : for (; n != NULL; n = n->next)
11229 : {
11230 150 : if (!n->sym->attr.pointer
11231 45 : && !n->sym->attr.allocatable
11232 30 : && !n->sym->attr.cray_pointer
11233 18 : && (n->sym->ts.type != BT_DERIVED
11234 18 : || (n->sym->ts.u.derived->from_intmod
11235 : != INTMOD_ISO_C_BINDING)
11236 18 : || (n->sym->ts.u.derived->intmod_sym_id
11237 : != ISOCBINDING_PTR)))
11238 0 : gfc_error ("%qs in ALIGNED clause must be POINTER, "
11239 : "ALLOCATABLE, Cray pointer or C_PTR at %L",
11240 : n->sym->name, &n->where);
11241 150 : else if (n->expr)
11242 : {
11243 147 : if (!gfc_resolve_expr (n->expr)
11244 147 : || n->expr->ts.type != BT_INTEGER
11245 146 : || n->expr->rank != 0
11246 146 : || n->expr->expr_type != EXPR_CONSTANT
11247 292 : || mpz_sgn (n->expr->value.integer) <= 0)
11248 4 : gfc_error ("%qs in ALIGNED clause at %L requires a scalar"
11249 : " positive constant integer alignment "
11250 4 : "expression", n->sym->name, &n->where);
11251 : }
11252 : }
11253 : break;
11254 : case OMP_LIST_AFFINITY:
11255 : case OMP_LIST_DEPEND:
11256 : case OMP_LIST_MAP:
11257 : case OMP_LIST_TO:
11258 : case OMP_LIST_FROM:
11259 : case OMP_LIST_CACHE:
11260 33236 : for (; n != NULL; n = n->next)
11261 20963 : resolve_omp_clauses_aff_dep_map_cache (code, n, name, list,
11262 : omp_clauses, openacc);
11263 : break;
11264 : case OMP_LIST_IS_DEVICE_PTR:
11265 : last = NULL;
11266 377 : for (n = omp_clauses->lists[list]; n != NULL; )
11267 : {
11268 257 : if ((n->sym->ts.type != BT_DERIVED
11269 71 : || !n->sym->ts.u.derived->ts.is_iso_c
11270 71 : || (n->sym->ts.u.derived->intmod_sym_id
11271 : != ISOCBINDING_PTR))
11272 187 : && code->op == EXEC_OMP_DISPATCH)
11273 : /* Non-TARGET (i.e. DISPATCH) requires a C_PTR. */
11274 3 : gfc_error ("List item %qs in %s clause at %L must be of "
11275 : "TYPE(C_PTR)", n->sym->name, name, &n->where);
11276 254 : else if (n->sym->ts.type != BT_DERIVED
11277 70 : || !n->sym->ts.u.derived->ts.is_iso_c
11278 70 : || (n->sym->ts.u.derived->intmod_sym_id
11279 : != ISOCBINDING_PTR))
11280 : {
11281 : /* For TARGET, non-C_PTR are deprecated and handled as
11282 : has_device_addr. */
11283 184 : gfc_warning (OPT_Wdeprecated_openmp,
11284 : "Non-C_PTR type argument at %L is deprecated, "
11285 : "use HAS_DEVICE_ADDR", &n->where);
11286 184 : gfc_omp_namelist *n2 = n;
11287 184 : n = n->next;
11288 184 : if (last)
11289 0 : last->next = n;
11290 : else
11291 184 : omp_clauses->lists[list] = n;
11292 184 : n2->next = omp_clauses->lists[OMP_LIST_HAS_DEVICE_ADDR];
11293 184 : omp_clauses->lists[OMP_LIST_HAS_DEVICE_ADDR] = n2;
11294 184 : continue;
11295 184 : }
11296 73 : last = n;
11297 73 : n = n->next;
11298 : }
11299 : break;
11300 : case OMP_LIST_HAS_DEVICE_ADDR:
11301 : case OMP_LIST_USE_DEVICE_ADDR:
11302 : break;
11303 : case OMP_LIST_USE_DEVICE_PTR:
11304 : /* Non-C_PTR are deprecated and handled as use_device_ADDR. */
11305 : last = NULL;
11306 475 : for (n = omp_clauses->lists[list]; n != NULL; )
11307 : {
11308 312 : gfc_omp_namelist *n2 = n;
11309 312 : if (n->sym->ts.type != BT_DERIVED
11310 18 : || !n->sym->ts.u.derived->ts.is_iso_c)
11311 : {
11312 294 : gfc_warning (OPT_Wdeprecated_openmp,
11313 : "Non-C_PTR type argument at %L is "
11314 : "deprecated, use USE_DEVICE_ADDR", &n->where);
11315 294 : n = n->next;
11316 294 : if (last)
11317 0 : last->next = n;
11318 : else
11319 294 : omp_clauses->lists[list] = n;
11320 294 : n2->next = omp_clauses->lists[OMP_LIST_USE_DEVICE_ADDR];
11321 294 : omp_clauses->lists[OMP_LIST_USE_DEVICE_ADDR] = n2;
11322 294 : continue;
11323 : }
11324 18 : last = n;
11325 18 : n = n->next;
11326 : }
11327 : break;
11328 65 : case OMP_LIST_USES_ALLOCATORS:
11329 65 : {
11330 65 : if (n != NULL
11331 65 : && n->u.memspace_sym
11332 20 : && (n->u.memspace_sym->attr.flavor != FL_PARAMETER
11333 18 : || n->u.memspace_sym->ts.type != BT_INTEGER
11334 18 : || n->u.memspace_sym->ts.kind != gfc_c_intptr_kind
11335 18 : || n->u.memspace_sym->attr.dimension
11336 18 : || (!startswith (n->u.memspace_sym->name, "omp_")
11337 0 : && !startswith (n->u.memspace_sym->name, "ompx_"))
11338 18 : || !endswith (n->u.memspace_sym->name, "_mem_space")))
11339 3 : gfc_error ("Memspace %qs at %L in USES_ALLOCATORS must be "
11340 : "a predefined memory space",
11341 : n->u.memspace_sym->name, &n->where);
11342 180 : for (; n != NULL; n = n->next)
11343 : {
11344 122 : if (n->sym->ts.type != BT_INTEGER
11345 121 : || n->sym->ts.kind != gfc_c_intptr_kind
11346 120 : || n->sym->attr.dimension)
11347 3 : gfc_error ("Allocator %qs at %L in USES_ALLOCATORS must "
11348 : "be a scalar integer of kind "
11349 : "%<omp_allocator_handle_kind%>", n->sym->name,
11350 : &n->where);
11351 119 : else if (n->sym->attr.flavor != FL_VARIABLE
11352 50 : && strcmp (n->sym->name, "omp_null_allocator") != 0
11353 165 : && ((!startswith (n->sym->name, "omp_")
11354 1 : && !startswith (n->sym->name, "ompx_"))
11355 45 : || !endswith (n->sym->name, "_mem_alloc")))
11356 2 : gfc_error ("Allocator %qs at %L in USES_ALLOCATORS must "
11357 : "either a variable or a predefined allocator",
11358 : n->sym->name, &n->where);
11359 117 : else if ((n->u.memspace_sym || n->u2.traits_sym)
11360 61 : && n->sym->attr.flavor != FL_VARIABLE)
11361 3 : gfc_error ("A memory space or traits array may not be "
11362 : "specified for predefined allocator %qs at %L",
11363 : n->sym->name, &n->where);
11364 122 : if (n->u2.traits_sym
11365 50 : && (n->u2.traits_sym->attr.flavor != FL_PARAMETER
11366 47 : || !n->u2.traits_sym->attr.dimension
11367 45 : || n->u2.traits_sym->as->rank != 1
11368 45 : || n->u2.traits_sym->ts.type != BT_DERIVED
11369 43 : || strcmp (n->u2.traits_sym->ts.u.derived->name,
11370 : "omp_alloctrait") != 0))
11371 : {
11372 7 : gfc_error ("Traits array %qs in USES_ALLOCATORS %L must "
11373 : "be a one-dimensional named constant array of "
11374 : "type %<omp_alloctrait%>",
11375 : n->u2.traits_sym->name, &n->where);
11376 7 : break;
11377 : }
11378 : }
11379 : break;
11380 : }
11381 : default:
11382 34820 : for (; n != NULL; n = n->next)
11383 : {
11384 20405 : if (n->sym == NULL)
11385 : {
11386 26 : gcc_assert (code->op == EXEC_OMP_ALLOCATORS
11387 : || code->op == EXEC_OMP_ALLOCATE);
11388 26 : continue;
11389 : }
11390 20379 : bool bad = false;
11391 20379 : bool is_reduction = (list == OMP_LIST_REDUCTION
11392 : || list == OMP_LIST_REDUCTION_INSCAN
11393 : || list == OMP_LIST_REDUCTION_TASK
11394 : || list == OMP_LIST_IN_REDUCTION
11395 20379 : || list == OMP_LIST_TASK_REDUCTION);
11396 20379 : if (list == OMP_LIST_REDUCTION_INSCAN)
11397 : has_inscan = true;
11398 20307 : else if (is_reduction)
11399 4739 : has_notinscan = true;
11400 20379 : if (has_inscan && has_notinscan && is_reduction)
11401 : {
11402 3 : gfc_error ("%<inscan%> and non-%<inscan%> %<reduction%> "
11403 : "clauses on the same construct at %L",
11404 : &n->where);
11405 3 : break;
11406 : }
11407 20376 : if (n->sym->attr.threadprivate)
11408 1 : gfc_error ("THREADPRIVATE object %qs in %s clause at %L",
11409 : n->sym->name, name, &n->where);
11410 20376 : if (n->sym->attr.cray_pointee)
11411 14 : gfc_error ("Cray pointee %qs in %s clause at %L",
11412 : n->sym->name, name, &n->where);
11413 20376 : if (n->sym->attr.associate_var)
11414 22 : gfc_error ("Associate name %qs in %s clause at %L",
11415 22 : n->sym->attr.select_type_temporary
11416 4 : ? n->sym->assoc->target->symtree->n.sym->name
11417 : : n->sym->name, name, &n->where);
11418 20376 : if (list != OMP_LIST_PRIVATE && is_reduction)
11419 : {
11420 4808 : if (n->sym->attr.proc_pointer)
11421 1 : gfc_error ("Procedure pointer %qs in %s clause at %L",
11422 : n->sym->name, name, &n->where);
11423 4808 : if (n->sym->attr.pointer)
11424 3 : gfc_error ("POINTER object %qs in %s clause at %L",
11425 : n->sym->name, name, &n->where);
11426 4808 : if (n->sym->attr.cray_pointer)
11427 5 : gfc_error ("Cray pointer %qs in %s clause at %L",
11428 : n->sym->name, name, &n->where);
11429 : }
11430 20376 : if (code
11431 20376 : && (oacc_is_loop (code)
11432 : || code->op == EXEC_OACC_PARALLEL
11433 : || code->op == EXEC_OACC_SERIAL))
11434 8741 : check_array_not_assumed (n->sym, n->where, name);
11435 11635 : else if (list != OMP_LIST_UNIFORM
11436 11518 : && n->sym->as && n->sym->as->type == AS_ASSUMED_SIZE)
11437 2 : gfc_error ("Assumed size array %qs in %s clause at %L",
11438 : n->sym->name, name, &n->where);
11439 20376 : if (n->sym->attr.in_namelist && !is_reduction)
11440 0 : gfc_error ("Variable %qs in %s clause is used in "
11441 : "NAMELIST statement at %L",
11442 : n->sym->name, name, &n->where);
11443 20376 : if (n->sym->attr.pointer && n->sym->attr.intent == INTENT_IN)
11444 3 : switch (list)
11445 : {
11446 3 : case OMP_LIST_PRIVATE:
11447 3 : case OMP_LIST_LASTPRIVATE:
11448 3 : case OMP_LIST_LINEAR:
11449 : /* case OMP_LIST_REDUCTION: */
11450 3 : gfc_error ("INTENT(IN) POINTER %qs in %s clause at %L",
11451 : n->sym->name, name, &n->where);
11452 3 : break;
11453 : default:
11454 : break;
11455 : }
11456 20376 : if (omp_clauses->detach
11457 3 : && (list == OMP_LIST_PRIVATE
11458 : || list == OMP_LIST_FIRSTPRIVATE
11459 : || list == OMP_LIST_LASTPRIVATE)
11460 3 : && n->sym == omp_clauses->detach->symtree->n.sym)
11461 1 : gfc_error ("DETACH event handle %qs in %s clause at %L",
11462 : n->sym->name, name, &n->where);
11463 :
11464 20376 : if (!openacc
11465 20376 : && (list == OMP_LIST_PRIVATE
11466 20376 : || list == OMP_LIST_FIRSTPRIVATE)
11467 4714 : && ((n->sym->ts.type == BT_DERIVED
11468 158 : && n->sym->ts.u.derived->attr.alloc_comp)
11469 4604 : || n->sym->ts.type == BT_CLASS))
11470 170 : switch (code->op)
11471 : {
11472 8 : case EXEC_OMP_TARGET:
11473 8 : case EXEC_OMP_TARGET_PARALLEL:
11474 8 : case EXEC_OMP_TARGET_PARALLEL_DO:
11475 8 : case EXEC_OMP_TARGET_PARALLEL_DO_SIMD:
11476 8 : case EXEC_OMP_TARGET_PARALLEL_LOOP:
11477 8 : case EXEC_OMP_TARGET_SIMD:
11478 8 : case EXEC_OMP_TARGET_TEAMS:
11479 8 : case EXEC_OMP_TARGET_TEAMS_DISTRIBUTE:
11480 8 : case EXEC_OMP_TARGET_TEAMS_DISTRIBUTE_PARALLEL_DO:
11481 8 : case EXEC_OMP_TARGET_TEAMS_DISTRIBUTE_PARALLEL_DO_SIMD:
11482 8 : case EXEC_OMP_TARGET_TEAMS_DISTRIBUTE_SIMD:
11483 8 : case EXEC_OMP_TARGET_TEAMS_LOOP:
11484 8 : if (n->sym->ts.type == BT_DERIVED
11485 2 : && n->sym->ts.u.derived->attr.alloc_comp)
11486 3 : gfc_error ("Sorry, list item %qs at %L with allocatable"
11487 : " components is not yet supported in %s "
11488 : "clause", n->sym->name, &n->where,
11489 : list == OMP_LIST_PRIVATE ? "PRIVATE"
11490 : : "FIRSTPRIVATE");
11491 : else
11492 9 : gfc_error ("Polymorphic list item %qs at %L in %s "
11493 : "clause has unspecified behavior and "
11494 : "unsupported", n->sym->name, &n->where,
11495 : list == OMP_LIST_PRIVATE ? "PRIVATE"
11496 : : "FIRSTPRIVATE");
11497 : break;
11498 : default:
11499 : break;
11500 : }
11501 :
11502 20376 : switch (list)
11503 : {
11504 104 : case OMP_LIST_REDUCTION_TASK:
11505 104 : if (code
11506 104 : && (code->op == EXEC_OMP_LOOP
11507 : || code->op == EXEC_OMP_TASKLOOP
11508 : || code->op == EXEC_OMP_TASKLOOP_SIMD
11509 : || code->op == EXEC_OMP_MASKED_TASKLOOP
11510 : || code->op == EXEC_OMP_MASKED_TASKLOOP_SIMD
11511 : || code->op == EXEC_OMP_MASTER_TASKLOOP
11512 : || code->op == EXEC_OMP_MASTER_TASKLOOP_SIMD
11513 : || code->op == EXEC_OMP_PARALLEL_LOOP
11514 : || code->op == EXEC_OMP_PARALLEL_MASKED_TASKLOOP
11515 : || code->op == EXEC_OMP_PARALLEL_MASKED_TASKLOOP_SIMD
11516 : || code->op == EXEC_OMP_PARALLEL_MASTER_TASKLOOP
11517 : || code->op == EXEC_OMP_PARALLEL_MASTER_TASKLOOP_SIMD
11518 : || code->op == EXEC_OMP_TARGET_PARALLEL_LOOP
11519 : || code->op == EXEC_OMP_TARGET_TEAMS_LOOP
11520 : || code->op == EXEC_OMP_TEAMS
11521 : || code->op == EXEC_OMP_TEAMS_DISTRIBUTE
11522 : || code->op == EXEC_OMP_TEAMS_LOOP))
11523 : {
11524 17 : gfc_error ("Only DEFAULT permitted as reduction-"
11525 : "modifier in REDUCTION clause at %L",
11526 : &n->where);
11527 17 : break;
11528 : }
11529 4791 : gcc_fallthrough ();
11530 4791 : case OMP_LIST_REDUCTION:
11531 4791 : case OMP_LIST_IN_REDUCTION:
11532 4791 : case OMP_LIST_TASK_REDUCTION:
11533 4791 : case OMP_LIST_REDUCTION_INSCAN:
11534 4791 : switch (n->u.reduction_op)
11535 : {
11536 2656 : case OMP_REDUCTION_PLUS:
11537 2656 : case OMP_REDUCTION_TIMES:
11538 2656 : case OMP_REDUCTION_MINUS:
11539 2656 : if (!gfc_numeric_ts (&n->sym->ts))
11540 : bad = true;
11541 : break;
11542 1112 : case OMP_REDUCTION_AND:
11543 1112 : case OMP_REDUCTION_OR:
11544 1112 : case OMP_REDUCTION_EQV:
11545 1112 : case OMP_REDUCTION_NEQV:
11546 1112 : if (n->sym->ts.type != BT_LOGICAL)
11547 : bad = true;
11548 : break;
11549 480 : case OMP_REDUCTION_MAX:
11550 480 : case OMP_REDUCTION_MIN:
11551 480 : if (n->sym->ts.type != BT_INTEGER
11552 212 : && n->sym->ts.type != BT_REAL)
11553 : bad = true;
11554 : break;
11555 192 : case OMP_REDUCTION_IAND:
11556 192 : case OMP_REDUCTION_IOR:
11557 192 : case OMP_REDUCTION_IEOR:
11558 192 : if (n->sym->ts.type != BT_INTEGER)
11559 : bad = true;
11560 : break;
11561 : case OMP_REDUCTION_USER:
11562 : bad = true;
11563 : break;
11564 : default:
11565 : break;
11566 : }
11567 : if (!bad)
11568 4216 : n->u2.udr = NULL;
11569 : else
11570 : {
11571 575 : const char *udr_name = NULL;
11572 575 : if (n->u2.udr)
11573 : {
11574 471 : udr_name = n->u2.udr->udr->name;
11575 471 : n->u2.udr->udr
11576 942 : = gfc_find_omp_udr (NULL, udr_name,
11577 471 : &n->sym->ts);
11578 471 : if (n->u2.udr->udr == NULL)
11579 : {
11580 0 : free (n->u2.udr);
11581 0 : n->u2.udr = NULL;
11582 : }
11583 : }
11584 575 : if (n->u2.udr == NULL)
11585 : {
11586 104 : if (udr_name == NULL)
11587 104 : switch (n->u.reduction_op)
11588 : {
11589 50 : case OMP_REDUCTION_PLUS:
11590 50 : case OMP_REDUCTION_TIMES:
11591 50 : case OMP_REDUCTION_MINUS:
11592 50 : case OMP_REDUCTION_AND:
11593 50 : case OMP_REDUCTION_OR:
11594 50 : case OMP_REDUCTION_EQV:
11595 50 : case OMP_REDUCTION_NEQV:
11596 50 : udr_name = gfc_op2string ((gfc_intrinsic_op)
11597 : n->u.reduction_op);
11598 50 : break;
11599 : case OMP_REDUCTION_MAX:
11600 : udr_name = "max";
11601 : break;
11602 9 : case OMP_REDUCTION_MIN:
11603 9 : udr_name = "min";
11604 9 : break;
11605 12 : case OMP_REDUCTION_IAND:
11606 12 : udr_name = "iand";
11607 12 : break;
11608 12 : case OMP_REDUCTION_IOR:
11609 12 : udr_name = "ior";
11610 12 : break;
11611 9 : case OMP_REDUCTION_IEOR:
11612 9 : udr_name = "ieor";
11613 9 : break;
11614 0 : default:
11615 0 : gcc_unreachable ();
11616 : }
11617 104 : gfc_error ("!$OMP DECLARE REDUCTION %s not found "
11618 : "for type %s at %L", udr_name,
11619 104 : gfc_typename (&n->sym->ts), &n->where);
11620 : }
11621 : else
11622 : {
11623 471 : gfc_omp_udr *udr = n->u2.udr->udr;
11624 471 : n->u.reduction_op = OMP_REDUCTION_USER;
11625 471 : n->u2.udr->combiner
11626 942 : = resolve_omp_udr_clause (n, udr->combiner_ns,
11627 471 : udr->omp_out,
11628 471 : udr->omp_in);
11629 471 : if (udr->initializer_ns)
11630 331 : n->u2.udr->initializer
11631 331 : = resolve_omp_udr_clause (n,
11632 : udr->initializer_ns,
11633 331 : udr->omp_priv,
11634 331 : udr->omp_orig);
11635 : }
11636 : }
11637 : break;
11638 887 : case OMP_LIST_LINEAR:
11639 887 : if (code)
11640 : {
11641 727 : bool is_worksharing_for = false;
11642 727 : switch (code->op)
11643 : {
11644 54 : case EXEC_OMP_DO:
11645 54 : case EXEC_OMP_PARALLEL_DO:
11646 54 : case EXEC_OMP_DISTRIBUTE_PARALLEL_DO:
11647 54 : case EXEC_OMP_TARGET_PARALLEL_DO:
11648 54 : case EXEC_OMP_TEAMS_DISTRIBUTE_PARALLEL_DO:
11649 54 : case EXEC_OMP_TARGET_TEAMS_DISTRIBUTE_PARALLEL_DO:
11650 54 : is_worksharing_for = true;
11651 54 : break;
11652 : default:
11653 : break;
11654 : }
11655 :
11656 54 : if (is_worksharing_for
11657 54 : && (n->sym->attr.dimension
11658 53 : || n->sym->attr.allocatable))
11659 : {
11660 1 : if (n->sym->attr.allocatable)
11661 0 : gfc_error ("Sorry, ALLOCATABLE object %qs in "
11662 : "LINEAR clause on worksharing-loop "
11663 : "construct at %L is not yet supported",
11664 : n->sym->name, &n->where);
11665 : else
11666 1 : gfc_error ("Sorry, array %qs in LINEAR clause "
11667 : "on worksharing-loop construct at %L "
11668 : "is not yet supported",
11669 : n->sym->name, &n->where);
11670 : break;
11671 : }
11672 : }
11673 :
11674 726 : if (code
11675 726 : && n->u.linear.op != OMP_LINEAR_DEFAULT
11676 23 : && n->u.linear.op != linear_op)
11677 : {
11678 23 : if (n->u.linear.old_modifier)
11679 : {
11680 9 : gfc_error ("LINEAR clause modifier used on DO or "
11681 : "SIMD construct at %L", &n->where);
11682 9 : linear_op = n->u.linear.op;
11683 : }
11684 14 : else if (n->u.linear.op != OMP_LINEAR_VAL)
11685 : {
11686 6 : gfc_error ("LINEAR clause modifier other than VAL "
11687 : "used on DO or SIMD construct at %L",
11688 : &n->where);
11689 6 : linear_op = n->u.linear.op;
11690 : }
11691 : }
11692 863 : else if (n->u.linear.op != OMP_LINEAR_REF
11693 813 : && n->sym->ts.type != BT_INTEGER)
11694 1 : gfc_error ("LINEAR variable %qs must be INTEGER "
11695 : "at %L", n->sym->name, &n->where);
11696 862 : else if ((n->u.linear.op == OMP_LINEAR_REF
11697 812 : || n->u.linear.op == OMP_LINEAR_UVAL)
11698 61 : && n->sym->attr.value)
11699 0 : gfc_error ("LINEAR dummy argument %qs with VALUE "
11700 : "attribute with %s modifier at %L",
11701 : n->sym->name,
11702 : n->u.linear.op == OMP_LINEAR_REF
11703 : ? "REF" : "UVAL", &n->where);
11704 862 : else if (n->expr)
11705 : {
11706 843 : gfc_expr *expr = n->expr;
11707 843 : if (!gfc_resolve_expr (expr)
11708 843 : || expr->ts.type != BT_INTEGER
11709 1686 : || expr->rank != 0)
11710 0 : gfc_error ("%qs in LINEAR clause at %L requires "
11711 : "a scalar integer linear-step expression",
11712 0 : n->sym->name, &n->where);
11713 843 : else if (!code && expr->expr_type != EXPR_CONSTANT)
11714 : {
11715 11 : if (expr->expr_type == EXPR_VARIABLE
11716 7 : && expr->symtree->n.sym->attr.dummy
11717 6 : && expr->symtree->n.sym->ns == ns)
11718 : {
11719 6 : gfc_omp_namelist *n2;
11720 6 : for (n2 = omp_clauses->lists[OMP_LIST_UNIFORM];
11721 6 : n2; n2 = n2->next)
11722 6 : if (n2->sym == expr->symtree->n.sym)
11723 : break;
11724 6 : if (n2)
11725 : break;
11726 : }
11727 5 : gfc_error ("%qs in LINEAR clause at %L requires "
11728 : "a constant integer linear-step "
11729 : "expression or dummy argument "
11730 : "specified in UNIFORM clause",
11731 5 : n->sym->name, &n->where);
11732 : }
11733 : }
11734 : break;
11735 : /* Workaround for PR middle-end/26316, nothing really needs
11736 : to be done here for OMP_LIST_PRIVATE. */
11737 9400 : case OMP_LIST_PRIVATE:
11738 9400 : gcc_assert (code && code->op != EXEC_NOP);
11739 : break;
11740 98 : case OMP_LIST_USE_DEVICE:
11741 98 : if (n->sym->attr.allocatable
11742 98 : || (n->sym->ts.type == BT_CLASS && CLASS_DATA (n->sym)
11743 0 : && CLASS_DATA (n->sym)->attr.allocatable))
11744 0 : gfc_error ("ALLOCATABLE object %qs in %s clause at %L",
11745 : n->sym->name, name, &n->where);
11746 98 : if (n->sym->ts.type == BT_CLASS
11747 0 : && CLASS_DATA (n->sym)
11748 0 : && CLASS_DATA (n->sym)->attr.class_pointer)
11749 0 : gfc_error ("POINTER object %qs of polymorphic type in "
11750 : "%s clause at %L", n->sym->name, name,
11751 : &n->where);
11752 98 : if (n->sym->attr.cray_pointer)
11753 2 : gfc_error ("Cray pointer object %qs in %s clause at %L",
11754 : n->sym->name, name, &n->where);
11755 96 : else if (n->sym->attr.cray_pointee)
11756 2 : gfc_error ("Cray pointee object %qs in %s clause at %L",
11757 : n->sym->name, name, &n->where);
11758 94 : else if (n->sym->attr.flavor == FL_VARIABLE
11759 93 : && !n->sym->as
11760 54 : && !n->sym->attr.pointer)
11761 13 : gfc_error ("%s clause variable %qs at %L is neither "
11762 : "a POINTER nor an array", name,
11763 : n->sym->name, &n->where);
11764 : /* FALLTHRU */
11765 98 : case OMP_LIST_DEVICE_RESIDENT:
11766 98 : check_symbol_not_pointer (n->sym, n->where, name);
11767 98 : check_array_not_assumed (n->sym, n->where, name);
11768 98 : break;
11769 : default:
11770 : break;
11771 : }
11772 : }
11773 : break;
11774 : }
11775 : }
11776 : /* OpenMP 5.1: use_device_ptr acts like use_device_addr, except for
11777 : type(c_ptr). */
11778 33190 : if (omp_clauses->lists[OMP_LIST_USE_DEVICE_PTR])
11779 : {
11780 9 : gfc_omp_namelist *n_prev, *n_next, *n_addr;
11781 9 : n_addr = omp_clauses->lists[OMP_LIST_USE_DEVICE_ADDR];
11782 28 : for (; n_addr && n_addr->next; n_addr = n_addr->next)
11783 : ;
11784 : n_prev = NULL;
11785 : n = omp_clauses->lists[OMP_LIST_USE_DEVICE_PTR];
11786 27 : while (n)
11787 : {
11788 18 : n_next = n->next;
11789 18 : if (n->sym->ts.type != BT_DERIVED
11790 18 : || n->sym->ts.u.derived->ts.f90_type != BT_VOID)
11791 : {
11792 0 : n->next = NULL;
11793 0 : if (n_addr)
11794 0 : n_addr->next = n;
11795 : else
11796 0 : omp_clauses->lists[OMP_LIST_USE_DEVICE_ADDR] = n;
11797 0 : n_addr = n;
11798 0 : if (n_prev)
11799 0 : n_prev->next = n_next;
11800 : else
11801 0 : omp_clauses->lists[OMP_LIST_USE_DEVICE_PTR] = n_next;
11802 : }
11803 : else
11804 : n_prev = n;
11805 18 : n = n_next;
11806 : }
11807 : }
11808 33190 : if (omp_clauses->safelen_expr)
11809 93 : resolve_positive_int_expr (omp_clauses->safelen_expr, "SAFELEN", false);
11810 33190 : if (omp_clauses->simdlen_expr)
11811 143 : resolve_positive_int_expr (omp_clauses->simdlen_expr, "SIMDLEN", false);
11812 33190 : if (omp_clauses->simdlen_divisor
11813 33190 : && (!gfc_resolve_expr (omp_clauses->simdlen_divisor)
11814 11 : || omp_clauses->simdlen_divisor->ts.type != BT_INTEGER
11815 11 : || omp_clauses->simdlen_divisor->rank != 0
11816 11 : || omp_clauses->simdlen_divisor->expr_type != EXPR_CONSTANT
11817 10 : || mpz_sgn (omp_clauses->simdlen_divisor->value.integer) <= 0))
11818 2 : gfc_error ("Divisor expression at %L of the SCALED modifier to SIMDLEN must"
11819 : " be a positive scalar constant integer expression",
11820 2 : &omp_clauses->simdlen_divisor->where);
11821 : /* Check that safelen >= simdlen * scaled; however, scaled is
11822 : unknown, hence, assume scaled == 1 as conservative estimate.
11823 : we need to repeat some const check as the program still continues
11824 : after the error diagnostic above. */
11825 33190 : if (omp_clauses->safelen_expr && omp_clauses->simdlen_expr
11826 36 : && omp_clauses->safelen_expr->expr_type == EXPR_CONSTANT
11827 36 : && omp_clauses->simdlen_expr->expr_type == EXPR_CONSTANT
11828 36 : && omp_clauses->safelen_expr->rank == 0
11829 36 : && omp_clauses->simdlen_expr->rank == 0
11830 36 : && omp_clauses->safelen_expr->ts.type == BT_INTEGER
11831 36 : && omp_clauses->simdlen_expr->ts.type == BT_INTEGER
11832 36 : && mpz_cmp (omp_clauses->safelen_expr->value.integer,
11833 36 : omp_clauses->simdlen_expr->value.integer) < 0)
11834 0 : gfc_error ("SIMDLEN at %L must be smaller or equal to SAFELEN at %L",
11835 : &omp_clauses->simdlen_expr->where,
11836 : &omp_clauses->safelen_expr->where);
11837 33388 : for (el = omp_clauses->num_teams_list; el; el = el->next)
11838 198 : resolve_positive_int_expr (el->expr, "NUM_TEAMS", true);
11839 33190 : if (omp_clauses->num_teams_list
11840 157 : && omp_clauses->num_teams_list->next
11841 34 : && !omp_clauses->num_teams_dims
11842 27 : && omp_clauses->num_teams_list->expr->expr_type == EXPR_CONSTANT
11843 13 : && omp_clauses->num_teams_list->next->expr->expr_type == EXPR_CONSTANT
11844 13 : && mpz_cmp (omp_clauses->num_teams_list->expr->value.integer,
11845 13 : omp_clauses->num_teams_list->next->expr->value.integer) > 0)
11846 2 : gfc_warning (OPT_Wopenmp, "NUM_TEAMS lower bound at %L larger than upper "
11847 : "bound at %L", &omp_clauses->num_teams_list->expr->where,
11848 : &omp_clauses->num_teams_list->next->expr->where);
11849 33190 : if (omp_clauses->device)
11850 334 : resolve_scalar_int_expr (omp_clauses->device, "DEVICE");
11851 33190 : if (omp_clauses->filter)
11852 42 : resolve_nonnegative_int_expr (omp_clauses->filter, "FILTER", true);
11853 33190 : if (omp_clauses->hint)
11854 : {
11855 47 : if (!gfc_resolve_expr (omp_clauses->hint)
11856 47 : || omp_clauses->hint->rank != 0
11857 47 : || omp_clauses->hint->ts.type != BT_INTEGER
11858 45 : || omp_clauses->hint->expr_type != EXPR_CONSTANT
11859 90 : || mpz_sgn (omp_clauses->hint->value.integer) < 0)
11860 5 : gfc_error ("Value of HINT clause at %L shall be a valid "
11861 5 : "constant hint expression", &omp_clauses->hint->where);
11862 : }
11863 33190 : if (omp_clauses->priority)
11864 35 : resolve_nonnegative_int_expr (omp_clauses->priority, "PRIORITY", true);
11865 33190 : if (omp_clauses->dist_chunk_size)
11866 : {
11867 83 : gfc_expr *expr = omp_clauses->dist_chunk_size;
11868 83 : if (!gfc_resolve_expr (expr)
11869 83 : || expr->ts.type != BT_INTEGER || expr->rank != 0)
11870 0 : gfc_error ("DIST_SCHEDULE clause's chunk_size at %L requires "
11871 : "a scalar INTEGER expression", &expr->where);
11872 : }
11873 33316 : for (el = omp_clauses->thread_limit_list; el; el = el->next)
11874 126 : resolve_positive_int_expr (el->expr, "THREAD_LIMIT", true);
11875 33190 : if (omp_clauses->grainsize)
11876 34 : resolve_positive_int_expr (omp_clauses->grainsize, "GRAINSIZE", true);
11877 33190 : if (omp_clauses->num_tasks)
11878 26 : resolve_positive_int_expr (omp_clauses->num_tasks, "NUM_TASKS", true);
11879 33190 : if (omp_clauses->grainsize && omp_clauses->num_tasks)
11880 1 : gfc_error ("%<GRAINSIZE%> clause at %L must not be used together with "
11881 : "%<NUM_TASKS%> clause", &omp_clauses->grainsize->where);
11882 33190 : if (omp_clauses->lists[OMP_LIST_REDUCTION] && omp_clauses->nogroup)
11883 1 : gfc_error ("%<REDUCTION%> clause at %L must not be used together with "
11884 : "%<NOGROUP%> clause",
11885 : &omp_clauses->lists[OMP_LIST_REDUCTION]->where);
11886 33190 : if (omp_clauses->full && omp_clauses->partial)
11887 0 : gfc_error ("%<FULL%> clause at %C must not be used together with "
11888 : "%<PARTIAL%> clause");
11889 33190 : if (omp_clauses->async)
11890 610 : if (omp_clauses->async_expr)
11891 610 : resolve_scalar_int_expr (omp_clauses->async_expr, "ASYNC");
11892 33190 : if (omp_clauses->device_num_expr)
11893 105 : resolve_scalar_int_expr (omp_clauses->device_num_expr, "DEVICE_NUM");
11894 33190 : if (code && code->op == EXEC_OACC_SET
11895 121 : && !omp_clauses->device_num_expr
11896 52 : && !omp_clauses->oacc_device_type_present)
11897 2 : gfc_error ("At least one of the clauses %<DEVICE_TYPE%> and %<DEVICE_NUM%> "
11898 : "should be present in %<SET%> directive at %L", &code->loc);
11899 33190 : if (omp_clauses->num_gangs_expr)
11900 682 : resolve_positive_int_expr (omp_clauses->num_gangs_expr, "NUM_GANGS", true);
11901 33190 : if (omp_clauses->num_workers_expr)
11902 599 : resolve_positive_int_expr (omp_clauses->num_workers_expr, "NUM_WORKERS",
11903 : true);
11904 33190 : if (omp_clauses->vector_length_expr)
11905 569 : resolve_positive_int_expr (omp_clauses->vector_length_expr,
11906 : "VECTOR_LENGTH", true);
11907 33190 : if (omp_clauses->gang_num_expr)
11908 114 : resolve_positive_int_expr (omp_clauses->gang_num_expr, "GANG", true);
11909 33190 : if (omp_clauses->gang_static_expr)
11910 94 : resolve_positive_int_expr (omp_clauses->gang_static_expr, "GANG", true);
11911 33190 : if (omp_clauses->worker_expr)
11912 101 : resolve_positive_int_expr (omp_clauses->worker_expr, "WORKER", true);
11913 33190 : if (omp_clauses->vector_expr)
11914 132 : resolve_positive_int_expr (omp_clauses->vector_expr, "VECTOR", true);
11915 33529 : for (el = omp_clauses->wait_list; el; el = el->next)
11916 339 : resolve_scalar_int_expr (el->expr, "WAIT");
11917 33190 : if (omp_clauses->collapse && omp_clauses->tile_list)
11918 4 : gfc_error ("Incompatible use of TILE and COLLAPSE at %L", &code->loc);
11919 33190 : if (omp_clauses->message)
11920 : {
11921 58 : gfc_expr *expr = omp_clauses->message;
11922 58 : if (!gfc_resolve_expr (expr)
11923 58 : || expr->ts.kind != gfc_default_character_kind
11924 113 : || expr->ts.type != BT_CHARACTER || expr->rank != 0)
11925 4 : gfc_error ("MESSAGE clause at %L requires a scalar default-kind "
11926 : "CHARACTER expression", &expr->where);
11927 : }
11928 33190 : if (!openacc
11929 33190 : && code
11930 19913 : && omp_clauses->lists[OMP_LIST_MAP] == NULL
11931 16116 : && omp_clauses->lists[OMP_LIST_USE_DEVICE_PTR] == NULL
11932 16113 : && omp_clauses->lists[OMP_LIST_USE_DEVICE_ADDR] == NULL)
11933 : {
11934 16090 : const char *p = NULL;
11935 16090 : switch (code->op)
11936 : {
11937 1 : case EXEC_OMP_TARGET_ENTER_DATA: p = "TARGET ENTER DATA"; break;
11938 1 : case EXEC_OMP_TARGET_EXIT_DATA: p = "TARGET EXIT DATA"; break;
11939 : default: break;
11940 : }
11941 16090 : if (code->op == EXEC_OMP_TARGET_DATA)
11942 1 : gfc_error ("TARGET DATA must contain at least one MAP, USE_DEVICE_PTR, "
11943 : "or USE_DEVICE_ADDR clause at %L", &code->loc);
11944 16089 : else if (p)
11945 2 : gfc_error ("%s must contain at least one MAP clause at %L",
11946 : p, &code->loc);
11947 : }
11948 33190 : if (omp_clauses->sizes_list)
11949 : {
11950 : gfc_expr_list *el;
11951 572 : for (el = omp_clauses->sizes_list; el; el = el->next)
11952 377 : resolve_positive_int_expr (el->expr, "SIZES", false);
11953 : }
11954 :
11955 33190 : if (!openacc && omp_clauses->detach)
11956 : {
11957 125 : if (!gfc_resolve_expr (omp_clauses->detach)
11958 125 : || omp_clauses->detach->ts.type != BT_INTEGER
11959 124 : || omp_clauses->detach->ts.kind != gfc_c_intptr_kind
11960 248 : || omp_clauses->detach->rank != 0)
11961 3 : gfc_error ("%qs at %L should be a scalar of type "
11962 : "integer(kind=omp_event_handle_kind)",
11963 3 : omp_clauses->detach->symtree->n.sym->name,
11964 3 : &omp_clauses->detach->where);
11965 122 : else if (omp_clauses->detach->symtree->n.sym->attr.dimension > 0)
11966 1 : gfc_error ("The event handle at %L must not be an array element",
11967 : &omp_clauses->detach->where);
11968 121 : else if (omp_clauses->detach->symtree->n.sym->ts.type == BT_DERIVED
11969 120 : || omp_clauses->detach->symtree->n.sym->ts.type == BT_CLASS)
11970 1 : gfc_error ("The event handle at %L must not be part of "
11971 : "a derived type or class", &omp_clauses->detach->where);
11972 :
11973 125 : if (omp_clauses->mergeable)
11974 2 : gfc_error ("%<DETACH%> clause at %L must not be used together with "
11975 2 : "%<MERGEABLE%> clause", &omp_clauses->detach->where);
11976 : }
11977 :
11978 : if (openacc
11979 12995 : && code->op == EXEC_OACC_HOST_DATA
11980 60 : && omp_clauses->lists[OMP_LIST_USE_DEVICE] == NULL)
11981 1 : gfc_error ("%<host_data%> construct at %L requires %<use_device%> clause",
11982 : &code->loc);
11983 :
11984 33190 : if (omp_clauses->assume)
11985 18 : gfc_resolve_omp_assumptions (omp_clauses->assume);
11986 : }
11987 :
11988 :
11989 : /* Return true if SYM is ever referenced in EXPR except in the SE node. */
11990 :
11991 : static bool
11992 5008 : expr_references_sym (gfc_expr *e, gfc_symbol *s, gfc_expr *se)
11993 : {
11994 6641 : gfc_actual_arglist *arg;
11995 6641 : if (e == NULL || e == se)
11996 : return false;
11997 5386 : switch (e->expr_type)
11998 : {
11999 3133 : case EXPR_CONSTANT:
12000 3133 : case EXPR_NULL:
12001 3133 : case EXPR_VARIABLE:
12002 3133 : case EXPR_STRUCTURE:
12003 3133 : case EXPR_ARRAY:
12004 3133 : if (e->symtree != NULL
12005 1157 : && e->symtree->n.sym == s)
12006 470 : return true;
12007 : return false;
12008 0 : case EXPR_SUBSTRING:
12009 0 : if (e->ref != NULL
12010 0 : && (expr_references_sym (e->ref->u.ss.start, s, se)
12011 0 : || expr_references_sym (e->ref->u.ss.end, s, se)))
12012 0 : return true;
12013 : return false;
12014 1742 : case EXPR_OP:
12015 1742 : if (expr_references_sym (e->value.op.op2, s, se))
12016 : return true;
12017 1633 : return expr_references_sym (e->value.op.op1, s, se);
12018 511 : case EXPR_FUNCTION:
12019 896 : for (arg = e->value.function.actual; arg; arg = arg->next)
12020 586 : if (expr_references_sym (arg->expr, s, se))
12021 : return true;
12022 : return false;
12023 0 : default:
12024 0 : gcc_unreachable ();
12025 : }
12026 : }
12027 :
12028 :
12029 : /* If EXPR is a conversion function that widens the type
12030 : if WIDENING is true or narrows the type if NARROW is true,
12031 : return the inner expression, otherwise return NULL. */
12032 :
12033 : static gfc_expr *
12034 5928 : is_conversion (gfc_expr *expr, bool narrowing, bool widening)
12035 : {
12036 5928 : gfc_typespec *ts1, *ts2;
12037 :
12038 5928 : if (expr->expr_type != EXPR_FUNCTION
12039 917 : || expr->value.function.isym == NULL
12040 894 : || expr->value.function.esym != NULL
12041 894 : || expr->value.function.isym->id != GFC_ISYM_CONVERSION
12042 388 : || (!narrowing && !widening))
12043 : return NULL;
12044 :
12045 388 : if (narrowing && widening)
12046 267 : return expr->value.function.actual->expr;
12047 :
12048 121 : if (widening)
12049 : {
12050 121 : ts1 = &expr->ts;
12051 121 : ts2 = &expr->value.function.actual->expr->ts;
12052 : }
12053 : else
12054 : {
12055 0 : ts1 = &expr->value.function.actual->expr->ts;
12056 0 : ts2 = &expr->ts;
12057 : }
12058 :
12059 121 : if (ts1->type > ts2->type
12060 49 : || (ts1->type == ts2->type && ts1->kind > ts2->kind))
12061 121 : return expr->value.function.actual->expr;
12062 :
12063 : return NULL;
12064 : }
12065 :
12066 : static bool
12067 6883 : is_scalar_intrinsic_expr (gfc_expr *expr, bool must_be_var, bool conv_ok)
12068 : {
12069 6883 : if (must_be_var
12070 4034 : && (expr->expr_type != EXPR_VARIABLE || !expr->symtree))
12071 : {
12072 37 : if (!conv_ok)
12073 : return false;
12074 37 : gfc_expr *conv = is_conversion (expr, true, true);
12075 37 : if (!conv)
12076 : return false;
12077 36 : if (conv->expr_type != EXPR_VARIABLE || !conv->symtree)
12078 : return false;
12079 : }
12080 6880 : return (expr->rank == 0
12081 6876 : && !gfc_is_coindexed (expr)
12082 13756 : && (expr->ts.type == BT_INTEGER
12083 1522 : || expr->ts.type == BT_REAL
12084 590 : || expr->ts.type == BT_COMPLEX
12085 572 : || expr->ts.type == BT_LOGICAL));
12086 : }
12087 :
12088 : static void
12089 2710 : resolve_omp_atomic (gfc_code *code)
12090 : {
12091 2710 : gfc_code *atomic_code = code->block;
12092 2710 : gfc_symbol *var;
12093 2710 : gfc_expr *stmt_expr2, *capt_expr2;
12094 2710 : gfc_omp_atomic_op aop
12095 2710 : = (gfc_omp_atomic_op) (atomic_code->ext.omp_clauses->atomic_op
12096 : & GFC_OMP_ATOMIC_MASK);
12097 2710 : gfc_code *stmt = NULL, *capture_stmt = NULL, *tailing_stmt = NULL;
12098 2710 : gfc_expr *comp_cond = NULL;
12099 2710 : locus *loc = NULL;
12100 :
12101 2710 : code = code->block->next;
12102 : /* resolve_blocks asserts this is initially EXEC_ASSIGN or EXEC_IF
12103 : If it changed to EXEC_NOP, assume an error has been emitted already. */
12104 2710 : if (code->op == EXEC_NOP)
12105 : return;
12106 :
12107 2709 : if (atomic_code->ext.omp_clauses->compare
12108 157 : && atomic_code->ext.omp_clauses->capture)
12109 : {
12110 : /* Must be either "if (x == e) then; x = d; else; v = x; end if"
12111 : or "v = expr" followed/preceded by
12112 : "if (x == e) then; x = d; end if" or "if (x == e) x = d". */
12113 103 : gfc_code *next = code;
12114 103 : if (code->op == EXEC_ASSIGN)
12115 : {
12116 19 : capture_stmt = code;
12117 19 : next = code->next;
12118 : }
12119 103 : if (next->op == EXEC_IF
12120 103 : && next->block
12121 103 : && next->block->op == EXEC_IF
12122 103 : && next->block->next
12123 102 : && next->block->next->op == EXEC_ASSIGN)
12124 : {
12125 102 : comp_cond = next->block->expr1;
12126 102 : stmt = next->block->next;
12127 102 : if (stmt->next)
12128 : {
12129 0 : loc = &stmt->loc;
12130 0 : goto unexpected;
12131 : }
12132 : }
12133 1 : else if (capture_stmt)
12134 : {
12135 0 : gfc_error ("Expected IF at %L in atomic compare capture",
12136 : &next->loc);
12137 0 : return;
12138 : }
12139 103 : if (stmt && !capture_stmt && next->block->block)
12140 : {
12141 64 : if (next->block->block->expr1)
12142 : {
12143 0 : gfc_error ("Expected ELSE at %L in atomic compare capture",
12144 : &next->block->block->expr1->where);
12145 0 : return;
12146 : }
12147 64 : if (!code->block->block->next
12148 64 : || code->block->block->next->op != EXEC_ASSIGN)
12149 : {
12150 0 : loc = (code->block->block->next ? &code->block->block->next->loc
12151 : : &code->block->block->loc);
12152 0 : goto unexpected;
12153 : }
12154 64 : capture_stmt = code->block->block->next;
12155 64 : if (capture_stmt->next)
12156 : {
12157 0 : loc = &capture_stmt->next->loc;
12158 0 : goto unexpected;
12159 : }
12160 : }
12161 103 : if (stmt && !capture_stmt && next->next->op == EXEC_ASSIGN)
12162 : capture_stmt = next->next;
12163 84 : else if (!capture_stmt)
12164 : {
12165 1 : loc = &code->loc;
12166 1 : goto unexpected;
12167 : }
12168 : }
12169 2606 : else if (atomic_code->ext.omp_clauses->compare)
12170 : {
12171 : /* Must be: "if (x == e) then; x = d; end if" or "if (x == e) x = d". */
12172 54 : if (code->op == EXEC_IF
12173 54 : && code->block
12174 54 : && code->block->op == EXEC_IF
12175 54 : && code->block->next
12176 52 : && code->block->next->op == EXEC_ASSIGN)
12177 : {
12178 52 : comp_cond = code->block->expr1;
12179 52 : stmt = code->block->next;
12180 52 : if (stmt->next || code->block->block)
12181 : {
12182 0 : loc = stmt->next ? &stmt->next->loc : &code->block->block->loc;
12183 0 : goto unexpected;
12184 : }
12185 : }
12186 : else
12187 : {
12188 2 : loc = &code->loc;
12189 2 : goto unexpected;
12190 : }
12191 : }
12192 2552 : else if (atomic_code->ext.omp_clauses->capture)
12193 : {
12194 : /* Must be: "v = x" followed/preceded by "x = ...". */
12195 489 : if (code->op != EXEC_ASSIGN)
12196 0 : goto unexpected;
12197 489 : if (code->next->op != EXEC_ASSIGN)
12198 : {
12199 0 : loc = &code->next->loc;
12200 0 : goto unexpected;
12201 : }
12202 489 : gfc_expr *expr2, *expr2_next;
12203 489 : expr2 = is_conversion (code->expr2, true, true);
12204 489 : if (expr2 == NULL)
12205 447 : expr2 = code->expr2;
12206 489 : expr2_next = is_conversion (code->next->expr2, true, true);
12207 489 : if (expr2_next == NULL)
12208 478 : expr2_next = code->next->expr2;
12209 489 : if (code->expr1->expr_type == EXPR_VARIABLE
12210 489 : && code->next->expr1->expr_type == EXPR_VARIABLE
12211 489 : && expr2->expr_type == EXPR_VARIABLE
12212 243 : && expr2_next->expr_type == EXPR_VARIABLE)
12213 : {
12214 1 : if (code->expr1->symtree->n.sym == expr2_next->symtree->n.sym)
12215 : {
12216 : stmt = code;
12217 : capture_stmt = code->next;
12218 : }
12219 : else
12220 : {
12221 489 : capture_stmt = code;
12222 489 : stmt = code->next;
12223 : }
12224 : }
12225 488 : else if (expr2->expr_type == EXPR_VARIABLE)
12226 : {
12227 : capture_stmt = code;
12228 : stmt = code->next;
12229 : }
12230 : else
12231 : {
12232 247 : stmt = code;
12233 247 : capture_stmt = code->next;
12234 : }
12235 : /* Shall be NULL but can happen for invalid code. */
12236 489 : tailing_stmt = code->next->next;
12237 : }
12238 : else
12239 : {
12240 : /* x = ... */
12241 2063 : stmt = code;
12242 2063 : if (!atomic_code->ext.omp_clauses->compare && stmt->op != EXEC_ASSIGN)
12243 1 : goto unexpected;
12244 : /* Shall be NULL but can happen for invalid code. */
12245 2062 : tailing_stmt = code->next;
12246 : }
12247 :
12248 2705 : if (comp_cond)
12249 : {
12250 154 : if (comp_cond->expr_type != EXPR_OP
12251 154 : || (comp_cond->value.op.op != INTRINSIC_EQ
12252 : && comp_cond->value.op.op != INTRINSIC_EQ_OS
12253 : && comp_cond->value.op.op != INTRINSIC_EQV))
12254 : {
12255 0 : gfc_error ("Expected %<==%>, %<.EQ.%> or %<.EQV.%> atomic comparison "
12256 : "expression at %L", &comp_cond->where);
12257 0 : return;
12258 : }
12259 154 : if (!is_scalar_intrinsic_expr (comp_cond->value.op.op1, true, true))
12260 : {
12261 1 : gfc_error ("Expected scalar intrinsic variable at %L in atomic "
12262 1 : "comparison", &comp_cond->value.op.op1->where);
12263 1 : return;
12264 : }
12265 153 : if (!gfc_resolve_expr (comp_cond->value.op.op2))
12266 : return;
12267 153 : if (!is_scalar_intrinsic_expr (comp_cond->value.op.op2, false, false))
12268 : {
12269 0 : gfc_error ("Expected scalar intrinsic expression at %L in atomic "
12270 0 : "comparison", &comp_cond->value.op.op1->where);
12271 0 : return;
12272 : }
12273 : }
12274 :
12275 2704 : if (!is_scalar_intrinsic_expr (stmt->expr1, true, false))
12276 : {
12277 4 : gfc_error ("!$OMP ATOMIC statement must set a scalar variable of "
12278 4 : "intrinsic type at %L", &stmt->expr1->where);
12279 4 : return;
12280 : }
12281 :
12282 2700 : if (!gfc_resolve_expr (stmt->expr2))
12283 : return;
12284 2696 : if (!is_scalar_intrinsic_expr (stmt->expr2, false, false))
12285 : {
12286 0 : gfc_error ("!$OMP ATOMIC statement must assign an expression of "
12287 0 : "intrinsic type at %L", &stmt->expr2->where);
12288 0 : return;
12289 : }
12290 :
12291 2696 : if (gfc_expr_attr (stmt->expr1).allocatable)
12292 : {
12293 0 : gfc_error ("!$OMP ATOMIC with ALLOCATABLE variable at %L",
12294 0 : &stmt->expr1->where);
12295 0 : return;
12296 : }
12297 :
12298 : /* Should be diagnosed above already. */
12299 2696 : gcc_assert (tailing_stmt == NULL);
12300 :
12301 2696 : var = stmt->expr1->symtree->n.sym;
12302 2696 : stmt_expr2 = is_conversion (stmt->expr2, true, true);
12303 2696 : if (stmt_expr2 == NULL)
12304 2540 : stmt_expr2 = stmt->expr2;
12305 :
12306 2696 : switch (aop)
12307 : {
12308 506 : case GFC_OMP_ATOMIC_READ:
12309 506 : if (stmt_expr2->expr_type != EXPR_VARIABLE)
12310 0 : gfc_error ("!$OMP ATOMIC READ statement must read from a scalar "
12311 : "variable of intrinsic type at %L", &stmt_expr2->where);
12312 : return;
12313 426 : case GFC_OMP_ATOMIC_WRITE:
12314 426 : if (expr_references_sym (stmt_expr2, var, NULL))
12315 0 : gfc_error ("expr in !$OMP ATOMIC WRITE assignment var = expr "
12316 : "must be scalar and cannot reference var at %L",
12317 : &stmt_expr2->where);
12318 : return;
12319 1764 : default:
12320 1764 : break;
12321 : }
12322 :
12323 1764 : if (atomic_code->ext.omp_clauses->capture)
12324 : {
12325 588 : if (!is_scalar_intrinsic_expr (capture_stmt->expr1, true, false))
12326 : {
12327 0 : gfc_error ("!$OMP ATOMIC capture-statement must set a scalar "
12328 : "variable of intrinsic type at %L",
12329 0 : &capture_stmt->expr1->where);
12330 0 : return;
12331 : }
12332 :
12333 588 : if (!is_scalar_intrinsic_expr (capture_stmt->expr2, true, true))
12334 : {
12335 2 : gfc_error ("!$OMP ATOMIC capture-statement requires a scalar variable"
12336 2 : " of intrinsic type at %L", &capture_stmt->expr2->where);
12337 2 : return;
12338 : }
12339 586 : capt_expr2 = is_conversion (capture_stmt->expr2, true, true);
12340 586 : if (capt_expr2 == NULL)
12341 564 : capt_expr2 = capture_stmt->expr2;
12342 :
12343 586 : if (capt_expr2->symtree->n.sym != var)
12344 : {
12345 1 : gfc_error ("!$OMP ATOMIC CAPTURE capture statement reads from "
12346 : "different variable than update statement writes "
12347 : "into at %L", &capture_stmt->expr2->where);
12348 1 : return;
12349 : }
12350 : }
12351 :
12352 1761 : if (atomic_code->ext.omp_clauses->compare)
12353 : {
12354 150 : gfc_expr *var_expr;
12355 150 : if (comp_cond->value.op.op1->expr_type == EXPR_VARIABLE)
12356 : var_expr = comp_cond->value.op.op1;
12357 : else
12358 12 : var_expr = comp_cond->value.op.op1->value.function.actual->expr;
12359 150 : if (var_expr->symtree->n.sym != var)
12360 : {
12361 2 : gfc_error ("For !$OMP ATOMIC COMPARE, the first operand in comparison"
12362 : " at %L must be the variable %qs that the update statement"
12363 : " writes into at %L", &var_expr->where, var->name,
12364 2 : &stmt->expr1->where);
12365 2 : return;
12366 : }
12367 148 : if (stmt_expr2->rank != 0 || expr_references_sym (stmt_expr2, var, NULL))
12368 : {
12369 1 : gfc_error ("expr in !$OMP ATOMIC COMPARE assignment var = expr "
12370 : "must be scalar and cannot reference var at %L",
12371 : &stmt_expr2->where);
12372 1 : return;
12373 : }
12374 : }
12375 1611 : else if (atomic_code->ext.omp_clauses->capture
12376 1611 : && !expr_references_sym (stmt_expr2, var, NULL))
12377 22 : atomic_code->ext.omp_clauses->atomic_op
12378 22 : = (gfc_omp_atomic_op) (atomic_code->ext.omp_clauses->atomic_op
12379 : | GFC_OMP_ATOMIC_SWAP);
12380 1589 : else if (stmt_expr2->expr_type == EXPR_OP)
12381 : {
12382 1233 : gfc_expr *v = NULL, *e, *c;
12383 1233 : gfc_intrinsic_op op = stmt_expr2->value.op.op;
12384 1233 : gfc_intrinsic_op alt_op = INTRINSIC_NONE;
12385 :
12386 1233 : if (atomic_code->ext.omp_clauses->fail != OMP_MEMORDER_UNSET)
12387 3 : gfc_error ("!$OMP ATOMIC UPDATE at %L with FAIL clause requires either"
12388 : " the COMPARE clause or using the intrinsic MIN/MAX "
12389 : "procedure", &atomic_code->loc);
12390 1233 : switch (op)
12391 : {
12392 746 : case INTRINSIC_PLUS:
12393 746 : alt_op = INTRINSIC_MINUS;
12394 746 : break;
12395 94 : case INTRINSIC_TIMES:
12396 94 : alt_op = INTRINSIC_DIVIDE;
12397 94 : break;
12398 120 : case INTRINSIC_MINUS:
12399 120 : alt_op = INTRINSIC_PLUS;
12400 120 : break;
12401 94 : case INTRINSIC_DIVIDE:
12402 94 : alt_op = INTRINSIC_TIMES;
12403 94 : break;
12404 : case INTRINSIC_AND:
12405 : case INTRINSIC_OR:
12406 : break;
12407 43 : case INTRINSIC_EQV:
12408 43 : alt_op = INTRINSIC_NEQV;
12409 43 : break;
12410 43 : case INTRINSIC_NEQV:
12411 43 : alt_op = INTRINSIC_EQV;
12412 43 : break;
12413 1 : default:
12414 1 : gfc_error ("!$OMP ATOMIC assignment operator must be binary "
12415 : "+, *, -, /, .AND., .OR., .EQV. or .NEQV. at %L",
12416 : &stmt_expr2->where);
12417 1 : return;
12418 : }
12419 :
12420 : /* Check for var = var op expr resp. var = expr op var where
12421 : expr doesn't reference var and var op expr is mathematically
12422 : equivalent to var op (expr) resp. expr op var equivalent to
12423 : (expr) op var. We rely here on the fact that the matcher
12424 : for x op1 y op2 z where op1 and op2 have equal precedence
12425 : returns (x op1 y) op2 z. */
12426 1232 : e = stmt_expr2->value.op.op2;
12427 1232 : if (e->expr_type == EXPR_VARIABLE
12428 288 : && e->symtree != NULL
12429 288 : && e->symtree->n.sym == var)
12430 : v = e;
12431 1003 : else if ((c = is_conversion (e, false, true)) != NULL
12432 48 : && c->expr_type == EXPR_VARIABLE
12433 48 : && c->symtree != NULL
12434 1051 : && c->symtree->n.sym == var)
12435 : v = c;
12436 : else
12437 : {
12438 955 : gfc_expr **p = NULL, **q;
12439 1053 : for (q = &stmt_expr2->value.op.op1; (e = *q) != NULL; )
12440 1053 : if (e->expr_type == EXPR_VARIABLE
12441 952 : && e->symtree != NULL
12442 952 : && e->symtree->n.sym == var)
12443 : {
12444 : v = e;
12445 : break;
12446 : }
12447 101 : else if ((c = is_conversion (e, false, true)) != NULL)
12448 60 : q = &e->value.function.actual->expr;
12449 41 : else if (e->expr_type != EXPR_OP
12450 41 : || (e->value.op.op != op
12451 15 : && e->value.op.op != alt_op)
12452 38 : || e->rank != 0)
12453 : break;
12454 : else
12455 : {
12456 38 : p = q;
12457 38 : q = &e->value.op.op1;
12458 : }
12459 :
12460 955 : if (v == NULL)
12461 : {
12462 3 : gfc_error ("!$OMP ATOMIC assignment must be var = var op expr "
12463 : "or var = expr op var at %L", &stmt_expr2->where);
12464 3 : return;
12465 : }
12466 :
12467 952 : if (p != NULL)
12468 : {
12469 38 : e = *p;
12470 38 : switch (e->value.op.op)
12471 : {
12472 8 : case INTRINSIC_MINUS:
12473 8 : case INTRINSIC_DIVIDE:
12474 8 : case INTRINSIC_EQV:
12475 8 : case INTRINSIC_NEQV:
12476 8 : gfc_error ("!$OMP ATOMIC var = var op expr not "
12477 : "mathematically equivalent to var = var op "
12478 : "(expr) at %L", &stmt_expr2->where);
12479 8 : break;
12480 : default:
12481 : break;
12482 : }
12483 :
12484 : /* Canonicalize into var = var op (expr). */
12485 38 : *p = e->value.op.op2;
12486 38 : e->value.op.op2 = stmt_expr2;
12487 38 : e->ts = stmt_expr2->ts;
12488 38 : if (stmt->expr2 == stmt_expr2)
12489 26 : stmt->expr2 = stmt_expr2 = e;
12490 : else
12491 12 : stmt->expr2->value.function.actual->expr = stmt_expr2 = e;
12492 :
12493 38 : if (!gfc_compare_types (&stmt_expr2->value.op.op1->ts,
12494 : &stmt_expr2->ts))
12495 : {
12496 24 : for (p = &stmt_expr2->value.op.op1; *p != v;
12497 12 : p = &(*p)->value.function.actual->expr)
12498 : ;
12499 12 : *p = NULL;
12500 12 : gfc_free_expr (stmt_expr2->value.op.op1);
12501 12 : stmt_expr2->value.op.op1 = v;
12502 12 : gfc_convert_type (v, &stmt_expr2->ts, 2);
12503 : }
12504 : }
12505 : }
12506 :
12507 1229 : if (e->rank != 0 || expr_references_sym (stmt->expr2, var, v))
12508 : {
12509 1 : gfc_error ("expr in !$OMP ATOMIC assignment var = var op expr "
12510 : "must be scalar and cannot reference var at %L",
12511 : &stmt_expr2->where);
12512 1 : return;
12513 : }
12514 : }
12515 356 : else if (stmt_expr2->expr_type == EXPR_FUNCTION
12516 355 : && stmt_expr2->value.function.isym != NULL
12517 355 : && stmt_expr2->value.function.esym == NULL
12518 355 : && stmt_expr2->value.function.actual != NULL
12519 355 : && stmt_expr2->value.function.actual->next != NULL)
12520 : {
12521 355 : gfc_actual_arglist *arg, *var_arg;
12522 :
12523 355 : switch (stmt_expr2->value.function.isym->id)
12524 : {
12525 : case GFC_ISYM_MIN:
12526 : case GFC_ISYM_MAX:
12527 : break;
12528 147 : case GFC_ISYM_IAND:
12529 147 : case GFC_ISYM_IOR:
12530 147 : case GFC_ISYM_IEOR:
12531 147 : if (stmt_expr2->value.function.actual->next->next != NULL)
12532 : {
12533 0 : gfc_error ("!$OMP ATOMIC assignment intrinsic IAND, IOR "
12534 : "or IEOR must have two arguments at %L",
12535 : &stmt_expr2->where);
12536 0 : return;
12537 : }
12538 : break;
12539 1 : default:
12540 1 : gfc_error ("!$OMP ATOMIC assignment intrinsic must be "
12541 : "MIN, MAX, IAND, IOR or IEOR at %L",
12542 : &stmt_expr2->where);
12543 1 : return;
12544 : }
12545 :
12546 : var_arg = NULL;
12547 1088 : for (arg = stmt_expr2->value.function.actual; arg; arg = arg->next)
12548 : {
12549 741 : gfc_expr *e = NULL;
12550 741 : if (arg == stmt_expr2->value.function.actual
12551 387 : || (var_arg == NULL && arg->next == NULL))
12552 : {
12553 527 : e = is_conversion (arg->expr, false, true);
12554 527 : if (!e)
12555 514 : e = arg->expr;
12556 527 : if (e->expr_type == EXPR_VARIABLE
12557 453 : && e->symtree != NULL
12558 453 : && e->symtree->n.sym == var)
12559 741 : var_arg = arg;
12560 : }
12561 741 : if ((!var_arg || !e) && expr_references_sym (arg->expr, var, NULL))
12562 : {
12563 7 : gfc_error ("!$OMP ATOMIC intrinsic arguments except one must "
12564 : "not reference %qs at %L",
12565 : var->name, &arg->expr->where);
12566 7 : return;
12567 : }
12568 734 : if (arg->expr->rank != 0)
12569 : {
12570 0 : gfc_error ("!$OMP ATOMIC intrinsic arguments must be scalar "
12571 : "at %L", &arg->expr->where);
12572 0 : return;
12573 : }
12574 : }
12575 :
12576 347 : if (var_arg == NULL)
12577 : {
12578 1 : gfc_error ("First or last !$OMP ATOMIC intrinsic argument must "
12579 : "be %qs at %L", var->name, &stmt_expr2->where);
12580 1 : return;
12581 : }
12582 :
12583 346 : if (var_arg != stmt_expr2->value.function.actual)
12584 : {
12585 : /* Canonicalize, so that var comes first. */
12586 172 : gcc_assert (var_arg->next == NULL);
12587 : for (arg = stmt_expr2->value.function.actual;
12588 185 : arg->next != var_arg; arg = arg->next)
12589 : ;
12590 172 : var_arg->next = stmt_expr2->value.function.actual;
12591 172 : stmt_expr2->value.function.actual = var_arg;
12592 172 : arg->next = NULL;
12593 : }
12594 : }
12595 : else
12596 1 : gfc_error ("!$OMP ATOMIC assignment must have an operator or "
12597 : "intrinsic on right hand side at %L", &stmt_expr2->where);
12598 : return;
12599 :
12600 4 : unexpected:
12601 4 : gfc_error ("unexpected !$OMP ATOMIC expression at %L",
12602 : loc ? loc : &code->loc);
12603 4 : return;
12604 : }
12605 :
12606 :
12607 : static struct fortran_omp_context
12608 : {
12609 : gfc_code *code;
12610 : hash_set<gfc_symbol *> *sharing_clauses;
12611 : hash_set<gfc_symbol *> *private_iterators;
12612 : struct fortran_omp_context *previous;
12613 : bool is_openmp;
12614 : } *omp_current_ctx;
12615 : static gfc_code *omp_current_do_code;
12616 : static int omp_current_do_collapse;
12617 :
12618 : /* Forward declaration for mutually recursive functions. */
12619 : static gfc_code *
12620 : find_nested_loop_in_block (gfc_code *block);
12621 :
12622 : /* Return the first nested DO loop in CHAIN, or NULL if there
12623 : isn't one. Does no error checking on intervening code. */
12624 :
12625 : static gfc_code *
12626 27482 : find_nested_loop_in_chain (gfc_code *chain)
12627 : {
12628 27482 : gfc_code *code;
12629 :
12630 27482 : if (!chain)
12631 : return NULL;
12632 :
12633 31643 : for (code = chain; code; code = code->next)
12634 31222 : switch (code->op)
12635 : {
12636 : case EXEC_DO:
12637 : case EXEC_OMP_TILE:
12638 : case EXEC_OMP_UNROLL:
12639 : return code;
12640 621 : case EXEC_BLOCK:
12641 621 : if (gfc_code *c = find_nested_loop_in_block (code))
12642 : return c;
12643 : break;
12644 : default:
12645 : break;
12646 : }
12647 : return NULL;
12648 : }
12649 :
12650 : /* Return the first nested DO loop in BLOCK, or NULL if there
12651 : isn't one. Does no error checking on intervening code. */
12652 : static gfc_code *
12653 939 : find_nested_loop_in_block (gfc_code *block)
12654 : {
12655 939 : gfc_namespace *ns;
12656 939 : gcc_assert (block->op == EXEC_BLOCK);
12657 939 : ns = block->ext.block.ns;
12658 939 : gcc_assert (ns);
12659 939 : return find_nested_loop_in_chain (ns->code);
12660 : }
12661 :
12662 : void
12663 5463 : gfc_resolve_omp_do_blocks (gfc_code *code, gfc_namespace *ns)
12664 : {
12665 5463 : if (code->block->next && code->block->next->op == EXEC_DO)
12666 : {
12667 5110 : int i;
12668 :
12669 5110 : omp_current_do_code = code->block->next;
12670 5110 : if (code->ext.omp_clauses->orderedc)
12671 142 : omp_current_do_collapse = code->ext.omp_clauses->orderedc;
12672 4968 : else if (code->ext.omp_clauses->collapse)
12673 1121 : omp_current_do_collapse = code->ext.omp_clauses->collapse;
12674 3847 : else if (code->ext.omp_clauses->sizes_list)
12675 175 : omp_current_do_collapse
12676 175 : = gfc_expr_list_len (code->ext.omp_clauses->sizes_list);
12677 : else
12678 3672 : omp_current_do_collapse = 1;
12679 5110 : if (code->ext.omp_clauses->lists[OMP_LIST_REDUCTION_INSCAN])
12680 : {
12681 : /* Checking that there is a matching EXEC_OMP_SCAN in the
12682 : innermost body cannot be deferred to resolve_omp_do because
12683 : we process directives nested in the loop before we get
12684 : there. */
12685 60 : locus *loc
12686 : = &code->ext.omp_clauses->lists[OMP_LIST_REDUCTION_INSCAN]->where;
12687 60 : gfc_code *c;
12688 :
12689 80 : for (i = 1, c = omp_current_do_code;
12690 80 : i < omp_current_do_collapse; i++)
12691 : {
12692 22 : c = find_nested_loop_in_chain (c->block->next);
12693 22 : if (!c || c->op != EXEC_DO || c->block == NULL)
12694 : break;
12695 : }
12696 :
12697 : /* Skip this if we don't have enough nested loops. That
12698 : problem will be diagnosed elsewhere. */
12699 60 : if (c && c->op == EXEC_DO)
12700 : {
12701 58 : gfc_code *block = c->block ? c->block->next : NULL;
12702 58 : if (block && block->op != EXEC_OMP_SCAN)
12703 54 : while (block && block->next
12704 54 : && block->next->op != EXEC_OMP_SCAN)
12705 : block = block->next;
12706 43 : if (!block
12707 46 : || (block->op != EXEC_OMP_SCAN
12708 43 : && (!block->next || block->next->op != EXEC_OMP_SCAN)))
12709 19 : gfc_error ("With INSCAN at %L, expected loop body with "
12710 : "!$OMP SCAN between two "
12711 : "structured block sequences", loc);
12712 : else
12713 : {
12714 39 : if (block->op == EXEC_OMP_SCAN)
12715 3 : gfc_warning (OPT_Wopenmp,
12716 : "!$OMP SCAN at %L with zero executable "
12717 : "statements in preceding structured block "
12718 : "sequence", &block->loc);
12719 39 : if ((block->op == EXEC_OMP_SCAN && !block->next)
12720 38 : || (block->next && block->next->op == EXEC_OMP_SCAN
12721 36 : && !block->next->next))
12722 3 : gfc_warning (OPT_Wopenmp,
12723 : "!$OMP SCAN at %L with zero executable "
12724 : "statements in succeeding structured block "
12725 : "sequence", block->op == EXEC_OMP_SCAN
12726 1 : ? &block->loc : &block->next->loc);
12727 : }
12728 58 : if (block && block->op != EXEC_OMP_SCAN)
12729 43 : block = block->next;
12730 46 : if (block && block->op == EXEC_OMP_SCAN)
12731 : /* Mark 'omp scan' as checked; flag will be unset later. */
12732 39 : block->ext.omp_clauses->if_present = true;
12733 : }
12734 : }
12735 : }
12736 5463 : gfc_resolve_blocks (code->block, ns);
12737 5463 : omp_current_do_collapse = 0;
12738 5463 : omp_current_do_code = NULL;
12739 5463 : }
12740 :
12741 :
12742 : void
12743 6129 : gfc_resolve_omp_parallel_blocks (gfc_code *code, gfc_namespace *ns)
12744 : {
12745 6129 : struct fortran_omp_context ctx;
12746 6129 : gfc_omp_clauses *omp_clauses = code->ext.omp_clauses;
12747 6129 : gfc_omp_namelist *n;
12748 :
12749 6129 : ctx.code = code;
12750 6129 : ctx.sharing_clauses = new hash_set<gfc_symbol *>;
12751 6129 : ctx.private_iterators = new hash_set<gfc_symbol *>;
12752 6129 : ctx.previous = omp_current_ctx;
12753 6129 : ctx.is_openmp = true;
12754 6129 : omp_current_ctx = &ctx;
12755 :
12756 245160 : for (enum gfc_omp_list_type list = OMP_LIST_FIRST; list < OMP_LIST_NUM;
12757 239031 : list = gfc_omp_list_type (list + 1))
12758 239031 : switch (list)
12759 : {
12760 61290 : case OMP_LIST_SHARED:
12761 61290 : case OMP_LIST_PRIVATE:
12762 61290 : case OMP_LIST_FIRSTPRIVATE:
12763 61290 : case OMP_LIST_LASTPRIVATE:
12764 61290 : case OMP_LIST_REDUCTION:
12765 61290 : case OMP_LIST_REDUCTION_INSCAN:
12766 61290 : case OMP_LIST_REDUCTION_TASK:
12767 61290 : case OMP_LIST_IN_REDUCTION:
12768 61290 : case OMP_LIST_TASK_REDUCTION:
12769 61290 : case OMP_LIST_LINEAR:
12770 70286 : for (n = omp_clauses->lists[list]; n; n = n->next)
12771 8996 : ctx.sharing_clauses->add (n->sym);
12772 : break;
12773 : default:
12774 : break;
12775 : }
12776 :
12777 6129 : switch (code->op)
12778 : {
12779 2375 : case EXEC_OMP_DISTRIBUTE_PARALLEL_DO:
12780 2375 : case EXEC_OMP_DISTRIBUTE_PARALLEL_DO_SIMD:
12781 2375 : case EXEC_OMP_MASKED_TASKLOOP:
12782 2375 : case EXEC_OMP_MASKED_TASKLOOP_SIMD:
12783 2375 : case EXEC_OMP_MASTER_TASKLOOP:
12784 2375 : case EXEC_OMP_MASTER_TASKLOOP_SIMD:
12785 2375 : case EXEC_OMP_PARALLEL_DO:
12786 2375 : case EXEC_OMP_PARALLEL_DO_SIMD:
12787 2375 : case EXEC_OMP_PARALLEL_LOOP:
12788 2375 : case EXEC_OMP_PARALLEL_MASKED_TASKLOOP:
12789 2375 : case EXEC_OMP_PARALLEL_MASKED_TASKLOOP_SIMD:
12790 2375 : case EXEC_OMP_PARALLEL_MASTER_TASKLOOP:
12791 2375 : case EXEC_OMP_PARALLEL_MASTER_TASKLOOP_SIMD:
12792 2375 : case EXEC_OMP_TARGET_PARALLEL_DO:
12793 2375 : case EXEC_OMP_TARGET_PARALLEL_DO_SIMD:
12794 2375 : case EXEC_OMP_TARGET_PARALLEL_LOOP:
12795 2375 : case EXEC_OMP_TARGET_TEAMS_DISTRIBUTE:
12796 2375 : case EXEC_OMP_TARGET_TEAMS_DISTRIBUTE_PARALLEL_DO:
12797 2375 : case EXEC_OMP_TARGET_TEAMS_DISTRIBUTE_PARALLEL_DO_SIMD:
12798 2375 : case EXEC_OMP_TARGET_TEAMS_DISTRIBUTE_SIMD:
12799 2375 : case EXEC_OMP_TARGET_TEAMS_LOOP:
12800 2375 : case EXEC_OMP_TASKLOOP:
12801 2375 : case EXEC_OMP_TASKLOOP_SIMD:
12802 2375 : case EXEC_OMP_TEAMS_DISTRIBUTE:
12803 2375 : case EXEC_OMP_TEAMS_DISTRIBUTE_PARALLEL_DO:
12804 2375 : case EXEC_OMP_TEAMS_DISTRIBUTE_PARALLEL_DO_SIMD:
12805 2375 : case EXEC_OMP_TEAMS_DISTRIBUTE_SIMD:
12806 2375 : case EXEC_OMP_TEAMS_LOOP:
12807 2375 : gfc_resolve_omp_do_blocks (code, ns);
12808 2375 : break;
12809 3754 : default:
12810 3754 : gfc_resolve_blocks (code->block, ns);
12811 : }
12812 :
12813 6129 : omp_current_ctx = ctx.previous;
12814 12258 : delete ctx.sharing_clauses;
12815 12258 : delete ctx.private_iterators;
12816 6129 : }
12817 :
12818 :
12819 : /* Save and clear openmp.cc private state. */
12820 :
12821 : void
12822 303413 : gfc_omp_save_and_clear_state (struct gfc_omp_saved_state *state)
12823 : {
12824 303413 : state->ptrs[0] = omp_current_ctx;
12825 303413 : state->ptrs[1] = omp_current_do_code;
12826 303413 : state->ints[0] = omp_current_do_collapse;
12827 303413 : omp_current_ctx = NULL;
12828 303413 : omp_current_do_code = NULL;
12829 303413 : omp_current_do_collapse = 0;
12830 303413 : }
12831 :
12832 :
12833 : /* Restore openmp.cc private state from the saved state. */
12834 :
12835 : void
12836 303412 : gfc_omp_restore_state (struct gfc_omp_saved_state *state)
12837 : {
12838 303412 : omp_current_ctx = (struct fortran_omp_context *) state->ptrs[0];
12839 303412 : omp_current_do_code = (gfc_code *) state->ptrs[1];
12840 303412 : omp_current_do_collapse = state->ints[0];
12841 303412 : }
12842 :
12843 :
12844 : /* Note a DO iterator variable. This is special in !$omp parallel
12845 : construct, where they are predetermined private. */
12846 :
12847 : void
12848 33533 : gfc_resolve_do_iterator (gfc_code *code, gfc_symbol *sym, bool add_clause)
12849 : {
12850 33533 : if (omp_current_ctx == NULL)
12851 : return;
12852 :
12853 13122 : int i = omp_current_do_collapse;
12854 13122 : gfc_code *c = omp_current_do_code;
12855 :
12856 13122 : if (sym->attr.threadprivate)
12857 : return;
12858 :
12859 : /* !$omp do and !$omp parallel do iteration variable is predetermined
12860 : private just in the !$omp do resp. !$omp parallel do construct,
12861 : with no implications for the outer parallel constructs. */
12862 :
12863 17957 : while (i-- >= 1 && c)
12864 : {
12865 9511 : if (code == c)
12866 : return;
12867 4835 : c = find_nested_loop_in_chain (c->block->next);
12868 4835 : if (c && (c->op == EXEC_OMP_TILE || c->op == EXEC_OMP_UNROLL))
12869 : return;
12870 : }
12871 :
12872 : /* An openacc context may represent a data clause. Abort if so. */
12873 8446 : if (!omp_current_ctx->is_openmp && !oacc_is_loop (omp_current_ctx->code))
12874 : return;
12875 :
12876 7468 : if (omp_current_ctx->sharing_clauses->contains (sym))
12877 : return;
12878 :
12879 6466 : if (! omp_current_ctx->private_iterators->add (sym) && add_clause)
12880 : {
12881 6276 : gfc_omp_clauses *omp_clauses = omp_current_ctx->code->ext.omp_clauses;
12882 6276 : gfc_omp_namelist *p;
12883 :
12884 6276 : p = gfc_get_omp_namelist ();
12885 6276 : p->sym = sym;
12886 6276 : p->where = omp_current_ctx->code->loc;
12887 6276 : p->next = omp_clauses->lists[OMP_LIST_PRIVATE];
12888 6276 : omp_clauses->lists[OMP_LIST_PRIVATE] = p;
12889 : }
12890 : }
12891 :
12892 : static void
12893 777 : handle_local_var (gfc_symbol *sym)
12894 : {
12895 777 : if (sym->attr.flavor != FL_VARIABLE
12896 180 : || sym->as != NULL
12897 139 : || (sym->ts.type != BT_INTEGER && sym->ts.type != BT_REAL))
12898 : return;
12899 72 : gfc_resolve_do_iterator (sym->ns->code, sym, false);
12900 : }
12901 :
12902 : void
12903 351850 : gfc_resolve_omp_local_vars (gfc_namespace *ns)
12904 : {
12905 351850 : if (omp_current_ctx)
12906 471 : gfc_traverse_ns (ns, handle_local_var);
12907 351850 : }
12908 :
12909 :
12910 : /* Error checking on intervening code uses a code walker. */
12911 :
12912 : struct icode_error_state
12913 : {
12914 : const char *name;
12915 : bool errorp;
12916 : gfc_code *nested;
12917 : gfc_code *next;
12918 : };
12919 :
12920 : static int
12921 944 : icode_code_error_callback (gfc_code **codep,
12922 : int *walk_subtrees ATTRIBUTE_UNUSED, void *opaque)
12923 : {
12924 944 : gfc_code *code = *codep;
12925 944 : icode_error_state *state = (icode_error_state *)opaque;
12926 :
12927 : /* gfc_code_walker walks down CODE's next chain as well as
12928 : walking things that are actually nested in CODE. We need to
12929 : special-case traversal of outer blocks, so stop immediately if we
12930 : are heading down such a next chain. */
12931 944 : if (code == state->next)
12932 : return 1;
12933 :
12934 647 : switch (code->op)
12935 : {
12936 1 : case EXEC_DO:
12937 1 : case EXEC_DO_WHILE:
12938 1 : case EXEC_DO_CONCURRENT:
12939 1 : gfc_error ("%s cannot contain loop in intervening code at %L",
12940 : state->name, &code->loc);
12941 1 : state->errorp = true;
12942 1 : break;
12943 0 : case EXEC_CYCLE:
12944 0 : case EXEC_EXIT:
12945 : /* Errors have already been diagnosed in match_exit_cycle. */
12946 0 : state->errorp = true;
12947 0 : break;
12948 : case EXEC_OMP_ASSUME:
12949 : case EXEC_OMP_METADIRECTIVE:
12950 : /* Per OpenMP 6.0, some non-executable directives are allowed in
12951 : intervening code. */
12952 : break;
12953 477 : case EXEC_CALL:
12954 : /* Per OpenMP 5.2, the "omp_" prefix is reserved, so we don't have to
12955 : consider the possibility that some locally-bound definition
12956 : overrides the runtime routine. */
12957 477 : if (code->resolved_sym
12958 477 : && omp_runtime_api_procname (code->resolved_sym->name))
12959 : {
12960 1 : gfc_error ("%s cannot contain OpenMP API call in intervening code "
12961 : "at %L",
12962 : state->name, &code->loc);
12963 1 : state->errorp = true;
12964 : }
12965 : break;
12966 168 : default:
12967 168 : if (code->op >= EXEC_OMP_FIRST_OPENMP_EXEC
12968 168 : && code->op <= EXEC_OMP_LAST_OPENMP_EXEC)
12969 : {
12970 2 : gfc_error ("%s cannot contain OpenMP directive in intervening code "
12971 : "at %L",
12972 : state->name, &code->loc);
12973 2 : state->errorp = true;
12974 : }
12975 : }
12976 : return 0;
12977 : }
12978 :
12979 : static int
12980 1081 : icode_expr_error_callback (gfc_expr **expr,
12981 : int *walk_subtrees ATTRIBUTE_UNUSED, void *opaque)
12982 : {
12983 1081 : icode_error_state *state = (icode_error_state *)opaque;
12984 :
12985 1081 : switch ((*expr)->expr_type)
12986 : {
12987 : /* As for EXPR_CALL with "omp_"-prefixed symbols. */
12988 2 : case EXPR_FUNCTION:
12989 2 : {
12990 2 : gfc_symbol *sym = (*expr)->value.function.esym;
12991 2 : if (sym && omp_runtime_api_procname (sym->name))
12992 : {
12993 1 : gfc_error ("%s cannot contain OpenMP API call in intervening code "
12994 : "at %L",
12995 1 : state->name, &((*expr)->where));
12996 1 : state->errorp = true;
12997 : }
12998 : }
12999 :
13000 : break;
13001 : default:
13002 : break;
13003 : }
13004 :
13005 : /* FIXME: The description of canonical loop form in the OpenMP standard
13006 : also says "array expressions" are not permitted in intervening code.
13007 : That term is not defined in either the OpenMP spec or the Fortran
13008 : standard, although the latter uses it informally to refer to any
13009 : expression that is not scalar-valued. It is also apparently not the
13010 : thing GCC internally calls EXPR_ARRAY. It seems the intent of the
13011 : OpenMP restriction is to disallow elemental operations/intrinsics
13012 : (including things that are not expressions, like assignment
13013 : statements) that generate implicit loops over array operands
13014 : (even if the result is a scalar), but even if the spec said
13015 : that there is no list of all the cases that would be forbidden.
13016 : This is OpenMP issue 3326. */
13017 :
13018 1081 : return 0;
13019 : }
13020 :
13021 : static void
13022 267 : diagnose_intervening_code_errors_1 (gfc_code *chain,
13023 : struct icode_error_state *state)
13024 : {
13025 267 : gfc_code *code;
13026 1080 : for (code = chain; code; code = code->next)
13027 : {
13028 813 : if (code == state->nested)
13029 : /* Do not walk the nested loop or its body, we are only
13030 : interested in intervening code. */
13031 : ;
13032 636 : else if (code->op == EXEC_BLOCK
13033 636 : && find_nested_loop_in_block (code) == state->nested)
13034 : /* This block contains the nested loop, recurse on its
13035 : statements. */
13036 : {
13037 90 : gfc_namespace* ns = code->ext.block.ns;
13038 90 : diagnose_intervening_code_errors_1 (ns->code, state);
13039 : }
13040 : else
13041 : /* Treat the whole statement as a unit. */
13042 : {
13043 546 : gfc_code *temp = state->next;
13044 546 : state->next = code->next;
13045 546 : gfc_code_walker (&code, icode_code_error_callback,
13046 : icode_expr_error_callback, state);
13047 546 : state->next = temp;
13048 : }
13049 : }
13050 267 : }
13051 :
13052 : /* Diagnose intervening code errors in BLOCK with nested loop NESTED.
13053 : NAME is the user-friendly name of the OMP directive, used for error
13054 : messages. Returns true if any error was found. */
13055 : static bool
13056 177 : diagnose_intervening_code_errors (gfc_code *chain, const char *name,
13057 : gfc_code *nested)
13058 : {
13059 177 : struct icode_error_state state;
13060 177 : state.name = name;
13061 177 : state.errorp = false;
13062 177 : state.nested = nested;
13063 177 : state.next = NULL;
13064 0 : diagnose_intervening_code_errors_1 (chain, &state);
13065 177 : return state.errorp;
13066 : }
13067 :
13068 : /* Helper function for restructure_intervening_code: wrap CHAIN in
13069 : a marker to indicate that it is a structured block sequence. That
13070 : information will be used later on (in omp-low.cc) for error checking. */
13071 : static gfc_code *
13072 461 : make_structured_block (gfc_code *chain)
13073 : {
13074 461 : gcc_assert (chain);
13075 461 : gfc_namespace *ns = gfc_build_block_ns (gfc_current_ns);
13076 461 : gfc_code *result = gfc_get_code (EXEC_BLOCK);
13077 461 : result->op = EXEC_BLOCK;
13078 461 : result->ext.block.ns = ns;
13079 461 : result->ext.block.assoc = NULL;
13080 461 : result->loc = chain->loc;
13081 461 : ns->omp_structured_block = 1;
13082 461 : ns->code = chain;
13083 461 : return result;
13084 : }
13085 :
13086 : /* Push intervening code surrounding a loop, including nested scopes,
13087 : into the body of the loop. CHAINP is the pointer to the head of
13088 : the next-chain to scan, OUTER_LOOP is the EXEC_DO for the next outer
13089 : loop level, and COLLAPSE is the number of nested loops we need to
13090 : process.
13091 : Note that CHAINP may point at outer_loop->block->next when we
13092 : are scanning the body of a loop, but if there is an intervening block
13093 : CHAINP points into the block's chain rather than its enclosing outer
13094 : loop. This is why OUTER_LOOP is passed separately. */
13095 : static gfc_code *
13096 7213 : restructure_intervening_code (gfc_code **chainp, gfc_code *outer_loop,
13097 : int count)
13098 : {
13099 7213 : gfc_code *code;
13100 7213 : gfc_code *head = *chainp;
13101 7213 : gfc_code *tail = NULL;
13102 7213 : gfc_code *innermost_loop = NULL;
13103 :
13104 7477 : for (code = *chainp; code; code = code->next, chainp = &(*chainp)->next)
13105 : {
13106 7477 : if (code->op == EXEC_DO)
13107 : {
13108 : /* Cut CODE free from its chain, leaving the ends dangling. */
13109 7129 : *chainp = NULL;
13110 7129 : tail = code->next;
13111 7129 : code->next = NULL;
13112 :
13113 7129 : if (count == 1)
13114 : innermost_loop = code;
13115 : else
13116 2090 : innermost_loop
13117 2090 : = restructure_intervening_code (&code->block->next,
13118 : code, count - 1);
13119 : break;
13120 : }
13121 348 : else if (code->op == EXEC_BLOCK
13122 348 : && find_nested_loop_in_block (code))
13123 : {
13124 84 : gfc_namespace *ns = code->ext.block.ns;
13125 :
13126 : /* Cut CODE free from its chain, leaving the ends dangling. */
13127 84 : *chainp = NULL;
13128 84 : tail = code->next;
13129 84 : code->next = NULL;
13130 :
13131 84 : innermost_loop
13132 84 : = restructure_intervening_code (&ns->code, outer_loop,
13133 : count);
13134 :
13135 : /* At this point we have already pulled out the nested loop and
13136 : pointed outer_loop at it, and moved the intervening code that
13137 : was previously in the block into the body of innermost_loop.
13138 : Now we want to move the BLOCK itself so it wraps the entire
13139 : current body of innermost_loop. */
13140 84 : ns->code = innermost_loop->block->next;
13141 84 : innermost_loop->block->next = code;
13142 84 : break;
13143 : }
13144 : }
13145 :
13146 2174 : gcc_assert (innermost_loop);
13147 :
13148 : /* Now we have split the intervening code into two parts:
13149 : head is the start of the part before the loop/block, terminating
13150 : at *chainp, and tail is the part after it. Mark each part as
13151 : a structured block sequence, and splice the two parts around the
13152 : existing body of the innermost loop. */
13153 7213 : if (head != code)
13154 : {
13155 222 : gfc_code *block = make_structured_block (head);
13156 222 : if (innermost_loop->block->next)
13157 221 : gfc_append_code (block, innermost_loop->block->next);
13158 222 : innermost_loop->block->next = block;
13159 : }
13160 7213 : if (tail)
13161 : {
13162 239 : gfc_code *block = make_structured_block (tail);
13163 239 : if (innermost_loop->block->next)
13164 237 : gfc_append_code (innermost_loop->block->next, block);
13165 : else
13166 2 : innermost_loop->block->next = block;
13167 : }
13168 :
13169 : /* For loops, finally splice CODE into OUTER_LOOP. We already handled
13170 : relinking EXEC_BLOCK above. */
13171 7213 : if (code->op == EXEC_DO && outer_loop)
13172 7129 : outer_loop->block->next = code;
13173 :
13174 7213 : return innermost_loop;
13175 : }
13176 :
13177 : /* CODE is an OMP loop construct. Return true if VAR matches an iteration
13178 : variable outer to level DEPTH. */
13179 : static bool
13180 8126 : is_outer_iteration_variable (gfc_code *code, int depth, gfc_symbol *var)
13181 : {
13182 8126 : int i;
13183 8126 : gfc_code *do_code = code;
13184 :
13185 12653 : for (i = 1; i < depth; i++)
13186 : {
13187 5028 : do_code = find_nested_loop_in_chain (do_code->block->next);
13188 5028 : gcc_assert (do_code);
13189 5028 : if (do_code->op == EXEC_OMP_TILE || do_code->op == EXEC_OMP_UNROLL)
13190 : {
13191 51 : --i;
13192 51 : continue;
13193 : }
13194 4977 : gfc_symbol *ivar = do_code->ext.iterator->var->symtree->n.sym;
13195 4977 : if (var == ivar)
13196 : return true;
13197 : }
13198 : return false;
13199 : }
13200 :
13201 : /* Forward declaration for recursive functions. */
13202 : static gfc_code *
13203 : check_nested_loop_in_block (gfc_code *block, gfc_expr *expr, gfc_symbol *sym,
13204 : bool *bad);
13205 :
13206 : /* Like find_nested_loop_in_chain, but additionally check that EXPR
13207 : does not reference any variables bound in intervening EXEC_BLOCKs
13208 : and that SYM is not bound in such intervening blocks. Either EXPR or SYM
13209 : may be null. Sets *BAD to true if either test fails. */
13210 : static gfc_code *
13211 48337 : check_nested_loop_in_chain (gfc_code *chain, gfc_expr *expr, gfc_symbol *sym,
13212 : bool *bad)
13213 : {
13214 51941 : for (gfc_code *code = chain; code; code = code->next)
13215 : {
13216 51653 : if (code->op == EXEC_DO)
13217 : return code;
13218 4123 : else if (code->op == EXEC_OMP_TILE || code->op == EXEC_OMP_UNROLL)
13219 1682 : return check_nested_loop_in_chain (code->block->next, expr, sym, bad);
13220 2441 : else if (code->op == EXEC_BLOCK)
13221 : {
13222 807 : gfc_code *c = check_nested_loop_in_block (code, expr, sym, bad);
13223 807 : if (c)
13224 : return c;
13225 : }
13226 : }
13227 : return NULL;
13228 : }
13229 :
13230 : /* Code walker for block symtrees. It doesn't take any kind of state
13231 : argument, so use a static variable. */
13232 : static struct check_nested_loop_in_block_state_t {
13233 : gfc_expr *expr;
13234 : gfc_symbol *sym;
13235 : bool *bad;
13236 : } check_nested_loop_in_block_state;
13237 :
13238 : static void
13239 766 : check_nested_loop_in_block_symbol (gfc_symbol *sym)
13240 : {
13241 766 : if (sym == check_nested_loop_in_block_state.sym
13242 766 : || (check_nested_loop_in_block_state.expr
13243 567 : && gfc_find_sym_in_expr (sym,
13244 : check_nested_loop_in_block_state.expr)))
13245 5 : *check_nested_loop_in_block_state.bad = true;
13246 766 : }
13247 :
13248 : /* Return the first nested DO loop in BLOCK, or NULL if there
13249 : isn't one. Set *BAD to true if EXPR references any variables in BLOCK, or
13250 : SYM is bound in BLOCK. Either EXPR or SYM may be null. */
13251 : static gfc_code *
13252 807 : check_nested_loop_in_block (gfc_code *block, gfc_expr *expr,
13253 : gfc_symbol *sym, bool *bad)
13254 : {
13255 807 : gfc_namespace *ns;
13256 807 : gcc_assert (block->op == EXEC_BLOCK);
13257 807 : ns = block->ext.block.ns;
13258 807 : gcc_assert (ns);
13259 :
13260 : /* Skip the check if this block doesn't contain the nested loop, or
13261 : if we already know it's bad. */
13262 807 : gfc_code *result = check_nested_loop_in_chain (ns->code, expr, sym, bad);
13263 807 : if (result && !*bad)
13264 : {
13265 519 : check_nested_loop_in_block_state.expr = expr;
13266 519 : check_nested_loop_in_block_state.sym = sym;
13267 519 : check_nested_loop_in_block_state.bad = bad;
13268 519 : gfc_traverse_ns (ns, check_nested_loop_in_block_symbol);
13269 519 : check_nested_loop_in_block_state.expr = NULL;
13270 519 : check_nested_loop_in_block_state.sym = NULL;
13271 519 : check_nested_loop_in_block_state.bad = NULL;
13272 : }
13273 807 : return result;
13274 : }
13275 :
13276 : /* CODE is an OMP loop construct. Return true if EXPR references
13277 : any variables bound in intervening code, to level DEPTH. */
13278 : static bool
13279 22846 : expr_uses_intervening_var (gfc_code *code, int depth, gfc_expr *expr)
13280 : {
13281 22846 : int i;
13282 22846 : gfc_code *do_code = code;
13283 :
13284 58471 : for (i = 0; i < depth; i++)
13285 : {
13286 35628 : bool bad = false;
13287 35628 : do_code = check_nested_loop_in_chain (do_code->block->next,
13288 : expr, NULL, &bad);
13289 35628 : if (bad)
13290 3 : return true;
13291 : }
13292 : return false;
13293 : }
13294 :
13295 : /* CODE is an OMP loop construct. Return true if SYM is bound in
13296 : intervening code, to level DEPTH. */
13297 : static bool
13298 7625 : is_intervening_var (gfc_code *code, int depth, gfc_symbol *sym)
13299 : {
13300 7625 : int i;
13301 7625 : gfc_code *do_code = code;
13302 :
13303 19525 : for (i = 0; i < depth; i++)
13304 : {
13305 11902 : bool bad = false;
13306 11902 : do_code = check_nested_loop_in_chain (do_code->block->next,
13307 : NULL, sym, &bad);
13308 11902 : if (bad)
13309 2 : return true;
13310 : }
13311 : return false;
13312 : }
13313 :
13314 : /* CODE is an OMP loop construct. Return true if EXPR does not reference
13315 : any iteration variables outer to level DEPTH. */
13316 : static bool
13317 23925 : expr_is_invariant (gfc_code *code, int depth, gfc_expr *expr)
13318 : {
13319 23925 : int i;
13320 23925 : gfc_code *do_code = code;
13321 :
13322 37247 : for (i = 1; i < depth; i++)
13323 : {
13324 14388 : do_code = find_nested_loop_in_chain (do_code->block->next);
13325 14388 : gcc_assert (do_code);
13326 14388 : if (do_code->op == EXEC_OMP_TILE || do_code->op == EXEC_OMP_UNROLL)
13327 : {
13328 136 : --i;
13329 136 : continue;
13330 : }
13331 14252 : gfc_symbol *ivar = do_code->ext.iterator->var->symtree->n.sym;
13332 14252 : if (gfc_find_sym_in_expr (ivar, expr))
13333 : return false;
13334 : }
13335 : return true;
13336 : }
13337 :
13338 : /* CODE is an OMP loop construct. Return true if EXPR matches one of the
13339 : canonical forms for a bound expression. It may include references to
13340 : an iteration variable outer to level DEPTH; set OUTER_VARP if so. */
13341 : static bool
13342 15241 : bound_expr_is_canonical (gfc_code *code, int depth, gfc_expr *expr,
13343 : gfc_symbol **outer_varp)
13344 : {
13345 15241 : gfc_expr *expr2 = NULL;
13346 :
13347 : /* Rectangular case. */
13348 15241 : if (depth == 0 || expr_is_invariant (code, depth, expr))
13349 : return true;
13350 :
13351 : /* Any simple variable that didn't pass expr_is_invariant must be
13352 : an outer_var. */
13353 568 : if (expr->expr_type == EXPR_VARIABLE && expr->rank == 0)
13354 : {
13355 63 : *outer_varp = expr->symtree->n.sym;
13356 63 : return true;
13357 : }
13358 :
13359 : /* All other permitted forms are binary operators. */
13360 505 : if (expr->expr_type != EXPR_OP)
13361 : return false;
13362 :
13363 : /* Check for plus/minus a loop invariant expr. */
13364 503 : if (expr->value.op.op == INTRINSIC_PLUS
13365 503 : || expr->value.op.op == INTRINSIC_MINUS)
13366 : {
13367 483 : if (expr_is_invariant (code, depth, expr->value.op.op1))
13368 48 : expr2 = expr->value.op.op2;
13369 435 : else if (expr_is_invariant (code, depth, expr->value.op.op2))
13370 434 : expr2 = expr->value.op.op1;
13371 : else
13372 : return false;
13373 : }
13374 : else
13375 : expr2 = expr;
13376 :
13377 : /* Check for a product with a loop-invariant expr. */
13378 502 : if (expr2->expr_type == EXPR_OP
13379 96 : && expr2->value.op.op == INTRINSIC_TIMES)
13380 : {
13381 96 : if (expr_is_invariant (code, depth, expr2->value.op.op1))
13382 40 : expr2 = expr2->value.op.op2;
13383 56 : else if (expr_is_invariant (code, depth, expr2->value.op.op2))
13384 53 : expr2 = expr2->value.op.op1;
13385 : else
13386 : return false;
13387 : }
13388 :
13389 : /* What's left must be a reference to an outer loop variable. */
13390 499 : if (expr2->expr_type == EXPR_VARIABLE
13391 499 : && expr2->rank == 0
13392 998 : && is_outer_iteration_variable (code, depth, expr2->symtree->n.sym))
13393 : {
13394 499 : *outer_varp = expr2->symtree->n.sym;
13395 499 : return true;
13396 : }
13397 :
13398 : return false;
13399 : }
13400 :
13401 : static void
13402 5463 : resolve_omp_do (gfc_code *code)
13403 : {
13404 5463 : gfc_code *do_code, *next;
13405 5463 : int i, count, non_generated_count;
13406 5463 : gfc_omp_namelist *n;
13407 5463 : gfc_symbol *dovar;
13408 5463 : const char *name;
13409 5463 : bool is_simd = false;
13410 5463 : bool errorp = false;
13411 5463 : bool perfect_nesting_errorp = false;
13412 5463 : bool imperfect = false;
13413 :
13414 5463 : switch (code->op)
13415 : {
13416 : case EXEC_OMP_DISTRIBUTE: name = "!$OMP DISTRIBUTE"; break;
13417 55 : case EXEC_OMP_DISTRIBUTE_PARALLEL_DO:
13418 55 : name = "!$OMP DISTRIBUTE PARALLEL DO";
13419 55 : break;
13420 32 : case EXEC_OMP_DISTRIBUTE_PARALLEL_DO_SIMD:
13421 32 : name = "!$OMP DISTRIBUTE PARALLEL DO SIMD";
13422 32 : is_simd = true;
13423 32 : break;
13424 50 : case EXEC_OMP_DISTRIBUTE_SIMD:
13425 50 : name = "!$OMP DISTRIBUTE SIMD";
13426 50 : is_simd = true;
13427 50 : break;
13428 1338 : case EXEC_OMP_DO: name = "!$OMP DO"; break;
13429 136 : case EXEC_OMP_DO_SIMD: name = "!$OMP DO SIMD"; is_simd = true; break;
13430 64 : case EXEC_OMP_LOOP: name = "!$OMP LOOP"; break;
13431 1220 : case EXEC_OMP_PARALLEL_DO: name = "!$OMP PARALLEL DO"; break;
13432 304 : case EXEC_OMP_PARALLEL_DO_SIMD:
13433 304 : name = "!$OMP PARALLEL DO SIMD";
13434 304 : is_simd = true;
13435 304 : break;
13436 46 : case EXEC_OMP_PARALLEL_LOOP: name = "!$OMP PARALLEL LOOP"; break;
13437 7 : case EXEC_OMP_PARALLEL_MASKED_TASKLOOP:
13438 7 : name = "!$OMP PARALLEL MASKED TASKLOOP";
13439 7 : break;
13440 10 : case EXEC_OMP_PARALLEL_MASKED_TASKLOOP_SIMD:
13441 10 : name = "!$OMP PARALLEL MASKED TASKLOOP SIMD";
13442 10 : is_simd = true;
13443 10 : break;
13444 13 : case EXEC_OMP_PARALLEL_MASTER_TASKLOOP:
13445 13 : name = "!$OMP PARALLEL MASTER TASKLOOP";
13446 13 : break;
13447 18 : case EXEC_OMP_PARALLEL_MASTER_TASKLOOP_SIMD:
13448 18 : name = "!$OMP PARALLEL MASTER TASKLOOP SIMD";
13449 18 : is_simd = true;
13450 18 : break;
13451 8 : case EXEC_OMP_MASKED_TASKLOOP: name = "!$OMP MASKED TASKLOOP"; break;
13452 14 : case EXEC_OMP_MASKED_TASKLOOP_SIMD:
13453 14 : name = "!$OMP MASKED TASKLOOP SIMD";
13454 14 : is_simd = true;
13455 14 : break;
13456 14 : case EXEC_OMP_MASTER_TASKLOOP: name = "!$OMP MASTER TASKLOOP"; break;
13457 19 : case EXEC_OMP_MASTER_TASKLOOP_SIMD:
13458 19 : name = "!$OMP MASTER TASKLOOP SIMD";
13459 19 : is_simd = true;
13460 19 : break;
13461 801 : case EXEC_OMP_SIMD: name = "!$OMP SIMD"; is_simd = true; break;
13462 88 : case EXEC_OMP_TARGET_PARALLEL_DO: name = "!$OMP TARGET PARALLEL DO"; break;
13463 20 : case EXEC_OMP_TARGET_PARALLEL_DO_SIMD:
13464 20 : name = "!$OMP TARGET PARALLEL DO SIMD";
13465 20 : is_simd = true;
13466 20 : break;
13467 16 : case EXEC_OMP_TARGET_PARALLEL_LOOP:
13468 16 : name = "!$OMP TARGET PARALLEL LOOP";
13469 16 : break;
13470 33 : case EXEC_OMP_TARGET_SIMD:
13471 33 : name = "!$OMP TARGET SIMD";
13472 33 : is_simd = true;
13473 33 : break;
13474 20 : case EXEC_OMP_TARGET_TEAMS_DISTRIBUTE:
13475 20 : name = "!$OMP TARGET TEAMS DISTRIBUTE";
13476 20 : break;
13477 77 : case EXEC_OMP_TARGET_TEAMS_DISTRIBUTE_PARALLEL_DO:
13478 77 : name = "!$OMP TARGET TEAMS DISTRIBUTE PARALLEL DO";
13479 77 : break;
13480 38 : case EXEC_OMP_TARGET_TEAMS_DISTRIBUTE_PARALLEL_DO_SIMD:
13481 38 : name = "!$OMP TARGET TEAMS DISTRIBUTE PARALLEL DO SIMD";
13482 38 : is_simd = true;
13483 38 : break;
13484 20 : case EXEC_OMP_TARGET_TEAMS_DISTRIBUTE_SIMD:
13485 20 : name = "!$OMP TARGET TEAMS DISTRIBUTE SIMD";
13486 20 : is_simd = true;
13487 20 : break;
13488 19 : case EXEC_OMP_TARGET_TEAMS_LOOP: name = "!$OMP TARGET TEAMS LOOP"; break;
13489 69 : case EXEC_OMP_TASKLOOP: name = "!$OMP TASKLOOP"; break;
13490 38 : case EXEC_OMP_TASKLOOP_SIMD:
13491 38 : name = "!$OMP TASKLOOP SIMD";
13492 38 : is_simd = true;
13493 38 : break;
13494 20 : case EXEC_OMP_TEAMS_DISTRIBUTE: name = "!$OMP TEAMS DISTRIBUTE"; break;
13495 39 : case EXEC_OMP_TEAMS_DISTRIBUTE_PARALLEL_DO:
13496 39 : name = "!$OMP TEAMS DISTRIBUTE PARALLEL DO";
13497 39 : break;
13498 61 : case EXEC_OMP_TEAMS_DISTRIBUTE_PARALLEL_DO_SIMD:
13499 61 : name = "!$OMP TEAMS DISTRIBUTE PARALLEL DO SIMD";
13500 61 : is_simd = true;
13501 61 : break;
13502 42 : case EXEC_OMP_TEAMS_DISTRIBUTE_SIMD:
13503 42 : name = "!$OMP TEAMS DISTRIBUTE SIMD";
13504 42 : is_simd = true;
13505 42 : break;
13506 48 : case EXEC_OMP_TEAMS_LOOP: name = "!$OMP TEAMS LOOP"; break;
13507 195 : case EXEC_OMP_TILE: name = "!$OMP TILE"; break;
13508 417 : case EXEC_OMP_UNROLL: name = "!$OMP UNROLL"; break;
13509 0 : default: gcc_unreachable ();
13510 : }
13511 :
13512 5463 : if (code->ext.omp_clauses)
13513 5463 : resolve_omp_clauses (code, code->ext.omp_clauses, NULL);
13514 :
13515 5463 : if (code->op == EXEC_OMP_TILE && code->ext.omp_clauses->sizes_list == NULL)
13516 0 : gfc_error ("SIZES clause is required on !$OMP TILE construct at %L",
13517 : &code->loc);
13518 :
13519 5463 : do_code = code->block->next;
13520 5463 : if (code->ext.omp_clauses->orderedc)
13521 : count = code->ext.omp_clauses->orderedc;
13522 5319 : else if (code->ext.omp_clauses->sizes_list)
13523 195 : count = gfc_expr_list_len (code->ext.omp_clauses->sizes_list);
13524 : else
13525 : {
13526 5124 : count = code->ext.omp_clauses->collapse;
13527 5124 : if (count <= 0)
13528 : count = 1;
13529 : }
13530 :
13531 5463 : non_generated_count = count;
13532 : /* While the spec defines the loop nest depth independently of the COLLAPSE
13533 : clause, in practice the middle end only pays attention to the COLLAPSE
13534 : depth and treats any further inner loops as the final-loop-body. So
13535 : here we also check canonical loop nest form only for the number of
13536 : outer loops specified by the COLLAPSE clause too. */
13537 8103 : for (i = 1; i <= count; i++)
13538 : {
13539 8103 : gfc_symbol *start_var = NULL, *end_var = NULL;
13540 : /* Parse errors are not recoverable. */
13541 8103 : if (do_code->op == EXEC_DO_WHILE)
13542 : {
13543 6 : gfc_error ("%s cannot be a DO WHILE or DO without loop control "
13544 : "at %L", name, &do_code->loc);
13545 106 : goto fail;
13546 : }
13547 8097 : if (do_code->op == EXEC_DO_CONCURRENT)
13548 : {
13549 4 : gfc_error ("%s cannot be a DO CONCURRENT loop at %L", name,
13550 : &do_code->loc);
13551 4 : goto fail;
13552 : }
13553 8093 : if (do_code->op == EXEC_OMP_TILE || do_code->op == EXEC_OMP_UNROLL)
13554 : {
13555 466 : if (do_code->op == EXEC_OMP_UNROLL)
13556 : {
13557 308 : if (!do_code->ext.omp_clauses->partial)
13558 : {
13559 53 : gfc_error ("Generated loop of UNROLL construct at %L "
13560 : "without PARTIAL clause does not have "
13561 : "canonical form", &do_code->loc);
13562 53 : goto fail;
13563 : }
13564 255 : else if (i != count)
13565 : {
13566 5 : gfc_error ("UNROLL construct at %L with PARTIAL clause "
13567 : "generates just one loop with canonical form "
13568 : "but %d loops are needed",
13569 5 : &do_code->loc, count - i + 1);
13570 5 : goto fail;
13571 : }
13572 : }
13573 158 : else if (do_code->op == EXEC_OMP_TILE)
13574 : {
13575 158 : if (do_code->ext.omp_clauses->sizes_list == NULL)
13576 : /* This should have been diagnosed earlier already. */
13577 0 : return;
13578 158 : int l = gfc_expr_list_len (do_code->ext.omp_clauses->sizes_list);
13579 158 : if (count - i + 1 > l)
13580 : {
13581 14 : gfc_error ("TILE construct at %L generates %d loops "
13582 : "with canonical form but %d loops are needed",
13583 : &do_code->loc, l, count - i + 1);
13584 14 : goto fail;
13585 : }
13586 : }
13587 394 : if (do_code->ext.omp_clauses && do_code->ext.omp_clauses->erroneous)
13588 17 : goto fail;
13589 377 : if (imperfect && !perfect_nesting_errorp)
13590 : {
13591 4 : sorry_at (gfc_get_location (&do_code->loc),
13592 : "Imperfectly nested loop using generated loops");
13593 4 : errorp = true;
13594 : }
13595 377 : if (non_generated_count == count)
13596 329 : non_generated_count = i - 1;
13597 377 : --i;
13598 377 : do_code = do_code->block->next;
13599 377 : continue;
13600 377 : }
13601 7627 : gcc_assert (do_code->op == EXEC_DO);
13602 7627 : if (do_code->ext.iterator->var->ts.type != BT_INTEGER)
13603 : {
13604 3 : gfc_error ("%s iteration variable must be of type integer at %L",
13605 : name, &do_code->loc);
13606 3 : errorp = true;
13607 : }
13608 7627 : dovar = do_code->ext.iterator->var->symtree->n.sym;
13609 7627 : if (dovar->attr.threadprivate)
13610 : {
13611 0 : gfc_error ("%s iteration variable must not be THREADPRIVATE "
13612 : "at %L", name, &do_code->loc);
13613 0 : errorp = true;
13614 : }
13615 7627 : if (code->ext.omp_clauses)
13616 305080 : for (enum gfc_omp_list_type list = OMP_LIST_FIRST; list < OMP_LIST_NUM;
13617 297453 : list = gfc_omp_list_type (list + 1))
13618 98358 : if (!is_simd || code->ext.omp_clauses->collapse > 1
13619 297453 : ? (list != OMP_LIST_PRIVATE && list != OMP_LIST_LASTPRIVATE
13620 255450 : && list != OMP_LIST_ALLOCATE)
13621 42003 : : (list != OMP_LIST_PRIVATE && list != OMP_LIST_LASTPRIVATE
13622 42003 : && list != OMP_LIST_ALLOCATE && list != OMP_LIST_LINEAR))
13623 277882 : for (n = code->ext.omp_clauses->lists[list]; n; n = n->next)
13624 4387 : if (dovar == n->sym)
13625 : {
13626 5 : if (!is_simd || code->ext.omp_clauses->collapse > 1)
13627 4 : gfc_error ("%s iteration variable present on clause "
13628 : "other than PRIVATE, LASTPRIVATE or "
13629 : "ALLOCATE at %L", name, &do_code->loc);
13630 : else
13631 1 : gfc_error ("%s iteration variable present on clause "
13632 : "other than PRIVATE, LASTPRIVATE, ALLOCATE or "
13633 : "LINEAR at %L", name, &do_code->loc);
13634 : errorp = true;
13635 : }
13636 7627 : if (is_outer_iteration_variable (code, i, dovar))
13637 : {
13638 2 : gfc_error ("%s iteration variable used in more than one loop at %L",
13639 : name, &do_code->loc);
13640 2 : errorp = true;
13641 : }
13642 7625 : else if (is_intervening_var (code, i, dovar))
13643 : {
13644 2 : gfc_error ("%s iteration variable at %L is bound in "
13645 : "intervening code",
13646 : name, &do_code->loc);
13647 2 : errorp = true;
13648 : }
13649 7623 : else if (!bound_expr_is_canonical (code, i,
13650 7623 : do_code->ext.iterator->start,
13651 : &start_var))
13652 : {
13653 4 : gfc_error ("%s loop start expression not in canonical form at %L",
13654 : name, &do_code->loc);
13655 4 : errorp = true;
13656 : }
13657 7619 : else if (expr_uses_intervening_var (code, i,
13658 7619 : do_code->ext.iterator->start))
13659 : {
13660 1 : gfc_error ("%s loop start expression at %L uses variable bound in "
13661 : "intervening code",
13662 : name, &do_code->loc);
13663 1 : errorp = true;
13664 : }
13665 7618 : else if (!bound_expr_is_canonical (code, i,
13666 7618 : do_code->ext.iterator->end,
13667 : &end_var))
13668 : {
13669 2 : gfc_error ("%s loop end expression not in canonical form at %L",
13670 : name, &do_code->loc);
13671 2 : errorp = true;
13672 : }
13673 7616 : else if (expr_uses_intervening_var (code, i,
13674 7616 : do_code->ext.iterator->end))
13675 : {
13676 1 : gfc_error ("%s loop end expression at %L uses variable bound in "
13677 : "intervening code",
13678 : name, &do_code->loc);
13679 1 : errorp = true;
13680 : }
13681 7615 : else if (start_var && end_var && start_var != end_var)
13682 : {
13683 1 : gfc_error ("%s loop bounds reference different "
13684 : "iteration variables at %L", name, &do_code->loc);
13685 1 : errorp = true;
13686 : }
13687 7614 : else if (!expr_is_invariant (code, i, do_code->ext.iterator->step))
13688 : {
13689 3 : gfc_error ("%s loop increment not in canonical form at %L",
13690 : name, &do_code->loc);
13691 3 : errorp = true;
13692 : }
13693 7611 : else if (expr_uses_intervening_var (code, i,
13694 7611 : do_code->ext.iterator->step))
13695 : {
13696 1 : gfc_error ("%s loop increment expression at %L uses variable "
13697 : "bound in intervening code",
13698 : name, &do_code->loc);
13699 1 : errorp = true;
13700 : }
13701 7627 : if (start_var || end_var)
13702 : {
13703 528 : code->ext.omp_clauses->non_rectangular = 1;
13704 528 : if (i > non_generated_count)
13705 : {
13706 3 : sorry_at (gfc_get_location (&do_code->loc),
13707 : "Non-rectangular loops from generated loops "
13708 : "unsupported");
13709 3 : errorp = true;
13710 : }
13711 : }
13712 :
13713 : /* Only parse loop body into nested loop and intervening code if
13714 : there are supposed to be more loops in the nest to collapse. */
13715 7627 : if (i == count)
13716 : break;
13717 :
13718 2270 : next = find_nested_loop_in_chain (do_code->block->next);
13719 :
13720 2270 : if (!next)
13721 : {
13722 : /* Parse error, can't recover from this. */
13723 7 : gfc_error ("not enough DO loops for collapsed %s (level %d) at %L",
13724 : name, i, &code->loc);
13725 7 : goto fail;
13726 : }
13727 2263 : else if (next != do_code->block->next
13728 2103 : || (next->next && next->next->op != EXEC_CONTINUE))
13729 : /* Imperfectly nested loop found. */
13730 : {
13731 : /* Only diagnose violation of imperfect nesting constraints once. */
13732 177 : if (!perfect_nesting_errorp)
13733 : {
13734 176 : if (code->ext.omp_clauses->orderedc)
13735 : {
13736 3 : gfc_error ("%s inner loops must be perfectly nested with "
13737 : "ORDERED clause at %L",
13738 : name, &code->loc);
13739 3 : perfect_nesting_errorp = true;
13740 : }
13741 173 : else if (code->ext.omp_clauses->lists[OMP_LIST_REDUCTION_INSCAN])
13742 : {
13743 2 : gfc_error ("%s inner loops must be perfectly nested with "
13744 : "REDUCTION INSCAN clause at %L",
13745 : name, &code->loc);
13746 2 : perfect_nesting_errorp = true;
13747 : }
13748 171 : else if (code->op == EXEC_OMP_TILE)
13749 : {
13750 8 : gfc_error ("%s inner loops must be perfectly nested at %L",
13751 : name, &code->loc);
13752 8 : perfect_nesting_errorp = true;
13753 : }
13754 13 : if (perfect_nesting_errorp)
13755 : errorp = true;
13756 : }
13757 177 : if (diagnose_intervening_code_errors (do_code->block->next,
13758 : name, next))
13759 5 : errorp = true;
13760 : imperfect = true;
13761 : }
13762 2263 : do_code = next;
13763 : }
13764 :
13765 : /* Give up now if we found any constraint violations. */
13766 5357 : if (errorp)
13767 : {
13768 48 : fail:
13769 154 : if (code->ext.omp_clauses)
13770 154 : code->ext.omp_clauses->erroneous = 1;
13771 : return;
13772 : }
13773 :
13774 5309 : if (non_generated_count)
13775 5039 : restructure_intervening_code (&code->block->next, code,
13776 : non_generated_count);
13777 : }
13778 :
13779 : /* Resolve the context selector. In particular, SKIP_P is set to true,
13780 : the context can never be matched. */
13781 :
13782 : static void
13783 804 : gfc_resolve_omp_context_selector (gfc_omp_set_selector *oss,
13784 : bool is_metadirective, bool *skip_p)
13785 : {
13786 804 : if (skip_p)
13787 327 : *skip_p = false;
13788 1527 : for (gfc_omp_set_selector *set_selector = oss; set_selector;
13789 723 : set_selector = set_selector->next)
13790 1558 : for (gfc_omp_selector *os = set_selector->trait_selectors; os; os = os->next)
13791 : {
13792 853 : if (os->score)
13793 : {
13794 52 : if (!gfc_resolve_expr (os->score)
13795 52 : || os->score->ts.type != BT_INTEGER
13796 104 : || os->score->rank != 0)
13797 : {
13798 0 : gfc_error ("%<score%> argument must be constant integer "
13799 0 : "expression at %L", &os->score->where);
13800 0 : gfc_free_expr (os->score);
13801 0 : os->score = nullptr;
13802 : }
13803 52 : else if (os->score->expr_type == EXPR_CONSTANT
13804 52 : && mpz_sgn (os->score->value.integer) < 0)
13805 : {
13806 1 : gfc_error ("%<score%> argument must be non-negative at %L",
13807 : &os->score->where);
13808 1 : gfc_free_expr (os->score);
13809 1 : os->score = nullptr;
13810 : }
13811 : }
13812 :
13813 853 : if (os->code == OMP_TRAIT_INVALID)
13814 : break;
13815 835 : enum omp_tp_type property_kind = omp_ts_map[os->code].tp_type;
13816 835 : gfc_omp_trait_property *otp = os->properties;
13817 :
13818 835 : if (!otp)
13819 419 : continue;
13820 416 : switch (property_kind)
13821 : {
13822 148 : case OMP_TRAIT_PROPERTY_DEV_NUM_EXPR:
13823 148 : case OMP_TRAIT_PROPERTY_BOOL_EXPR:
13824 148 : if (!gfc_resolve_expr (otp->expr)
13825 147 : || (property_kind == OMP_TRAIT_PROPERTY_BOOL_EXPR
13826 133 : && otp->expr->ts.type != BT_LOGICAL)
13827 146 : || (property_kind == OMP_TRAIT_PROPERTY_DEV_NUM_EXPR
13828 14 : && otp->expr->ts.type != BT_INTEGER)
13829 146 : || otp->expr->rank != 0
13830 294 : || (!is_metadirective && otp->expr->expr_type != EXPR_CONSTANT))
13831 : {
13832 3 : if (is_metadirective)
13833 : {
13834 0 : if (property_kind == OMP_TRAIT_PROPERTY_BOOL_EXPR)
13835 0 : gfc_error ("property must be a "
13836 : "logical expression at %L",
13837 0 : &otp->expr->where);
13838 : else
13839 0 : gfc_error ("property must be an "
13840 : "integer expression at %L",
13841 0 : &otp->expr->where);
13842 : }
13843 : else
13844 : {
13845 3 : if (property_kind == OMP_TRAIT_PROPERTY_BOOL_EXPR)
13846 2 : gfc_error ("property must be a constant "
13847 : "logical expression at %L",
13848 2 : &otp->expr->where);
13849 : else
13850 1 : gfc_error ("property must be a constant "
13851 : "integer expression at %L",
13852 1 : &otp->expr->where);
13853 : }
13854 : /* Prevent later ICEs. */
13855 3 : gfc_expr *e;
13856 3 : if (property_kind == OMP_TRAIT_PROPERTY_BOOL_EXPR)
13857 2 : e = gfc_get_logical_expr (gfc_default_logical_kind,
13858 2 : &otp->expr->where, true);
13859 : else
13860 1 : e = gfc_get_int_expr (gfc_default_integer_kind,
13861 1 : &otp->expr->where, 0);
13862 3 : gfc_free_expr (otp->expr);
13863 3 : otp->expr = e;
13864 3 : continue;
13865 3 : }
13866 : /* Device number must be conforming, which includes
13867 : omp_initial_device (-1), omp_invalid_device (-4),
13868 : and omp_default_device (-5). */
13869 145 : if (property_kind == OMP_TRAIT_PROPERTY_DEV_NUM_EXPR
13870 14 : && otp->expr->expr_type == EXPR_CONSTANT
13871 5 : && mpz_sgn (otp->expr->value.integer) < 0
13872 3 : && mpz_cmp_si (otp->expr->value.integer, -1) != 0
13873 2 : && mpz_cmp_si (otp->expr->value.integer, -4) != 0
13874 1 : && mpz_cmp_si (otp->expr->value.integer, -5) != 0)
13875 1 : gfc_error ("property must be a conforming device number at %L",
13876 : &otp->expr->where);
13877 : break;
13878 : default:
13879 : break;
13880 : }
13881 : /* This only handles one specific case: User condition.
13882 : FIXME: Handle more cases by calling omp_context_selector_matches;
13883 : unfortunately, we cannot generate the tree here as, e.g., PARM_DECL
13884 : backend decl are not available at this stage - but might be used in,
13885 : e.g. user conditions. See PR122361. */
13886 413 : if (skip_p && otp
13887 149 : && os->code == OMP_TRAIT_USER_CONDITION
13888 88 : && otp->expr->expr_type == EXPR_CONSTANT
13889 14 : && otp->expr->value.logical == false)
13890 12 : *skip_p = true;
13891 : }
13892 804 : }
13893 :
13894 :
13895 : static void
13896 146 : resolve_omp_metadirective (gfc_code *code, gfc_namespace *ns)
13897 : {
13898 146 : gfc_omp_variant *variant = code->ext.omp_variants;
13899 146 : gfc_omp_variant *prev_variant = variant;
13900 :
13901 473 : while (variant)
13902 : {
13903 327 : bool skip;
13904 327 : gfc_resolve_omp_context_selector (variant->selectors, true, &skip);
13905 327 : gfc_code *variant_code = variant->code;
13906 327 : gfc_resolve_code (variant_code, ns);
13907 327 : if (skip)
13908 : {
13909 : /* The following should only be true if an error occurred
13910 : as the 'otherwise' clause should always match. */
13911 12 : if (variant == code->ext.omp_variants && !variant->next)
13912 : break;
13913 12 : gfc_omp_variant *tmp = variant;
13914 12 : if (variant == code->ext.omp_variants)
13915 11 : variant = prev_variant = code->ext.omp_variants = variant->next;
13916 : else
13917 1 : variant = prev_variant->next = variant->next;
13918 12 : gfc_free_omp_set_selector_list (tmp->selectors);
13919 12 : free (tmp);
13920 : }
13921 : else
13922 : {
13923 315 : prev_variant = variant;
13924 315 : variant = variant->next;
13925 : }
13926 : }
13927 : /* Replace metadirective by its body if only 'nothing' remains. */
13928 146 : if (!code->ext.omp_variants->next && code->ext.omp_variants->stmt == ST_NONE)
13929 : {
13930 11 : gfc_code *next = code->next;
13931 11 : gfc_code *inner = code->ext.omp_variants->code;
13932 11 : gfc_free_omp_set_selector_list (code->ext.omp_variants->selectors);
13933 11 : free (code->ext.omp_variants);
13934 11 : *code = *inner;
13935 11 : free (inner);
13936 11 : while (code->next)
13937 : code = code->next;
13938 11 : code->next = next;
13939 : }
13940 146 : }
13941 :
13942 :
13943 : static gfc_statement
13944 63 : omp_code_to_statement (gfc_code *code)
13945 : {
13946 63 : switch (code->op)
13947 : {
13948 : case EXEC_OMP_PARALLEL:
13949 : return ST_OMP_PARALLEL;
13950 0 : case EXEC_OMP_PARALLEL_MASKED:
13951 0 : return ST_OMP_PARALLEL_MASKED;
13952 0 : case EXEC_OMP_PARALLEL_MASKED_TASKLOOP:
13953 0 : return ST_OMP_PARALLEL_MASKED_TASKLOOP;
13954 0 : case EXEC_OMP_PARALLEL_MASKED_TASKLOOP_SIMD:
13955 0 : return ST_OMP_PARALLEL_MASKED_TASKLOOP_SIMD;
13956 0 : case EXEC_OMP_PARALLEL_MASTER:
13957 0 : return ST_OMP_PARALLEL_MASTER;
13958 0 : case EXEC_OMP_PARALLEL_MASTER_TASKLOOP:
13959 0 : return ST_OMP_PARALLEL_MASTER_TASKLOOP;
13960 0 : case EXEC_OMP_PARALLEL_MASTER_TASKLOOP_SIMD:
13961 0 : return ST_OMP_PARALLEL_MASTER_TASKLOOP_SIMD;
13962 1 : case EXEC_OMP_PARALLEL_SECTIONS:
13963 1 : return ST_OMP_PARALLEL_SECTIONS;
13964 1 : case EXEC_OMP_SECTIONS:
13965 1 : return ST_OMP_SECTIONS;
13966 1 : case EXEC_OMP_ORDERED:
13967 1 : return ST_OMP_ORDERED;
13968 1 : case EXEC_OMP_CRITICAL:
13969 1 : return ST_OMP_CRITICAL;
13970 0 : case EXEC_OMP_MASKED:
13971 0 : return ST_OMP_MASKED;
13972 0 : case EXEC_OMP_MASKED_TASKLOOP:
13973 0 : return ST_OMP_MASKED_TASKLOOP;
13974 0 : case EXEC_OMP_MASKED_TASKLOOP_SIMD:
13975 0 : return ST_OMP_MASKED_TASKLOOP_SIMD;
13976 1 : case EXEC_OMP_MASTER:
13977 1 : return ST_OMP_MASTER;
13978 0 : case EXEC_OMP_MASTER_TASKLOOP:
13979 0 : return ST_OMP_MASTER_TASKLOOP;
13980 0 : case EXEC_OMP_MASTER_TASKLOOP_SIMD:
13981 0 : return ST_OMP_MASTER_TASKLOOP_SIMD;
13982 1 : case EXEC_OMP_SINGLE:
13983 1 : return ST_OMP_SINGLE;
13984 1 : case EXEC_OMP_TASK:
13985 1 : return ST_OMP_TASK;
13986 1 : case EXEC_OMP_WORKSHARE:
13987 1 : return ST_OMP_WORKSHARE;
13988 1 : case EXEC_OMP_PARALLEL_WORKSHARE:
13989 1 : return ST_OMP_PARALLEL_WORKSHARE;
13990 3 : case EXEC_OMP_DO:
13991 3 : return ST_OMP_DO;
13992 0 : case EXEC_OMP_LOOP:
13993 0 : return ST_OMP_LOOP;
13994 0 : case EXEC_OMP_ALLOCATE:
13995 0 : return ST_OMP_ALLOCATE_EXEC;
13996 0 : case EXEC_OMP_ALLOCATORS:
13997 0 : return ST_OMP_ALLOCATORS;
13998 0 : case EXEC_OMP_ASSUME:
13999 0 : return ST_OMP_ASSUME;
14000 1 : case EXEC_OMP_ATOMIC:
14001 1 : return ST_OMP_ATOMIC;
14002 1 : case EXEC_OMP_BARRIER:
14003 1 : return ST_OMP_BARRIER;
14004 1 : case EXEC_OMP_CANCEL:
14005 1 : return ST_OMP_CANCEL;
14006 1 : case EXEC_OMP_CANCELLATION_POINT:
14007 1 : return ST_OMP_CANCELLATION_POINT;
14008 0 : case EXEC_OMP_ERROR:
14009 0 : return ST_OMP_ERROR;
14010 1 : case EXEC_OMP_FLUSH:
14011 1 : return ST_OMP_FLUSH;
14012 0 : case EXEC_OMP_INTEROP:
14013 0 : return ST_OMP_INTEROP;
14014 1 : case EXEC_OMP_DISTRIBUTE:
14015 1 : return ST_OMP_DISTRIBUTE;
14016 1 : case EXEC_OMP_DISTRIBUTE_PARALLEL_DO:
14017 1 : return ST_OMP_DISTRIBUTE_PARALLEL_DO;
14018 1 : case EXEC_OMP_DISTRIBUTE_PARALLEL_DO_SIMD:
14019 1 : return ST_OMP_DISTRIBUTE_PARALLEL_DO_SIMD;
14020 1 : case EXEC_OMP_DISTRIBUTE_SIMD:
14021 1 : return ST_OMP_DISTRIBUTE_SIMD;
14022 1 : case EXEC_OMP_DO_SIMD:
14023 1 : return ST_OMP_DO_SIMD;
14024 0 : case EXEC_OMP_SCAN:
14025 0 : return ST_OMP_SCAN;
14026 0 : case EXEC_OMP_SCOPE:
14027 0 : return ST_OMP_SCOPE;
14028 1 : case EXEC_OMP_SIMD:
14029 1 : return ST_OMP_SIMD;
14030 1 : case EXEC_OMP_TARGET:
14031 1 : return ST_OMP_TARGET;
14032 1 : case EXEC_OMP_TARGET_DATA:
14033 1 : return ST_OMP_TARGET_DATA;
14034 1 : case EXEC_OMP_TARGET_ENTER_DATA:
14035 1 : return ST_OMP_TARGET_ENTER_DATA;
14036 1 : case EXEC_OMP_TARGET_EXIT_DATA:
14037 1 : return ST_OMP_TARGET_EXIT_DATA;
14038 1 : case EXEC_OMP_TARGET_PARALLEL:
14039 1 : return ST_OMP_TARGET_PARALLEL;
14040 1 : case EXEC_OMP_TARGET_PARALLEL_DO:
14041 1 : return ST_OMP_TARGET_PARALLEL_DO;
14042 1 : case EXEC_OMP_TARGET_PARALLEL_DO_SIMD:
14043 1 : return ST_OMP_TARGET_PARALLEL_DO_SIMD;
14044 0 : case EXEC_OMP_TARGET_PARALLEL_LOOP:
14045 0 : return ST_OMP_TARGET_PARALLEL_LOOP;
14046 1 : case EXEC_OMP_TARGET_SIMD:
14047 1 : return ST_OMP_TARGET_SIMD;
14048 1 : case EXEC_OMP_TARGET_TEAMS:
14049 1 : return ST_OMP_TARGET_TEAMS;
14050 1 : case EXEC_OMP_TARGET_TEAMS_DISTRIBUTE:
14051 1 : return ST_OMP_TARGET_TEAMS_DISTRIBUTE;
14052 1 : case EXEC_OMP_TARGET_TEAMS_DISTRIBUTE_PARALLEL_DO:
14053 1 : return ST_OMP_TARGET_TEAMS_DISTRIBUTE_PARALLEL_DO;
14054 1 : case EXEC_OMP_TARGET_TEAMS_DISTRIBUTE_PARALLEL_DO_SIMD:
14055 1 : return ST_OMP_TARGET_TEAMS_DISTRIBUTE_PARALLEL_DO_SIMD;
14056 1 : case EXEC_OMP_TARGET_TEAMS_DISTRIBUTE_SIMD:
14057 1 : return ST_OMP_TARGET_TEAMS_DISTRIBUTE_SIMD;
14058 0 : case EXEC_OMP_TARGET_TEAMS_LOOP:
14059 0 : return ST_OMP_TARGET_TEAMS_LOOP;
14060 1 : case EXEC_OMP_TARGET_UPDATE:
14061 1 : return ST_OMP_TARGET_UPDATE;
14062 1 : case EXEC_OMP_TASKGROUP:
14063 1 : return ST_OMP_TASKGROUP;
14064 1 : case EXEC_OMP_TASKLOOP:
14065 1 : return ST_OMP_TASKLOOP;
14066 1 : case EXEC_OMP_TASKLOOP_SIMD:
14067 1 : return ST_OMP_TASKLOOP_SIMD;
14068 1 : case EXEC_OMP_TASKWAIT:
14069 1 : return ST_OMP_TASKWAIT;
14070 1 : case EXEC_OMP_TASKYIELD:
14071 1 : return ST_OMP_TASKYIELD;
14072 1 : case EXEC_OMP_TEAMS:
14073 1 : return ST_OMP_TEAMS;
14074 1 : case EXEC_OMP_TEAMS_DISTRIBUTE:
14075 1 : return ST_OMP_TEAMS_DISTRIBUTE;
14076 1 : case EXEC_OMP_TEAMS_DISTRIBUTE_PARALLEL_DO:
14077 1 : return ST_OMP_TEAMS_DISTRIBUTE_PARALLEL_DO;
14078 1 : case EXEC_OMP_TEAMS_DISTRIBUTE_PARALLEL_DO_SIMD:
14079 1 : return ST_OMP_TEAMS_DISTRIBUTE_PARALLEL_DO_SIMD;
14080 1 : case EXEC_OMP_TEAMS_DISTRIBUTE_SIMD:
14081 1 : return ST_OMP_TEAMS_DISTRIBUTE_SIMD;
14082 0 : case EXEC_OMP_TEAMS_LOOP:
14083 0 : return ST_OMP_TEAMS_LOOP;
14084 6 : case EXEC_OMP_PARALLEL_DO:
14085 6 : return ST_OMP_PARALLEL_DO;
14086 1 : case EXEC_OMP_PARALLEL_DO_SIMD:
14087 1 : return ST_OMP_PARALLEL_DO_SIMD;
14088 0 : case EXEC_OMP_PARALLEL_LOOP:
14089 0 : return ST_OMP_PARALLEL_LOOP;
14090 1 : case EXEC_OMP_DEPOBJ:
14091 1 : return ST_OMP_DEPOBJ;
14092 0 : case EXEC_OMP_TILE:
14093 0 : return ST_OMP_TILE;
14094 0 : case EXEC_OMP_UNROLL:
14095 0 : return ST_OMP_UNROLL;
14096 0 : case EXEC_OMP_DISPATCH:
14097 0 : return ST_OMP_DISPATCH;
14098 0 : default:
14099 0 : gcc_unreachable ();
14100 : }
14101 : }
14102 :
14103 : static gfc_statement
14104 63 : oacc_code_to_statement (gfc_code *code)
14105 : {
14106 63 : switch (code->op)
14107 : {
14108 : case EXEC_OACC_PARALLEL:
14109 : return ST_OACC_PARALLEL;
14110 : case EXEC_OACC_KERNELS:
14111 : return ST_OACC_KERNELS;
14112 : case EXEC_OACC_SERIAL:
14113 : return ST_OACC_SERIAL;
14114 : case EXEC_OACC_DATA:
14115 : return ST_OACC_DATA;
14116 : case EXEC_OACC_HOST_DATA:
14117 : return ST_OACC_HOST_DATA;
14118 : case EXEC_OACC_PARALLEL_LOOP:
14119 : return ST_OACC_PARALLEL_LOOP;
14120 : case EXEC_OACC_KERNELS_LOOP:
14121 : return ST_OACC_KERNELS_LOOP;
14122 : case EXEC_OACC_SERIAL_LOOP:
14123 : return ST_OACC_SERIAL_LOOP;
14124 : case EXEC_OACC_LOOP:
14125 : return ST_OACC_LOOP;
14126 : case EXEC_OACC_ATOMIC:
14127 : return ST_OACC_ATOMIC;
14128 : case EXEC_OACC_ROUTINE:
14129 : return ST_OACC_ROUTINE;
14130 : case EXEC_OACC_UPDATE:
14131 : return ST_OACC_UPDATE;
14132 : case EXEC_OACC_WAIT:
14133 : return ST_OACC_WAIT;
14134 : case EXEC_OACC_CACHE:
14135 : return ST_OACC_CACHE;
14136 : case EXEC_OACC_ENTER_DATA:
14137 : return ST_OACC_ENTER_DATA;
14138 : case EXEC_OACC_EXIT_DATA:
14139 : return ST_OACC_EXIT_DATA;
14140 : case EXEC_OACC_DECLARE:
14141 : return ST_OACC_DECLARE;
14142 : case EXEC_OACC_INIT:
14143 : return ST_OACC_INIT;
14144 : case EXEC_OACC_SHUTDOWN:
14145 : return ST_OACC_SHUTDOWN;
14146 : case EXEC_OACC_SET:
14147 : return ST_OACC_SET;
14148 0 : default:
14149 0 : gcc_unreachable ();
14150 : }
14151 : }
14152 :
14153 : static void
14154 13538 : resolve_oacc_directive_inside_omp_region (gfc_code *code)
14155 : {
14156 13538 : if (omp_current_ctx != NULL && omp_current_ctx->is_openmp)
14157 : {
14158 11 : gfc_statement st = omp_code_to_statement (omp_current_ctx->code);
14159 11 : gfc_statement oacc_st = oacc_code_to_statement (code);
14160 11 : gfc_error ("The %s directive cannot be specified within "
14161 : "a %s region at %L", gfc_ascii_statement (oacc_st),
14162 : gfc_ascii_statement (st), &code->loc);
14163 : }
14164 13538 : }
14165 :
14166 : static void
14167 21385 : resolve_omp_directive_inside_oacc_region (gfc_code *code)
14168 : {
14169 21385 : if (omp_current_ctx != NULL && !omp_current_ctx->is_openmp)
14170 : {
14171 52 : gfc_statement st = oacc_code_to_statement (omp_current_ctx->code);
14172 52 : gfc_statement omp_st = omp_code_to_statement (code);
14173 52 : gfc_error ("The %s directive cannot be specified within "
14174 : "a %s region at %L", gfc_ascii_statement (omp_st),
14175 : gfc_ascii_statement (st), &code->loc);
14176 : }
14177 21385 : }
14178 :
14179 :
14180 : static void
14181 5272 : resolve_oacc_nested_loops (gfc_code *code, gfc_code* do_code, int collapse,
14182 : const char *clause)
14183 : {
14184 5272 : gfc_symbol *dovar;
14185 5272 : gfc_code *c;
14186 5272 : int i;
14187 :
14188 5792 : for (i = 1; i <= collapse; i++)
14189 : {
14190 5792 : if (do_code->op == EXEC_DO_WHILE)
14191 : {
14192 10 : gfc_error ("!$ACC LOOP cannot be a DO WHILE or DO without loop control "
14193 : "at %L", &do_code->loc);
14194 10 : break;
14195 : }
14196 5782 : if (do_code->op == EXEC_DO_CONCURRENT)
14197 : {
14198 3 : gfc_error ("!$ACC LOOP cannot be a DO CONCURRENT loop at %L",
14199 : &do_code->loc);
14200 3 : break;
14201 : }
14202 5779 : gcc_assert (do_code->op == EXEC_DO);
14203 5779 : if (do_code->ext.iterator->var->ts.type != BT_INTEGER)
14204 6 : gfc_error ("!$ACC LOOP iteration variable must be of type integer at %L",
14205 : &do_code->loc);
14206 5779 : dovar = do_code->ext.iterator->var->symtree->n.sym;
14207 5779 : if (i > 1)
14208 : {
14209 518 : gfc_code *do_code2 = code->block->next;
14210 518 : int j;
14211 :
14212 1218 : for (j = 1; j < i; j++)
14213 : {
14214 710 : gfc_symbol *ivar = do_code2->ext.iterator->var->symtree->n.sym;
14215 710 : if (dovar == ivar
14216 710 : || gfc_find_sym_in_expr (ivar, do_code->ext.iterator->start)
14217 701 : || gfc_find_sym_in_expr (ivar, do_code->ext.iterator->end)
14218 1410 : || gfc_find_sym_in_expr (ivar, do_code->ext.iterator->step))
14219 : {
14220 10 : gfc_error ("!$ACC LOOP %s loops don't form rectangular "
14221 : "iteration space at %L", clause, &do_code->loc);
14222 10 : break;
14223 : }
14224 700 : do_code2 = do_code2->block->next;
14225 : }
14226 : }
14227 5779 : if (i == collapse)
14228 : break;
14229 577 : for (c = do_code->next; c; c = c->next)
14230 48 : if (c->op != EXEC_NOP && c->op != EXEC_CONTINUE)
14231 : {
14232 0 : gfc_error ("%s !$ACC LOOP loops not perfectly nested at %L",
14233 : clause, &c->loc);
14234 0 : break;
14235 : }
14236 529 : if (c)
14237 : break;
14238 529 : do_code = do_code->block;
14239 529 : if (do_code->op != EXEC_DO && do_code->op != EXEC_DO_WHILE
14240 0 : && do_code->op != EXEC_DO_CONCURRENT)
14241 : {
14242 0 : gfc_error ("not enough DO loops for %s !$ACC LOOP at %L",
14243 : clause, &code->loc);
14244 0 : break;
14245 : }
14246 529 : do_code = do_code->next;
14247 529 : if (do_code == NULL
14248 522 : || (do_code->op != EXEC_DO && do_code->op != EXEC_DO_WHILE
14249 2 : && do_code->op != EXEC_DO_CONCURRENT))
14250 : {
14251 9 : gfc_error ("not enough DO loops for %s !$ACC LOOP at %L",
14252 : clause, &code->loc);
14253 9 : break;
14254 : }
14255 : }
14256 5272 : }
14257 :
14258 :
14259 : static void
14260 10119 : resolve_oacc_loop_blocks (gfc_code *code)
14261 : {
14262 10119 : if (!oacc_is_loop (code))
14263 : return;
14264 :
14265 5272 : if (code->ext.omp_clauses->tile_list && code->ext.omp_clauses->gang
14266 24 : && code->ext.omp_clauses->worker && code->ext.omp_clauses->vector)
14267 0 : gfc_error ("Tiled loop cannot be parallelized across gangs, workers and "
14268 : "vectors at the same time at %L", &code->loc);
14269 :
14270 5272 : if (code->ext.omp_clauses->tile_list)
14271 : {
14272 : gfc_expr_list *el;
14273 501 : for (el = code->ext.omp_clauses->tile_list; el; el = el->next)
14274 : {
14275 304 : if (el->expr == NULL)
14276 : {
14277 : /* NULL expressions are used to represent '*' arguments.
14278 : Convert those to a 0 expressions. */
14279 113 : el->expr = gfc_get_constant_expr (BT_INTEGER,
14280 : gfc_default_integer_kind,
14281 : &code->loc);
14282 113 : mpz_set_si (el->expr->value.integer, 0);
14283 : }
14284 : else
14285 191 : resolve_positive_int_expr (el->expr, "TILE", false);
14286 : }
14287 : }
14288 : }
14289 :
14290 :
14291 : void
14292 10119 : gfc_resolve_oacc_blocks (gfc_code *code, gfc_namespace *ns)
14293 : {
14294 10119 : fortran_omp_context ctx;
14295 10119 : gfc_omp_clauses *omp_clauses = code->ext.omp_clauses;
14296 10119 : gfc_omp_namelist *n;
14297 :
14298 10119 : resolve_oacc_loop_blocks (code);
14299 :
14300 10119 : ctx.code = code;
14301 10119 : ctx.sharing_clauses = new hash_set<gfc_symbol *>;
14302 10119 : ctx.private_iterators = new hash_set<gfc_symbol *>;
14303 10119 : ctx.previous = omp_current_ctx;
14304 10119 : ctx.is_openmp = false;
14305 10119 : omp_current_ctx = &ctx;
14306 :
14307 404760 : for (enum gfc_omp_list_type list = OMP_LIST_FIRST; list < OMP_LIST_NUM;
14308 394641 : list = gfc_omp_list_type (list + 1))
14309 394641 : switch (list)
14310 : {
14311 10119 : case OMP_LIST_PRIVATE:
14312 10710 : for (n = omp_clauses->lists[list]; n; n = n->next)
14313 591 : ctx.sharing_clauses->add (n->sym);
14314 : break;
14315 : default:
14316 : break;
14317 : }
14318 :
14319 10119 : gfc_resolve_blocks (code->block, ns);
14320 :
14321 10119 : omp_current_ctx = ctx.previous;
14322 20238 : delete ctx.sharing_clauses;
14323 20238 : delete ctx.private_iterators;
14324 10119 : }
14325 :
14326 :
14327 : static void
14328 5272 : resolve_oacc_loop (gfc_code *code)
14329 : {
14330 5272 : gfc_code *do_code;
14331 5272 : int collapse;
14332 :
14333 5272 : if (code->ext.omp_clauses)
14334 5272 : resolve_omp_clauses (code, code->ext.omp_clauses, NULL, true);
14335 :
14336 5272 : do_code = code->block->next;
14337 5272 : collapse = code->ext.omp_clauses->collapse;
14338 :
14339 : /* Both collapsed and tiled loops are lowered the same way, but are not
14340 : compatible. In gfc_trans_omp_do, the tile is prioritized. */
14341 5272 : if (code->ext.omp_clauses->tile_list)
14342 : {
14343 : int num = 0;
14344 : gfc_expr_list *el;
14345 501 : for (el = code->ext.omp_clauses->tile_list; el; el = el->next)
14346 304 : ++num;
14347 197 : resolve_oacc_nested_loops (code, code->block->next, num, "tiled");
14348 197 : return;
14349 : }
14350 :
14351 5075 : if (collapse <= 0)
14352 : collapse = 1;
14353 5075 : resolve_oacc_nested_loops (code, do_code, collapse, "collapsed");
14354 : }
14355 :
14356 : void
14357 351850 : gfc_resolve_oacc_declare (gfc_namespace *ns)
14358 : {
14359 351850 : enum gfc_omp_list_type list;
14360 351850 : gfc_omp_namelist *n;
14361 351850 : gfc_oacc_declare *oc;
14362 :
14363 351850 : if (ns->oacc_declare == NULL)
14364 : return;
14365 :
14366 290 : for (oc = ns->oacc_declare; oc; oc = oc->next)
14367 : {
14368 6480 : for (list = OMP_LIST_FIRST; list < OMP_LIST_NUM;
14369 6318 : list = gfc_omp_list_type (list + 1))
14370 6574 : for (n = oc->clauses->lists[list]; n; n = n->next)
14371 : {
14372 256 : n->sym->mark = 0;
14373 256 : if (n->sym->attr.flavor != FL_VARIABLE
14374 16 : && (n->sym->attr.flavor != FL_PROCEDURE
14375 8 : || n->sym->result != n->sym))
14376 : {
14377 14 : if (n->sym->attr.flavor != FL_PARAMETER)
14378 : {
14379 8 : gfc_error ("Object %qs is not a variable at %L",
14380 : n->sym->name, &oc->loc);
14381 8 : continue;
14382 : }
14383 : /* Note that OpenACC 3.4 permits name constants, but the
14384 : implementation is permitted to ignore the clause;
14385 : as semantically, device_resident kind of makes sense
14386 : (and the wording with it is a bit odd), the warning
14387 : is suppressed. */
14388 6 : if (list != OMP_LIST_DEVICE_RESIDENT)
14389 5 : gfc_warning (OPT_Wsurprising, "Object %qs at %L is ignored as"
14390 : " parameters need not be copied", n->sym->name,
14391 : &oc->loc);
14392 : }
14393 :
14394 248 : if (n->expr && n->expr->ref->type == REF_ARRAY)
14395 : {
14396 1 : gfc_error ("Array sections: %qs not allowed in"
14397 1 : " !$ACC DECLARE at %L", n->sym->name, &oc->loc);
14398 1 : continue;
14399 : }
14400 : }
14401 :
14402 252 : for (n = oc->clauses->lists[OMP_LIST_DEVICE_RESIDENT]; n; n = n->next)
14403 90 : check_array_not_assumed (n->sym, oc->loc, "DEVICE_RESIDENT");
14404 : }
14405 :
14406 290 : for (oc = ns->oacc_declare; oc; oc = oc->next)
14407 : {
14408 6480 : for (list = OMP_LIST_FIRST; list < OMP_LIST_NUM;
14409 6318 : list = gfc_omp_list_type (list + 1))
14410 6574 : for (n = oc->clauses->lists[list]; n; n = n->next)
14411 : {
14412 256 : if (n->sym->mark)
14413 : {
14414 9 : gfc_error ("Symbol %qs present on multiple clauses at %L",
14415 : n->sym->name, &oc->loc);
14416 9 : continue;
14417 : }
14418 : else
14419 247 : n->sym->mark = 1;
14420 : }
14421 : }
14422 :
14423 290 : for (oc = ns->oacc_declare; oc; oc = oc->next)
14424 : {
14425 6480 : for (list = OMP_LIST_FIRST; list < OMP_LIST_NUM;
14426 6318 : list = gfc_omp_list_type (list + 1))
14427 6574 : for (n = oc->clauses->lists[list]; n; n = n->next)
14428 256 : n->sym->mark = 0;
14429 : }
14430 : }
14431 :
14432 :
14433 : void
14434 351850 : gfc_resolve_oacc_routines (gfc_namespace *ns)
14435 : {
14436 351850 : for (gfc_oacc_routine_name *orn = ns->oacc_routine_names;
14437 351950 : orn;
14438 100 : orn = orn->next)
14439 : {
14440 100 : gfc_symbol *sym = orn->sym;
14441 100 : if (!sym->attr.external
14442 29 : && !sym->attr.function
14443 27 : && !sym->attr.subroutine)
14444 : {
14445 7 : gfc_error ("NAME %qs does not refer to a subroutine or function"
14446 : " in !$ACC ROUTINE ( NAME ) at %L", sym->name, &orn->loc);
14447 7 : continue;
14448 : }
14449 93 : if (!gfc_add_omp_declare_target (&sym->attr, sym->name, &orn->loc))
14450 : {
14451 20 : gfc_error ("NAME %qs invalid"
14452 : " in !$ACC ROUTINE ( NAME ) at %L", sym->name, &orn->loc);
14453 20 : continue;
14454 : }
14455 : }
14456 351850 : }
14457 :
14458 :
14459 : void
14460 13538 : gfc_resolve_oacc_directive (gfc_code *code, gfc_namespace *ns ATTRIBUTE_UNUSED)
14461 : {
14462 13538 : resolve_oacc_directive_inside_omp_region (code);
14463 :
14464 13538 : switch (code->op)
14465 : {
14466 7723 : case EXEC_OACC_PARALLEL:
14467 7723 : case EXEC_OACC_KERNELS:
14468 7723 : case EXEC_OACC_SERIAL:
14469 7723 : case EXEC_OACC_DATA:
14470 7723 : case EXEC_OACC_HOST_DATA:
14471 7723 : case EXEC_OACC_UPDATE:
14472 7723 : case EXEC_OACC_ENTER_DATA:
14473 7723 : case EXEC_OACC_EXIT_DATA:
14474 7723 : case EXEC_OACC_WAIT:
14475 7723 : case EXEC_OACC_CACHE:
14476 7723 : case EXEC_OACC_INIT:
14477 7723 : case EXEC_OACC_SHUTDOWN:
14478 7723 : case EXEC_OACC_SET:
14479 7723 : resolve_omp_clauses (code, code->ext.omp_clauses, NULL, true);
14480 7723 : break;
14481 5272 : case EXEC_OACC_PARALLEL_LOOP:
14482 5272 : case EXEC_OACC_KERNELS_LOOP:
14483 5272 : case EXEC_OACC_SERIAL_LOOP:
14484 5272 : case EXEC_OACC_LOOP:
14485 5272 : resolve_oacc_loop (code);
14486 5272 : break;
14487 543 : case EXEC_OACC_ATOMIC:
14488 543 : resolve_omp_atomic (code);
14489 543 : break;
14490 : default:
14491 : break;
14492 : }
14493 13538 : }
14494 :
14495 :
14496 : static void
14497 2190 : resolve_omp_target (gfc_code *code)
14498 : {
14499 : #define GFC_IS_TEAMS_CONSTRUCT(op) \
14500 : (op == EXEC_OMP_TEAMS \
14501 : || op == EXEC_OMP_TEAMS_DISTRIBUTE \
14502 : || op == EXEC_OMP_TEAMS_DISTRIBUTE_SIMD \
14503 : || op == EXEC_OMP_TEAMS_DISTRIBUTE_PARALLEL_DO \
14504 : || op == EXEC_OMP_TEAMS_DISTRIBUTE_PARALLEL_DO_SIMD \
14505 : || op == EXEC_OMP_TEAMS_LOOP)
14506 :
14507 2190 : if (!code->ext.omp_clauses->contains_teams_construct)
14508 : return;
14509 204 : gfc_code *c = code->block->next;
14510 204 : if (c->op == EXEC_BLOCK)
14511 30 : c = c->ext.block.ns->code;
14512 204 : if (code->ext.omp_clauses->target_first_st_is_teams_or_meta)
14513 : {
14514 193 : if (c->op == EXEC_OMP_METADIRECTIVE)
14515 : {
14516 16 : struct gfc_omp_variant *mc
14517 : = c->ext.omp_variants;
14518 : /* All mc->(next...->)code should be identical with regards
14519 : to the diagnostic below. */
14520 17 : do
14521 : {
14522 17 : if (mc->stmt != ST_NONE
14523 16 : && GFC_IS_TEAMS_CONSTRUCT (mc->code->op))
14524 : {
14525 15 : if (c->next == NULL && mc->code->next == NULL)
14526 : return;
14527 23 : c = mc->code;
14528 : break;
14529 : }
14530 2 : mc = mc->next;
14531 : }
14532 2 : while (mc);
14533 : }
14534 177 : else if (GFC_IS_TEAMS_CONSTRUCT (c->op) && c->next == NULL)
14535 : return;
14536 : }
14537 :
14538 31 : while (c && !GFC_IS_TEAMS_CONSTRUCT (c->op))
14539 8 : c = c->next;
14540 23 : if (c)
14541 19 : gfc_error ("!$OMP TARGET region at %L with a nested TEAMS at %L may not "
14542 : "contain any other statement, declaration or directive outside "
14543 : "of the single TEAMS construct", &c->loc, &code->loc);
14544 : else
14545 4 : gfc_error ("!$OMP TARGET region at %L with a nested TEAMS may not "
14546 : "contain any other statement, declaration or directive outside "
14547 : "of the single TEAMS construct", &code->loc);
14548 : #undef GFC_IS_TEAMS_CONSTRUCT
14549 : }
14550 :
14551 : static void
14552 154 : resolve_omp_dispatch (gfc_code *code)
14553 : {
14554 154 : gfc_code *next = code->block->next;
14555 154 : if (next == NULL)
14556 : return;
14557 :
14558 151 : gfc_exec_op op = next->op;
14559 151 : gcc_assert (op == EXEC_CALL || op == EXEC_ASSIGN);
14560 151 : if (op != EXEC_CALL
14561 74 : && (op != EXEC_ASSIGN || next->expr2->expr_type != EXPR_FUNCTION))
14562 3 : gfc_error (
14563 : "%<OMP DISPATCH%> directive at %L must be followed by a procedure "
14564 : "call with optional assignment",
14565 : &code->loc);
14566 :
14567 77 : if ((op == EXEC_CALL && next->resolved_sym != NULL
14568 76 : && next->resolved_sym->attr.proc_pointer)
14569 151 : || (op == EXEC_ASSIGN && gfc_expr_attr (next->expr2).proc_pointer))
14570 1 : gfc_error ("%<OMP DISPATCH%> directive at %L cannot be followed by a "
14571 : "procedure pointer",
14572 : &code->loc);
14573 : }
14574 :
14575 : /* Resolve OpenMP directive clauses and check various requirements
14576 : of each directive. */
14577 :
14578 : void
14579 21385 : gfc_resolve_omp_directive (gfc_code *code, gfc_namespace *ns)
14580 : {
14581 21385 : resolve_omp_directive_inside_oacc_region (code);
14582 :
14583 21385 : if (code->op != EXEC_OMP_ATOMIC)
14584 19218 : gfc_maybe_initialize_eh ();
14585 :
14586 21385 : switch (code->op)
14587 : {
14588 5463 : case EXEC_OMP_DISTRIBUTE:
14589 5463 : case EXEC_OMP_DISTRIBUTE_PARALLEL_DO:
14590 5463 : case EXEC_OMP_DISTRIBUTE_PARALLEL_DO_SIMD:
14591 5463 : case EXEC_OMP_DISTRIBUTE_SIMD:
14592 5463 : case EXEC_OMP_DO:
14593 5463 : case EXEC_OMP_DO_SIMD:
14594 5463 : case EXEC_OMP_LOOP:
14595 5463 : case EXEC_OMP_PARALLEL_DO:
14596 5463 : case EXEC_OMP_PARALLEL_DO_SIMD:
14597 5463 : case EXEC_OMP_PARALLEL_LOOP:
14598 5463 : case EXEC_OMP_PARALLEL_MASKED_TASKLOOP:
14599 5463 : case EXEC_OMP_PARALLEL_MASKED_TASKLOOP_SIMD:
14600 5463 : case EXEC_OMP_PARALLEL_MASTER_TASKLOOP:
14601 5463 : case EXEC_OMP_PARALLEL_MASTER_TASKLOOP_SIMD:
14602 5463 : case EXEC_OMP_MASKED_TASKLOOP:
14603 5463 : case EXEC_OMP_MASKED_TASKLOOP_SIMD:
14604 5463 : case EXEC_OMP_MASTER_TASKLOOP:
14605 5463 : case EXEC_OMP_MASTER_TASKLOOP_SIMD:
14606 5463 : case EXEC_OMP_SIMD:
14607 5463 : case EXEC_OMP_TARGET_PARALLEL_DO:
14608 5463 : case EXEC_OMP_TARGET_PARALLEL_DO_SIMD:
14609 5463 : case EXEC_OMP_TARGET_PARALLEL_LOOP:
14610 5463 : case EXEC_OMP_TARGET_SIMD:
14611 5463 : case EXEC_OMP_TARGET_TEAMS_DISTRIBUTE:
14612 5463 : case EXEC_OMP_TARGET_TEAMS_DISTRIBUTE_PARALLEL_DO:
14613 5463 : case EXEC_OMP_TARGET_TEAMS_DISTRIBUTE_PARALLEL_DO_SIMD:
14614 5463 : case EXEC_OMP_TARGET_TEAMS_DISTRIBUTE_SIMD:
14615 5463 : case EXEC_OMP_TARGET_TEAMS_LOOP:
14616 5463 : case EXEC_OMP_TASKLOOP:
14617 5463 : case EXEC_OMP_TASKLOOP_SIMD:
14618 5463 : case EXEC_OMP_TEAMS_DISTRIBUTE:
14619 5463 : case EXEC_OMP_TEAMS_DISTRIBUTE_PARALLEL_DO:
14620 5463 : case EXEC_OMP_TEAMS_DISTRIBUTE_PARALLEL_DO_SIMD:
14621 5463 : case EXEC_OMP_TEAMS_DISTRIBUTE_SIMD:
14622 5463 : case EXEC_OMP_TEAMS_LOOP:
14623 5463 : case EXEC_OMP_TILE:
14624 5463 : case EXEC_OMP_UNROLL:
14625 5463 : resolve_omp_do (code);
14626 5463 : break;
14627 2190 : case EXEC_OMP_TARGET:
14628 2190 : resolve_omp_target (code);
14629 10336 : gcc_fallthrough ();
14630 10336 : case EXEC_OMP_ALLOCATE:
14631 10336 : case EXEC_OMP_ALLOCATORS:
14632 10336 : case EXEC_OMP_ASSUME:
14633 10336 : case EXEC_OMP_CANCEL:
14634 10336 : case EXEC_OMP_ERROR:
14635 10336 : case EXEC_OMP_INTEROP:
14636 10336 : case EXEC_OMP_MASKED:
14637 10336 : case EXEC_OMP_ORDERED:
14638 10336 : case EXEC_OMP_PARALLEL_WORKSHARE:
14639 10336 : case EXEC_OMP_PARALLEL:
14640 10336 : case EXEC_OMP_PARALLEL_MASKED:
14641 10336 : case EXEC_OMP_PARALLEL_MASTER:
14642 10336 : case EXEC_OMP_PARALLEL_SECTIONS:
14643 10336 : case EXEC_OMP_SCOPE:
14644 10336 : case EXEC_OMP_SECTIONS:
14645 10336 : case EXEC_OMP_SINGLE:
14646 10336 : case EXEC_OMP_TARGET_DATA:
14647 10336 : case EXEC_OMP_TARGET_ENTER_DATA:
14648 10336 : case EXEC_OMP_TARGET_EXIT_DATA:
14649 10336 : case EXEC_OMP_TARGET_PARALLEL:
14650 10336 : case EXEC_OMP_TARGET_TEAMS:
14651 10336 : case EXEC_OMP_TASK:
14652 10336 : case EXEC_OMP_TASKWAIT:
14653 10336 : case EXEC_OMP_TEAMS:
14654 10336 : case EXEC_OMP_WORKSHARE:
14655 10336 : case EXEC_OMP_DEPOBJ:
14656 10336 : if (code->ext.omp_clauses)
14657 10195 : resolve_omp_clauses (code, code->ext.omp_clauses, NULL);
14658 : break;
14659 1720 : case EXEC_OMP_TARGET_UPDATE:
14660 1720 : if (code->ext.omp_clauses)
14661 1720 : resolve_omp_clauses (code, code->ext.omp_clauses, NULL);
14662 1720 : if (code->ext.omp_clauses == NULL
14663 1720 : || (code->ext.omp_clauses->lists[OMP_LIST_TO] == NULL
14664 996 : && code->ext.omp_clauses->lists[OMP_LIST_FROM] == NULL))
14665 0 : gfc_error ("OMP TARGET UPDATE at %L requires at least one TO or "
14666 : "FROM clause", &code->loc);
14667 : break;
14668 2167 : case EXEC_OMP_ATOMIC:
14669 2167 : resolve_omp_clauses (code, code->block->ext.omp_clauses, NULL);
14670 2167 : resolve_omp_atomic (code);
14671 2167 : break;
14672 165 : case EXEC_OMP_CRITICAL:
14673 165 : resolve_omp_clauses (code, code->ext.omp_clauses, NULL);
14674 165 : if (!code->ext.omp_clauses->critical_name
14675 114 : && code->ext.omp_clauses->hint
14676 5 : && code->ext.omp_clauses->hint->ts.type == BT_INTEGER
14677 5 : && code->ext.omp_clauses->hint->expr_type == EXPR_CONSTANT
14678 5 : && mpz_sgn (code->ext.omp_clauses->hint->value.integer) != 0)
14679 1 : gfc_error ("OMP CRITICAL at %L with HINT clause requires a NAME, "
14680 : "except when omp_sync_hint_none is used", &code->loc);
14681 : break;
14682 49 : case EXEC_OMP_SCAN:
14683 : /* Flag is only used to checking, hence, it is unset afterwards. */
14684 49 : if (!code->ext.omp_clauses->if_present)
14685 10 : gfc_error ("Unexpected !$OMP SCAN at %L outside loop construct with "
14686 : "%<inscan%> REDUCTION clause", &code->loc);
14687 49 : code->ext.omp_clauses->if_present = false;
14688 49 : resolve_omp_clauses (code, code->ext.omp_clauses, ns);
14689 49 : break;
14690 154 : case EXEC_OMP_DISPATCH:
14691 154 : if (code->ext.omp_clauses)
14692 154 : resolve_omp_clauses (code, code->ext.omp_clauses, ns);
14693 154 : resolve_omp_dispatch (code);
14694 154 : break;
14695 146 : case EXEC_OMP_METADIRECTIVE:
14696 146 : resolve_omp_metadirective (code, ns);
14697 146 : break;
14698 : default:
14699 : break;
14700 : }
14701 21385 : }
14702 :
14703 : /* Resolve !$omp declare {variant|simd} constructs in NS.
14704 : Note that !$omp declare target is resolved in resolve_symbol. */
14705 :
14706 : void
14707 364147 : gfc_resolve_omp_declare (gfc_namespace *ns)
14708 : {
14709 364147 : gfc_omp_declare_simd *ods;
14710 364399 : for (ods = ns->omp_declare_simd; ods; ods = ods->next)
14711 : {
14712 252 : if (ods->proc_name != NULL
14713 197 : && ods->proc_name != ns->proc_name)
14714 6 : gfc_error ("!$OMP DECLARE SIMD should refer to containing procedure "
14715 : "%qs at %L", ns->proc_name->name, &ods->where);
14716 252 : if (ods->clauses)
14717 252 : resolve_omp_clauses (NULL, ods->clauses, ns);
14718 : }
14719 :
14720 364147 : gfc_omp_declare_variant *odv;
14721 364147 : gfc_omp_namelist *range_begin = NULL;
14722 :
14723 364624 : for (odv = ns->omp_declare_variant; odv; odv = odv->next)
14724 477 : gfc_resolve_omp_context_selector (odv->set_selectors, false, nullptr);
14725 364624 : for (odv = ns->omp_declare_variant; odv; odv = odv->next)
14726 680 : for (gfc_omp_namelist *n = odv->adjust_args_list; n != NULL; n = n->next)
14727 : {
14728 203 : if ((n->expr == NULL
14729 6 : && (range_begin
14730 4 : || n->u.adj_args.range_start
14731 1 : || n->u.adj_args.omp_num_args_plus
14732 1 : || n->u.adj_args.omp_num_args_minus))
14733 198 : || n->u.adj_args.error_p)
14734 : {
14735 : }
14736 197 : else if (range_begin
14737 191 : || n->u.adj_args.range_start
14738 186 : || n->u.adj_args.omp_num_args_plus
14739 186 : || n->u.adj_args.omp_num_args_minus)
14740 : {
14741 11 : if (!n->expr
14742 11 : || !gfc_resolve_expr (n->expr)
14743 11 : || n->expr->expr_type != EXPR_CONSTANT
14744 10 : || n->expr->ts.type != BT_INTEGER
14745 10 : || n->expr->rank != 0
14746 10 : || mpz_sgn (n->expr->value.integer) < 0
14747 20 : || ((n->u.adj_args.omp_num_args_plus
14748 8 : || n->u.adj_args.omp_num_args_minus)
14749 5 : && mpz_sgn (n->expr->value.integer) == 0))
14750 : {
14751 2 : if (n->u.adj_args.omp_num_args_plus
14752 2 : || n->u.adj_args.omp_num_args_minus)
14753 0 : gfc_error ("Expected constant non-negative scalar integer "
14754 : "offset expression at %L", &n->where);
14755 : else
14756 2 : gfc_error ("For range-based %<adjust_args%>, a constant "
14757 : "positive scalar integer expression is required "
14758 : "at %L", &n->where);
14759 : }
14760 : }
14761 186 : else if (n->expr
14762 186 : && n->expr->expr_type == EXPR_CONSTANT
14763 21 : && n->expr->ts.type == BT_INTEGER
14764 20 : && mpz_sgn (n->expr->value.integer) > 0)
14765 : {
14766 : }
14767 166 : else if (!n->expr
14768 166 : || !gfc_resolve_expr (n->expr)
14769 331 : || n->expr->expr_type != EXPR_VARIABLE)
14770 2 : gfc_error ("Expected dummy parameter name or a positive integer "
14771 : "at %L", &n->where);
14772 164 : else if (n->expr->expr_type == EXPR_VARIABLE)
14773 164 : n->sym = n->expr->symtree->n.sym;
14774 :
14775 203 : range_begin = n->u.adj_args.range_start ? n : NULL;
14776 : }
14777 364147 : }
14778 :
14779 : struct omp_udr_callback_data
14780 : {
14781 : gfc_omp_udr *omp_udr;
14782 : bool is_initializer;
14783 : };
14784 :
14785 : static int
14786 3746 : omp_udr_callback (gfc_expr **e, int *walk_subtrees ATTRIBUTE_UNUSED,
14787 : void *data)
14788 : {
14789 3746 : struct omp_udr_callback_data *cd = (struct omp_udr_callback_data *) data;
14790 3746 : if ((*e)->expr_type == EXPR_VARIABLE)
14791 : {
14792 2303 : if (cd->is_initializer)
14793 : {
14794 545 : if ((*e)->symtree->n.sym != cd->omp_udr->omp_priv
14795 140 : && (*e)->symtree->n.sym != cd->omp_udr->omp_orig)
14796 4 : gfc_error ("Variable other than OMP_PRIV or OMP_ORIG used in "
14797 : "INITIALIZER clause of !$OMP DECLARE REDUCTION at %L",
14798 : &(*e)->where);
14799 : }
14800 : else
14801 : {
14802 1758 : if ((*e)->symtree->n.sym != cd->omp_udr->omp_out
14803 626 : && (*e)->symtree->n.sym != cd->omp_udr->omp_in)
14804 6 : gfc_error ("Variable other than OMP_OUT or OMP_IN used in "
14805 : "combiner of !$OMP DECLARE REDUCTION at %L",
14806 : &(*e)->where);
14807 : }
14808 : }
14809 3746 : return 0;
14810 : }
14811 :
14812 : /* Resolve !$omp declare reduction constructs. */
14813 :
14814 : static void
14815 633 : gfc_resolve_omp_udr (gfc_omp_udr *omp_udr)
14816 : {
14817 633 : gfc_actual_arglist *a;
14818 633 : const char *predef_name = NULL;
14819 :
14820 633 : switch (omp_udr->rop)
14821 : {
14822 632 : case OMP_REDUCTION_PLUS:
14823 632 : case OMP_REDUCTION_TIMES:
14824 632 : case OMP_REDUCTION_MINUS:
14825 632 : case OMP_REDUCTION_AND:
14826 632 : case OMP_REDUCTION_OR:
14827 632 : case OMP_REDUCTION_EQV:
14828 632 : case OMP_REDUCTION_NEQV:
14829 632 : case OMP_REDUCTION_MAX:
14830 632 : case OMP_REDUCTION_USER:
14831 632 : break;
14832 1 : default:
14833 1 : gfc_error ("Invalid operator for !$OMP DECLARE REDUCTION %s at %L",
14834 : omp_udr->name, &omp_udr->where);
14835 26 : return;
14836 : }
14837 :
14838 632 : if (gfc_omp_udr_predef (omp_udr->rop, omp_udr->name,
14839 : &omp_udr->ts, &predef_name))
14840 : {
14841 19 : if (predef_name)
14842 19 : gfc_error ("Redefinition of predefined %qs in "
14843 : "!$OMP DECLARE REDUCTION at %L",
14844 : predef_name, &omp_udr->where);
14845 : else
14846 0 : gfc_error ("Redefinition of predefined %qs in "
14847 : "!$OMP DECLARE REDUCTION at %L", omp_udr->name,
14848 : &omp_udr->where);
14849 : return;
14850 : }
14851 :
14852 613 : if (omp_udr->ts.type == BT_CHARACTER
14853 62 : && omp_udr->ts.u.cl->length
14854 32 : && omp_udr->ts.u.cl->length->expr_type != EXPR_CONSTANT)
14855 : {
14856 1 : gfc_error ("CHARACTER length in !$OMP DECLARE REDUCTION %qs not "
14857 : "constant at %L", omp_udr->name, &omp_udr->where);
14858 1 : return;
14859 : }
14860 :
14861 612 : struct omp_udr_callback_data cd;
14862 612 : cd.omp_udr = omp_udr;
14863 612 : cd.is_initializer = false;
14864 612 : gfc_code_walker (&omp_udr->combiner_ns->code, gfc_dummy_code_callback,
14865 : omp_udr_callback, &cd);
14866 612 : if (omp_udr->combiner_ns->code->op == EXEC_CALL)
14867 : {
14868 346 : for (a = omp_udr->combiner_ns->code->ext.actual; a; a = a->next)
14869 237 : if (a->expr == NULL)
14870 : break;
14871 110 : if (a)
14872 1 : gfc_error ("Subroutine call with alternate returns in combiner "
14873 : "of !$OMP DECLARE REDUCTION at %L",
14874 : &omp_udr->combiner_ns->code->loc);
14875 : }
14876 612 : if (omp_udr->initializer_ns)
14877 : {
14878 383 : cd.is_initializer = true;
14879 383 : gfc_code_walker (&omp_udr->initializer_ns->code, gfc_dummy_code_callback,
14880 : omp_udr_callback, &cd);
14881 383 : if (omp_udr->initializer_ns->code->op == EXEC_CALL)
14882 : {
14883 377 : for (a = omp_udr->initializer_ns->code->ext.actual; a; a = a->next)
14884 243 : if (a->expr == NULL)
14885 : break;
14886 135 : if (a)
14887 1 : gfc_error ("Subroutine call with alternate returns in "
14888 : "INITIALIZER clause of !$OMP DECLARE REDUCTION "
14889 : "at %L", &omp_udr->initializer_ns->code->loc);
14890 136 : for (a = omp_udr->initializer_ns->code->ext.actual; a; a = a->next)
14891 135 : if (a->expr
14892 135 : && a->expr->expr_type == EXPR_VARIABLE
14893 135 : && a->expr->symtree->n.sym == omp_udr->omp_priv
14894 134 : && a->expr->ref == NULL)
14895 : break;
14896 135 : if (a == NULL)
14897 1 : gfc_error ("One of actual subroutine arguments in INITIALIZER "
14898 : "clause of !$OMP DECLARE REDUCTION must be OMP_PRIV "
14899 : "at %L", &omp_udr->initializer_ns->code->loc);
14900 : }
14901 : }
14902 229 : else if (omp_udr->ts.type == BT_DERIVED
14903 229 : && !gfc_has_default_initializer (omp_udr->ts.u.derived))
14904 : {
14905 4 : gfc_error ("Missing INITIALIZER clause for !$OMP DECLARE REDUCTION "
14906 : "of derived type without default initializer at %L",
14907 : &omp_udr->where);
14908 4 : return;
14909 : }
14910 : }
14911 :
14912 : void
14913 365215 : gfc_resolve_omp_udrs (gfc_symtree *st)
14914 : {
14915 365215 : gfc_omp_udr *omp_udr;
14916 :
14917 365215 : if (st == NULL)
14918 : return;
14919 534 : gfc_resolve_omp_udrs (st->left);
14920 534 : gfc_resolve_omp_udrs (st->right);
14921 1167 : for (omp_udr = st->n.omp_udr; omp_udr; omp_udr = omp_udr->next)
14922 633 : gfc_resolve_omp_udr (omp_udr);
14923 : }
14924 :
14925 : /* Resolve !$omp declare mapper constructs. */
14926 :
14927 : static void
14928 30 : gfc_resolve_omp_udm (gfc_omp_udm *omp_udm)
14929 : {
14930 30 : resolve_omp_clauses (NULL, omp_udm->clauses, omp_udm->mapper_ns);
14931 :
14932 30 : gfc_omp_namelist *n;
14933 32 : for (n = omp_udm->clauses->lists[OMP_LIST_MAP]; n; n = n->next)
14934 30 : if (n->sym == omp_udm->var_sym)
14935 : break;
14936 30 : if (!n)
14937 2 : gfc_error ("At least one %<map%> clause in !$OMP DECLARE MAPPER at %L must "
14938 : "map %qs or an element of it",
14939 2 : &omp_udm->where, omp_udm->var_sym->name);
14940 30 : }
14941 :
14942 : void
14943 364205 : gfc_resolve_omp_udms (gfc_symtree *st)
14944 : {
14945 364205 : gfc_omp_udm *omp_udm;
14946 :
14947 364205 : if (st == NULL)
14948 : return;
14949 29 : gfc_resolve_omp_udms (st->left);
14950 29 : gfc_resolve_omp_udms (st->right);
14951 59 : for (omp_udm = st->n.omp_udm; omp_udm; omp_udm = omp_udm->next)
14952 30 : gfc_resolve_omp_udm (omp_udm);
14953 : }
|
