Branch data Line data Source code
1 : : /* OpenMP directive matching and resolving.
2 : : Copyright (C) 2005-2024 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 : : #include "config.h"
22 : : #include "system.h"
23 : : #include "coretypes.h"
24 : : #include "options.h"
25 : : #include "gfortran.h"
26 : : #include "arith.h"
27 : : #include "match.h"
28 : : #include "parse.h"
29 : : #include "constructor.h"
30 : : #include "diagnostic.h"
31 : : #include "gomp-constants.h"
32 : : #include "target-memory.h" /* For gfc_encode_character. */
33 : : #include "bitmap.h"
34 : : #include "omp-api.h" /* For omp_runtime_api_procname. */
35 : :
36 : :
37 : : static gfc_statement omp_code_to_statement (gfc_code *);
38 : :
39 : : enum gfc_omp_directive_kind {
40 : : GFC_OMP_DIR_DECLARATIVE,
41 : : GFC_OMP_DIR_EXECUTABLE,
42 : : GFC_OMP_DIR_INFORMATIONAL,
43 : : GFC_OMP_DIR_META,
44 : : GFC_OMP_DIR_SUBSIDIARY,
45 : : GFC_OMP_DIR_UTILITY
46 : : };
47 : :
48 : : struct gfc_omp_directive {
49 : : const char *name;
50 : : enum gfc_omp_directive_kind kind;
51 : : gfc_statement st;
52 : : };
53 : :
54 : : /* Alphabetically sorted OpenMP clauses, except that longer strings are before
55 : : substrings; excludes combined/composite directives. See note for "ordered"
56 : : and "nothing". */
57 : :
58 : : static const struct gfc_omp_directive gfc_omp_directives[] = {
59 : : {"allocate", GFC_OMP_DIR_DECLARATIVE, ST_OMP_ALLOCATE},
60 : : {"allocators", GFC_OMP_DIR_EXECUTABLE, ST_OMP_ALLOCATORS},
61 : : {"assumes", GFC_OMP_DIR_INFORMATIONAL, ST_OMP_ASSUMES},
62 : : {"assume", GFC_OMP_DIR_INFORMATIONAL, ST_OMP_ASSUME},
63 : : {"atomic", GFC_OMP_DIR_EXECUTABLE, ST_OMP_ATOMIC},
64 : : {"barrier", GFC_OMP_DIR_EXECUTABLE, ST_OMP_BARRIER},
65 : : {"cancellation point", GFC_OMP_DIR_EXECUTABLE, ST_OMP_CANCELLATION_POINT},
66 : : {"cancel", GFC_OMP_DIR_EXECUTABLE, ST_OMP_CANCEL},
67 : : {"critical", GFC_OMP_DIR_EXECUTABLE, ST_OMP_CRITICAL},
68 : : /* {"declare mapper", GFC_OMP_DIR_DECLARATIVE, ST_OMP_DECLARE_MAPPER}, */
69 : : {"declare reduction", GFC_OMP_DIR_DECLARATIVE, ST_OMP_DECLARE_REDUCTION},
70 : : {"declare simd", GFC_OMP_DIR_DECLARATIVE, ST_OMP_DECLARE_SIMD},
71 : : {"declare target", GFC_OMP_DIR_DECLARATIVE, ST_OMP_DECLARE_TARGET},
72 : : {"declare variant", GFC_OMP_DIR_DECLARATIVE, ST_OMP_DECLARE_VARIANT},
73 : : {"depobj", GFC_OMP_DIR_EXECUTABLE, ST_OMP_DEPOBJ},
74 : : /* {"dispatch", GFC_OMP_DIR_EXECUTABLE, ST_OMP_DISPATCH}, */
75 : : {"distribute", GFC_OMP_DIR_EXECUTABLE, ST_OMP_DISTRIBUTE},
76 : : {"do", GFC_OMP_DIR_EXECUTABLE, ST_OMP_DO},
77 : : /* "error" becomes GFC_OMP_DIR_EXECUTABLE with at(execution) */
78 : : {"error", GFC_OMP_DIR_UTILITY, ST_OMP_ERROR},
79 : : {"flush", GFC_OMP_DIR_EXECUTABLE, ST_OMP_FLUSH},
80 : : /* {"interop", GFC_OMP_DIR_EXECUTABLE, ST_OMP_INTEROP}, */
81 : : {"loop", GFC_OMP_DIR_EXECUTABLE, ST_OMP_LOOP},
82 : : {"masked", GFC_OMP_DIR_EXECUTABLE, ST_OMP_MASKED},
83 : : /* {"metadirective", GFC_OMP_DIR_META, ST_OMP_METADIRECTIVE}, */
84 : : /* Note: gfc_match_omp_nothing returns ST_NONE. */
85 : : {"nothing", GFC_OMP_DIR_UTILITY, ST_OMP_NOTHING},
86 : : /* Special case; for now map to the first one.
87 : : ordered-blockassoc = ST_OMP_ORDERED
88 : : ordered-standalone = ST_OMP_ORDERED_DEPEND + depend/doacross. */
89 : : {"ordered", GFC_OMP_DIR_EXECUTABLE, ST_OMP_ORDERED},
90 : : {"parallel", GFC_OMP_DIR_EXECUTABLE, ST_OMP_PARALLEL},
91 : : {"requires", GFC_OMP_DIR_INFORMATIONAL, ST_OMP_REQUIRES},
92 : : {"scan", GFC_OMP_DIR_SUBSIDIARY, ST_OMP_SCAN},
93 : : {"scope", GFC_OMP_DIR_EXECUTABLE, ST_OMP_SCOPE},
94 : : {"sections", GFC_OMP_DIR_EXECUTABLE, ST_OMP_SECTIONS},
95 : : {"section", GFC_OMP_DIR_SUBSIDIARY, ST_OMP_SECTION},
96 : : {"simd", GFC_OMP_DIR_EXECUTABLE, ST_OMP_SIMD},
97 : : {"single", GFC_OMP_DIR_EXECUTABLE, ST_OMP_SINGLE},
98 : : {"target data", GFC_OMP_DIR_EXECUTABLE, ST_OMP_TARGET_DATA},
99 : : {"target enter data", GFC_OMP_DIR_EXECUTABLE, ST_OMP_TARGET_ENTER_DATA},
100 : : {"target exit data", GFC_OMP_DIR_EXECUTABLE, ST_OMP_TARGET_EXIT_DATA},
101 : : {"target update", GFC_OMP_DIR_EXECUTABLE, ST_OMP_TARGET_UPDATE},
102 : : {"target", GFC_OMP_DIR_EXECUTABLE, ST_OMP_TARGET},
103 : : {"taskloop", GFC_OMP_DIR_EXECUTABLE, ST_OMP_TASKLOOP},
104 : : {"taskwait", GFC_OMP_DIR_EXECUTABLE, ST_OMP_TASKWAIT},
105 : : {"taskyield", GFC_OMP_DIR_EXECUTABLE, ST_OMP_TASKYIELD},
106 : : {"task", GFC_OMP_DIR_EXECUTABLE, ST_OMP_TASK},
107 : : {"teams", GFC_OMP_DIR_EXECUTABLE, ST_OMP_TEAMS},
108 : : {"threadprivate", GFC_OMP_DIR_DECLARATIVE, ST_OMP_THREADPRIVATE},
109 : : /* {"tile", GFC_OMP_DIR_EXECUTABLE, ST_OMP_TILE}, */
110 : : /* {"unroll", GFC_OMP_DIR_EXECUTABLE, ST_OMP_UNROLL}, */
111 : : {"workshare", GFC_OMP_DIR_EXECUTABLE, ST_OMP_WORKSHARE},
112 : : };
113 : :
114 : :
115 : : /* Match an end of OpenMP directive. End of OpenMP directive is optional
116 : : whitespace, followed by '\n' or comment '!'. */
117 : :
118 : : static match
119 : 49834 : gfc_match_omp_eos (void)
120 : : {
121 : 49834 : locus old_loc;
122 : 49834 : char c;
123 : :
124 : 49834 : old_loc = gfc_current_locus;
125 : 49834 : gfc_gobble_whitespace ();
126 : :
127 : 49834 : c = gfc_next_ascii_char ();
128 : 49834 : switch (c)
129 : : {
130 : 0 : case '!':
131 : 0 : do
132 : 0 : c = gfc_next_ascii_char ();
133 : 0 : while (c != '\n');
134 : : /* Fall through */
135 : :
136 : : case '\n':
137 : : return MATCH_YES;
138 : : }
139 : :
140 : 1405 : gfc_current_locus = old_loc;
141 : 1405 : return MATCH_NO;
142 : : }
143 : :
144 : : match
145 : 12450 : gfc_match_omp_eos_error (void)
146 : : {
147 : 12450 : if (gfc_match_omp_eos() == MATCH_YES)
148 : : return MATCH_YES;
149 : :
150 : 35 : gfc_error ("Unexpected junk at %C");
151 : 35 : return MATCH_ERROR;
152 : : }
153 : :
154 : :
155 : : /* Free an omp_clauses structure. */
156 : :
157 : : void
158 : 55649 : gfc_free_omp_clauses (gfc_omp_clauses *c)
159 : : {
160 : 55649 : int i;
161 : 55649 : if (c == NULL)
162 : : return;
163 : :
164 : 31395 : gfc_free_expr (c->if_expr);
165 : 376740 : for (i = 0; i < OMP_IF_LAST; i++)
166 : 313950 : gfc_free_expr (c->if_exprs[i]);
167 : 31395 : gfc_free_expr (c->self_expr);
168 : 31395 : gfc_free_expr (c->final_expr);
169 : 31395 : gfc_free_expr (c->num_threads);
170 : 31395 : gfc_free_expr (c->chunk_size);
171 : 31395 : gfc_free_expr (c->safelen_expr);
172 : 31395 : gfc_free_expr (c->simdlen_expr);
173 : 31395 : gfc_free_expr (c->num_teams_lower);
174 : 31395 : gfc_free_expr (c->num_teams_upper);
175 : 31395 : gfc_free_expr (c->device);
176 : 31395 : gfc_free_expr (c->thread_limit);
177 : 31395 : gfc_free_expr (c->dist_chunk_size);
178 : 31395 : gfc_free_expr (c->grainsize);
179 : 31395 : gfc_free_expr (c->hint);
180 : 31395 : gfc_free_expr (c->num_tasks);
181 : 31395 : gfc_free_expr (c->priority);
182 : 31395 : gfc_free_expr (c->detach);
183 : 31395 : gfc_free_expr (c->async_expr);
184 : 31395 : gfc_free_expr (c->gang_num_expr);
185 : 31395 : gfc_free_expr (c->gang_static_expr);
186 : 31395 : gfc_free_expr (c->worker_expr);
187 : 31395 : gfc_free_expr (c->vector_expr);
188 : 31395 : gfc_free_expr (c->num_gangs_expr);
189 : 31395 : gfc_free_expr (c->num_workers_expr);
190 : 31395 : gfc_free_expr (c->vector_length_expr);
191 : 1098825 : for (i = 0; i < OMP_LIST_NUM; i++)
192 : 1036035 : gfc_free_omp_namelist (c->lists[i],
193 : 1036035 : i == OMP_LIST_AFFINITY || i == OMP_LIST_DEPEND,
194 : : i == OMP_LIST_ALLOCATE,
195 : : i == OMP_LIST_USES_ALLOCATORS);
196 : 31395 : gfc_free_expr_list (c->wait_list);
197 : 31395 : gfc_free_expr_list (c->tile_list);
198 : 31395 : free (CONST_CAST (char *, c->critical_name));
199 : 31395 : if (c->assume)
200 : : {
201 : 18 : free (c->assume->absent);
202 : 18 : free (c->assume->contains);
203 : 18 : gfc_free_expr_list (c->assume->holds);
204 : 18 : free (c->assume);
205 : : }
206 : 31395 : free (c);
207 : : }
208 : :
209 : : /* Free oacc_declare structures. */
210 : :
211 : : void
212 : 73 : gfc_free_oacc_declare_clauses (struct gfc_oacc_declare *oc)
213 : : {
214 : 73 : struct gfc_oacc_declare *decl = oc;
215 : :
216 : 73 : do
217 : : {
218 : 73 : struct gfc_oacc_declare *next;
219 : :
220 : 73 : next = decl->next;
221 : 73 : gfc_free_omp_clauses (decl->clauses);
222 : 73 : free (decl);
223 : 73 : decl = next;
224 : : }
225 : 73 : while (decl);
226 : 73 : }
227 : :
228 : : /* Free expression list. */
229 : : void
230 : 62854 : gfc_free_expr_list (gfc_expr_list *list)
231 : : {
232 : 62854 : gfc_expr_list *n;
233 : :
234 : 63499 : for (; list; list = n)
235 : : {
236 : 645 : n = list->next;
237 : 645 : free (list);
238 : : }
239 : 62854 : }
240 : :
241 : : /* Free an !$omp declare simd construct list. */
242 : :
243 : : void
244 : 261 : gfc_free_omp_declare_simd (gfc_omp_declare_simd *ods)
245 : : {
246 : 261 : if (ods)
247 : : {
248 : 261 : gfc_free_omp_clauses (ods->clauses);
249 : 261 : free (ods);
250 : : }
251 : 261 : }
252 : :
253 : : void
254 : 443413 : gfc_free_omp_declare_simd_list (gfc_omp_declare_simd *list)
255 : : {
256 : 443674 : while (list)
257 : : {
258 : 261 : gfc_omp_declare_simd *current = list;
259 : 261 : list = list->next;
260 : 261 : gfc_free_omp_declare_simd (current);
261 : : }
262 : 443413 : }
263 : :
264 : : static void
265 : 443 : gfc_free_omp_trait_property_list (gfc_omp_trait_property *list)
266 : : {
267 : 725 : while (list)
268 : : {
269 : 282 : gfc_omp_trait_property *current = list;
270 : 282 : list = list->next;
271 : 282 : switch (current->property_kind)
272 : : {
273 : 25 : case OMP_TRAIT_PROPERTY_ID:
274 : 25 : free (current->name);
275 : 25 : break;
276 : 196 : case OMP_TRAIT_PROPERTY_NAME_LIST:
277 : 196 : if (current->is_name)
278 : 149 : free (current->name);
279 : : break;
280 : 15 : case OMP_TRAIT_PROPERTY_CLAUSE_LIST:
281 : 15 : gfc_free_omp_clauses (current->clauses);
282 : 15 : break;
283 : : default:
284 : : break;
285 : : }
286 : 282 : free (current);
287 : : }
288 : 443 : }
289 : :
290 : : static void
291 : 345 : gfc_free_omp_selector_list (gfc_omp_selector *list)
292 : : {
293 : 788 : while (list)
294 : : {
295 : 443 : gfc_omp_selector *current = list;
296 : 443 : list = list->next;
297 : 443 : gfc_free_omp_trait_property_list (current->properties);
298 : 443 : free (current);
299 : : }
300 : 345 : }
301 : :
302 : : static void
303 : 307 : gfc_free_omp_set_selector_list (gfc_omp_set_selector *list)
304 : : {
305 : 652 : while (list)
306 : : {
307 : 345 : gfc_omp_set_selector *current = list;
308 : 345 : list = list->next;
309 : 345 : gfc_free_omp_selector_list (current->trait_selectors);
310 : 345 : free (current);
311 : : }
312 : 307 : }
313 : :
314 : : /* Free an !$omp declare variant construct list. */
315 : :
316 : : void
317 : 443413 : gfc_free_omp_declare_variant_list (gfc_omp_declare_variant *list)
318 : : {
319 : 443720 : while (list)
320 : : {
321 : 307 : gfc_omp_declare_variant *current = list;
322 : 307 : list = list->next;
323 : 307 : gfc_free_omp_set_selector_list (current->set_selectors);
324 : 307 : free (current);
325 : : }
326 : 443413 : }
327 : :
328 : : /* Free an !$omp declare reduction. */
329 : :
330 : : void
331 : 1118 : gfc_free_omp_udr (gfc_omp_udr *omp_udr)
332 : : {
333 : 1118 : if (omp_udr)
334 : : {
335 : 607 : gfc_free_omp_udr (omp_udr->next);
336 : 607 : gfc_free_namespace (omp_udr->combiner_ns);
337 : 607 : if (omp_udr->initializer_ns)
338 : 377 : gfc_free_namespace (omp_udr->initializer_ns);
339 : 607 : free (omp_udr);
340 : : }
341 : 1118 : }
342 : :
343 : :
344 : : static gfc_omp_udr *
345 : 4346 : gfc_find_omp_udr (gfc_namespace *ns, const char *name, gfc_typespec *ts)
346 : : {
347 : 4346 : gfc_symtree *st;
348 : :
349 : 4346 : if (ns == NULL)
350 : 467 : ns = gfc_current_ns;
351 : 5199 : do
352 : : {
353 : 5199 : gfc_omp_udr *omp_udr;
354 : :
355 : 5199 : st = gfc_find_symtree (ns->omp_udr_root, name);
356 : 5199 : if (st != NULL)
357 : : {
358 : 934 : for (omp_udr = st->n.omp_udr; omp_udr; omp_udr = omp_udr->next)
359 : 934 : if (ts == NULL)
360 : 367 : return omp_udr;
361 : 567 : else if (gfc_compare_types (&omp_udr->ts, ts))
362 : : {
363 : 479 : if (ts->type == BT_CHARACTER)
364 : : {
365 : 60 : if (omp_udr->ts.u.cl->length == NULL)
366 : 24 : return omp_udr;
367 : 36 : if (ts->u.cl->length == NULL)
368 : 0 : continue;
369 : 36 : if (gfc_compare_expr (omp_udr->ts.u.cl->length,
370 : : ts->u.cl->length,
371 : : INTRINSIC_EQ) != 0)
372 : 12 : continue;
373 : : }
374 : 443 : return omp_udr;
375 : : }
376 : : }
377 : :
378 : : /* Don't escape an interface block. */
379 : 4365 : if (ns && !ns->has_import_set
380 : 4365 : && ns->proc_name && ns->proc_name->attr.if_source == IFSRC_IFBODY)
381 : : break;
382 : :
383 : 4365 : ns = ns->parent;
384 : : }
385 : 4365 : while (ns != NULL);
386 : :
387 : : return NULL;
388 : : }
389 : :
390 : :
391 : : /* Match a variable/common block list and construct a namelist from it;
392 : : if has_all_memory != NULL, *has_all_memory is set and omp_all_memory
393 : : yields a list->sym NULL entry. */
394 : :
395 : : static match
396 : 29103 : gfc_match_omp_variable_list (const char *str, gfc_omp_namelist **list,
397 : : bool allow_common, bool *end_colon = NULL,
398 : : gfc_omp_namelist ***headp = NULL,
399 : : bool allow_sections = false,
400 : : bool allow_derived = false,
401 : : bool *has_all_memory = NULL,
402 : : bool reject_common_vars = false)
403 : : {
404 : 29103 : gfc_omp_namelist *head, *tail, *p;
405 : 29103 : locus old_loc, cur_loc;
406 : 29103 : char n[GFC_MAX_SYMBOL_LEN+1];
407 : 29103 : gfc_symbol *sym;
408 : 29103 : match m;
409 : 29103 : gfc_symtree *st;
410 : :
411 : 29103 : head = tail = NULL;
412 : :
413 : 29103 : old_loc = gfc_current_locus;
414 : 29103 : if (has_all_memory)
415 : 683 : *has_all_memory = false;
416 : 29103 : m = gfc_match (str);
417 : 29103 : if (m != MATCH_YES)
418 : : return m;
419 : :
420 : 35040 : for (;;)
421 : : {
422 : 35040 : cur_loc = gfc_current_locus;
423 : :
424 : 35040 : m = gfc_match_name (n);
425 : 35040 : if (m == MATCH_YES && strcmp (n, "omp_all_memory") == 0)
426 : : {
427 : 23 : if (!has_all_memory)
428 : : {
429 : 2 : gfc_error ("%<omp_all_memory%> at %C not permitted in this "
430 : : "clause");
431 : 2 : goto cleanup;
432 : : }
433 : 21 : *has_all_memory = true;
434 : 21 : p = gfc_get_omp_namelist ();
435 : 21 : if (head == NULL)
436 : : head = tail = p;
437 : : else
438 : : {
439 : 3 : tail->next = p;
440 : 3 : tail = tail->next;
441 : : }
442 : 21 : tail->where = cur_loc;
443 : 21 : goto next_item;
444 : : }
445 : 34834 : if (m == MATCH_YES)
446 : : {
447 : 34834 : gfc_symtree *st;
448 : 34834 : if ((m = gfc_get_ha_sym_tree (n, &st) ? MATCH_ERROR : MATCH_YES)
449 : : == MATCH_YES)
450 : 34834 : sym = st->n.sym;
451 : : }
452 : 35017 : switch (m)
453 : : {
454 : 34834 : case MATCH_YES:
455 : 34834 : gfc_expr *expr;
456 : 34834 : expr = NULL;
457 : 34834 : gfc_gobble_whitespace ();
458 : 21266 : if ((allow_sections && gfc_peek_ascii_char () == '(')
459 : 52059 : || (allow_derived && gfc_peek_ascii_char () == '%'))
460 : : {
461 : 5812 : gfc_current_locus = cur_loc;
462 : 5812 : m = gfc_match_variable (&expr, 0);
463 : 5812 : switch (m)
464 : : {
465 : 4 : case MATCH_ERROR:
466 : 12 : goto cleanup;
467 : 0 : case MATCH_NO:
468 : 0 : goto syntax;
469 : 5808 : default:
470 : 5808 : break;
471 : : }
472 : 5808 : if (gfc_is_coindexed (expr))
473 : : {
474 : 5 : gfc_error ("List item shall not be coindexed at %C");
475 : 5 : goto cleanup;
476 : : }
477 : : }
478 : 34825 : gfc_set_sym_referenced (sym);
479 : 34825 : p = gfc_get_omp_namelist ();
480 : 34825 : if (head == NULL)
481 : : head = tail = p;
482 : : else
483 : : {
484 : 9350 : tail->next = p;
485 : 9350 : tail = tail->next;
486 : : }
487 : 34825 : tail->sym = sym;
488 : 34825 : tail->expr = expr;
489 : 34825 : tail->where = cur_loc;
490 : 34825 : if (reject_common_vars && sym->attr.in_common)
491 : : {
492 : 3 : gcc_assert (allow_common);
493 : 3 : gfc_error ("%qs at %L is part of the common block %</%s/%> and "
494 : : "may only be specificed implicitly via the named "
495 : : "common block", sym->name, &cur_loc,
496 : 3 : sym->common_head->name);
497 : 3 : goto cleanup;
498 : : }
499 : 34822 : goto next_item;
500 : 183 : case MATCH_NO:
501 : 183 : break;
502 : 0 : case MATCH_ERROR:
503 : 0 : goto cleanup;
504 : : }
505 : :
506 : 183 : if (!allow_common)
507 : 8 : goto syntax;
508 : :
509 : 175 : m = gfc_match (" / %n /", n);
510 : 175 : if (m == MATCH_ERROR)
511 : 0 : goto cleanup;
512 : 175 : if (m == MATCH_NO)
513 : 14 : goto syntax;
514 : :
515 : 161 : st = gfc_find_symtree (gfc_current_ns->common_root, n);
516 : 161 : if (st == NULL)
517 : : {
518 : 2 : gfc_error ("COMMON block /%s/ not found at %C", n);
519 : 2 : goto cleanup;
520 : : }
521 : 573 : for (sym = st->n.common->head; sym; sym = sym->common_next)
522 : : {
523 : 414 : gfc_set_sym_referenced (sym);
524 : 414 : p = gfc_get_omp_namelist ();
525 : 414 : if (head == NULL)
526 : : head = tail = p;
527 : : else
528 : : {
529 : 296 : tail->next = p;
530 : 296 : tail = tail->next;
531 : : }
532 : 414 : tail->sym = sym;
533 : 414 : tail->where = cur_loc;
534 : : }
535 : :
536 : 159 : next_item:
537 : 35002 : if (end_colon && gfc_match_char (':') == MATCH_YES)
538 : : {
539 : 790 : *end_colon = true;
540 : 790 : break;
541 : : }
542 : 34212 : if (gfc_match_char (')') == MATCH_YES)
543 : : break;
544 : 9407 : if (gfc_match_char (',') != MATCH_YES)
545 : 13 : goto syntax;
546 : : }
547 : :
548 : 34796 : while (*list)
549 : 9201 : list = &(*list)->next;
550 : :
551 : 25595 : *list = head;
552 : 25595 : if (headp)
553 : 20392 : *headp = list;
554 : : return MATCH_YES;
555 : :
556 : 35 : syntax:
557 : 35 : gfc_error ("Syntax error in OpenMP variable list at %C");
558 : :
559 : 51 : cleanup:
560 : 51 : gfc_free_omp_namelist (head, false, false, false);
561 : 51 : gfc_current_locus = old_loc;
562 : 51 : return MATCH_ERROR;
563 : : }
564 : :
565 : : /* Match a variable/procedure/common block list and construct a namelist
566 : : from it. */
567 : :
568 : : static match
569 : 300 : gfc_match_omp_to_link (const char *str, gfc_omp_namelist **list)
570 : : {
571 : 300 : gfc_omp_namelist *head, *tail, *p;
572 : 300 : locus old_loc, cur_loc;
573 : 300 : char n[GFC_MAX_SYMBOL_LEN+1];
574 : 300 : gfc_symbol *sym;
575 : 300 : match m;
576 : 300 : gfc_symtree *st;
577 : :
578 : 300 : head = tail = NULL;
579 : :
580 : 300 : old_loc = gfc_current_locus;
581 : :
582 : 300 : m = gfc_match (str);
583 : 300 : if (m != MATCH_YES)
584 : : return m;
585 : :
586 : 485 : for (;;)
587 : : {
588 : 485 : cur_loc = gfc_current_locus;
589 : 485 : m = gfc_match_symbol (&sym, 1);
590 : 485 : switch (m)
591 : : {
592 : 460 : case MATCH_YES:
593 : 460 : p = gfc_get_omp_namelist ();
594 : 460 : if (head == NULL)
595 : : head = tail = p;
596 : : else
597 : : {
598 : 182 : tail->next = p;
599 : 182 : tail = tail->next;
600 : : }
601 : 460 : tail->sym = sym;
602 : 460 : tail->where = cur_loc;
603 : 460 : goto next_item;
604 : : case MATCH_NO:
605 : : break;
606 : 0 : case MATCH_ERROR:
607 : 0 : goto cleanup;
608 : : }
609 : :
610 : 25 : m = gfc_match (" / %n /", n);
611 : 25 : if (m == MATCH_ERROR)
612 : 0 : goto cleanup;
613 : 25 : if (m == MATCH_NO)
614 : 0 : goto syntax;
615 : :
616 : 25 : st = gfc_find_symtree (gfc_current_ns->common_root, n);
617 : 25 : if (st == NULL)
618 : : {
619 : 0 : gfc_error ("COMMON block /%s/ not found at %C", n);
620 : 0 : goto cleanup;
621 : : }
622 : 25 : p = gfc_get_omp_namelist ();
623 : 25 : if (head == NULL)
624 : : head = tail = p;
625 : : else
626 : : {
627 : 3 : tail->next = p;
628 : 3 : tail = tail->next;
629 : : }
630 : 25 : tail->u.common = st->n.common;
631 : 25 : tail->where = cur_loc;
632 : :
633 : 485 : next_item:
634 : 485 : if (gfc_match_char (')') == MATCH_YES)
635 : : break;
636 : 185 : if (gfc_match_char (',') != MATCH_YES)
637 : 0 : goto syntax;
638 : : }
639 : :
640 : 311 : while (*list)
641 : 11 : list = &(*list)->next;
642 : :
643 : 300 : *list = head;
644 : 300 : return MATCH_YES;
645 : :
646 : 0 : syntax:
647 : 0 : gfc_error ("Syntax error in OpenMP variable list at %C");
648 : :
649 : 0 : cleanup:
650 : 0 : gfc_free_omp_namelist (head, false, false, false);
651 : 0 : gfc_current_locus = old_loc;
652 : 0 : return MATCH_ERROR;
653 : : }
654 : :
655 : : /* Match detach(event-handle). */
656 : :
657 : : static match
658 : 126 : gfc_match_omp_detach (gfc_expr **expr)
659 : : {
660 : 126 : locus old_loc = gfc_current_locus;
661 : :
662 : 126 : if (gfc_match ("detach ( ") != MATCH_YES)
663 : 0 : goto syntax_error;
664 : :
665 : 126 : if (gfc_match_variable (expr, 0) != MATCH_YES)
666 : 0 : goto syntax_error;
667 : :
668 : 126 : if (gfc_match_char (')') != MATCH_YES)
669 : 0 : goto syntax_error;
670 : :
671 : : return MATCH_YES;
672 : :
673 : 0 : syntax_error:
674 : 0 : gfc_error ("Syntax error in OpenMP detach clause at %C");
675 : 0 : gfc_current_locus = old_loc;
676 : 0 : return MATCH_ERROR;
677 : :
678 : : }
679 : :
680 : : /* Match doacross(sink : ...) construct a namelist from it;
681 : : if depend is true, match legacy 'depend(sink : ...)'. */
682 : :
683 : : static match
684 : 240 : gfc_match_omp_doacross_sink (gfc_omp_namelist **list, bool depend)
685 : : {
686 : 240 : char n[GFC_MAX_SYMBOL_LEN+1];
687 : 240 : gfc_omp_namelist *head, *tail, *p;
688 : 240 : locus old_loc, cur_loc;
689 : 240 : gfc_symbol *sym;
690 : :
691 : 240 : head = tail = NULL;
692 : :
693 : 240 : old_loc = gfc_current_locus;
694 : :
695 : 1235 : for (;;)
696 : : {
697 : 1235 : cur_loc = gfc_current_locus;
698 : :
699 : 1235 : if (gfc_match_name (n) != MATCH_YES)
700 : 1 : goto syntax;
701 : 1234 : if (UNLIKELY (strcmp (n, "omp_all_memory") == 0))
702 : : {
703 : 1 : gfc_error ("%<omp_all_memory%> used with dependence-type "
704 : : "other than OUT or INOUT at %C");
705 : 1 : goto cleanup;
706 : : }
707 : 1233 : sym = NULL;
708 : 1233 : if (!(strcmp (n, "omp_cur_iteration") == 0))
709 : : {
710 : 1228 : gfc_symtree *st;
711 : 1228 : if (gfc_get_ha_sym_tree (n, &st))
712 : 0 : goto syntax;
713 : 1228 : sym = st->n.sym;
714 : 1228 : gfc_set_sym_referenced (sym);
715 : : }
716 : 1233 : p = gfc_get_omp_namelist ();
717 : 1233 : if (head == NULL)
718 : : {
719 : 238 : head = tail = p;
720 : 252 : head->u.depend_doacross_op = (depend ? OMP_DEPEND_SINK_FIRST
721 : : : OMP_DOACROSS_SINK_FIRST);
722 : : }
723 : : else
724 : : {
725 : 995 : tail->next = p;
726 : 995 : tail = tail->next;
727 : 995 : tail->u.depend_doacross_op = OMP_DOACROSS_SINK;
728 : : }
729 : 1233 : tail->sym = sym;
730 : 1233 : tail->expr = NULL;
731 : 1233 : tail->where = cur_loc;
732 : 1233 : if (gfc_match_char ('+') == MATCH_YES)
733 : : {
734 : 154 : if (gfc_match_literal_constant (&tail->expr, 0) != MATCH_YES)
735 : 0 : goto syntax;
736 : : }
737 : 1079 : else if (gfc_match_char ('-') == MATCH_YES)
738 : : {
739 : 418 : if (gfc_match_literal_constant (&tail->expr, 0) != MATCH_YES)
740 : 1 : goto syntax;
741 : 417 : tail->expr = gfc_uminus (tail->expr);
742 : : }
743 : 1232 : if (gfc_match_char (')') == MATCH_YES)
744 : : break;
745 : 995 : if (gfc_match_char (',') != MATCH_YES)
746 : 0 : goto syntax;
747 : : }
748 : :
749 : 1029 : while (*list)
750 : 792 : list = &(*list)->next;
751 : :
752 : 237 : *list = head;
753 : 237 : return MATCH_YES;
754 : :
755 : 2 : syntax:
756 : 2 : gfc_error ("Syntax error in OpenMP SINK dependence-type list at %C");
757 : :
758 : 3 : cleanup:
759 : 3 : gfc_free_omp_namelist (head, false, false, false);
760 : 3 : gfc_current_locus = old_loc;
761 : 3 : return MATCH_ERROR;
762 : : }
763 : :
764 : : static match
765 : 574 : match_oacc_expr_list (const char *str, gfc_expr_list **list,
766 : : bool allow_asterisk)
767 : : {
768 : 574 : gfc_expr_list *head, *tail, *p;
769 : 574 : locus old_loc;
770 : 574 : gfc_expr *expr;
771 : 574 : match m;
772 : :
773 : 574 : head = tail = NULL;
774 : :
775 : 574 : old_loc = gfc_current_locus;
776 : :
777 : 574 : m = gfc_match (str);
778 : 574 : if (m != MATCH_YES)
779 : : return m;
780 : :
781 : 595 : for (;;)
782 : : {
783 : 595 : m = gfc_match_expr (&expr);
784 : 595 : if (m == MATCH_YES || allow_asterisk)
785 : : {
786 : 589 : p = gfc_get_expr_list ();
787 : 589 : if (head == NULL)
788 : : head = tail = p;
789 : : else
790 : : {
791 : 144 : tail->next = p;
792 : 144 : tail = tail->next;
793 : : }
794 : 589 : if (m == MATCH_YES)
795 : 473 : tail->expr = expr;
796 : 116 : else if (gfc_match (" *") != MATCH_YES)
797 : 16 : goto syntax;
798 : 573 : goto next_item;
799 : : }
800 : 6 : if (m == MATCH_ERROR)
801 : 0 : goto cleanup;
802 : 6 : goto syntax;
803 : :
804 : 573 : next_item:
805 : 573 : if (gfc_match_char (')') == MATCH_YES)
806 : : break;
807 : 152 : if (gfc_match_char (',') != MATCH_YES)
808 : 5 : goto syntax;
809 : : }
810 : :
811 : 427 : while (*list)
812 : 6 : list = &(*list)->next;
813 : :
814 : 421 : *list = head;
815 : 421 : return MATCH_YES;
816 : :
817 : 27 : syntax:
818 : 27 : gfc_error ("Syntax error in OpenACC expression list at %C");
819 : :
820 : 27 : cleanup:
821 : 27 : gfc_free_expr_list (head);
822 : 27 : gfc_current_locus = old_loc;
823 : 27 : return MATCH_ERROR;
824 : : }
825 : :
826 : : static match
827 : 2877 : match_oacc_clause_gwv (gfc_omp_clauses *cp, unsigned gwv)
828 : : {
829 : 2877 : match ret = MATCH_YES;
830 : :
831 : 2877 : if (gfc_match (" ( ") != MATCH_YES)
832 : : return MATCH_NO;
833 : :
834 : 449 : if (gwv == GOMP_DIM_GANG)
835 : : {
836 : : /* The gang clause accepts two optional arguments, num and static.
837 : : The num argument may either be explicit (num: <val>) or
838 : : implicit without (<val> without num:). */
839 : :
840 : 431 : while (ret == MATCH_YES)
841 : : {
842 : 223 : if (gfc_match (" static :") == MATCH_YES)
843 : : {
844 : 105 : if (cp->gang_static)
845 : : return MATCH_ERROR;
846 : : else
847 : 104 : cp->gang_static = true;
848 : 104 : if (gfc_match_char ('*') == MATCH_YES)
849 : 15 : cp->gang_static_expr = NULL;
850 : 89 : else if (gfc_match (" %e ", &cp->gang_static_expr) != MATCH_YES)
851 : : return MATCH_ERROR;
852 : : }
853 : : else
854 : : {
855 : 118 : if (cp->gang_num_expr)
856 : : return MATCH_ERROR;
857 : :
858 : : /* The 'num' argument is optional. */
859 : 117 : gfc_match (" num :");
860 : :
861 : 117 : if (gfc_match (" %e ", &cp->gang_num_expr) != MATCH_YES)
862 : : return MATCH_ERROR;
863 : : }
864 : :
865 : 218 : ret = gfc_match (" , ");
866 : : }
867 : : }
868 : 236 : else if (gwv == GOMP_DIM_WORKER)
869 : : {
870 : : /* The 'num' argument is optional. */
871 : 103 : gfc_match (" num :");
872 : :
873 : 103 : if (gfc_match (" %e ", &cp->worker_expr) != MATCH_YES)
874 : : return MATCH_ERROR;
875 : : }
876 : 133 : else if (gwv == GOMP_DIM_VECTOR)
877 : : {
878 : : /* The 'length' argument is optional. */
879 : 133 : gfc_match (" length :");
880 : :
881 : 133 : if (gfc_match (" %e ", &cp->vector_expr) != MATCH_YES)
882 : : return MATCH_ERROR;
883 : : }
884 : : else
885 : 0 : gfc_fatal_error ("Unexpected OpenACC parallelism.");
886 : :
887 : 438 : return gfc_match (" )");
888 : : }
889 : :
890 : : static match
891 : 8 : gfc_match_oacc_clause_link (const char *str, gfc_omp_namelist **list)
892 : : {
893 : 8 : gfc_omp_namelist *head = NULL;
894 : 8 : gfc_omp_namelist *tail, *p;
895 : 8 : locus old_loc;
896 : 8 : char n[GFC_MAX_SYMBOL_LEN+1];
897 : 8 : gfc_symbol *sym;
898 : 8 : match m;
899 : 8 : gfc_symtree *st;
900 : :
901 : 8 : old_loc = gfc_current_locus;
902 : :
903 : 8 : m = gfc_match (str);
904 : 8 : if (m != MATCH_YES)
905 : : return m;
906 : :
907 : 8 : m = gfc_match (" (");
908 : :
909 : 14 : for (;;)
910 : : {
911 : 14 : m = gfc_match_symbol (&sym, 0);
912 : 14 : switch (m)
913 : : {
914 : 8 : case MATCH_YES:
915 : 8 : if (sym->attr.in_common)
916 : : {
917 : 2 : gfc_error_now ("Variable at %C is an element of a COMMON block");
918 : 2 : goto cleanup;
919 : : }
920 : 6 : gfc_set_sym_referenced (sym);
921 : 6 : p = gfc_get_omp_namelist ();
922 : 6 : if (head == NULL)
923 : : head = tail = p;
924 : : else
925 : : {
926 : 4 : tail->next = p;
927 : 4 : tail = tail->next;
928 : : }
929 : 6 : tail->sym = sym;
930 : 6 : tail->expr = NULL;
931 : 6 : tail->where = gfc_current_locus;
932 : 6 : goto next_item;
933 : : case MATCH_NO:
934 : : break;
935 : :
936 : 0 : case MATCH_ERROR:
937 : 0 : goto cleanup;
938 : : }
939 : :
940 : 6 : m = gfc_match (" / %n /", n);
941 : 6 : if (m == MATCH_ERROR)
942 : 0 : goto cleanup;
943 : 6 : if (m == MATCH_NO || n[0] == '\0')
944 : 0 : goto syntax;
945 : :
946 : 6 : st = gfc_find_symtree (gfc_current_ns->common_root, n);
947 : 6 : if (st == NULL)
948 : : {
949 : 1 : gfc_error ("COMMON block /%s/ not found at %C", n);
950 : 1 : goto cleanup;
951 : : }
952 : :
953 : 20 : for (sym = st->n.common->head; sym; sym = sym->common_next)
954 : : {
955 : 15 : gfc_set_sym_referenced (sym);
956 : 15 : p = gfc_get_omp_namelist ();
957 : 15 : if (head == NULL)
958 : : head = tail = p;
959 : : else
960 : : {
961 : 12 : tail->next = p;
962 : 12 : tail = tail->next;
963 : : }
964 : 15 : tail->sym = sym;
965 : 15 : tail->where = gfc_current_locus;
966 : : }
967 : :
968 : 5 : next_item:
969 : 11 : if (gfc_match_char (')') == MATCH_YES)
970 : : break;
971 : 6 : if (gfc_match_char (',') != MATCH_YES)
972 : 0 : goto syntax;
973 : : }
974 : :
975 : 5 : if (gfc_match_omp_eos () != MATCH_YES)
976 : : {
977 : 1 : gfc_error ("Unexpected junk after !$ACC DECLARE at %C");
978 : 1 : goto cleanup;
979 : : }
980 : :
981 : 4 : while (*list)
982 : 0 : list = &(*list)->next;
983 : 4 : *list = head;
984 : 4 : return MATCH_YES;
985 : :
986 : 0 : syntax:
987 : 0 : gfc_error ("Syntax error in !$ACC DECLARE list at %C");
988 : :
989 : 4 : cleanup:
990 : 4 : gfc_current_locus = old_loc;
991 : 4 : return MATCH_ERROR;
992 : : }
993 : :
994 : : /* OpenMP clauses. */
995 : : enum omp_mask1
996 : : {
997 : : OMP_CLAUSE_PRIVATE,
998 : : OMP_CLAUSE_FIRSTPRIVATE,
999 : : OMP_CLAUSE_LASTPRIVATE,
1000 : : OMP_CLAUSE_COPYPRIVATE,
1001 : : OMP_CLAUSE_SHARED,
1002 : : OMP_CLAUSE_COPYIN,
1003 : : OMP_CLAUSE_REDUCTION,
1004 : : OMP_CLAUSE_IN_REDUCTION,
1005 : : OMP_CLAUSE_TASK_REDUCTION,
1006 : : OMP_CLAUSE_IF,
1007 : : OMP_CLAUSE_NUM_THREADS,
1008 : : OMP_CLAUSE_SCHEDULE,
1009 : : OMP_CLAUSE_DEFAULT,
1010 : : OMP_CLAUSE_ORDER,
1011 : : OMP_CLAUSE_ORDERED,
1012 : : OMP_CLAUSE_COLLAPSE,
1013 : : OMP_CLAUSE_UNTIED,
1014 : : OMP_CLAUSE_FINAL,
1015 : : OMP_CLAUSE_MERGEABLE,
1016 : : OMP_CLAUSE_ALIGNED,
1017 : : OMP_CLAUSE_DEPEND,
1018 : : OMP_CLAUSE_INBRANCH,
1019 : : OMP_CLAUSE_LINEAR,
1020 : : OMP_CLAUSE_NOTINBRANCH,
1021 : : OMP_CLAUSE_PROC_BIND,
1022 : : OMP_CLAUSE_SAFELEN,
1023 : : OMP_CLAUSE_SIMDLEN,
1024 : : OMP_CLAUSE_UNIFORM,
1025 : : OMP_CLAUSE_DEVICE,
1026 : : OMP_CLAUSE_MAP,
1027 : : OMP_CLAUSE_TO,
1028 : : OMP_CLAUSE_FROM,
1029 : : OMP_CLAUSE_NUM_TEAMS,
1030 : : OMP_CLAUSE_THREAD_LIMIT,
1031 : : OMP_CLAUSE_DIST_SCHEDULE,
1032 : : OMP_CLAUSE_DEFAULTMAP,
1033 : : OMP_CLAUSE_GRAINSIZE,
1034 : : OMP_CLAUSE_HINT,
1035 : : OMP_CLAUSE_IS_DEVICE_PTR,
1036 : : OMP_CLAUSE_LINK,
1037 : : OMP_CLAUSE_NOGROUP,
1038 : : OMP_CLAUSE_NOTEMPORAL,
1039 : : OMP_CLAUSE_NUM_TASKS,
1040 : : OMP_CLAUSE_PRIORITY,
1041 : : OMP_CLAUSE_SIMD,
1042 : : OMP_CLAUSE_THREADS,
1043 : : OMP_CLAUSE_USE_DEVICE_PTR,
1044 : : OMP_CLAUSE_USE_DEVICE_ADDR, /* OpenMP 5.0. */
1045 : : OMP_CLAUSE_DEVICE_TYPE, /* OpenMP 5.0. */
1046 : : OMP_CLAUSE_ATOMIC, /* OpenMP 5.0. */
1047 : : OMP_CLAUSE_CAPTURE, /* OpenMP 5.0. */
1048 : : OMP_CLAUSE_MEMORDER, /* OpenMP 5.0. */
1049 : : OMP_CLAUSE_DETACH, /* OpenMP 5.0. */
1050 : : OMP_CLAUSE_AFFINITY, /* OpenMP 5.0. */
1051 : : OMP_CLAUSE_ALLOCATE, /* OpenMP 5.0. */
1052 : : OMP_CLAUSE_BIND, /* OpenMP 5.0. */
1053 : : OMP_CLAUSE_FILTER, /* OpenMP 5.1. */
1054 : : OMP_CLAUSE_AT, /* OpenMP 5.1. */
1055 : : OMP_CLAUSE_MESSAGE, /* OpenMP 5.1. */
1056 : : OMP_CLAUSE_SEVERITY, /* OpenMP 5.1. */
1057 : : OMP_CLAUSE_COMPARE, /* OpenMP 5.1. */
1058 : : OMP_CLAUSE_FAIL, /* OpenMP 5.1. */
1059 : : OMP_CLAUSE_WEAK, /* OpenMP 5.1. */
1060 : : OMP_CLAUSE_NOWAIT,
1061 : : /* This must come last. */
1062 : : OMP_MASK1_LAST
1063 : : };
1064 : :
1065 : : /* More OpenMP clauses and OpenACC 2.0+ specific clauses. */
1066 : : enum omp_mask2
1067 : : {
1068 : : OMP_CLAUSE_ASYNC,
1069 : : OMP_CLAUSE_NUM_GANGS,
1070 : : OMP_CLAUSE_NUM_WORKERS,
1071 : : OMP_CLAUSE_VECTOR_LENGTH,
1072 : : OMP_CLAUSE_COPY,
1073 : : OMP_CLAUSE_COPYOUT,
1074 : : OMP_CLAUSE_CREATE,
1075 : : OMP_CLAUSE_NO_CREATE,
1076 : : OMP_CLAUSE_PRESENT,
1077 : : OMP_CLAUSE_DEVICEPTR,
1078 : : OMP_CLAUSE_GANG,
1079 : : OMP_CLAUSE_WORKER,
1080 : : OMP_CLAUSE_VECTOR,
1081 : : OMP_CLAUSE_SEQ,
1082 : : OMP_CLAUSE_INDEPENDENT,
1083 : : OMP_CLAUSE_USE_DEVICE,
1084 : : OMP_CLAUSE_DEVICE_RESIDENT,
1085 : : OMP_CLAUSE_SELF,
1086 : : OMP_CLAUSE_HOST,
1087 : : OMP_CLAUSE_WAIT,
1088 : : OMP_CLAUSE_DELETE,
1089 : : OMP_CLAUSE_AUTO,
1090 : : OMP_CLAUSE_TILE,
1091 : : OMP_CLAUSE_IF_PRESENT,
1092 : : OMP_CLAUSE_FINALIZE,
1093 : : OMP_CLAUSE_ATTACH,
1094 : : OMP_CLAUSE_NOHOST,
1095 : : OMP_CLAUSE_HAS_DEVICE_ADDR, /* OpenMP 5.1 */
1096 : : OMP_CLAUSE_ENTER, /* OpenMP 5.2 */
1097 : : OMP_CLAUSE_DOACROSS, /* OpenMP 5.2 */
1098 : : OMP_CLAUSE_ASSUMPTIONS, /* OpenMP 5.1. */
1099 : : OMP_CLAUSE_USES_ALLOCATORS, /* OpenMP 5.0 */
1100 : : OMP_CLAUSE_INDIRECT, /* OpenMP 5.1 */
1101 : : /* This must come last. */
1102 : : OMP_MASK2_LAST
1103 : : };
1104 : :
1105 : : struct omp_inv_mask;
1106 : :
1107 : : /* Customized bitset for up to 128-bits.
1108 : : The two enums above provide bit numbers to use, and which of the
1109 : : two enums it is determines which of the two mask fields is used.
1110 : : Supported operations are defining a mask, like:
1111 : : #define XXX_CLAUSES \
1112 : : (omp_mask (OMP_CLAUSE_XXX) | OMP_CLAUSE_YYY | OMP_CLAUSE_ZZZ)
1113 : : oring such bitsets together or removing selected bits:
1114 : : (XXX_CLAUSES | YYY_CLAUSES) & ~(omp_mask (OMP_CLAUSE_VVV))
1115 : : and testing individual bits:
1116 : : if (mask & OMP_CLAUSE_UUU) */
1117 : :
1118 : : struct omp_mask {
1119 : : const uint64_t mask1;
1120 : : const uint64_t mask2;
1121 : : inline omp_mask ();
1122 : : inline omp_mask (omp_mask1);
1123 : : inline omp_mask (omp_mask2);
1124 : : inline omp_mask (uint64_t, uint64_t);
1125 : : inline omp_mask operator| (omp_mask1) const;
1126 : : inline omp_mask operator| (omp_mask2) const;
1127 : : inline omp_mask operator| (omp_mask) const;
1128 : : inline omp_mask operator& (const omp_inv_mask &) const;
1129 : : inline bool operator& (omp_mask1) const;
1130 : : inline bool operator& (omp_mask2) const;
1131 : : inline omp_inv_mask operator~ () const;
1132 : : };
1133 : :
1134 : : struct omp_inv_mask : public omp_mask {
1135 : : inline omp_inv_mask (const omp_mask &);
1136 : : };
1137 : :
1138 : : omp_mask::omp_mask () : mask1 (0), mask2 (0)
1139 : : {
1140 : : }
1141 : :
1142 : 29536 : omp_mask::omp_mask (omp_mask1 m) : mask1 (((uint64_t) 1) << m), mask2 (0)
1143 : : {
1144 : : }
1145 : :
1146 : 1510 : omp_mask::omp_mask (omp_mask2 m) : mask1 (0), mask2 (((uint64_t) 1) << m)
1147 : : {
1148 : : }
1149 : :
1150 : 29810 : omp_mask::omp_mask (uint64_t m1, uint64_t m2) : mask1 (m1), mask2 (m2)
1151 : : {
1152 : : }
1153 : :
1154 : : omp_mask
1155 : 29290 : omp_mask::operator| (omp_mask1 m) const
1156 : : {
1157 : 29290 : return omp_mask (mask1 | (((uint64_t) 1) << m), mask2);
1158 : : }
1159 : :
1160 : : omp_mask
1161 : 14541 : omp_mask::operator| (omp_mask2 m) const
1162 : : {
1163 : 14541 : return omp_mask (mask1, mask2 | (((uint64_t) 1) << m));
1164 : : }
1165 : :
1166 : : omp_mask
1167 : 3716 : omp_mask::operator| (omp_mask m) const
1168 : : {
1169 : 3716 : return omp_mask (mask1 | m.mask1, mask2 | m.mask2);
1170 : : }
1171 : :
1172 : : omp_mask
1173 : 1655 : omp_mask::operator& (const omp_inv_mask &m) const
1174 : : {
1175 : 1655 : return omp_mask (mask1 & ~m.mask1, mask2 & ~m.mask2);
1176 : : }
1177 : :
1178 : : bool
1179 : 115962 : omp_mask::operator& (omp_mask1 m) const
1180 : : {
1181 : 115962 : return (mask1 & (((uint64_t) 1) << m)) != 0;
1182 : : }
1183 : :
1184 : : bool
1185 : 69975 : omp_mask::operator& (omp_mask2 m) const
1186 : : {
1187 : 69975 : return (mask2 & (((uint64_t) 1) << m)) != 0;
1188 : : }
1189 : :
1190 : : omp_inv_mask
1191 : 1655 : omp_mask::operator~ () const
1192 : : {
1193 : 1655 : return omp_inv_mask (*this);
1194 : : }
1195 : :
1196 : 1655 : omp_inv_mask::omp_inv_mask (const omp_mask &m) : omp_mask (m)
1197 : : {
1198 : : }
1199 : :
1200 : : /* Helper function for OpenACC and OpenMP clauses involving memory
1201 : : mapping. */
1202 : :
1203 : : static bool
1204 : 5449 : gfc_match_omp_map_clause (gfc_omp_namelist **list, gfc_omp_map_op map_op,
1205 : : bool allow_common, bool allow_derived)
1206 : : {
1207 : 5449 : gfc_omp_namelist **head = NULL;
1208 : 5449 : if (gfc_match_omp_variable_list ("", list, allow_common, NULL, &head, true,
1209 : : allow_derived)
1210 : : == MATCH_YES)
1211 : : {
1212 : 5440 : gfc_omp_namelist *n;
1213 : 13074 : for (n = *head; n; n = n->next)
1214 : 7634 : n->u.map.op = map_op;
1215 : : return true;
1216 : : }
1217 : :
1218 : : return false;
1219 : : }
1220 : :
1221 : : static match
1222 : 1087 : gfc_match_iterator (gfc_namespace **ns, bool permit_var)
1223 : : {
1224 : 1087 : locus old_loc = gfc_current_locus;
1225 : :
1226 : 1087 : if (gfc_match ("iterator ( ") != MATCH_YES)
1227 : : return MATCH_NO;
1228 : :
1229 : 77 : gfc_typespec ts;
1230 : 77 : gfc_symbol *last = NULL;
1231 : 77 : gfc_expr *begin, *end, *step;
1232 : 77 : *ns = gfc_build_block_ns (gfc_current_ns);
1233 : 83 : char name[GFC_MAX_SYMBOL_LEN + 1];
1234 : 89 : while (true)
1235 : : {
1236 : 83 : locus prev_loc = gfc_current_locus;
1237 : 83 : if (gfc_match_type_spec (&ts) == MATCH_YES
1238 : 83 : && gfc_match (" :: ") == MATCH_YES)
1239 : : {
1240 : 5 : if (ts.type != BT_INTEGER)
1241 : : {
1242 : 2 : gfc_error ("Expected INTEGER type at %L", &prev_loc);
1243 : 5 : return MATCH_ERROR;
1244 : : }
1245 : : permit_var = false;
1246 : : }
1247 : : else
1248 : : {
1249 : 78 : ts.type = BT_INTEGER;
1250 : 78 : ts.kind = gfc_default_integer_kind;
1251 : 78 : gfc_current_locus = prev_loc;
1252 : : }
1253 : 81 : prev_loc = gfc_current_locus;
1254 : 81 : if (gfc_match_name (name) != MATCH_YES)
1255 : : {
1256 : 4 : gfc_error ("Expected identifier at %C");
1257 : 4 : goto failed;
1258 : : }
1259 : 77 : if (gfc_find_symtree ((*ns)->sym_root, name))
1260 : : {
1261 : 2 : gfc_error ("Same identifier %qs specified again at %C", name);
1262 : 2 : goto failed;
1263 : : }
1264 : :
1265 : 75 : gfc_symbol *sym = gfc_new_symbol (name, *ns);
1266 : 75 : if (last)
1267 : 4 : last->tlink = sym;
1268 : : else
1269 : 71 : (*ns)->omp_affinity_iterators = sym;
1270 : 75 : last = sym;
1271 : 75 : sym->declared_at = prev_loc;
1272 : 75 : sym->ts = ts;
1273 : 75 : sym->attr.flavor = FL_VARIABLE;
1274 : 75 : sym->attr.artificial = 1;
1275 : 75 : sym->attr.referenced = 1;
1276 : 75 : sym->refs++;
1277 : 75 : gfc_symtree *st = gfc_new_symtree (&(*ns)->sym_root, name);
1278 : 75 : st->n.sym = sym;
1279 : :
1280 : 75 : prev_loc = gfc_current_locus;
1281 : 75 : if (gfc_match (" = ") != MATCH_YES)
1282 : 3 : goto failed;
1283 : 72 : permit_var = false;
1284 : 72 : begin = end = step = NULL;
1285 : 72 : if (gfc_match ("%e : ", &begin) != MATCH_YES
1286 : 72 : || gfc_match ("%e ", &end) != MATCH_YES)
1287 : : {
1288 : 3 : gfc_error ("Expected range-specification at %C");
1289 : 3 : gfc_free_expr (begin);
1290 : 3 : gfc_free_expr (end);
1291 : 3 : return MATCH_ERROR;
1292 : : }
1293 : 69 : if (':' == gfc_peek_ascii_char ())
1294 : : {
1295 : 23 : if (gfc_match (": %e ", &step) != MATCH_YES)
1296 : : {
1297 : 5 : gfc_free_expr (begin);
1298 : 5 : gfc_free_expr (end);
1299 : 5 : gfc_free_expr (step);
1300 : 5 : goto failed;
1301 : : }
1302 : : }
1303 : :
1304 : 64 : gfc_expr *e = gfc_get_expr ();
1305 : 64 : e->where = prev_loc;
1306 : 64 : e->expr_type = EXPR_ARRAY;
1307 : 64 : e->ts = ts;
1308 : 64 : e->rank = 1;
1309 : 64 : e->shape = gfc_get_shape (1);
1310 : 110 : mpz_init_set_ui (e->shape[0], step ? 3 : 2);
1311 : 64 : gfc_constructor_append_expr (&e->value.constructor, begin, &begin->where);
1312 : 64 : gfc_constructor_append_expr (&e->value.constructor, end, &end->where);
1313 : 64 : if (step)
1314 : 18 : gfc_constructor_append_expr (&e->value.constructor, step, &step->where);
1315 : 64 : sym->value = e;
1316 : :
1317 : 64 : if (gfc_match (") ") == MATCH_YES)
1318 : : break;
1319 : 6 : if (gfc_match (", ") != MATCH_YES)
1320 : 0 : goto failed;
1321 : 6 : }
1322 : 58 : return MATCH_YES;
1323 : :
1324 : 14 : failed:
1325 : 14 : gfc_namespace *prev_ns = NULL;
1326 : 14 : for (gfc_namespace *it = gfc_current_ns->contained; it; it = it->sibling)
1327 : : {
1328 : 0 : if (it == *ns)
1329 : : {
1330 : 0 : if (prev_ns)
1331 : 0 : prev_ns->sibling = it->sibling;
1332 : : else
1333 : 0 : gfc_current_ns->contained = it->sibling;
1334 : 0 : gfc_free_namespace (it);
1335 : 0 : break;
1336 : : }
1337 : 0 : prev_ns = it;
1338 : : }
1339 : 14 : *ns = NULL;
1340 : 14 : if (!permit_var)
1341 : : return MATCH_ERROR;
1342 : 4 : gfc_current_locus = old_loc;
1343 : 4 : return MATCH_NO;
1344 : : }
1345 : :
1346 : : /* Match target update's to/from( [present:] var-list). */
1347 : :
1348 : : static match
1349 : 1718 : gfc_match_motion_var_list (const char *str, gfc_omp_namelist **list,
1350 : : gfc_omp_namelist ***headp)
1351 : : {
1352 : 1718 : match m = gfc_match (str);
1353 : 1718 : if (m != MATCH_YES)
1354 : : return m;
1355 : :
1356 : 1718 : match m_present = gfc_match (" present : ");
1357 : :
1358 : 1718 : m = gfc_match_omp_variable_list ("", list, false, NULL, headp, true, true);
1359 : 1718 : if (m != MATCH_YES)
1360 : : return m;
1361 : 1718 : if (m_present == MATCH_YES)
1362 : : {
1363 : 5 : gfc_omp_namelist *n;
1364 : 10 : for (n = **headp; n; n = n->next)
1365 : 5 : n->u.present_modifier = true;
1366 : : }
1367 : : return MATCH_YES;
1368 : : }
1369 : :
1370 : : /* reduction ( reduction-modifier, reduction-operator : variable-list )
1371 : : in_reduction ( reduction-operator : variable-list )
1372 : : task_reduction ( reduction-operator : variable-list ) */
1373 : :
1374 : : static match
1375 : 3982 : gfc_match_omp_clause_reduction (char pc, gfc_omp_clauses *c, bool openacc,
1376 : : bool allow_derived, bool openmp_target = false)
1377 : : {
1378 : 3982 : if (pc == 'r' && gfc_match ("reduction ( ") != MATCH_YES)
1379 : : return MATCH_NO;
1380 : 3982 : else if (pc == 'i' && gfc_match ("in_reduction ( ") != MATCH_YES)
1381 : : return MATCH_NO;
1382 : 3881 : else if (pc == 't' && gfc_match ("task_reduction ( ") != MATCH_YES)
1383 : : return MATCH_NO;
1384 : :
1385 : 3881 : locus old_loc = gfc_current_locus;
1386 : 3881 : int list_idx = 0;
1387 : :
1388 : 3881 : if (pc == 'r' && !openacc)
1389 : : {
1390 : 2041 : if (gfc_match ("inscan") == MATCH_YES)
1391 : : list_idx = OMP_LIST_REDUCTION_INSCAN;
1392 : 1975 : else if (gfc_match ("task") == MATCH_YES)
1393 : : list_idx = OMP_LIST_REDUCTION_TASK;
1394 : 1871 : else if (gfc_match ("default") == MATCH_YES)
1395 : : list_idx = OMP_LIST_REDUCTION;
1396 : 226 : if (list_idx != 0 && gfc_match (", ") != MATCH_YES)
1397 : : {
1398 : 1 : gfc_error ("Comma expected at %C");
1399 : 1 : gfc_current_locus = old_loc;
1400 : 1 : return MATCH_NO;
1401 : : }
1402 : 2040 : if (list_idx == 0)
1403 : 3472 : list_idx = OMP_LIST_REDUCTION;
1404 : : }
1405 : 1840 : else if (pc == 'i')
1406 : : list_idx = OMP_LIST_IN_REDUCTION;
1407 : 1722 : else if (pc == 't')
1408 : : list_idx = OMP_LIST_TASK_REDUCTION;
1409 : : else
1410 : 3472 : list_idx = OMP_LIST_REDUCTION;
1411 : :
1412 : 3880 : gfc_omp_reduction_op rop = OMP_REDUCTION_NONE;
1413 : 3880 : char buffer[GFC_MAX_SYMBOL_LEN + 3];
1414 : 3880 : if (gfc_match_char ('+') == MATCH_YES)
1415 : : rop = OMP_REDUCTION_PLUS;
1416 : 2089 : else if (gfc_match_char ('*') == MATCH_YES)
1417 : : rop = OMP_REDUCTION_TIMES;
1418 : 1875 : else if (gfc_match_char ('-') == MATCH_YES)
1419 : : rop = OMP_REDUCTION_MINUS;
1420 : 1758 : else if (gfc_match (".and.") == MATCH_YES)
1421 : : rop = OMP_REDUCTION_AND;
1422 : 1659 : else if (gfc_match (".or.") == MATCH_YES)
1423 : : rop = OMP_REDUCTION_OR;
1424 : 880 : else if (gfc_match (".eqv.") == MATCH_YES)
1425 : : rop = OMP_REDUCTION_EQV;
1426 : 788 : else if (gfc_match (".neqv.") == MATCH_YES)
1427 : : rop = OMP_REDUCTION_NEQV;
1428 : 698 : if (rop != OMP_REDUCTION_NONE)
1429 : 3182 : snprintf (buffer, sizeof buffer, "operator %s",
1430 : : gfc_op2string ((gfc_intrinsic_op) rop));
1431 : 698 : else if (gfc_match_defined_op_name (buffer + 1, 1) == MATCH_YES)
1432 : : {
1433 : 38 : buffer[0] = '.';
1434 : 38 : strcat (buffer, ".");
1435 : : }
1436 : 660 : else if (gfc_match_name (buffer) == MATCH_YES)
1437 : : {
1438 : 659 : gfc_symbol *sym;
1439 : 659 : const char *n = buffer;
1440 : :
1441 : 659 : gfc_find_symbol (buffer, NULL, 1, &sym);
1442 : 659 : if (sym != NULL)
1443 : : {
1444 : 213 : if (sym->attr.intrinsic)
1445 : 139 : n = sym->name;
1446 : 74 : else if ((sym->attr.flavor != FL_UNKNOWN
1447 : 72 : && sym->attr.flavor != FL_PROCEDURE)
1448 : : || sym->attr.external
1449 : 72 : || sym->attr.generic
1450 : 61 : || sym->attr.entry
1451 : : || sym->attr.result
1452 : : || sym->attr.dummy
1453 : : || sym->attr.subroutine
1454 : : || sym->attr.pointer
1455 : 61 : || sym->attr.target
1456 : : || sym->attr.cray_pointer
1457 : 60 : || sym->attr.cray_pointee
1458 : 60 : || (sym->attr.proc != PROC_UNKNOWN
1459 : 1 : && sym->attr.proc != PROC_INTRINSIC)
1460 : 59 : || sym->attr.if_source != IFSRC_UNKNOWN
1461 : 59 : || sym == sym->ns->proc_name)
1462 : : {
1463 : : sym = NULL;
1464 : : n = NULL;
1465 : : }
1466 : : else
1467 : 59 : n = sym->name;
1468 : : }
1469 : 198 : if (n == NULL)
1470 : : rop = OMP_REDUCTION_NONE;
1471 : 644 : else if (strcmp (n, "max") == 0)
1472 : : rop = OMP_REDUCTION_MAX;
1473 : 491 : else if (strcmp (n, "min") == 0)
1474 : : rop = OMP_REDUCTION_MIN;
1475 : 356 : else if (strcmp (n, "iand") == 0)
1476 : : rop = OMP_REDUCTION_IAND;
1477 : 308 : else if (strcmp (n, "ior") == 0)
1478 : : rop = OMP_REDUCTION_IOR;
1479 : 249 : else if (strcmp (n, "ieor") == 0)
1480 : : rop = OMP_REDUCTION_IEOR;
1481 : : if (rop != OMP_REDUCTION_NONE
1482 : 439 : && sym != NULL
1483 : : && ! sym->attr.intrinsic
1484 : 197 : && ! sym->attr.use_assoc
1485 : 58 : && ((sym->attr.flavor == FL_UNKNOWN
1486 : 2 : && !gfc_add_flavor (&sym->attr, FL_PROCEDURE,
1487 : : sym->name, NULL))
1488 : 58 : || !gfc_add_intrinsic (&sym->attr, NULL)))
1489 : : rop = OMP_REDUCTION_NONE;
1490 : : }
1491 : : else
1492 : 1 : buffer[0] = '\0';
1493 : 3880 : gfc_omp_udr *udr = (buffer[0] ? gfc_find_omp_udr (gfc_current_ns, buffer, NULL)
1494 : 3880 : : NULL);
1495 : 3880 : gfc_omp_namelist **head = NULL;
1496 : 3880 : if (rop == OMP_REDUCTION_NONE && udr)
1497 : 250 : rop = OMP_REDUCTION_USER;
1498 : :
1499 : 3880 : if (gfc_match_omp_variable_list (" :", &c->lists[list_idx], false, NULL,
1500 : : &head, openacc, allow_derived) != MATCH_YES)
1501 : : {
1502 : 7 : gfc_current_locus = old_loc;
1503 : 7 : return MATCH_NO;
1504 : : }
1505 : 3873 : gfc_omp_namelist *n;
1506 : 3873 : if (rop == OMP_REDUCTION_NONE)
1507 : : {
1508 : 6 : n = *head;
1509 : 6 : *head = NULL;
1510 : 6 : gfc_error_now ("!$OMP DECLARE REDUCTION %s not found at %L",
1511 : : buffer, &old_loc);
1512 : 6 : gfc_free_omp_namelist (n, false, false, false);
1513 : : }
1514 : : else
1515 : 8357 : for (n = *head; n; n = n->next)
1516 : : {
1517 : 4490 : n->u.reduction_op = rop;
1518 : 4490 : if (udr)
1519 : : {
1520 : 473 : n->u2.udr = gfc_get_omp_namelist_udr ();
1521 : 473 : n->u2.udr->udr = udr;
1522 : : }
1523 : 4490 : if (openmp_target && list_idx == OMP_LIST_IN_REDUCTION)
1524 : : {
1525 : 40 : gfc_omp_namelist *p = gfc_get_omp_namelist (), **tl;
1526 : 40 : p->sym = n->sym;
1527 : 40 : p->where = p->where;
1528 : 40 : p->u.map.op = OMP_MAP_ALWAYS_TOFROM;
1529 : :
1530 : 40 : tl = &c->lists[OMP_LIST_MAP];
1531 : 52 : while (*tl)
1532 : 12 : tl = &((*tl)->next);
1533 : 40 : *tl = p;
1534 : 40 : p->next = NULL;
1535 : : }
1536 : : }
1537 : : return MATCH_YES;
1538 : : }
1539 : :
1540 : : static match
1541 : 37 : gfc_omp_absent_contains_clause (gfc_omp_assumptions **assume, bool is_absent)
1542 : : {
1543 : 37 : if (*assume == NULL)
1544 : 12 : *assume = gfc_get_omp_assumptions ();
1545 : 59 : do
1546 : : {
1547 : 48 : gfc_statement st = ST_NONE;
1548 : 48 : gfc_gobble_whitespace ();
1549 : 48 : locus old_loc = gfc_current_locus;
1550 : 48 : char c = gfc_peek_ascii_char ();
1551 : 48 : enum gfc_omp_directive_kind kind
1552 : : = GFC_OMP_DIR_DECLARATIVE; /* Silence warning. */
1553 : 1329 : for (size_t i = 0; i < ARRAY_SIZE (gfc_omp_directives); i++)
1554 : : {
1555 : 1329 : if (gfc_omp_directives[i].name[0] > c)
1556 : : break;
1557 : 1281 : if (gfc_omp_directives[i].name[0] != c)
1558 : 963 : continue;
1559 : 318 : if (gfc_match (gfc_omp_directives[i].name) == MATCH_YES)
1560 : : {
1561 : 48 : st = gfc_omp_directives[i].st;
1562 : 48 : kind = gfc_omp_directives[i].kind;
1563 : : }
1564 : : }
1565 : 48 : gfc_gobble_whitespace ();
1566 : 48 : c = gfc_peek_ascii_char ();
1567 : 48 : if (st == ST_NONE || (c != ',' && c != ')'))
1568 : : {
1569 : 0 : if (st == ST_NONE)
1570 : 0 : gfc_error ("Unknown directive at %L", &old_loc);
1571 : : else
1572 : 0 : gfc_error ("Invalid combined or composite directive at %L",
1573 : : &old_loc);
1574 : 3 : return MATCH_ERROR;
1575 : : }
1576 : 48 : if (kind == GFC_OMP_DIR_DECLARATIVE
1577 : 48 : || kind == GFC_OMP_DIR_INFORMATIONAL
1578 : : || kind == GFC_OMP_DIR_META)
1579 : : {
1580 : 3 : gfc_error ("Invalid %qs directive at %L in %s clause: declarative, "
1581 : : "informational and meta directives not permitted",
1582 : : gfc_ascii_statement (st, true), &old_loc,
1583 : : is_absent ? "ABSENT" : "CONTAINS");
1584 : 3 : return MATCH_ERROR;
1585 : : }
1586 : 45 : if (is_absent)
1587 : : {
1588 : : /* Use exponential allocation; equivalent to pow2p(x). */
1589 : 33 : int i = (*assume)->n_absent;
1590 : 33 : int size = ((i == 0) ? 4
1591 : 10 : : pow2p_hwi (i) == 1 ? i*2 : 0);
1592 : 8 : if (size != 0)
1593 : 31 : (*assume)->absent = XRESIZEVEC (gfc_statement,
1594 : : (*assume)->absent, size);
1595 : 33 : (*assume)->absent[(*assume)->n_absent++] = st;
1596 : : }
1597 : : else
1598 : : {
1599 : 12 : int i = (*assume)->n_contains;
1600 : 12 : int size = ((i == 0) ? 4
1601 : 4 : : pow2p_hwi (i) == 1 ? i*2 : 0);
1602 : 4 : if (size != 0)
1603 : 12 : (*assume)->contains = XRESIZEVEC (gfc_statement,
1604 : : (*assume)->contains, size);
1605 : 12 : (*assume)->contains[(*assume)->n_contains++] = st;
1606 : : }
1607 : 45 : gfc_gobble_whitespace ();
1608 : 45 : if (gfc_match(",") == MATCH_YES)
1609 : 11 : continue;
1610 : 34 : if (gfc_match(")") == MATCH_YES)
1611 : : break;
1612 : 0 : gfc_error ("Expected %<,%> or %<)%> at %C");
1613 : 0 : return MATCH_ERROR;
1614 : : }
1615 : : while (true);
1616 : :
1617 : 34 : return MATCH_YES;
1618 : : }
1619 : :
1620 : : /* Check 'check' argument for duplicated statements in absent and/or contains
1621 : : clauses. If 'merge', merge them from check to 'merge'. */
1622 : :
1623 : : static match
1624 : 40 : omp_verify_merge_absent_contains (gfc_statement st, gfc_omp_assumptions *check,
1625 : : gfc_omp_assumptions *merge, locus *loc)
1626 : : {
1627 : 40 : if (check == NULL)
1628 : : return MATCH_YES;
1629 : 40 : bitmap_head absent_head, contains_head;
1630 : 40 : bitmap_obstack_initialize (NULL);
1631 : 40 : bitmap_initialize (&absent_head, &bitmap_default_obstack);
1632 : 40 : bitmap_initialize (&contains_head, &bitmap_default_obstack);
1633 : :
1634 : 40 : match m = MATCH_YES;
1635 : 73 : for (int i = 0; i < check->n_absent; i++)
1636 : 33 : if (!bitmap_set_bit (&absent_head, check->absent[i]))
1637 : : {
1638 : 2 : gfc_error ("%qs directive mentioned multiple times in %s clause in %s "
1639 : : "directive at %L",
1640 : 2 : gfc_ascii_statement (check->absent[i], true),
1641 : : "ABSENT", gfc_ascii_statement (st), loc);
1642 : 2 : m = MATCH_ERROR;
1643 : : }
1644 : 52 : for (int i = 0; i < check->n_contains; i++)
1645 : : {
1646 : 12 : if (!bitmap_set_bit (&contains_head, check->contains[i]))
1647 : : {
1648 : 2 : gfc_error ("%qs directive mentioned multiple times in %s clause in %s "
1649 : : "directive at %L",
1650 : 2 : gfc_ascii_statement (check->contains[i], true),
1651 : : "CONTAINS", gfc_ascii_statement (st), loc);
1652 : 2 : m = MATCH_ERROR;
1653 : : }
1654 : 12 : if (bitmap_bit_p (&absent_head, check->contains[i]))
1655 : : {
1656 : 2 : gfc_error ("%qs directive mentioned both times in ABSENT and CONTAINS "
1657 : : "clauses in %s directive at %L",
1658 : 2 : gfc_ascii_statement (check->absent[i], true),
1659 : : gfc_ascii_statement (st), loc);
1660 : 2 : m = MATCH_ERROR;
1661 : : }
1662 : : }
1663 : :
1664 : 40 : if (m == MATCH_ERROR)
1665 : : return MATCH_ERROR;
1666 : 34 : if (merge == NULL)
1667 : : return MATCH_YES;
1668 : 2 : if (merge->absent == NULL && check->absent)
1669 : : {
1670 : 1 : merge->n_absent = check->n_absent;
1671 : 1 : merge->absent = check->absent;
1672 : 1 : check->absent = NULL;
1673 : : }
1674 : 1 : else if (merge->absent && check->absent)
1675 : : {
1676 : 0 : check->absent = XRESIZEVEC (gfc_statement, check->absent,
1677 : : merge->n_absent + check->n_absent);
1678 : 0 : for (int i = 0; i < merge->n_absent; i++)
1679 : 0 : if (!bitmap_bit_p (&absent_head, merge->absent[i]))
1680 : 0 : check->absent[check->n_absent++] = merge->absent[i];
1681 : 0 : free (merge->absent);
1682 : 0 : merge->absent = check->absent;
1683 : 0 : merge->n_absent = check->n_absent;
1684 : 0 : check->absent = NULL;
1685 : : }
1686 : 2 : if (merge->contains == NULL && check->contains)
1687 : : {
1688 : 0 : merge->n_contains = check->n_contains;
1689 : 0 : merge->contains = check->contains;
1690 : 0 : check->contains = NULL;
1691 : : }
1692 : 2 : else if (merge->contains && check->contains)
1693 : : {
1694 : 0 : check->contains = XRESIZEVEC (gfc_statement, check->contains,
1695 : : merge->n_contains + check->n_contains);
1696 : 0 : for (int i = 0; i < merge->n_contains; i++)
1697 : 0 : if (!bitmap_bit_p (&contains_head, merge->contains[i]))
1698 : 0 : check->contains[check->n_contains++] = merge->contains[i];
1699 : 0 : free (merge->contains);
1700 : 0 : merge->contains = check->contains;
1701 : 0 : merge->n_contains = check->n_contains;
1702 : 0 : check->contains = NULL;
1703 : : }
1704 : : return MATCH_YES;
1705 : : }
1706 : :
1707 : : /* OpenMP 5.0
1708 : : uses_allocators ( allocator-list )
1709 : :
1710 : : allocator:
1711 : : predefined-allocator
1712 : : variable ( traits-array )
1713 : :
1714 : : OpenMP 5.2:
1715 : : uses_allocators ( [modifier-list :] allocator-list )
1716 : :
1717 : : allocator:
1718 : : variable or predefined-allocator
1719 : : modifier:
1720 : : traits ( traits-array )
1721 : : memspace ( mem-space-handle ) */
1722 : :
1723 : : static match
1724 : 47 : gfc_match_omp_clause_uses_allocators (gfc_omp_clauses *c)
1725 : : {
1726 : 47 : gfc_symbol *memspace_sym = NULL;
1727 : 47 : gfc_symbol *traits_sym = NULL;
1728 : 47 : gfc_omp_namelist *head = NULL;
1729 : 47 : gfc_omp_namelist *p, *tail, **list;
1730 : 47 : int ntraits, nmemspace;
1731 : 47 : bool has_modifiers;
1732 : 47 : locus old_loc, cur_loc;
1733 : :
1734 : 47 : gfc_gobble_whitespace ();
1735 : 47 : old_loc = gfc_current_locus;
1736 : 47 : ntraits = nmemspace = 0;
1737 : 77 : do
1738 : : {
1739 : 62 : cur_loc = gfc_current_locus;
1740 : 62 : if (gfc_match ("traits ( %S ) ", &traits_sym) == MATCH_YES)
1741 : 21 : ntraits++;
1742 : 41 : else if (gfc_match ("memspace ( %S ) ", &memspace_sym) == MATCH_YES)
1743 : 21 : nmemspace++;
1744 : 62 : if (ntraits > 1 || nmemspace > 1)
1745 : : {
1746 : 2 : gfc_error ("Duplicate %s modifier at %L in USES_ALLOCATORS clause",
1747 : : ntraits > 1 ? "TRAITS" : "MEMSPACE", &cur_loc);
1748 : 2 : return MATCH_ERROR;
1749 : : }
1750 : 60 : if (gfc_match (", ") == MATCH_YES)
1751 : 15 : continue;
1752 : 45 : if (gfc_match (": ") != MATCH_YES)
1753 : : {
1754 : : /* Assume no modifier. */
1755 : 22 : memspace_sym = traits_sym = NULL;
1756 : 22 : gfc_current_locus = old_loc;
1757 : 22 : break;
1758 : : }
1759 : : break;
1760 : : } while (true);
1761 : :
1762 : 68 : has_modifiers = traits_sym != NULL || memspace_sym != NULL;
1763 : 127 : do
1764 : : {
1765 : 86 : p = gfc_get_omp_namelist ();
1766 : 86 : p->where = gfc_current_locus;
1767 : 86 : if (head == NULL)
1768 : : head = tail = p;
1769 : : else
1770 : : {
1771 : 41 : tail->next = p;
1772 : 41 : tail = tail->next;
1773 : : }
1774 : 86 : if (gfc_match ("%S ", &p->sym) != MATCH_YES)
1775 : 0 : goto error;
1776 : 86 : if (!has_modifiers)
1777 : 58 : gfc_match ("( %S ) ", &p->u2.traits_sym);
1778 : 28 : else if (gfc_peek_ascii_char () == '(')
1779 : : {
1780 : 0 : gfc_error ("Unexpected %<(%> at %C");
1781 : 0 : goto error;
1782 : : }
1783 : : else
1784 : : {
1785 : 28 : p->u.memspace_sym = memspace_sym;
1786 : 28 : p->u2.traits_sym = traits_sym;
1787 : : }
1788 : 86 : if (gfc_match (", ") == MATCH_YES)
1789 : 41 : continue;
1790 : 45 : if (gfc_match (") ") == MATCH_YES)
1791 : : break;
1792 : 2 : goto error;
1793 : : } while (true);
1794 : :
1795 : 43 : list = &c->lists[OMP_LIST_USES_ALLOCATORS];
1796 : 48 : while (*list)
1797 : 5 : list = &(*list)->next;
1798 : 43 : *list = head;
1799 : :
1800 : 43 : return MATCH_YES;
1801 : :
1802 : 2 : error:
1803 : 2 : gfc_free_omp_namelist (head, false, false, true);
1804 : 2 : return MATCH_ERROR;
1805 : : }
1806 : :
1807 : :
1808 : : /* Match with duplicate check. Matches 'name'. If expr != NULL, it
1809 : : then matches '(expr)', otherwise, if open_parens is true,
1810 : : it matches a ' ( ' after 'name'.
1811 : : dupl_message requires '%qs %L' - and is used by
1812 : : gfc_match_dupl_memorder and gfc_match_dupl_atomic. */
1813 : :
1814 : : static match
1815 : 20575 : gfc_match_dupl_check (bool not_dupl, const char *name, bool open_parens = false,
1816 : : gfc_expr **expr = NULL, const char *dupl_msg = NULL)
1817 : : {
1818 : 20575 : match m;
1819 : 20575 : locus old_loc = gfc_current_locus;
1820 : 20575 : if ((m = gfc_match (name)) != MATCH_YES)
1821 : : return m;
1822 : 15904 : if (!not_dupl)
1823 : : {
1824 : 37 : if (dupl_msg)
1825 : 2 : gfc_error (dupl_msg, name, &old_loc);
1826 : : else
1827 : 35 : gfc_error ("Duplicated %qs clause at %L", name, &old_loc);
1828 : 37 : return MATCH_ERROR;
1829 : : }
1830 : 15867 : if (open_parens || expr)
1831 : : {
1832 : 8608 : if (gfc_match (" ( ") != MATCH_YES)
1833 : : {
1834 : 22 : gfc_error ("Expected %<(%> after %qs at %C", name);
1835 : 22 : return MATCH_ERROR;
1836 : : }
1837 : 8586 : if (expr)
1838 : : {
1839 : 4165 : if (gfc_match ("%e )", expr) != MATCH_YES)
1840 : : {
1841 : 7 : gfc_error ("Invalid expression after %<%s(%> at %C", name);
1842 : 7 : return MATCH_ERROR;
1843 : : }
1844 : : }
1845 : : }
1846 : : return MATCH_YES;
1847 : : }
1848 : :
1849 : : static match
1850 : 211 : gfc_match_dupl_memorder (bool not_dupl, const char *name)
1851 : : {
1852 : 0 : return gfc_match_dupl_check (not_dupl, name, false, NULL,
1853 : : "Duplicated memory-order clause: unexpected %s "
1854 : 0 : "clause at %L");
1855 : : }
1856 : :
1857 : : static match
1858 : 1172 : gfc_match_dupl_atomic (bool not_dupl, const char *name)
1859 : : {
1860 : 0 : return gfc_match_dupl_check (not_dupl, name, false, NULL,
1861 : : "Duplicated atomic clause: unexpected %s "
1862 : 0 : "clause at %L");
1863 : : }
1864 : :
1865 : : /* Match OpenMP and OpenACC directive clauses. MASK is a bitmask of
1866 : : clauses that are allowed for a particular directive. */
1867 : :
1868 : : static match
1869 : 31046 : gfc_match_omp_clauses (gfc_omp_clauses **cp, const omp_mask mask,
1870 : : bool first = true, bool needs_space = true,
1871 : : bool openacc = false, bool context_selector = false,
1872 : : bool openmp_target = false)
1873 : : {
1874 : 31046 : bool error = false;
1875 : 31046 : gfc_omp_clauses *c = gfc_get_omp_clauses ();
1876 : 31046 : locus old_loc;
1877 : : /* Determine whether we're dealing with an OpenACC directive that permits
1878 : : derived type member accesses. This in particular disallows
1879 : : "!$acc declare" from using such accesses, because it's not clear if/how
1880 : : that should work. */
1881 : 31046 : bool allow_derived = (openacc
1882 : 31046 : && ((mask & OMP_CLAUSE_ATTACH)
1883 : 5564 : || (mask & OMP_CLAUSE_DETACH)));
1884 : :
1885 : 31046 : gcc_checking_assert (OMP_MASK1_LAST <= 64 && OMP_MASK2_LAST <= 64);
1886 : 31046 : *cp = NULL;
1887 : 115736 : while (1)
1888 : : {
1889 : 73391 : match m = MATCH_NO;
1890 : 55145 : if ((first || (m = gfc_match_char (',')) != MATCH_YES)
1891 : 128220 : && (needs_space && gfc_match_space () != MATCH_YES))
1892 : : break;
1893 : 65860 : needs_space = false;
1894 : 65860 : first = false;
1895 : 65860 : gfc_gobble_whitespace ();
1896 : 65860 : bool end_colon;
1897 : 65860 : gfc_omp_namelist **head;
1898 : 65860 : old_loc = gfc_current_locus;
1899 : 65860 : char pc = gfc_peek_ascii_char ();
1900 : 65860 : if (pc == '\n' && m == MATCH_YES)
1901 : : {
1902 : 1 : gfc_error ("Clause expected at %C after trailing comma");
1903 : 1 : goto error;
1904 : : }
1905 : 65859 : switch (pc)
1906 : : {
1907 : 1201 : case 'a':
1908 : 1201 : end_colon = false;
1909 : 1201 : head = NULL;
1910 : 1225 : if ((mask & OMP_CLAUSE_ASSUMPTIONS)
1911 : 1201 : && gfc_match ("absent ( ") == MATCH_YES)
1912 : : {
1913 : 27 : if (gfc_omp_absent_contains_clause (&c->assume, true)
1914 : : != MATCH_YES)
1915 : 3 : goto error;
1916 : 24 : continue;
1917 : : }
1918 : 1174 : if ((mask & OMP_CLAUSE_ALIGNED)
1919 : 1174 : && gfc_match_omp_variable_list ("aligned (",
1920 : : &c->lists[OMP_LIST_ALIGNED],
1921 : : false, &end_colon,
1922 : : &head) == MATCH_YES)
1923 : : {
1924 : 112 : gfc_expr *alignment = NULL;
1925 : 112 : gfc_omp_namelist *n;
1926 : :
1927 : 112 : if (end_colon && gfc_match (" %e )", &alignment) != MATCH_YES)
1928 : : {
1929 : 0 : gfc_free_omp_namelist (*head, false, false, false);
1930 : 0 : gfc_current_locus = old_loc;
1931 : 0 : *head = NULL;
1932 : 0 : break;
1933 : : }
1934 : 268 : for (n = *head; n; n = n->next)
1935 : 156 : if (n->next && alignment)
1936 : 42 : n->expr = gfc_copy_expr (alignment);
1937 : : else
1938 : 114 : n->expr = alignment;
1939 : 112 : continue;
1940 : 112 : }
1941 : 1072 : if ((mask & OMP_CLAUSE_MEMORDER)
1942 : 1079 : && (m = gfc_match_dupl_memorder ((c->memorder
1943 : 17 : == OMP_MEMORDER_UNSET),
1944 : : "acq_rel")) != MATCH_NO)
1945 : : {
1946 : 10 : if (m == MATCH_ERROR)
1947 : 0 : goto error;
1948 : 10 : c->memorder = OMP_MEMORDER_ACQ_REL;
1949 : 10 : needs_space = true;
1950 : 10 : continue;
1951 : : }
1952 : 1059 : if ((mask & OMP_CLAUSE_MEMORDER)
1953 : 1059 : && (m = gfc_match_dupl_memorder ((c->memorder
1954 : 7 : == OMP_MEMORDER_UNSET),
1955 : : "acquire")) != MATCH_NO)
1956 : : {
1957 : 7 : if (m == MATCH_ERROR)
1958 : 0 : goto error;
1959 : 7 : c->memorder = OMP_MEMORDER_ACQUIRE;
1960 : 7 : needs_space = true;
1961 : 7 : continue;
1962 : : }
1963 : 1045 : if ((mask & OMP_CLAUSE_AFFINITY)
1964 : 1045 : && gfc_match ("affinity ( ") == MATCH_YES)
1965 : : {
1966 : 41 : gfc_namespace *ns_iter = NULL, *ns_curr = gfc_current_ns;
1967 : 41 : m = gfc_match_iterator (&ns_iter, true);
1968 : 41 : if (m == MATCH_ERROR)
1969 : : break;
1970 : 31 : if (m == MATCH_YES && gfc_match (" : ") != MATCH_YES)
1971 : : {
1972 : 1 : gfc_error ("Expected %<:%> at %C");
1973 : 1 : break;
1974 : : }
1975 : 30 : if (ns_iter)
1976 : 18 : gfc_current_ns = ns_iter;
1977 : 30 : head = NULL;
1978 : 30 : m = gfc_match_omp_variable_list ("", &c->lists[OMP_LIST_AFFINITY],
1979 : : false, NULL, &head, true);
1980 : 30 : gfc_current_ns = ns_curr;
1981 : 30 : if (m == MATCH_ERROR)
1982 : : break;
1983 : 27 : if (ns_iter)
1984 : : {
1985 : 45 : for (gfc_omp_namelist *n = *head; n; n = n->next)
1986 : : {
1987 : 27 : n->u2.ns = ns_iter;
1988 : 27 : ns_iter->refs++;
1989 : : }
1990 : : }
1991 : 27 : continue;
1992 : 27 : }
1993 : 1004 : if ((mask & OMP_CLAUSE_ALLOCATE)
1994 : 1004 : && gfc_match ("allocate ( ") == MATCH_YES)
1995 : : {
1996 : 230 : gfc_expr *allocator = NULL;
1997 : 230 : gfc_expr *align = NULL;
1998 : 230 : old_loc = gfc_current_locus;
1999 : 230 : if ((m = gfc_match ("allocator ( %e )", &allocator)) == MATCH_YES)
2000 : 6 : gfc_match (" , align ( %e )", &align);
2001 : 224 : else if ((m = gfc_match ("align ( %e )", &align)) == MATCH_YES)
2002 : 29 : gfc_match (" , allocator ( %e )", &allocator);
2003 : :
2004 : 230 : if (m == MATCH_YES)
2005 : : {
2006 : 35 : if (gfc_match (" : ") != MATCH_YES)
2007 : : {
2008 : 5 : gfc_error ("Expected %<:%> at %C");
2009 : 8 : goto error;
2010 : : }
2011 : : }
2012 : : else
2013 : : {
2014 : 195 : m = gfc_match_expr (&allocator);
2015 : 195 : if (m == MATCH_YES && gfc_match (" : ") != MATCH_YES)
2016 : : {
2017 : : /* If no ":" then there is no allocator, we backtrack
2018 : : and read the variable list. */
2019 : 101 : gfc_free_expr (allocator);
2020 : 101 : allocator = NULL;
2021 : 101 : gfc_current_locus = old_loc;
2022 : : }
2023 : : }
2024 : 225 : gfc_omp_namelist **head = NULL;
2025 : 225 : m = gfc_match_omp_variable_list ("", &c->lists[OMP_LIST_ALLOCATE],
2026 : : true, NULL, &head);
2027 : :
2028 : 225 : if (m != MATCH_YES)
2029 : : {
2030 : 3 : gfc_free_expr (allocator);
2031 : 3 : gfc_free_expr (align);
2032 : 3 : gfc_error ("Expected variable list at %C");
2033 : 3 : goto error;
2034 : : }
2035 : :
2036 : 620 : for (gfc_omp_namelist *n = *head; n; n = n->next)
2037 : : {
2038 : 398 : n->u2.allocator = allocator;
2039 : 398 : n->u.align = (align) ? gfc_copy_expr (align) : NULL;
2040 : : }
2041 : 222 : gfc_free_expr (align);
2042 : 222 : continue;
2043 : 222 : }
2044 : 821 : if ((mask & OMP_CLAUSE_AT)
2045 : 774 : && (m = gfc_match_dupl_check (c->at == OMP_AT_UNSET, "at", true))
2046 : : != MATCH_NO)
2047 : : {
2048 : 53 : if (m == MATCH_ERROR)
2049 : 2 : goto error;
2050 : 51 : if (gfc_match ("compilation )") == MATCH_YES)
2051 : 14 : c->at = OMP_AT_COMPILATION;
2052 : 37 : else if (gfc_match ("execution )") == MATCH_YES)
2053 : 33 : c->at = OMP_AT_EXECUTION;
2054 : : else
2055 : : {
2056 : 4 : gfc_error ("Expected COMPILATION or EXECUTION in AT clause "
2057 : : "at %C");
2058 : 4 : goto error;
2059 : : }
2060 : 47 : continue;
2061 : : }
2062 : 1334 : if ((mask & OMP_CLAUSE_ASYNC)
2063 : 721 : && (m = gfc_match_dupl_check (!c->async, "async")) != MATCH_NO)
2064 : : {
2065 : 613 : if (m == MATCH_ERROR)
2066 : 0 : goto error;
2067 : 613 : c->async = true;
2068 : 613 : m = gfc_match (" ( %e )", &c->async_expr);
2069 : 613 : if (m == MATCH_ERROR)
2070 : : {
2071 : 0 : gfc_current_locus = old_loc;
2072 : 0 : break;
2073 : : }
2074 : 613 : else if (m == MATCH_NO)
2075 : : {
2076 : 126 : c->async_expr
2077 : 126 : = gfc_get_constant_expr (BT_INTEGER,
2078 : : gfc_default_integer_kind,
2079 : : &gfc_current_locus);
2080 : 126 : mpz_set_si (c->async_expr->value.integer, GOMP_ASYNC_NOVAL);
2081 : 126 : needs_space = true;
2082 : : }
2083 : 613 : continue;
2084 : : }
2085 : 155 : if ((mask & OMP_CLAUSE_AUTO)
2086 : 108 : && (m = gfc_match_dupl_check (!c->par_auto, "auto"))
2087 : : != MATCH_NO)
2088 : : {
2089 : 47 : if (m == MATCH_ERROR)
2090 : 0 : goto error;
2091 : 47 : c->par_auto = true;
2092 : 47 : needs_space = true;
2093 : 47 : continue;
2094 : : }
2095 : 120 : if ((mask & OMP_CLAUSE_ATTACH)
2096 : 59 : && gfc_match ("attach ( ") == MATCH_YES
2097 : 120 : && gfc_match_omp_map_clause (&c->lists[OMP_LIST_MAP],
2098 : : OMP_MAP_ATTACH, false,
2099 : : allow_derived))
2100 : 59 : continue;
2101 : : break;
2102 : 36 : case 'b':
2103 : 70 : if ((mask & OMP_CLAUSE_BIND)
2104 : 36 : && (m = gfc_match_dupl_check (c->bind == OMP_BIND_UNSET, "bind",
2105 : : true)) != MATCH_NO)
2106 : : {
2107 : 36 : if (m == MATCH_ERROR)
2108 : 1 : goto error;
2109 : 35 : if (gfc_match ("teams )") == MATCH_YES)
2110 : 11 : c->bind = OMP_BIND_TEAMS;
2111 : 24 : else if (gfc_match ("parallel )") == MATCH_YES)
2112 : 15 : c->bind = OMP_BIND_PARALLEL;
2113 : 9 : else if (gfc_match ("thread )") == MATCH_YES)
2114 : 8 : c->bind = OMP_BIND_THREAD;
2115 : : else
2116 : : {
2117 : 1 : gfc_error ("Expected TEAMS, PARALLEL or THREAD as binding in "
2118 : : "BIND at %C");
2119 : 1 : break;
2120 : : }
2121 : 34 : continue;
2122 : : }
2123 : : break;
2124 : 6951 : case 'c':
2125 : 7240 : if ((mask & OMP_CLAUSE_CAPTURE)
2126 : 6951 : && (m = gfc_match_dupl_check (!c->capture, "capture"))
2127 : : != MATCH_NO)
2128 : : {
2129 : 290 : if (m == MATCH_ERROR)
2130 : 1 : goto error;
2131 : 289 : c->capture = true;
2132 : 289 : needs_space = true;
2133 : 289 : continue;
2134 : : }
2135 : 6661 : if (mask & OMP_CLAUSE_COLLAPSE)
2136 : : {
2137 : 1886 : gfc_expr *cexpr = NULL;
2138 : 1886 : if ((m = gfc_match_dupl_check (!c->collapse, "collapse", true,
2139 : : &cexpr)) != MATCH_NO)
2140 : : {
2141 : 1405 : int collapse;
2142 : 1405 : if (m == MATCH_ERROR)
2143 : 0 : goto error;
2144 : 1405 : if (gfc_extract_int (cexpr, &collapse, -1))
2145 : 4 : collapse = 1;
2146 : 1401 : else if (collapse <= 0)
2147 : : {
2148 : 8 : gfc_error_now ("COLLAPSE clause argument not constant "
2149 : : "positive integer at %C");
2150 : 8 : collapse = 1;
2151 : : }
2152 : 1405 : gfc_free_expr (cexpr);
2153 : 1405 : c->collapse = collapse;
2154 : 1405 : continue;
2155 : 1405 : }
2156 : : }
2157 : 5422 : if ((mask & OMP_CLAUSE_COMPARE)
2158 : 5256 : && (m = gfc_match_dupl_check (!c->compare, "compare"))
2159 : : != MATCH_NO)
2160 : : {
2161 : 167 : if (m == MATCH_ERROR)
2162 : 1 : goto error;
2163 : 166 : c->compare = true;
2164 : 166 : needs_space = true;
2165 : 166 : continue;
2166 : : }
2167 : 5099 : if ((mask & OMP_CLAUSE_ASSUMPTIONS)
2168 : 5089 : && gfc_match ("contains ( ") == MATCH_YES)
2169 : : {
2170 : 10 : if (gfc_omp_absent_contains_clause (&c->assume, false)
2171 : : != MATCH_YES)
2172 : 0 : goto error;
2173 : 10 : continue;
2174 : : }
2175 : 7167 : if ((mask & OMP_CLAUSE_COPY)
2176 : 3678 : && gfc_match ("copy ( ") == MATCH_YES
2177 : 7168 : && gfc_match_omp_map_clause (&c->lists[OMP_LIST_MAP],
2178 : : OMP_MAP_TOFROM, true,
2179 : : allow_derived))
2180 : 2088 : continue;
2181 : 2991 : if (mask & OMP_CLAUSE_COPYIN)
2182 : : {
2183 : 2593 : if (openacc)
2184 : : {
2185 : 2494 : if (gfc_match ("copyin ( ") == MATCH_YES)
2186 : : {
2187 : 1433 : bool readonly = gfc_match ("readonly : ") == MATCH_YES;
2188 : 1433 : head = NULL;
2189 : 1433 : if (gfc_match_omp_variable_list ("",
2190 : : &c->lists[OMP_LIST_MAP],
2191 : : true, NULL, &head, true,
2192 : : allow_derived)
2193 : : == MATCH_YES)
2194 : : {
2195 : 1427 : gfc_omp_namelist *n;
2196 : 3263 : for (n = *head; n; n = n->next)
2197 : : {
2198 : 1836 : n->u.map.op = OMP_MAP_TO;
2199 : 1836 : n->u.map.readonly = readonly;
2200 : : }
2201 : 1427 : continue;
2202 : 1427 : }
2203 : : }
2204 : : }
2205 : 99 : else if (gfc_match_omp_variable_list ("copyin (",
2206 : : &c->lists[OMP_LIST_COPYIN],
2207 : : true) == MATCH_YES)
2208 : 97 : continue;
2209 : : }
2210 : 2523 : if ((mask & OMP_CLAUSE_COPYOUT)
2211 : 1198 : && gfc_match ("copyout ( ") == MATCH_YES
2212 : 2523 : && gfc_match_omp_map_clause (&c->lists[OMP_LIST_MAP],
2213 : : OMP_MAP_FROM, true, allow_derived))
2214 : 1056 : continue;
2215 : 495 : if ((mask & OMP_CLAUSE_COPYPRIVATE)
2216 : 411 : && gfc_match_omp_variable_list ("copyprivate (",
2217 : : &c->lists[OMP_LIST_COPYPRIVATE],
2218 : : true) == MATCH_YES)
2219 : 84 : continue;
2220 : 645 : if ((mask & OMP_CLAUSE_CREATE)
2221 : 325 : && gfc_match ("create ( ") == MATCH_YES
2222 : 645 : && gfc_match_omp_map_clause (&c->lists[OMP_LIST_MAP],
2223 : : OMP_MAP_ALLOC, true, allow_derived))
2224 : 318 : continue;
2225 : : break;
2226 : 3442 : case 'd':
2227 : 3442 : if ((mask & OMP_CLAUSE_DEFAULTMAP)
2228 : 3442 : && gfc_match ("defaultmap ( ") == MATCH_YES)
2229 : : {
2230 : 172 : enum gfc_omp_defaultmap behavior;
2231 : 172 : gfc_omp_defaultmap_category category
2232 : : = OMP_DEFAULTMAP_CAT_UNCATEGORIZED;
2233 : 172 : if (gfc_match ("alloc ") == MATCH_YES)
2234 : : behavior = OMP_DEFAULTMAP_ALLOC;
2235 : 166 : else if (gfc_match ("tofrom ") == MATCH_YES)
2236 : : behavior = OMP_DEFAULTMAP_TOFROM;
2237 : 134 : else if (gfc_match ("to ") == MATCH_YES)
2238 : : behavior = OMP_DEFAULTMAP_TO;
2239 : 129 : else if (gfc_match ("from ") == MATCH_YES)
2240 : : behavior = OMP_DEFAULTMAP_FROM;
2241 : 126 : else if (gfc_match ("firstprivate ") == MATCH_YES)
2242 : : behavior = OMP_DEFAULTMAP_FIRSTPRIVATE;
2243 : 91 : else if (gfc_match ("present ") == MATCH_YES)
2244 : : behavior = OMP_DEFAULTMAP_PRESENT;
2245 : 87 : else if (gfc_match ("none ") == MATCH_YES)
2246 : : behavior = OMP_DEFAULTMAP_NONE;
2247 : 10 : else if (gfc_match ("default ") == MATCH_YES)
2248 : : behavior = OMP_DEFAULTMAP_DEFAULT;
2249 : : else
2250 : : {
2251 : 1 : gfc_error ("Expected ALLOC, TO, FROM, TOFROM, FIRSTPRIVATE, "
2252 : : "PRESENT, NONE or DEFAULT at %C");
2253 : 1 : break;
2254 : : }
2255 : 171 : if (')' == gfc_peek_ascii_char ())
2256 : : ;
2257 : 97 : else if (gfc_match (": ") != MATCH_YES)
2258 : : break;
2259 : : else
2260 : : {
2261 : 97 : if (gfc_match ("scalar ") == MATCH_YES)
2262 : : category = OMP_DEFAULTMAP_CAT_SCALAR;
2263 : 62 : else if (gfc_match ("aggregate ") == MATCH_YES)
2264 : : category = OMP_DEFAULTMAP_CAT_AGGREGATE;
2265 : 38 : else if (gfc_match ("allocatable ") == MATCH_YES)
2266 : : category = OMP_DEFAULTMAP_CAT_ALLOCATABLE;
2267 : 26 : else if (gfc_match ("pointer ") == MATCH_YES)
2268 : : category = OMP_DEFAULTMAP_CAT_POINTER;
2269 : 9 : else if (gfc_match ("all ") == MATCH_YES)
2270 : : category = OMP_DEFAULTMAP_CAT_ALL;
2271 : : else
2272 : : {
2273 : 1 : gfc_error ("Expected SCALAR, AGGREGATE, ALLOCATABLE, "
2274 : : "POINTER or ALL at %C");
2275 : 1 : break;
2276 : : }
2277 : : }
2278 : 1137 : for (int i = 0; i < OMP_DEFAULTMAP_CAT_NUM; ++i)
2279 : : {
2280 : 980 : if (i != category
2281 : 980 : && category != OMP_DEFAULTMAP_CAT_UNCATEGORIZED
2282 : 461 : && category != OMP_DEFAULTMAP_CAT_ALL
2283 : 461 : && i != OMP_DEFAULTMAP_CAT_UNCATEGORIZED
2284 : 341 : && i != OMP_DEFAULTMAP_CAT_ALL)
2285 : 254 : continue;
2286 : 726 : if (c->defaultmap[i] != OMP_DEFAULTMAP_UNSET)
2287 : : {
2288 : 13 : const char *pcategory = NULL;
2289 : 13 : switch (i)
2290 : : {
2291 : : case OMP_DEFAULTMAP_CAT_UNCATEGORIZED: break;
2292 : : case OMP_DEFAULTMAP_CAT_ALL: pcategory = "ALL"; break;
2293 : 1 : case OMP_DEFAULTMAP_CAT_SCALAR: pcategory = "SCALAR"; break;
2294 : 2 : case OMP_DEFAULTMAP_CAT_AGGREGATE:
2295 : 2 : pcategory = "AGGREGATE";
2296 : 2 : break;
2297 : 1 : case OMP_DEFAULTMAP_CAT_ALLOCATABLE:
2298 : 1 : pcategory = "ALLOCATABLE";
2299 : 1 : break;
2300 : 2 : case OMP_DEFAULTMAP_CAT_POINTER:
2301 : 2 : pcategory = "POINTER";
2302 : 2 : break;
2303 : : default: gcc_unreachable ();
2304 : : }
2305 : 6 : if (i == OMP_DEFAULTMAP_CAT_UNCATEGORIZED)
2306 : 4 : gfc_error ("DEFAULTMAP at %C but prior DEFAULTMAP with "
2307 : : "unspecified category");
2308 : : else
2309 : 9 : gfc_error ("DEFAULTMAP at %C but prior DEFAULTMAP for "
2310 : : "category %s", pcategory);
2311 : 13 : goto error;
2312 : : }
2313 : : }
2314 : 157 : c->defaultmap[category] = behavior;
2315 : 157 : if (gfc_match (")") != MATCH_YES)
2316 : : break;
2317 : 157 : continue;
2318 : 157 : }
2319 : 4193 : if ((mask & OMP_CLAUSE_DEFAULT)
2320 : 3270 : && (m = gfc_match_dupl_check (c->default_sharing
2321 : : == OMP_DEFAULT_UNKNOWN, "default",
2322 : : true)) != MATCH_NO)
2323 : : {
2324 : 953 : if (m == MATCH_ERROR)
2325 : 4 : goto error;
2326 : 949 : if (gfc_match ("none") == MATCH_YES)
2327 : 554 : c->default_sharing = OMP_DEFAULT_NONE;
2328 : 395 : else if (openacc)
2329 : : {
2330 : 210 : if (gfc_match ("present") == MATCH_YES)
2331 : 190 : c->default_sharing = OMP_DEFAULT_PRESENT;
2332 : : }
2333 : : else
2334 : : {
2335 : 185 : if (gfc_match ("firstprivate") == MATCH_YES)
2336 : 8 : c->default_sharing = OMP_DEFAULT_FIRSTPRIVATE;
2337 : 177 : else if (gfc_match ("private") == MATCH_YES)
2338 : 24 : c->default_sharing = OMP_DEFAULT_PRIVATE;
2339 : 153 : else if (gfc_match ("shared") == MATCH_YES)
2340 : 153 : c->default_sharing = OMP_DEFAULT_SHARED;
2341 : : }
2342 : 949 : if (c->default_sharing == OMP_DEFAULT_UNKNOWN)
2343 : : {
2344 : 20 : if (openacc)
2345 : 20 : gfc_error ("Expected NONE or PRESENT in DEFAULT clause "
2346 : : "at %C");
2347 : : else
2348 : 0 : gfc_error ("Expected NONE, FIRSTPRIVATE, PRIVATE or SHARED "
2349 : : "in DEFAULT clause at %C");
2350 : 20 : goto error;
2351 : : }
2352 : 929 : if (gfc_match (" )") != MATCH_YES)
2353 : 6 : goto error;
2354 : 923 : continue;
2355 : : }
2356 : 2605 : if ((mask & OMP_CLAUSE_DELETE)
2357 : 323 : && gfc_match ("delete ( ") == MATCH_YES
2358 : 2605 : && gfc_match_omp_map_clause (&c->lists[OMP_LIST_MAP],
2359 : : OMP_MAP_RELEASE, true,
2360 : : allow_derived))
2361 : 288 : continue;
2362 : : /* DOACROSS: match 'doacross' and 'depend' with sink/source.
2363 : : DEPEND: match 'depend' but not sink/source. */
2364 : 2029 : m = MATCH_NO;
2365 : 2029 : if (((mask & OMP_CLAUSE_DOACROSS)
2366 : 381 : && gfc_match ("doacross ( ") == MATCH_YES)
2367 : 2383 : || (((mask & OMP_CLAUSE_DEPEND) || (mask & OMP_CLAUSE_DOACROSS))
2368 : 1437 : && (m = gfc_match ("depend ( ")) == MATCH_YES))
2369 : : {
2370 : 1073 : bool has_omp_all_memory;
2371 : 1073 : bool is_depend = m == MATCH_YES;
2372 : 1073 : gfc_namespace *ns_iter = NULL, *ns_curr = gfc_current_ns;
2373 : 1073 : match m_it = MATCH_NO;
2374 : 1073 : if (is_depend)
2375 : 1046 : m_it = gfc_match_iterator (&ns_iter, false);
2376 : 1046 : if (m_it == MATCH_ERROR)
2377 : : break;
2378 : 1068 : if (m_it == MATCH_YES && gfc_match (" , ") != MATCH_YES)
2379 : : break;
2380 : 1068 : m = MATCH_YES;
2381 : 1068 : gfc_omp_depend_doacross_op depend_op = OMP_DEPEND_OUT;
2382 : 1068 : if (gfc_match ("inoutset") == MATCH_YES)
2383 : : depend_op = OMP_DEPEND_INOUTSET;
2384 : 1056 : else if (gfc_match ("inout") == MATCH_YES)
2385 : : depend_op = OMP_DEPEND_INOUT;
2386 : 982 : else if (gfc_match ("in") == MATCH_YES)
2387 : : depend_op = OMP_DEPEND_IN;
2388 : 697 : else if (gfc_match ("out") == MATCH_YES)
2389 : : depend_op = OMP_DEPEND_OUT;
2390 : 437 : else if (gfc_match ("mutexinoutset") == MATCH_YES)
2391 : : depend_op = OMP_DEPEND_MUTEXINOUTSET;
2392 : 419 : else if (gfc_match ("depobj") == MATCH_YES)
2393 : : depend_op = OMP_DEPEND_DEPOBJ;
2394 : 385 : else if (gfc_match ("source") == MATCH_YES)
2395 : : {
2396 : 142 : if (m_it == MATCH_YES)
2397 : : {
2398 : 1 : gfc_error ("ITERATOR may not be combined with SOURCE "
2399 : : "at %C");
2400 : 17 : goto error;
2401 : : }
2402 : 141 : if (!(mask & OMP_CLAUSE_DOACROSS))
2403 : : {
2404 : 1 : gfc_error ("SOURCE at %C not permitted as dependence-type"
2405 : : " for this directive");
2406 : 1 : goto error;
2407 : : }
2408 : 140 : if (c->doacross_source)
2409 : : {
2410 : 0 : gfc_error ("Duplicated clause with SOURCE dependence-type"
2411 : : " at %C");
2412 : 0 : goto error;
2413 : : }
2414 : 140 : gfc_gobble_whitespace ();
2415 : 140 : m = gfc_match (": ");
2416 : 140 : if (m != MATCH_YES && !is_depend)
2417 : : {
2418 : 1 : gfc_error ("Expected %<:%> at %C");
2419 : 1 : goto error;
2420 : : }
2421 : 139 : if (gfc_match (")") != MATCH_YES
2422 : 145 : && !(m == MATCH_YES
2423 : 6 : && gfc_match ("omp_cur_iteration )") == MATCH_YES))
2424 : : {
2425 : 2 : gfc_error ("Expected %<)%> or %<omp_cur_iteration)%> "
2426 : : "at %C");
2427 : 2 : goto error;
2428 : : }
2429 : 137 : c->doacross_source = true;
2430 : 137 : c->depend_source = is_depend;
2431 : 1051 : continue;
2432 : : }
2433 : 243 : else if (gfc_match ("sink ") == MATCH_YES)
2434 : : {
2435 : 243 : if (!(mask & OMP_CLAUSE_DOACROSS))
2436 : : {
2437 : 2 : gfc_error ("SINK at %C not permitted as dependence-type "
2438 : : "for this directive");
2439 : 2 : goto error;
2440 : : }
2441 : 241 : if (gfc_match (": ") != MATCH_YES)
2442 : : {
2443 : 1 : gfc_error ("Expected %<:%> at %C");
2444 : 1 : goto error;
2445 : : }
2446 : 240 : if (m_it == MATCH_YES)
2447 : : {
2448 : 0 : gfc_error ("ITERATOR may not be combined with SINK "
2449 : : "at %C");
2450 : 0 : goto error;
2451 : : }
2452 : 240 : m = gfc_match_omp_doacross_sink (&c->lists[OMP_LIST_DEPEND],
2453 : : is_depend);
2454 : 240 : if (m == MATCH_YES)
2455 : 237 : continue;
2456 : 3 : goto error;
2457 : : }
2458 : : else
2459 : : m = MATCH_NO;
2460 : 683 : if (!(mask & OMP_CLAUSE_DEPEND))
2461 : : {
2462 : 0 : gfc_error ("Expected dependence-type SINK or SOURCE at %C");
2463 : 0 : goto error;
2464 : : }
2465 : 683 : head = NULL;
2466 : 683 : if (ns_iter)
2467 : 37 : gfc_current_ns = ns_iter;
2468 : 683 : if (m == MATCH_YES)
2469 : 683 : m = gfc_match_omp_variable_list (" : ",
2470 : : &c->lists[OMP_LIST_DEPEND],
2471 : : false, NULL, &head, true,
2472 : : false, &has_omp_all_memory);
2473 : 683 : if (m != MATCH_YES)
2474 : 2 : goto error;
2475 : 681 : gfc_current_ns = ns_curr;
2476 : 681 : if (has_omp_all_memory && depend_op != OMP_DEPEND_INOUT
2477 : 21 : && depend_op != OMP_DEPEND_OUT)
2478 : : {
2479 : 4 : gfc_error ("%<omp_all_memory%> used with DEPEND kind "
2480 : : "other than OUT or INOUT at %C");
2481 : 4 : goto error;
2482 : : }
2483 : 677 : gfc_omp_namelist *n;
2484 : 1382 : for (n = *head; n; n = n->next)
2485 : : {
2486 : 705 : n->u.depend_doacross_op = depend_op;
2487 : 705 : n->u2.ns = ns_iter;
2488 : 705 : if (ns_iter)
2489 : 36 : ns_iter->refs++;
2490 : : }
2491 : 677 : continue;
2492 : 677 : }
2493 : 1082 : if ((mask & OMP_CLAUSE_DETACH)
2494 : 162 : && !openacc
2495 : 127 : && !c->detach
2496 : 1082 : && gfc_match_omp_detach (&c->detach) == MATCH_YES)
2497 : 126 : continue;
2498 : 865 : if ((mask & OMP_CLAUSE_DETACH)
2499 : 36 : && openacc
2500 : 35 : && gfc_match ("detach ( ") == MATCH_YES
2501 : 865 : && gfc_match_omp_map_clause (&c->lists[OMP_LIST_MAP],
2502 : : OMP_MAP_DETACH, false,
2503 : : allow_derived))
2504 : 35 : continue;
2505 : 795 : if ((mask & OMP_CLAUSE_DEVICE)
2506 : 591 : && !openacc
2507 : 1072 : && ((m = gfc_match_dupl_check (!c->device, "device", true))
2508 : : != MATCH_NO))
2509 : : {
2510 : 251 : if (m == MATCH_ERROR)
2511 : 0 : goto error;
2512 : 251 : c->ancestor = false;
2513 : 251 : if (gfc_match ("device_num : ") == MATCH_YES)
2514 : : {
2515 : 16 : if (gfc_match ("%e )", &c->device) != MATCH_YES)
2516 : : {
2517 : 1 : gfc_error ("Expected integer expression at %C");
2518 : 1 : break;
2519 : : }
2520 : : }
2521 : 235 : else if (gfc_match ("ancestor : ") == MATCH_YES)
2522 : : {
2523 : 45 : bool has_requires = false;
2524 : 45 : c->ancestor = true;
2525 : 82 : for (gfc_namespace *ns = gfc_current_ns; ns; ns = ns->parent)
2526 : 80 : if (ns->omp_requires & OMP_REQ_REVERSE_OFFLOAD)
2527 : : {
2528 : : has_requires = true;
2529 : : break;
2530 : : }
2531 : 45 : if (!has_requires)
2532 : : {
2533 : 2 : gfc_error ("%<ancestor%> device modifier not "
2534 : : "preceded by %<requires%> directive "
2535 : : "with %<reverse_offload%> clause at %C");
2536 : 2 : break;
2537 : : }
2538 : 43 : locus old_loc2 = gfc_current_locus;
2539 : 43 : if (gfc_match ("%e )", &c->device) == MATCH_YES)
2540 : : {
2541 : 43 : int device = 0;
2542 : 43 : if (!gfc_extract_int (c->device, &device) && device != 1)
2543 : : {
2544 : 1 : gfc_current_locus = old_loc2;
2545 : 1 : gfc_error ("the %<device%> clause expression must "
2546 : : "evaluate to %<1%> at %C");
2547 : 1 : break;
2548 : : }
2549 : : }
2550 : : else
2551 : : {
2552 : 0 : gfc_error ("Expected integer expression at %C");
2553 : 0 : break;
2554 : : }
2555 : : }
2556 : 190 : else if (gfc_match ("%e )", &c->device) != MATCH_YES)
2557 : : {
2558 : 13 : gfc_error ("Expected integer expression or a single device-"
2559 : : "modifier %<device_num%> or %<ancestor%> at %C");
2560 : 13 : break;
2561 : : }
2562 : 234 : continue;
2563 : 234 : }
2564 : 856 : if ((mask & OMP_CLAUSE_DEVICE)
2565 : 340 : && openacc
2566 : 314 : && gfc_match ("device ( ") == MATCH_YES
2567 : 857 : && gfc_match_omp_map_clause (&c->lists[OMP_LIST_MAP],
2568 : : OMP_MAP_FORCE_TO, true,
2569 : : /* allow_derived = */ true))
2570 : 312 : continue;
2571 : 263 : if ((mask & OMP_CLAUSE_DEVICEPTR)
2572 : 80 : && gfc_match ("deviceptr ( ") == MATCH_YES
2573 : 265 : && gfc_match_omp_map_clause (&c->lists[OMP_LIST_MAP],
2574 : : OMP_MAP_FORCE_DEVICEPTR, false,
2575 : : allow_derived))
2576 : 31 : continue;
2577 : 251 : if ((mask & OMP_CLAUSE_DEVICE_TYPE)
2578 : 201 : && gfc_match ("device_type ( ") == MATCH_YES)
2579 : : {
2580 : 51 : if (gfc_match ("host") == MATCH_YES)
2581 : 17 : c->device_type = OMP_DEVICE_TYPE_HOST;
2582 : 34 : else if (gfc_match ("nohost") == MATCH_YES)
2583 : 17 : c->device_type = OMP_DEVICE_TYPE_NOHOST;
2584 : 17 : else if (gfc_match ("any") == MATCH_YES)
2585 : 16 : c->device_type = OMP_DEVICE_TYPE_ANY;
2586 : : else
2587 : : {
2588 : 1 : gfc_error ("Expected HOST, NOHOST or ANY at %C");
2589 : 1 : break;
2590 : : }
2591 : 50 : if (gfc_match (" )") != MATCH_YES)
2592 : : break;
2593 : 50 : continue;
2594 : : }
2595 : 196 : if ((mask & OMP_CLAUSE_DEVICE_RESIDENT)
2596 : 197 : && gfc_match_omp_variable_list
2597 : 47 : ("device_resident (",
2598 : : &c->lists[OMP_LIST_DEVICE_RESIDENT], true) == MATCH_YES)
2599 : 46 : continue;
2600 : 104 : if ((mask & OMP_CLAUSE_DIST_SCHEDULE)
2601 : 97 : && c->dist_sched_kind == OMP_SCHED_NONE
2602 : 201 : && gfc_match ("dist_schedule ( static") == MATCH_YES)
2603 : : {
2604 : 97 : m = MATCH_NO;
2605 : 97 : c->dist_sched_kind = OMP_SCHED_STATIC;
2606 : 97 : m = gfc_match (" , %e )", &c->dist_chunk_size);
2607 : 97 : if (m != MATCH_YES)
2608 : 14 : m = gfc_match_char (')');
2609 : 14 : if (m != MATCH_YES)
2610 : : {
2611 : 0 : c->dist_sched_kind = OMP_SCHED_NONE;
2612 : 0 : gfc_current_locus = old_loc;
2613 : : }
2614 : : else
2615 : 97 : continue;
2616 : : }
2617 : : break;
2618 : 69 : case 'e':
2619 : 69 : if ((mask & OMP_CLAUSE_ENTER))
2620 : : {
2621 : 69 : m = gfc_match_omp_to_link ("enter (", &c->lists[OMP_LIST_ENTER]);
2622 : 69 : if (m == MATCH_ERROR)
2623 : 0 : goto error;
2624 : 69 : if (m == MATCH_YES)
2625 : 69 : continue;
2626 : : }
2627 : : break;
2628 : 2141 : case 'f':
2629 : 2190 : if ((mask & OMP_CLAUSE_FAIL)
2630 : 2141 : && (m = gfc_match_dupl_check (c->fail == OMP_MEMORDER_UNSET,
2631 : : "fail", true)) != MATCH_NO)
2632 : : {
2633 : 58 : if (m == MATCH_ERROR)
2634 : 3 : goto error;
2635 : 55 : if (gfc_match ("seq_cst") == MATCH_YES)
2636 : 6 : c->fail = OMP_MEMORDER_SEQ_CST;
2637 : 49 : else if (gfc_match ("acquire") == MATCH_YES)
2638 : 14 : c->fail = OMP_MEMORDER_ACQUIRE;
2639 : 35 : else if (gfc_match ("relaxed") == MATCH_YES)
2640 : 30 : c->fail = OMP_MEMORDER_RELAXED;
2641 : : else
2642 : : {
2643 : 5 : gfc_error ("Expected SEQ_CST, ACQUIRE or RELAXED at %C");
2644 : 5 : break;
2645 : : }
2646 : 50 : if (gfc_match (" )") != MATCH_YES)
2647 : 1 : goto error;
2648 : 49 : continue;
2649 : : }
2650 : 2126 : if ((mask & OMP_CLAUSE_FILTER)
2651 : 2083 : && (m = gfc_match_dupl_check (!c->filter, "filter", true,
2652 : : &c->filter)) != MATCH_NO)
2653 : : {
2654 : 44 : if (m == MATCH_ERROR)
2655 : 1 : goto error;
2656 : 43 : continue;
2657 : : }
2658 : 2103 : if ((mask & OMP_CLAUSE_FINAL)
2659 : 2039 : && (m = gfc_match_dupl_check (!c->final_expr, "final", true,
2660 : : &c->final_expr)) != MATCH_NO)
2661 : : {
2662 : 64 : if (m == MATCH_ERROR)
2663 : 0 : goto error;
2664 : 64 : continue;
2665 : : }
2666 : 1993 : if ((mask & OMP_CLAUSE_FINALIZE)
2667 : 1975 : && (m = gfc_match_dupl_check (!c->finalize, "finalize"))
2668 : : != MATCH_NO)
2669 : : {
2670 : 18 : if (m == MATCH_ERROR)
2671 : 0 : goto error;
2672 : 18 : c->finalize = true;
2673 : 18 : needs_space = true;
2674 : 18 : continue;
2675 : : }
2676 : 2909 : if ((mask & OMP_CLAUSE_FIRSTPRIVATE)
2677 : 1957 : && gfc_match_omp_variable_list ("firstprivate (",
2678 : : &c->lists[OMP_LIST_FIRSTPRIVATE],
2679 : : true) == MATCH_YES)
2680 : 952 : continue;
2681 : 2003 : if ((mask & OMP_CLAUSE_FROM)
2682 : 1005 : && gfc_match_motion_var_list ("from (", &c->lists[OMP_LIST_FROM],
2683 : : &head) == MATCH_YES)
2684 : 998 : continue;
2685 : : break;
2686 : 1170 : case 'g':
2687 : 2292 : if ((mask & OMP_CLAUSE_GANG)
2688 : 1170 : && (m = gfc_match_dupl_check (!c->gang, "gang")) != MATCH_NO)
2689 : : {
2690 : 1127 : if (m == MATCH_ERROR)
2691 : 0 : goto error;
2692 : 1127 : c->gang = true;
2693 : 1127 : m = match_oacc_clause_gwv (c, GOMP_DIM_GANG);
2694 : 1127 : if (m == MATCH_ERROR)
2695 : : {
2696 : 5 : gfc_current_locus = old_loc;
2697 : 5 : break;
2698 : : }
2699 : 1122 : else if (m == MATCH_NO)
2700 : 916 : needs_space = true;
2701 : 1122 : continue;
2702 : : }
2703 : 86 : if ((mask & OMP_CLAUSE_GRAINSIZE)
2704 : 43 : && (m = gfc_match_dupl_check (!c->grainsize, "grainsize", true))
2705 : : != MATCH_NO)
2706 : : {
2707 : 43 : if (m == MATCH_ERROR)
2708 : 0 : goto error;
2709 : 43 : if (gfc_match ("strict : ") == MATCH_YES)
2710 : 6 : c->grainsize_strict = true;
2711 : 43 : if (gfc_match (" %e )", &c->grainsize) != MATCH_YES)
2712 : 0 : goto error;
2713 : 43 : continue;
2714 : : }
2715 : : break;
2716 : 451 : case 'h':
2717 : 486 : if ((mask & OMP_CLAUSE_HAS_DEVICE_ADDR)
2718 : 486 : && gfc_match_omp_variable_list
2719 : 35 : ("has_device_addr (", &c->lists[OMP_LIST_HAS_DEVICE_ADDR],
2720 : : false, NULL, NULL, true) == MATCH_YES)
2721 : 35 : continue;
2722 : 459 : if ((mask & OMP_CLAUSE_HINT)
2723 : 416 : && (m = gfc_match_dupl_check (!c->hint, "hint", true, &c->hint))
2724 : : != MATCH_NO)
2725 : : {
2726 : 43 : if (m == MATCH_ERROR)
2727 : 0 : goto error;
2728 : 43 : continue;
2729 : : }
2730 : 373 : if ((mask & OMP_CLAUSE_ASSUMPTIONS)
2731 : 373 : && gfc_match ("holds ( ") == MATCH_YES)
2732 : : {
2733 : 18 : gfc_expr *e;
2734 : 18 : if (gfc_match ("%e )", &e) != MATCH_YES)
2735 : 0 : goto error;
2736 : 18 : if (c->assume == NULL)
2737 : 11 : c->assume = gfc_get_omp_assumptions ();
2738 : 18 : gfc_expr_list *el = XCNEW (gfc_expr_list);
2739 : 18 : el->expr = e;
2740 : 18 : el->next = c->assume->holds;
2741 : 18 : c->assume->holds = el;
2742 : 18 : continue;
2743 : 18 : }
2744 : 709 : if ((mask & OMP_CLAUSE_HOST)
2745 : 355 : && gfc_match ("host ( ") == MATCH_YES
2746 : 710 : && gfc_match_omp_map_clause (&c->lists[OMP_LIST_MAP],
2747 : : OMP_MAP_FORCE_FROM, true,
2748 : : /* allow_derived = */ true))
2749 : 354 : continue;
2750 : : break;
2751 : 1845 : case 'i':
2752 : 1868 : if ((mask & OMP_CLAUSE_IF_PRESENT)
2753 : 1845 : && (m = gfc_match_dupl_check (!c->if_present, "if_present"))
2754 : : != MATCH_NO)
2755 : : {
2756 : 23 : if (m == MATCH_ERROR)
2757 : 0 : goto error;
2758 : 23 : c->if_present = true;
2759 : 23 : needs_space = true;
2760 : 23 : continue;
2761 : : }
2762 : 1822 : if ((mask & OMP_CLAUSE_IF)
2763 : 1822 : && (m = gfc_match_dupl_check (!c->if_expr, "if", true))
2764 : : != MATCH_NO)
2765 : : {
2766 : 1324 : if (m == MATCH_ERROR)
2767 : 15 : goto error;
2768 : 1309 : if (!openacc)
2769 : : {
2770 : : /* This should match the enum gfc_omp_if_kind order. */
2771 : : static const char *ifs[OMP_IF_LAST] = {
2772 : : "cancel : %e )",
2773 : : "parallel : %e )",
2774 : : "simd : %e )",
2775 : : "task : %e )",
2776 : : "taskloop : %e )",
2777 : : "target : %e )",
2778 : : "target data : %e )",
2779 : : "target update : %e )",
2780 : : "target enter data : %e )",
2781 : : "target exit data : %e )" };
2782 : : int i;
2783 : 4786 : for (i = 0; i < OMP_IF_LAST; i++)
2784 : 4393 : if (c->if_exprs[i] == NULL
2785 : 4393 : && gfc_match (ifs[i], &c->if_exprs[i]) == MATCH_YES)
2786 : : break;
2787 : 531 : if (i < OMP_IF_LAST)
2788 : 138 : continue;
2789 : : }
2790 : 1171 : if (gfc_match (" %e )", &c->if_expr) == MATCH_YES)
2791 : 1167 : continue;
2792 : 4 : goto error;
2793 : : }
2794 : 615 : if ((mask & OMP_CLAUSE_IN_REDUCTION)
2795 : 498 : && gfc_match_omp_clause_reduction (pc, c, openacc, allow_derived,
2796 : : openmp_target) == MATCH_YES)
2797 : 117 : continue;
2798 : 406 : if ((mask & OMP_CLAUSE_INBRANCH)
2799 : 381 : && (m = gfc_match_dupl_check (!c->inbranch && !c->notinbranch,
2800 : : "inbranch")) != MATCH_NO)
2801 : : {
2802 : 25 : if (m == MATCH_ERROR)
2803 : 0 : goto error;
2804 : 25 : c->inbranch = needs_space = true;
2805 : 25 : continue;
2806 : : }
2807 : 543 : if ((mask & OMP_CLAUSE_INDEPENDENT)
2808 : 356 : && (m = gfc_match_dupl_check (!c->independent, "independent"))
2809 : : != MATCH_NO)
2810 : : {
2811 : 187 : if (m == MATCH_ERROR)
2812 : 0 : goto error;
2813 : 187 : c->independent = true;
2814 : 187 : needs_space = true;
2815 : 187 : continue;
2816 : : }
2817 : 169 : if ((mask & OMP_CLAUSE_INDIRECT)
2818 : 169 : && (m = gfc_match_dupl_check (!c->indirect, "indirect"))
2819 : : != MATCH_NO)
2820 : : {
2821 : 61 : if (m == MATCH_ERROR)
2822 : 5 : goto error;
2823 : 60 : gfc_expr *indirect_expr = NULL;
2824 : 60 : m = gfc_match (" ( %e )", &indirect_expr);
2825 : 60 : if (m == MATCH_YES)
2826 : : {
2827 : 13 : if (!gfc_resolve_expr (indirect_expr)
2828 : 13 : || indirect_expr->ts.type != BT_LOGICAL
2829 : 23 : || indirect_expr->expr_type != EXPR_CONSTANT)
2830 : : {
2831 : 4 : gfc_error ("INDIRECT clause at %C requires a constant "
2832 : : "logical expression");
2833 : 4 : gfc_free_expr (indirect_expr);
2834 : 4 : goto error;
2835 : : }
2836 : 9 : c->indirect = indirect_expr->value.logical;
2837 : 9 : gfc_free_expr (indirect_expr);
2838 : : }
2839 : : else
2840 : 47 : c->indirect = 1;
2841 : 56 : continue;
2842 : 56 : }
2843 : 209 : if ((mask & OMP_CLAUSE_IS_DEVICE_PTR)
2844 : 209 : && gfc_match_omp_variable_list
2845 : 101 : ("is_device_ptr (",
2846 : : &c->lists[OMP_LIST_IS_DEVICE_PTR], false) == MATCH_YES)
2847 : 101 : continue;
2848 : : break;
2849 : 2274 : case 'l':
2850 : 2274 : if ((mask & OMP_CLAUSE_LASTPRIVATE)
2851 : 2274 : && gfc_match ("lastprivate ( ") == MATCH_YES)
2852 : : {
2853 : 1389 : bool conditional = gfc_match ("conditional : ") == MATCH_YES;
2854 : 1389 : head = NULL;
2855 : 1389 : if (gfc_match_omp_variable_list ("",
2856 : : &c->lists[OMP_LIST_LASTPRIVATE],
2857 : : false, NULL, &head) == MATCH_YES)
2858 : : {
2859 : 1389 : gfc_omp_namelist *n;
2860 : 3653 : for (n = *head; n; n = n->next)
2861 : 2264 : n->u.lastprivate_conditional = conditional;
2862 : 1389 : continue;
2863 : 1389 : }
2864 : 0 : gfc_current_locus = old_loc;
2865 : 0 : break;
2866 : : }
2867 : 885 : end_colon = false;
2868 : 885 : head = NULL;
2869 : 885 : if ((mask & OMP_CLAUSE_LINEAR)
2870 : 885 : && gfc_match ("linear (") == MATCH_YES)
2871 : : {
2872 : 840 : bool old_linear_modifier = false;
2873 : 840 : gfc_omp_linear_op linear_op = OMP_LINEAR_DEFAULT;
2874 : 840 : gfc_expr *step = NULL;
2875 : :
2876 : 840 : if (gfc_match_omp_variable_list (" ref (",
2877 : : &c->lists[OMP_LIST_LINEAR],
2878 : : false, NULL, &head)
2879 : : == MATCH_YES)
2880 : : {
2881 : : linear_op = OMP_LINEAR_REF;
2882 : : old_linear_modifier = true;
2883 : : }
2884 : 811 : else if (gfc_match_omp_variable_list (" val (",
2885 : : &c->lists[OMP_LIST_LINEAR],
2886 : : false, NULL, &head)
2887 : : == MATCH_YES)
2888 : : {
2889 : : linear_op = OMP_LINEAR_VAL;
2890 : : old_linear_modifier = true;
2891 : : }
2892 : 799 : else if (gfc_match_omp_variable_list (" uval (",
2893 : : &c->lists[OMP_LIST_LINEAR],
2894 : : false, NULL, &head)
2895 : : == MATCH_YES)
2896 : : {
2897 : : linear_op = OMP_LINEAR_UVAL;
2898 : : old_linear_modifier = true;
2899 : : }
2900 : 789 : else if (gfc_match_omp_variable_list ("",
2901 : : &c->lists[OMP_LIST_LINEAR],
2902 : : false, &end_colon, &head)
2903 : : == MATCH_YES)
2904 : : linear_op = OMP_LINEAR_DEFAULT;
2905 : : else
2906 : : {
2907 : 2 : gfc_current_locus = old_loc;
2908 : 2 : break;
2909 : : }
2910 : : if (linear_op != OMP_LINEAR_DEFAULT)
2911 : : {
2912 : 51 : if (gfc_match (" :") == MATCH_YES)
2913 : 31 : end_colon = true;
2914 : 20 : else if (gfc_match (" )") != MATCH_YES)
2915 : : {
2916 : 0 : gfc_free_omp_namelist (*head, false, false, false);
2917 : 0 : gfc_current_locus = old_loc;
2918 : 0 : *head = NULL;
2919 : 0 : break;
2920 : : }
2921 : : }
2922 : 838 : gfc_gobble_whitespace ();
2923 : 838 : if (old_linear_modifier && end_colon)
2924 : : {
2925 : 31 : if (gfc_match (" %e )", &step) != MATCH_YES)
2926 : : {
2927 : 1 : gfc_free_omp_namelist (*head, false, false, false);
2928 : 1 : gfc_current_locus = old_loc;
2929 : 1 : *head = NULL;
2930 : 5 : goto error;
2931 : : }
2932 : : }
2933 : 807 : else if (end_colon)
2934 : : {
2935 : 710 : bool has_error = false;
2936 : : bool has_modifiers = false;
2937 : : bool has_step = false;
2938 : 710 : bool duplicate_step = false;
2939 : 710 : bool duplicate_mod = false;
2940 : 710 : while (true)
2941 : : {
2942 : 710 : old_loc = gfc_current_locus;
2943 : 710 : bool close_paren = gfc_match ("val )") == MATCH_YES;
2944 : 710 : if (close_paren || gfc_match ("val , ") == MATCH_YES)
2945 : : {
2946 : 16 : if (linear_op != OMP_LINEAR_DEFAULT)
2947 : : {
2948 : : duplicate_mod = true;
2949 : : break;
2950 : : }
2951 : 15 : linear_op = OMP_LINEAR_VAL;
2952 : 15 : has_modifiers = true;
2953 : 15 : if (close_paren)
2954 : : break;
2955 : 10 : continue;
2956 : : }
2957 : 694 : close_paren = gfc_match ("uval )") == MATCH_YES;
2958 : 694 : if (close_paren || gfc_match ("uval , ") == MATCH_YES)
2959 : : {
2960 : 6 : if (linear_op != OMP_LINEAR_DEFAULT)
2961 : : {
2962 : : duplicate_mod = true;
2963 : : break;
2964 : : }
2965 : 6 : linear_op = OMP_LINEAR_UVAL;
2966 : 6 : has_modifiers = true;
2967 : 6 : if (close_paren)
2968 : : break;
2969 : 2 : continue;
2970 : : }
2971 : 688 : close_paren = gfc_match ("ref )") == MATCH_YES;
2972 : 688 : if (close_paren || gfc_match ("ref , ") == MATCH_YES)
2973 : : {
2974 : 15 : if (linear_op != OMP_LINEAR_DEFAULT)
2975 : : {
2976 : : duplicate_mod = true;
2977 : : break;
2978 : : }
2979 : 14 : linear_op = OMP_LINEAR_REF;
2980 : 14 : has_modifiers = true;
2981 : 14 : if (close_paren)
2982 : : break;
2983 : 7 : continue;
2984 : : }
2985 : 673 : close_paren = (gfc_match ("step ( %e ) )", &step)
2986 : : == MATCH_YES);
2987 : 684 : if (close_paren
2988 : 673 : || gfc_match ("step ( %e ) , ", &step) == MATCH_YES)
2989 : : {
2990 : 38 : if (has_step)
2991 : : {
2992 : : duplicate_step = true;
2993 : : break;
2994 : : }
2995 : 37 : has_modifiers = has_step = true;
2996 : 37 : if (close_paren)
2997 : : break;
2998 : 11 : continue;
2999 : : }
3000 : 635 : if (!has_modifiers
3001 : 635 : && gfc_match ("%e )", &step) == MATCH_YES)
3002 : : {
3003 : 635 : if ((step->expr_type == EXPR_FUNCTION
3004 : 634 : || step->expr_type == EXPR_VARIABLE)
3005 : 31 : && strcmp (step->symtree->name, "step") == 0)
3006 : : {
3007 : 1 : gfc_current_locus = old_loc;
3008 : 1 : gfc_match ("step (");
3009 : 1 : has_error = true;
3010 : : }
3011 : : break;
3012 : : }
3013 : : has_error = true;
3014 : : break;
3015 : : }
3016 : 680 : if (duplicate_mod || duplicate_step)
3017 : : {
3018 : 3 : gfc_error ("Multiple %qs modifiers specified at %C",
3019 : : duplicate_mod ? "linear" : "step");
3020 : 3 : has_error = true;
3021 : : }
3022 : 680 : if (has_error)
3023 : : {
3024 : 4 : gfc_free_omp_namelist (*head, false, false, false);
3025 : 4 : *head = NULL;
3026 : 4 : goto error;
3027 : : }
3028 : : }
3029 : 833 : if (step == NULL)
3030 : : {
3031 : 134 : step = gfc_get_constant_expr (BT_INTEGER,
3032 : : gfc_default_integer_kind,
3033 : : &old_loc);
3034 : 134 : mpz_set_si (step->value.integer, 1);
3035 : : }
3036 : 833 : (*head)->expr = step;
3037 : 833 : if (linear_op != OMP_LINEAR_DEFAULT || old_linear_modifier)
3038 : 176 : for (gfc_omp_namelist *n = *head; n; n = n->next)
3039 : : {
3040 : 94 : n->u.linear.op = linear_op;
3041 : 94 : n->u.linear.old_modifier = old_linear_modifier;
3042 : : }
3043 : 833 : continue;
3044 : 833 : }
3045 : 49 : if ((mask & OMP_CLAUSE_LINK)
3046 : 45 : && openacc
3047 : 53 : && (gfc_match_oacc_clause_link ("link (",
3048 : : &c->lists[OMP_LIST_LINK])
3049 : : == MATCH_YES))
3050 : 4 : continue;
3051 : 78 : else if ((mask & OMP_CLAUSE_LINK)
3052 : 41 : && !openacc
3053 : 78 : && (gfc_match_omp_to_link ("link (",
3054 : : &c->lists[OMP_LIST_LINK])
3055 : : == MATCH_YES))
3056 : 37 : continue;
3057 : : break;
3058 : 4673 : case 'm':
3059 : 4673 : if ((mask & OMP_CLAUSE_MAP)
3060 : 4673 : && gfc_match ("map ( ") == MATCH_YES)
3061 : : {
3062 : 4592 : locus old_loc2 = gfc_current_locus;
3063 : 4592 : int always_modifier = 0;
3064 : 4592 : int close_modifier = 0;
3065 : 4592 : int present_modifier = 0;
3066 : 4592 : locus second_always_locus = old_loc2;
3067 : 4592 : locus second_close_locus = old_loc2;
3068 : 4592 : locus second_present_locus = old_loc2;
3069 : :
3070 : 5074 : for (;;)
3071 : : {
3072 : 4833 : locus current_locus = gfc_current_locus;
3073 : 4833 : if (gfc_match ("always ") == MATCH_YES)
3074 : : {
3075 : 125 : if (always_modifier++ == 1)
3076 : 5 : second_always_locus = current_locus;
3077 : : }
3078 : 4708 : else if (gfc_match ("close ") == MATCH_YES)
3079 : : {
3080 : 65 : if (close_modifier++ == 1)
3081 : 5 : second_close_locus = current_locus;
3082 : : }
3083 : 4643 : else if (gfc_match ("present ") == MATCH_YES)
3084 : : {
3085 : 51 : if (present_modifier++ == 1)
3086 : 4 : second_present_locus = current_locus;
3087 : : }
3088 : : else
3089 : : break;
3090 : 241 : gfc_match (", ");
3091 : 241 : }
3092 : :
3093 : 4592 : gfc_omp_map_op map_op = OMP_MAP_TOFROM;
3094 : 4592 : int always_present_modifier
3095 : 4592 : = always_modifier && present_modifier;
3096 : :
3097 : 4592 : if (gfc_match ("alloc : ") == MATCH_YES)
3098 : 527 : map_op = (present_modifier ? OMP_MAP_PRESENT_ALLOC
3099 : : : OMP_MAP_ALLOC);
3100 : 4065 : else if (gfc_match ("tofrom : ") == MATCH_YES)
3101 : 790 : map_op = (always_present_modifier ? OMP_MAP_ALWAYS_PRESENT_TOFROM
3102 : 786 : : present_modifier ? OMP_MAP_PRESENT_TOFROM
3103 : 782 : : always_modifier ? OMP_MAP_ALWAYS_TOFROM
3104 : : : OMP_MAP_TOFROM);
3105 : 3275 : else if (gfc_match ("to : ") == MATCH_YES)
3106 : 1486 : map_op = (always_present_modifier ? OMP_MAP_ALWAYS_PRESENT_TO
3107 : 1482 : : present_modifier ? OMP_MAP_PRESENT_TO
3108 : 1471 : : always_modifier ? OMP_MAP_ALWAYS_TO
3109 : : : OMP_MAP_TO);
3110 : 1789 : else if (gfc_match ("from : ") == MATCH_YES)
3111 : 1361 : map_op = (always_present_modifier ? OMP_MAP_ALWAYS_PRESENT_FROM
3112 : 1357 : : present_modifier ? OMP_MAP_PRESENT_FROM
3113 : 1353 : : always_modifier ? OMP_MAP_ALWAYS_FROM
3114 : : : OMP_MAP_FROM);
3115 : 428 : else if (gfc_match ("release : ") == MATCH_YES)
3116 : : map_op = OMP_MAP_RELEASE;
3117 : 412 : else if (gfc_match ("delete : ") == MATCH_YES)
3118 : : map_op = OMP_MAP_DELETE;
3119 : : else
3120 : : {
3121 : 366 : gfc_current_locus = old_loc2;
3122 : 366 : always_modifier = 0;
3123 : 366 : close_modifier = 0;
3124 : : }
3125 : :
3126 : 4592 : if (always_modifier > 1)
3127 : : {
3128 : 5 : gfc_error ("too many %<always%> modifiers at %L",
3129 : : &second_always_locus);
3130 : 21 : break;
3131 : : }
3132 : 4587 : if (close_modifier > 1)
3133 : : {
3134 : 4 : gfc_error ("too many %<close%> modifiers at %L",
3135 : : &second_close_locus);
3136 : 4 : break;
3137 : : }
3138 : 4583 : if (present_modifier > 1)
3139 : : {
3140 : 4 : gfc_error ("too many %<present%> modifiers at %L",
3141 : : &second_present_locus);
3142 : 4 : break;
3143 : : }
3144 : :
3145 : 4579 : head = NULL;
3146 : 4579 : if (gfc_match_omp_variable_list ("", &c->lists[OMP_LIST_MAP],
3147 : : false, NULL, &head,
3148 : : true, true) == MATCH_YES)
3149 : : {
3150 : 4576 : gfc_omp_namelist *n;
3151 : 10441 : for (n = *head; n; n = n->next)
3152 : 5865 : n->u.map.op = map_op;
3153 : 4576 : continue;
3154 : 4576 : }
3155 : 3 : gfc_current_locus = old_loc;
3156 : 3 : break;
3157 : : }
3158 : 115 : if ((mask & OMP_CLAUSE_MERGEABLE)
3159 : 81 : && (m = gfc_match_dupl_check (!c->mergeable, "mergeable"))
3160 : : != MATCH_NO)
3161 : : {
3162 : 34 : if (m == MATCH_ERROR)
3163 : 0 : goto error;
3164 : 34 : c->mergeable = needs_space = true;
3165 : 34 : continue;
3166 : : }
3167 : 89 : if ((mask & OMP_CLAUSE_MESSAGE)
3168 : 47 : && (m = gfc_match_dupl_check (!c->message, "message", true,
3169 : : &c->message)) != MATCH_NO)
3170 : : {
3171 : 47 : if (m == MATCH_ERROR)
3172 : 5 : goto error;
3173 : 42 : continue;
3174 : : }
3175 : : break;
3176 : 2861 : case 'n':
3177 : 2911 : if ((mask & OMP_CLAUSE_NO_CREATE)
3178 : 1341 : && gfc_match ("no_create ( ") == MATCH_YES
3179 : 2911 : && gfc_match_omp_map_clause (&c->lists[OMP_LIST_MAP],
3180 : : OMP_MAP_IF_PRESENT, true,
3181 : : allow_derived))
3182 : 50 : continue;
3183 : 2823 : if ((mask & OMP_CLAUSE_ASSUMPTIONS)
3184 : 2831 : && (m = gfc_match_dupl_check (!c->assume
3185 : 20 : || !c->assume->no_openmp_routines,
3186 : : "no_openmp_routines")) == MATCH_YES)
3187 : : {
3188 : 12 : if (m == MATCH_ERROR)
3189 : : goto error;
3190 : 12 : if (c->assume == NULL)
3191 : 12 : c->assume = gfc_get_omp_assumptions ();
3192 : 12 : c->assume->no_openmp_routines = needs_space = true;
3193 : 12 : continue;
3194 : : }
3195 : 2801 : if ((mask & OMP_CLAUSE_ASSUMPTIONS)
3196 : 2807 : && (m = gfc_match_dupl_check (!c->assume || !c->assume->no_openmp,
3197 : : "no_openmp")) == MATCH_YES)
3198 : : {
3199 : 2 : if (m == MATCH_ERROR)
3200 : : goto error;
3201 : 2 : if (c->assume == NULL)
3202 : 2 : c->assume = gfc_get_omp_assumptions ();
3203 : 2 : c->assume->no_openmp = needs_space = true;
3204 : 2 : continue;
3205 : : }
3206 : 2803 : if ((mask & OMP_CLAUSE_ASSUMPTIONS)
3207 : 2803 : && (m = gfc_match_dupl_check (!c->assume
3208 : 6 : || !c->assume->no_parallelism,
3209 : : "no_parallelism")) == MATCH_YES)
3210 : : {
3211 : 6 : if (m == MATCH_ERROR)
3212 : : goto error;
3213 : 6 : if (c->assume == NULL)
3214 : 6 : c->assume = gfc_get_omp_assumptions ();
3215 : 6 : c->assume->no_parallelism = needs_space = true;
3216 : 6 : continue;
3217 : : }
3218 : 2804 : if ((mask & OMP_CLAUSE_NOGROUP)
3219 : 2791 : && (m = gfc_match_dupl_check (!c->nogroup, "nogroup"))
3220 : : != MATCH_NO)
3221 : : {
3222 : 13 : if (m == MATCH_ERROR)
3223 : 0 : goto error;
3224 : 13 : c->nogroup = needs_space = true;
3225 : 13 : continue;
3226 : : }
3227 : 2928 : if ((mask & OMP_CLAUSE_NOHOST)
3228 : 2778 : && (m = gfc_match_dupl_check (!c->nohost, "nohost")) != MATCH_NO)
3229 : : {
3230 : 151 : if (m == MATCH_ERROR)
3231 : 1 : goto error;
3232 : 150 : c->nohost = needs_space = true;
3233 : 150 : continue;
3234 : : }
3235 : 2669 : if ((mask & OMP_CLAUSE_NOTEMPORAL)
3236 : 2627 : && gfc_match_omp_variable_list ("nontemporal (",
3237 : : &c->lists[OMP_LIST_NONTEMPORAL],
3238 : : true) == MATCH_YES)
3239 : 42 : continue;
3240 : 2614 : if ((mask & OMP_CLAUSE_NOTINBRANCH)
3241 : 2585 : && (m = gfc_match_dupl_check (!c->notinbranch && !c->inbranch,
3242 : : "notinbranch")) != MATCH_NO)
3243 : : {
3244 : 30 : if (m == MATCH_ERROR)
3245 : 1 : goto error;
3246 : 29 : c->notinbranch = needs_space = true;
3247 : 29 : continue;
3248 : : }
3249 : 2671 : if ((mask & OMP_CLAUSE_NOWAIT)
3250 : 2555 : && (m = gfc_match_dupl_check (!c->nowait, "nowait")) != MATCH_NO)
3251 : : {
3252 : 118 : if (m == MATCH_ERROR)
3253 : 2 : goto error;
3254 : 116 : c->nowait = needs_space = true;
3255 : 116 : continue;
3256 : : }
3257 : 3119 : if ((mask & OMP_CLAUSE_NUM_GANGS)
3258 : 2437 : && (m = gfc_match_dupl_check (!c->num_gangs_expr, "num_gangs",
3259 : : true)) != MATCH_NO)
3260 : : {
3261 : 686 : if (m == MATCH_ERROR)
3262 : 2 : goto error;
3263 : 684 : if (gfc_match (" %e )", &c->num_gangs_expr) != MATCH_YES)
3264 : 2 : goto error;
3265 : 682 : continue;
3266 : : }
3267 : 1786 : if ((mask & OMP_CLAUSE_NUM_TASKS)
3268 : 1751 : && (m = gfc_match_dupl_check (!c->num_tasks, "num_tasks", true))
3269 : : != MATCH_NO)
3270 : : {
3271 : 35 : if (m == MATCH_ERROR)
3272 : 0 : goto error;
3273 : 35 : if (gfc_match ("strict : ") == MATCH_YES)
3274 : 6 : c->num_tasks_strict = true;
3275 : 35 : if (gfc_match (" %e )", &c->num_tasks) != MATCH_YES)
3276 : 0 : goto error;
3277 : 35 : continue;
3278 : : }
3279 : 1843 : if ((mask & OMP_CLAUSE_NUM_TEAMS)
3280 : 1716 : && (m = gfc_match_dupl_check (!c->num_teams_upper, "num_teams",
3281 : : true)) != MATCH_NO)
3282 : : {
3283 : 127 : if (m == MATCH_ERROR)
3284 : 0 : goto error;
3285 : 127 : if (gfc_match ("%e ", &c->num_teams_upper) != MATCH_YES)
3286 : 0 : goto error;
3287 : 127 : if (gfc_peek_ascii_char () == ':')
3288 : : {
3289 : 21 : c->num_teams_lower = c->num_teams_upper;
3290 : 21 : c->num_teams_upper = NULL;
3291 : 21 : if (gfc_match (": %e ", &c->num_teams_upper) != MATCH_YES)
3292 : 0 : goto error;
3293 : : }
3294 : 127 : if (gfc_match (") ") != MATCH_YES)
3295 : 0 : goto error;
3296 : 127 : continue;
3297 : : }
3298 : 2538 : if ((mask & OMP_CLAUSE_NUM_THREADS)
3299 : 1589 : && (m = gfc_match_dupl_check (!c->num_threads, "num_threads", true,
3300 : : &c->num_threads)) != MATCH_NO)
3301 : : {
3302 : 949 : if (m == MATCH_ERROR)
3303 : 0 : goto error;
3304 : 949 : continue;
3305 : : }
3306 : 1239 : if ((mask & OMP_CLAUSE_NUM_WORKERS)
3307 : 640 : && (m = gfc_match_dupl_check (!c->num_workers_expr, "num_workers",
3308 : : true, &c->num_workers_expr))
3309 : : != MATCH_NO)
3310 : : {
3311 : 603 : if (m == MATCH_ERROR)
3312 : 4 : goto error;
3313 : 599 : continue;
3314 : : }
3315 : : break;
3316 : 587 : case 'o':
3317 : 821 : if ((mask & OMP_CLAUSE_ORDER)
3318 : 587 : && (m = gfc_match_dupl_check (!c->order_concurrent, "order ("))
3319 : : != MATCH_NO)
3320 : : {
3321 : 245 : if (m == MATCH_ERROR)
3322 : 8 : goto error;
3323 : 237 : if (gfc_match (" reproducible : concurrent )") == MATCH_YES)
3324 : 55 : c->order_reproducible = true;
3325 : 182 : else if (gfc_match (" concurrent )") == MATCH_YES)
3326 : : ;
3327 : 50 : else if (gfc_match (" unconstrained : concurrent )") == MATCH_YES)
3328 : 47 : c->order_unconstrained = true;
3329 : : else
3330 : : {
3331 : 3 : gfc_error ("Expected ORDER(CONCURRENT) at %C "
3332 : : "with optional %<reproducible%> or "
3333 : : "%<unconstrained%> modifier");
3334 : 3 : goto error;
3335 : : }
3336 : 234 : c->order_concurrent = true;
3337 : 234 : continue;
3338 : : }
3339 : 342 : if ((mask & OMP_CLAUSE_ORDERED)
3340 : 342 : && (m = gfc_match_dupl_check (!c->ordered, "ordered"))
3341 : : != MATCH_NO)
3342 : : {
3343 : 339 : if (m == MATCH_ERROR)
3344 : 0 : goto error;
3345 : 339 : gfc_expr *cexpr = NULL;
3346 : 339 : m = gfc_match (" ( %e )", &cexpr);
3347 : :
3348 : 339 : c->ordered = true;
3349 : 339 : if (m == MATCH_YES)
3350 : : {
3351 : 140 : int ordered = 0;
3352 : 140 : if (gfc_extract_int (cexpr, &ordered, -1))
3353 : 0 : ordered = 0;
3354 : 140 : else if (ordered <= 0)
3355 : : {
3356 : 0 : gfc_error_now ("ORDERED clause argument not"
3357 : : " constant positive integer at %C");
3358 : 0 : ordered = 0;
3359 : : }
3360 : 140 : c->orderedc = ordered;
3361 : 140 : gfc_free_expr (cexpr);
3362 : 140 : continue;
3363 : 140 : }
3364 : :
3365 : 199 : needs_space = true;
3366 : 199 : continue;
3367 : 199 : }
3368 : : break;
3369 : 2462 : case 'p':
3370 : 2527 : if ((mask & OMP_CLAUSE_COPY)
3371 : 814 : && gfc_match ("pcopy ( ") == MATCH_YES
3372 : 2528 : && gfc_match_omp_map_clause (&c->lists[OMP_LIST_MAP],
3373 : : OMP_MAP_TOFROM, true, allow_derived))
3374 : 65 : continue;
3375 : 2469 : if ((mask & OMP_CLAUSE_COPYIN)
3376 : 1646 : && gfc_match ("pcopyin ( ") == MATCH_YES
3377 : 2469 : && gfc_match_omp_map_clause (&c->lists[OMP_LIST_MAP],
3378 : : OMP_MAP_TO, true, allow_derived))
3379 : 72 : continue;
3380 : 2395 : if ((mask & OMP_CLAUSE_COPYOUT)
3381 : 678 : && gfc_match ("pcopyout ( ") == MATCH_YES
3382 : 2395 : && gfc_match_omp_map_clause (&c->lists[OMP_LIST_MAP],
3383 : : OMP_MAP_FROM, true, allow_derived))
3384 : 70 : continue;
3385 : 2268 : if ((mask & OMP_CLAUSE_CREATE)
3386 : 618 : && gfc_match ("pcreate ( ") == MATCH_YES
3387 : 2268 : && gfc_match_omp_map_clause (&c->lists[OMP_LIST_MAP],
3388 : : OMP_MAP_ALLOC, true, allow_derived))
3389 : 13 : continue;
3390 : 2655 : if ((mask & OMP_CLAUSE_PRESENT)
3391 : 595 : && gfc_match ("present ( ") == MATCH_YES
3392 : 2657 : && gfc_match_omp_map_clause (&c->lists[OMP_LIST_MAP],
3393 : : OMP_MAP_FORCE_PRESENT, false,
3394 : : allow_derived))
3395 : 413 : continue;
3396 : 1851 : if ((mask & OMP_CLAUSE_COPY)
3397 : 182 : && gfc_match ("present_or_copy ( ") == MATCH_YES
3398 : 1851 : && gfc_match_omp_map_clause (&c->lists[OMP_LIST_MAP],
3399 : : OMP_MAP_TOFROM, true,
3400 : : allow_derived))
3401 : 22 : continue;
3402 : 1846 : if ((mask & OMP_CLAUSE_COPYIN)
3403 : 1056 : && gfc_match ("present_or_copyin ( ") == MATCH_YES
3404 : 1846 : && gfc_match_omp_map_clause (&c->lists[OMP_LIST_MAP],
3405 : : OMP_MAP_TO, true, allow_derived))
3406 : 39 : continue;
3407 : 1802 : if ((mask & OMP_CLAUSE_COPYOUT)
3408 : 126 : && gfc_match ("present_or_copyout ( ") == MATCH_YES
3409 : 1802 : && gfc_match_omp_map_clause (&c->lists[OMP_LIST_MAP],
3410 : : OMP_MAP_FROM, true, allow_derived))
3411 : 34 : continue;
3412 : 1761 : if ((mask & OMP_CLAUSE_CREATE)
3413 : 97 : && gfc_match ("present_or_create ( ") == MATCH_YES
3414 : 1761 : && gfc_match_omp_map_clause (&c->lists[OMP_LIST_MAP],
3415 : : OMP_MAP_ALLOC, true, allow_derived))
3416 : 27 : continue;
3417 : 1741 : if ((mask & OMP_CLAUSE_PRIORITY)
3418 : 1707 : && (m = gfc_match_dupl_check (!c->priority, "priority", true,
3419 : : &c->priority)) != MATCH_NO)
3420 : : {
3421 : 34 : if (m == MATCH_ERROR)
3422 : 0 : goto error;
3423 : 34 : continue;
3424 : : }
3425 : 3273 : if ((mask & OMP_CLAUSE_PRIVATE)
3426 : 1673 : && gfc_match_omp_variable_list ("private (",
3427 : : &c->lists[OMP_LIST_PRIVATE],
3428 : : true) == MATCH_YES)
3429 : 1600 : continue;
3430 : 137 : if ((mask & OMP_CLAUSE_PROC_BIND)
3431 : 137 : && (m = gfc_match_dupl_check ((c->proc_bind
3432 : 64 : == OMP_PROC_BIND_UNKNOWN),
3433 : : "proc_bind", true)) != MATCH_NO)
3434 : : {
3435 : 64 : if (m == MATCH_ERROR)
3436 : 0 : goto error;
3437 : 64 : if (gfc_match ("primary )") == MATCH_YES)
3438 : 1 : c->proc_bind = OMP_PROC_BIND_PRIMARY;
3439 : 63 : else if (gfc_match ("master )") == MATCH_YES)
3440 : 9 : c->proc_bind = OMP_PROC_BIND_MASTER;
3441 : 54 : else if (gfc_match ("spread )") == MATCH_YES)
3442 : 53 : c->proc_bind = OMP_PROC_BIND_SPREAD;
3443 : 1 : else if (gfc_match ("close )") == MATCH_YES)
3444 : 1 : c->proc_bind = OMP_PROC_BIND_CLOSE;
3445 : : else
3446 : 0 : goto error;
3447 : 64 : continue;
3448 : : }
3449 : : break;
3450 : 4216 : case 'r':
3451 : 4706 : if ((mask & OMP_CLAUSE_ATOMIC)
3452 : 4216 : && (m = gfc_match_dupl_atomic ((c->atomic_op
3453 : : == GFC_OMP_ATOMIC_UNSET),
3454 : : "read")) != MATCH_NO)
3455 : : {
3456 : 490 : if (m == MATCH_ERROR)
3457 : 0 : goto error;
3458 : 490 : c->atomic_op = GFC_OMP_ATOMIC_READ;
3459 : 490 : needs_space = true;
3460 : 490 : continue;
3461 : : }
3462 : 7417 : if ((mask & OMP_CLAUSE_REDUCTION)
3463 : 3726 : && gfc_match_omp_clause_reduction (pc, c, openacc,
3464 : : allow_derived) == MATCH_YES)
3465 : 3691 : continue;
3466 : 45 : if ((mask & OMP_CLAUSE_MEMORDER)
3467 : 63 : && (m = gfc_match_dupl_memorder ((c->memorder
3468 : 28 : == OMP_MEMORDER_UNSET),
3469 : : "relaxed")) != MATCH_NO)
3470 : : {
3471 : 10 : if (m == MATCH_ERROR)
3472 : 0 : goto error;
3473 : 10 : c->memorder = OMP_MEMORDER_RELAXED;
3474 : 10 : needs_space = true;
3475 : 10 : continue;
3476 : : }
3477 : 42 : if ((mask & OMP_CLAUSE_MEMORDER)
3478 : 43 : && (m = gfc_match_dupl_memorder ((c->memorder
3479 : 18 : == OMP_MEMORDER_UNSET),
3480 : : "release")) != MATCH_NO)
3481 : : {
3482 : 18 : if (m == MATCH_ERROR)
3483 : 1 : goto error;
3484 : 17 : c->memorder = OMP_MEMORDER_RELEASE;
3485 : 17 : needs_space = true;
3486 : 17 : continue;
3487 : : }
3488 : : break;
3489 : 2741 : case 's':
3490 : 2834 : if ((mask & OMP_CLAUSE_SAFELEN)
3491 : 2741 : && (m = gfc_match_dupl_check (!c->safelen_expr, "safelen",
3492 : : true, &c->safelen_expr))
3493 : : != MATCH_NO)
3494 : : {
3495 : 93 : if (m == MATCH_ERROR)
3496 : 0 : goto error;
3497 : 93 : continue;
3498 : : }
3499 : 2648 : if ((mask & OMP_CLAUSE_SCHEDULE)
3500 : 2648 : && (m = gfc_match_dupl_check (c->sched_kind == OMP_SCHED_NONE,
3501 : : "schedule", true)) != MATCH_NO)
3502 : : {
3503 : 775 : if (m == MATCH_ERROR)
3504 : 0 : goto error;
3505 : 775 : int nmodifiers = 0;
3506 : 775 : locus old_loc2 = gfc_current_locus;
3507 : 793 : do
3508 : : {
3509 : 784 : if (gfc_match ("simd") == MATCH_YES)
3510 : : {
3511 : 18 : c->sched_simd = true;
3512 : 18 : nmodifiers++;
3513 : : }
3514 : 766 : else if (gfc_match ("monotonic") == MATCH_YES)
3515 : : {
3516 : 30 : c->sched_monotonic = true;
3517 : 30 : nmodifiers++;
3518 : : }
3519 : 736 : else if (gfc_match ("nonmonotonic") == MATCH_YES)
3520 : : {
3521 : 35 : c->sched_nonmonotonic = true;
3522 : 35 : nmodifiers++;
3523 : : }
3524 : : else
3525 : : {
3526 : 701 : if (nmodifiers)
3527 : 0 : gfc_current_locus = old_loc2;
3528 : : break;
3529 : : }
3530 : 92 : if (nmodifiers == 1
3531 : 83 : && gfc_match (" , ") == MATCH_YES)
3532 : 9 : continue;
3533 : 74 : else if (gfc_match (" : ") == MATCH_YES)
3534 : : break;
3535 : 0 : gfc_current_locus = old_loc2;
3536 : 0 : break;
3537 : : }
3538 : : while (1);
3539 : 775 : if (gfc_match ("static") == MATCH_YES)
3540 : 405 : c->sched_kind = OMP_SCHED_STATIC;
3541 : 370 : else if (gfc_match ("dynamic") == MATCH_YES)
3542 : 164 : c->sched_kind = OMP_SCHED_DYNAMIC;
3543 : 206 : else if (gfc_match ("guided") == MATCH_YES)
3544 : 113 : c->sched_kind = OMP_SCHED_GUIDED;
3545 : 93 : else if (gfc_match ("runtime") == MATCH_YES)
3546 : 85 : c->sched_kind = OMP_SCHED_RUNTIME;
3547 : 8 : else if (gfc_match ("auto") == MATCH_YES)
3548 : 8 : c->sched_kind = OMP_SCHED_AUTO;
3549 : 775 : if (c->sched_kind != OMP_SCHED_NONE)
3550 : : {
3551 : 775 : m = MATCH_NO;
3552 : 775 : if (c->sched_kind != OMP_SCHED_RUNTIME
3553 : 690 : && c->sched_kind != OMP_SCHED_AUTO)
3554 : 682 : m = gfc_match (" , %e )", &c->chunk_size);
3555 : 682 : if (m != MATCH_YES)
3556 : 271 : m = gfc_match_char (')');
3557 : 271 : if (m != MATCH_YES)
3558 : 0 : c->sched_kind = OMP_SCHED_NONE;
3559 : : }
3560 : 775 : if (c->sched_kind != OMP_SCHED_NONE)
3561 : 775 : continue;
3562 : : else
3563 : 0 : gfc_current_locus = old_loc;
3564 : : }
3565 : 2055 : if ((mask & OMP_CLAUSE_SELF)
3566 : 311 : && !(mask & OMP_CLAUSE_HOST) /* OpenACC compute construct */
3567 : 2089 : && (m = gfc_match_dupl_check (!c->self_expr, "self"))
3568 : : != MATCH_NO)
3569 : : {
3570 : 185 : if (m == MATCH_ERROR)
3571 : 3 : goto error;
3572 : 182 : m = gfc_match (" ( %e )", &c->self_expr);
3573 : 182 : if (m == MATCH_ERROR)
3574 : : {
3575 : 0 : gfc_current_locus = old_loc;
3576 : 0 : break;
3577 : : }
3578 : 182 : else if (m == MATCH_NO)
3579 : : {
3580 : 8 : c->self_expr = gfc_get_logical_expr (gfc_default_logical_kind,
3581 : : NULL, true);
3582 : 8 : needs_space = true;
3583 : : }
3584 : 182 : continue;
3585 : : }
3586 : 1782 : if ((mask & OMP_CLAUSE_SELF)
3587 : 126 : && (mask & OMP_CLAUSE_HOST) /* OpenACC 'update' directive */
3588 : 95 : && gfc_match ("self ( ") == MATCH_YES
3589 : 1783 : && gfc_match_omp_map_clause (&c->lists[OMP_LIST_MAP],
3590 : : OMP_MAP_FORCE_FROM, true,
3591 : : /* allow_derived = */ true))
3592 : 94 : continue;
3593 : 1911 : if ((mask & OMP_CLAUSE_SEQ)
3594 : 1594 : && (m = gfc_match_dupl_check (!c->seq, "seq")) != MATCH_NO)
3595 : : {
3596 : 317 : if (m == MATCH_ERROR)
3597 : 0 : goto error;
3598 : 317 : c->seq = true;
3599 : 317 : needs_space = true;
3600 : 317 : continue;
3601 : : }
3602 : 1418 : if ((mask & OMP_CLAUSE_MEMORDER)
3603 : 1418 : && (m = gfc_match_dupl_memorder ((c->memorder
3604 : 141 : == OMP_MEMORDER_UNSET),
3605 : : "seq_cst")) != MATCH_NO)
3606 : : {
3607 : 141 : if (m == MATCH_ERROR)
3608 : 0 : goto error;
3609 : 141 : c->memorder = OMP_MEMORDER_SEQ_CST;
3610 : 141 : needs_space = true;
3611 : 141 : continue;
3612 : : }
3613 : 2086 : if ((mask & OMP_CLAUSE_SHARED)
3614 : 1136 : && gfc_match_omp_variable_list ("shared (",
3615 : : &c->lists[OMP_LIST_SHARED],
3616 : : true) == MATCH_YES)
3617 : 950 : continue;
3618 : 304 : if ((mask & OMP_CLAUSE_SIMDLEN)
3619 : 186 : && (m = gfc_match_dupl_check (!c->simdlen_expr, "simdlen", true,
3620 : : &c->simdlen_expr)) != MATCH_NO)
3621 : : {
3622 : 118 : if (m == MATCH_ERROR)
3623 : 0 : goto error;
3624 : 118 : continue;
3625 : : }
3626 : 90 : if ((mask & OMP_CLAUSE_SIMD)
3627 : 68 : && (m = gfc_match_dupl_check (!c->simd, "simd")) != MATCH_NO)
3628 : : {
3629 : 22 : if (m == MATCH_ERROR)
3630 : 0 : goto error;
3631 : 22 : c->simd = needs_space = true;
3632 : 22 : continue;
3633 : : }
3634 : 85 : if ((mask & OMP_CLAUSE_SEVERITY)
3635 : 46 : && (m = gfc_match_dupl_check (!c->severity, "severity", true))
3636 : : != MATCH_NO)
3637 : : {
3638 : 45 : if (m == MATCH_ERROR)
3639 : 2 : goto error;
3640 : 43 : if (gfc_match ("fatal )") == MATCH_YES)
3641 : 10 : c->severity = OMP_SEVERITY_FATAL;
3642 : 33 : else if (gfc_match ("warning )") == MATCH_YES)
3643 : 29 : c->severity = OMP_SEVERITY_WARNING;
3644 : : else
3645 : : {
3646 : 4 : gfc_error ("Expected FATAL or WARNING in SEVERITY clause "
3647 : : "at %C");
3648 : 4 : goto error;
3649 : : }
3650 : 39 : continue;
3651 : : }
3652 : : break;
3653 : 1169 : case 't':
3654 : 1234 : if ((mask & OMP_CLAUSE_TASK_REDUCTION)
3655 : 1169 : && gfc_match_omp_clause_reduction (pc, c, openacc,
3656 : : allow_derived) == MATCH_YES)
3657 : 65 : continue;
3658 : 1176 : if ((mask & OMP_CLAUSE_THREAD_LIMIT)
3659 : 1104 : && (m = gfc_match_dupl_check (!c->thread_limit, "thread_limit",
3660 : : true, &c->thread_limit))
3661 : : != MATCH_NO)
3662 : : {
3663 : 72 : if (m == MATCH_ERROR)
3664 : 0 : goto error;
3665 : 72 : continue;
3666 : : }
3667 : 1045 : if ((mask & OMP_CLAUSE_THREADS)
3668 : 1032 : && (m = gfc_match_dupl_check (!c->threads, "threads"))
3669 : : != MATCH_NO)
3670 : : {
3671 : 13 : if (m == MATCH_ERROR)
3672 : 0 : goto error;
3673 : 13 : c->threads = needs_space = true;
3674 : 13 : continue;
3675 : : }
3676 : 1189 : if ((mask & OMP_CLAUSE_TILE)
3677 : 190 : && !c->tile_list
3678 : 1209 : && match_oacc_expr_list ("tile (", &c->tile_list,
3679 : : true) == MATCH_YES)
3680 : 170 : continue;
3681 : 849 : if ((mask & OMP_CLAUSE_TO) && (mask & OMP_CLAUSE_LINK))
3682 : : {
3683 : : /* Declare target: 'to' is an alias for 'enter';
3684 : : 'to' is deprecated since 5.2. */
3685 : 109 : m = gfc_match_omp_to_link ("to (", &c->lists[OMP_LIST_TO]);
3686 : 109 : if (m == MATCH_ERROR)
3687 : 0 : goto error;
3688 : 109 : if (m == MATCH_YES)
3689 : 109 : continue;
3690 : : }
3691 : 1460 : else if ((mask & OMP_CLAUSE_TO)
3692 : 740 : && gfc_match_motion_var_list ("to (", &c->lists[OMP_LIST_TO],
3693 : : &head) == MATCH_YES)
3694 : 720 : continue;
3695 : : break;
3696 : 1484 : case 'u':
3697 : 1547 : if ((mask & OMP_CLAUSE_UNIFORM)
3698 : 1484 : && gfc_match_omp_variable_list ("uniform (",
3699 : : &c->lists[OMP_LIST_UNIFORM],
3700 : : false) == MATCH_YES)
3701 : 63 : continue;
3702 : 1562 : if ((mask & OMP_CLAUSE_UNTIED)
3703 : 1421 : && (m = gfc_match_dupl_check (!c->untied, "untied")) != MATCH_NO)
3704 : : {
3705 : 141 : if (m == MATCH_ERROR)
3706 : 0 : goto error;
3707 : 141 : c->untied = needs_space = true;
3708 : 141 : continue;
3709 : : }
3710 : 1521 : if ((mask & OMP_CLAUSE_ATOMIC)
3711 : 1280 : && (m = gfc_match_dupl_atomic ((c->atomic_op
3712 : : == GFC_OMP_ATOMIC_UNSET),
3713 : : "update")) != MATCH_NO)
3714 : : {
3715 : 242 : if (m == MATCH_ERROR)
3716 : 1 : goto error;
3717 : 241 : c->atomic_op = GFC_OMP_ATOMIC_UPDATE;
3718 : 241 : needs_space = true;
3719 : 241 : continue;
3720 : : }
3721 : 1098 : if ((mask & OMP_CLAUSE_USE_DEVICE)
3722 : 1038 : && gfc_match_omp_variable_list ("use_device (",
3723 : : &c->lists[OMP_LIST_USE_DEVICE],
3724 : : true) == MATCH_YES)
3725 : 60 : continue;
3726 : 1139 : if ((mask & OMP_CLAUSE_USE_DEVICE_PTR)
3727 : 1904 : && gfc_match_omp_variable_list
3728 : 926 : ("use_device_ptr (",
3729 : : &c->lists[OMP_LIST_USE_DEVICE_PTR], false) == MATCH_YES)
3730 : 161 : continue;
3731 : 1582 : if ((mask & OMP_CLAUSE_USE_DEVICE_ADDR)
3732 : 1582 : && gfc_match_omp_variable_list
3733 : 765 : ("use_device_addr (", &c->lists[OMP_LIST_USE_DEVICE_ADDR],
3734 : : false, NULL, NULL, true) == MATCH_YES)
3735 : 765 : continue;
3736 : 95 : if ((mask & OMP_CLAUSE_USES_ALLOCATORS)
3737 : 52 : && (gfc_match ("uses_allocators ( ") == MATCH_YES))
3738 : : {
3739 : 47 : if (gfc_match_omp_clause_uses_allocators (c) != MATCH_YES)
3740 : 4 : goto error;
3741 : 43 : continue;
3742 : : }
3743 : : break;
3744 : 1516 : case 'v':
3745 : : /* VECTOR_LENGTH must be matched before VECTOR, because the latter
3746 : : doesn't unconditionally match '('. */
3747 : 2085 : if ((mask & OMP_CLAUSE_VECTOR_LENGTH)
3748 : 1516 : && (m = gfc_match_dupl_check (!c->vector_length_expr,
3749 : : "vector_length", true,
3750 : : &c->vector_length_expr))
3751 : : != MATCH_NO)
3752 : : {
3753 : 573 : if (m == MATCH_ERROR)
3754 : 4 : goto error;
3755 : 569 : continue;
3756 : : }
3757 : 1881 : if ((mask & OMP_CLAUSE_VECTOR)
3758 : 943 : && (m = gfc_match_dupl_check (!c->vector, "vector")) != MATCH_NO)
3759 : : {
3760 : 941 : if (m == MATCH_ERROR)
3761 : 0 : goto error;
3762 : 941 : c->vector = true;
3763 : 941 : m = match_oacc_clause_gwv (c, GOMP_DIM_VECTOR);
3764 : 941 : if (m == MATCH_ERROR)
3765 : 3 : goto error;
3766 : 938 : if (m == MATCH_NO)
3767 : 810 : needs_space = true;
3768 : 938 : continue;
3769 : : }
3770 : : break;
3771 : 1422 : case 'w':
3772 : 1422 : if ((mask & OMP_CLAUSE_WAIT)
3773 : 1422 : && gfc_match ("wait") == MATCH_YES)
3774 : : {
3775 : 187 : m = match_oacc_expr_list (" (", &c->wait_list, false);
3776 : 187 : if (m == MATCH_ERROR)
3777 : 9 : goto error;
3778 : 178 : else if (m == MATCH_NO)
3779 : : {
3780 : 47 : gfc_expr *expr
3781 : 47 : = gfc_get_constant_expr (BT_INTEGER,
3782 : : gfc_default_integer_kind,
3783 : : &gfc_current_locus);
3784 : 47 : mpz_set_si (expr->value.integer, GOMP_ASYNC_NOVAL);
3785 : 47 : gfc_expr_list **expr_list = &c->wait_list;
3786 : 103 : while (*expr_list)
3787 : 9 : expr_list = &(*expr_list)->next;
3788 : 47 : *expr_list = gfc_get_expr_list ();
3789 : 47 : (*expr_list)->expr = expr;
3790 : 47 : needs_space = true;
3791 : : }
3792 : 178 : continue;
3793 : 178 : }
3794 : 1248 : if ((mask & OMP_CLAUSE_WEAK)
3795 : 1235 : && (m = gfc_match_dupl_check (!c->weak, "weak"))
3796 : : != MATCH_NO)
3797 : : {
3798 : 14 : if (m == MATCH_ERROR)
3799 : 1 : goto error;
3800 : 13 : c->weak = true;
3801 : 13 : needs_space = true;
3802 : 13 : continue;
3803 : : }
3804 : 2027 : if ((mask & OMP_CLAUSE_WORKER)
3805 : 1221 : && (m = gfc_match_dupl_check (!c->worker, "worker")) != MATCH_NO)
3806 : : {
3807 : 809 : if (m == MATCH_ERROR)
3808 : 0 : goto error;
3809 : 809 : c->worker = true;
3810 : 809 : m = match_oacc_clause_gwv (c, GOMP_DIM_WORKER);
3811 : 809 : if (m == MATCH_ERROR)
3812 : 3 : goto error;
3813 : 806 : else if (m == MATCH_NO)
3814 : 709 : needs_space = true;
3815 : 806 : continue;
3816 : : }
3817 : 824 : if ((mask & OMP_CLAUSE_ATOMIC)
3818 : 412 : && (m = gfc_match_dupl_atomic ((c->atomic_op
3819 : : == GFC_OMP_ATOMIC_UNSET),
3820 : : "write")) != MATCH_NO)
3821 : : {
3822 : 412 : if (m == MATCH_ERROR)
3823 : 0 : goto error;
3824 : 412 : c->atomic_op = GFC_OMP_ATOMIC_WRITE;
3825 : 412 : needs_space = true;
3826 : 412 : continue;
3827 : : }
3828 : : break;
3829 : : }
3830 : : break;
3831 : 42345 : }
3832 : :
3833 : 31046 : end:
3834 : 31046 : if (error
3835 : 30868 : || (context_selector && gfc_peek_ascii_char () != ')')
3836 : 30853 : || (!context_selector && gfc_match_omp_eos () != MATCH_YES))
3837 : : {
3838 : 417 : if (!gfc_error_flag_test ())
3839 : 121 : gfc_error ("Failed to match clause at %C");
3840 : 417 : gfc_free_omp_clauses (c);
3841 : 417 : return MATCH_ERROR;
3842 : : }
3843 : :
3844 : 30629 : *cp = c;
3845 : 30629 : return MATCH_YES;
3846 : :
3847 : 178 : error:
3848 : 178 : error = true;
3849 : 178 : goto end;
3850 : : }
3851 : :
3852 : :
3853 : : #define OACC_PARALLEL_CLAUSES \
3854 : : (omp_mask (OMP_CLAUSE_IF) | OMP_CLAUSE_ASYNC | OMP_CLAUSE_NUM_GANGS \
3855 : : | OMP_CLAUSE_NUM_WORKERS | OMP_CLAUSE_VECTOR_LENGTH | OMP_CLAUSE_REDUCTION \
3856 : : | OMP_CLAUSE_COPY | OMP_CLAUSE_COPYIN | OMP_CLAUSE_COPYOUT \
3857 : : | OMP_CLAUSE_CREATE | OMP_CLAUSE_NO_CREATE | OMP_CLAUSE_PRESENT \
3858 : : | OMP_CLAUSE_DEVICEPTR | OMP_CLAUSE_PRIVATE | OMP_CLAUSE_FIRSTPRIVATE \
3859 : : | OMP_CLAUSE_DEFAULT | OMP_CLAUSE_WAIT | OMP_CLAUSE_ATTACH \
3860 : : | OMP_CLAUSE_SELF)
3861 : : #define OACC_KERNELS_CLAUSES \
3862 : : (omp_mask (OMP_CLAUSE_IF) | OMP_CLAUSE_ASYNC | OMP_CLAUSE_NUM_GANGS \
3863 : : | OMP_CLAUSE_NUM_WORKERS | OMP_CLAUSE_VECTOR_LENGTH | OMP_CLAUSE_DEVICEPTR \
3864 : : | OMP_CLAUSE_COPY | OMP_CLAUSE_COPYIN | OMP_CLAUSE_COPYOUT \
3865 : : | OMP_CLAUSE_CREATE | OMP_CLAUSE_NO_CREATE | OMP_CLAUSE_PRESENT \
3866 : : | OMP_CLAUSE_DEFAULT | OMP_CLAUSE_WAIT | OMP_CLAUSE_ATTACH \
3867 : : | OMP_CLAUSE_SELF)
3868 : : #define OACC_SERIAL_CLAUSES \
3869 : : (omp_mask (OMP_CLAUSE_IF) | OMP_CLAUSE_ASYNC | OMP_CLAUSE_REDUCTION \
3870 : : | OMP_CLAUSE_COPY | OMP_CLAUSE_COPYIN | OMP_CLAUSE_COPYOUT \
3871 : : | OMP_CLAUSE_CREATE | OMP_CLAUSE_NO_CREATE | OMP_CLAUSE_PRESENT \
3872 : : | OMP_CLAUSE_DEVICEPTR | OMP_CLAUSE_PRIVATE | OMP_CLAUSE_FIRSTPRIVATE \
3873 : : | OMP_CLAUSE_DEFAULT | OMP_CLAUSE_WAIT | OMP_CLAUSE_ATTACH \
3874 : : | OMP_CLAUSE_SELF)
3875 : : #define OACC_DATA_CLAUSES \
3876 : : (omp_mask (OMP_CLAUSE_IF) | OMP_CLAUSE_DEVICEPTR | OMP_CLAUSE_COPY \
3877 : : | OMP_CLAUSE_COPYIN | OMP_CLAUSE_COPYOUT | OMP_CLAUSE_CREATE \
3878 : : | OMP_CLAUSE_NO_CREATE | OMP_CLAUSE_PRESENT | OMP_CLAUSE_ATTACH \
3879 : : | OMP_CLAUSE_DEFAULT)
3880 : : #define OACC_LOOP_CLAUSES \
3881 : : (omp_mask (OMP_CLAUSE_COLLAPSE) | OMP_CLAUSE_GANG | OMP_CLAUSE_WORKER \
3882 : : | OMP_CLAUSE_VECTOR | OMP_CLAUSE_SEQ | OMP_CLAUSE_INDEPENDENT \
3883 : : | OMP_CLAUSE_PRIVATE | OMP_CLAUSE_REDUCTION | OMP_CLAUSE_AUTO \
3884 : : | OMP_CLAUSE_TILE)
3885 : : #define OACC_PARALLEL_LOOP_CLAUSES \
3886 : : (OACC_LOOP_CLAUSES | OACC_PARALLEL_CLAUSES)
3887 : : #define OACC_KERNELS_LOOP_CLAUSES \
3888 : : (OACC_LOOP_CLAUSES | OACC_KERNELS_CLAUSES)
3889 : : #define OACC_SERIAL_LOOP_CLAUSES \
3890 : : (OACC_LOOP_CLAUSES | OACC_SERIAL_CLAUSES)
3891 : : #define OACC_HOST_DATA_CLAUSES \
3892 : : (omp_mask (OMP_CLAUSE_USE_DEVICE) \
3893 : : | OMP_CLAUSE_IF \
3894 : : | OMP_CLAUSE_IF_PRESENT)
3895 : : #define OACC_DECLARE_CLAUSES \
3896 : : (omp_mask (OMP_CLAUSE_COPY) | OMP_CLAUSE_COPYIN | OMP_CLAUSE_COPYOUT \
3897 : : | OMP_CLAUSE_CREATE | OMP_CLAUSE_DEVICEPTR | OMP_CLAUSE_DEVICE_RESIDENT \
3898 : : | OMP_CLAUSE_PRESENT \
3899 : : | OMP_CLAUSE_LINK)
3900 : : #define OACC_UPDATE_CLAUSES \
3901 : : (omp_mask (OMP_CLAUSE_IF) | OMP_CLAUSE_ASYNC | OMP_CLAUSE_HOST \
3902 : : | OMP_CLAUSE_DEVICE | OMP_CLAUSE_WAIT | OMP_CLAUSE_IF_PRESENT \
3903 : : | OMP_CLAUSE_SELF)
3904 : : #define OACC_ENTER_DATA_CLAUSES \
3905 : : (omp_mask (OMP_CLAUSE_IF) | OMP_CLAUSE_ASYNC | OMP_CLAUSE_WAIT \
3906 : : | OMP_CLAUSE_COPYIN | OMP_CLAUSE_CREATE | OMP_CLAUSE_ATTACH)
3907 : : #define OACC_EXIT_DATA_CLAUSES \
3908 : : (omp_mask (OMP_CLAUSE_IF) | OMP_CLAUSE_ASYNC | OMP_CLAUSE_WAIT \
3909 : : | OMP_CLAUSE_COPYOUT | OMP_CLAUSE_DELETE | OMP_CLAUSE_FINALIZE \
3910 : : | OMP_CLAUSE_DETACH)
3911 : : #define OACC_WAIT_CLAUSES \
3912 : : omp_mask (OMP_CLAUSE_ASYNC)
3913 : : #define OACC_ROUTINE_CLAUSES \
3914 : : (omp_mask (OMP_CLAUSE_GANG) | OMP_CLAUSE_WORKER | OMP_CLAUSE_VECTOR \
3915 : : | OMP_CLAUSE_SEQ \
3916 : : | OMP_CLAUSE_NOHOST)
3917 : :
3918 : :
3919 : : static match
3920 : 10862 : match_acc (gfc_exec_op op, const omp_mask mask)
3921 : : {
3922 : 10862 : gfc_omp_clauses *c;
3923 : 10862 : if (gfc_match_omp_clauses (&c, mask, false, false, true) != MATCH_YES)
3924 : : return MATCH_ERROR;
3925 : 10696 : new_st.op = op;
3926 : 10696 : new_st.ext.omp_clauses = c;
3927 : 10696 : return MATCH_YES;
3928 : : }
3929 : :
3930 : : match
3931 : 1377 : gfc_match_oacc_parallel_loop (void)
3932 : : {
3933 : 1377 : return match_acc (EXEC_OACC_PARALLEL_LOOP, OACC_PARALLEL_LOOP_CLAUSES);
3934 : : }
3935 : :
3936 : :
3937 : : match
3938 : 2951 : gfc_match_oacc_parallel (void)
3939 : : {
3940 : 2951 : return match_acc (EXEC_OACC_PARALLEL, OACC_PARALLEL_CLAUSES);
3941 : : }
3942 : :
3943 : :
3944 : : match
3945 : 128 : gfc_match_oacc_kernels_loop (void)
3946 : : {
3947 : 128 : return match_acc (EXEC_OACC_KERNELS_LOOP, OACC_KERNELS_LOOP_CLAUSES);
3948 : : }
3949 : :
3950 : :
3951 : : match
3952 : 896 : gfc_match_oacc_kernels (void)
3953 : : {
3954 : 896 : return match_acc (EXEC_OACC_KERNELS, OACC_KERNELS_CLAUSES);
3955 : : }
3956 : :
3957 : :
3958 : : match
3959 : 4 : gfc_match_oacc_serial_loop (void)
3960 : : {
3961 : 4 : return match_acc (EXEC_OACC_SERIAL_LOOP, OACC_SERIAL_LOOP_CLAUSES);
3962 : : }
3963 : :
3964 : :
3965 : : match
3966 : 70 : gfc_match_oacc_serial (void)
3967 : : {
3968 : 70 : return match_acc (EXEC_OACC_SERIAL, OACC_SERIAL_CLAUSES);
3969 : : }
3970 : :
3971 : :
3972 : : match
3973 : 658 : gfc_match_oacc_data (void)
3974 : : {
3975 : 658 : return match_acc (EXEC_OACC_DATA, OACC_DATA_CLAUSES);
3976 : : }
3977 : :
3978 : :
3979 : : match
3980 : 65 : gfc_match_oacc_host_data (void)
3981 : : {
3982 : 65 : return match_acc (EXEC_OACC_HOST_DATA, OACC_HOST_DATA_CLAUSES);
3983 : : }
3984 : :
3985 : :
3986 : : match
3987 : 3274 : gfc_match_oacc_loop (void)
3988 : : {
3989 : 3274 : return match_acc (EXEC_OACC_LOOP, OACC_LOOP_CLAUSES);
3990 : : }
3991 : :
3992 : :
3993 : : match
3994 : 172 : gfc_match_oacc_declare (void)
3995 : : {
3996 : 172 : gfc_omp_clauses *c;
3997 : 172 : gfc_omp_namelist *n;
3998 : 172 : gfc_namespace *ns = gfc_current_ns;
3999 : 172 : gfc_oacc_declare *new_oc;
4000 : 172 : bool module_var = false;
4001 : 172 : locus where = gfc_current_locus;
4002 : :
4003 : 172 : if (gfc_match_omp_clauses (&c, OACC_DECLARE_CLAUSES, false, false, true)
4004 : : != MATCH_YES)
4005 : : return MATCH_ERROR;
4006 : :
4007 : 254 : for (n = c->lists[OMP_LIST_DEVICE_RESIDENT]; n != NULL; n = n->next)
4008 : 88 : n->sym->attr.oacc_declare_device_resident = 1;
4009 : :
4010 : 186 : for (n = c->lists[OMP_LIST_LINK]; n != NULL; n = n->next)
4011 : 20 : n->sym->attr.oacc_declare_link = 1;
4012 : :
4013 : 301 : for (n = c->lists[OMP_LIST_MAP]; n != NULL; n = n->next)
4014 : : {
4015 : 145 : gfc_symbol *s = n->sym;
4016 : :
4017 : 145 : if (gfc_current_ns->proc_name
4018 : 145 : && gfc_current_ns->proc_name->attr.flavor == FL_MODULE)
4019 : : {
4020 : 48 : if (n->u.map.op != OMP_MAP_ALLOC && n->u.map.op != OMP_MAP_TO)
4021 : : {
4022 : 6 : gfc_error ("Invalid clause in module with !$ACC DECLARE at %L",
4023 : : &where);
4024 : 6 : return MATCH_ERROR;
4025 : : }
4026 : :
4027 : : module_var = true;
4028 : : }
4029 : :
4030 : 139 : if (s->attr.use_assoc)
4031 : : {
4032 : 0 : gfc_error ("Variable is USE-associated with !$ACC DECLARE at %L",
4033 : : &where);
4034 : 0 : return MATCH_ERROR;
4035 : : }
4036 : :
4037 : 139 : if ((s->result == s && s->ns->contained != gfc_current_ns)
4038 : 139 : || ((s->attr.flavor == FL_UNKNOWN || s->attr.flavor == FL_VARIABLE)
4039 : 129 : && s->ns != gfc_current_ns))
4040 : : {
4041 : 2 : gfc_error ("Variable %qs shall be declared in the same scoping unit "
4042 : : "as !$ACC DECLARE at %L", s->name, &where);
4043 : 2 : return MATCH_ERROR;
4044 : : }
4045 : :
4046 : 137 : if ((s->attr.dimension || s->attr.codimension)
4047 : 73 : && s->attr.dummy && s->as->type != AS_EXPLICIT)
4048 : : {
4049 : 2 : gfc_error ("Assumed-size dummy array with !$ACC DECLARE at %L",
4050 : : &where);
4051 : 2 : return MATCH_ERROR;
4052 : : }
4053 : :
4054 : 135 : switch (n->u.map.op)
4055 : : {
4056 : 49 : case OMP_MAP_FORCE_ALLOC:
4057 : 49 : case OMP_MAP_ALLOC:
4058 : 49 : s->attr.oacc_declare_create = 1;
4059 : 49 : break;
4060 : :
4061 : 52 : case OMP_MAP_FORCE_TO:
4062 : 52 : case OMP_MAP_TO:
4063 : 52 : s->attr.oacc_declare_copyin = 1;
4064 : 52 : break;
4065 : :
4066 : 1 : case OMP_MAP_FORCE_DEVICEPTR:
4067 : 1 : s->attr.oacc_declare_deviceptr = 1;
4068 : 1 : break;
4069 : :
4070 : : default:
4071 : : break;
4072 : : }
4073 : : }
4074 : :
4075 : 156 : new_oc = gfc_get_oacc_declare ();
4076 : 156 : new_oc->next = ns->oacc_declare;
4077 : 156 : new_oc->module_var = module_var;
4078 : 156 : new_oc->clauses = c;
4079 : 156 : new_oc->loc = gfc_current_locus;
4080 : 156 : ns->oacc_declare = new_oc;
4081 : :
4082 : 156 : return MATCH_YES;
4083 : : }
4084 : :
4085 : :
4086 : : match
4087 : 760 : gfc_match_oacc_update (void)
4088 : : {
4089 : 760 : gfc_omp_clauses *c;
4090 : 760 : locus here = gfc_current_locus;
4091 : :
4092 : 760 : if (gfc_match_omp_clauses (&c, OACC_UPDATE_CLAUSES, false, false, true)
4093 : : != MATCH_YES)
4094 : : return MATCH_ERROR;
4095 : :
4096 : 756 : if (!c->lists[OMP_LIST_MAP])
4097 : : {
4098 : 1 : gfc_error ("%<acc update%> must contain at least one "
4099 : : "%<device%> or %<host%> or %<self%> clause at %L", &here);
4100 : 1 : return MATCH_ERROR;
4101 : : }
4102 : :
4103 : 755 : new_st.op = EXEC_OACC_UPDATE;
4104 : 755 : new_st.ext.omp_clauses = c;
4105 : 755 : return MATCH_YES;
4106 : : }
4107 : :
4108 : :
4109 : : match
4110 : 857 : gfc_match_oacc_enter_data (void)
4111 : : {
4112 : 857 : return match_acc (EXEC_OACC_ENTER_DATA, OACC_ENTER_DATA_CLAUSES);
4113 : : }
4114 : :
4115 : :
4116 : : match
4117 : 582 : gfc_match_oacc_exit_data (void)
4118 : : {
4119 : 582 : return match_acc (EXEC_OACC_EXIT_DATA, OACC_EXIT_DATA_CLAUSES);
4120 : : }
4121 : :
4122 : :
4123 : : match
4124 : 197 : gfc_match_oacc_wait (void)
4125 : : {
4126 : 197 : gfc_omp_clauses *c = gfc_get_omp_clauses ();
4127 : 197 : gfc_expr_list *wait_list = NULL, *el;
4128 : 197 : bool space = true;
4129 : 197 : match m;
4130 : :
4131 : 197 : m = match_oacc_expr_list (" (", &wait_list, true);
4132 : 197 : if (m == MATCH_ERROR)
4133 : : return m;
4134 : 191 : else if (m == MATCH_YES)
4135 : 120 : space = false;
4136 : :
4137 : 191 : if (gfc_match_omp_clauses (&c, OACC_WAIT_CLAUSES, space, space, true)
4138 : : == MATCH_ERROR)
4139 : : return MATCH_ERROR;
4140 : :
4141 : 178 : if (wait_list)
4142 : 249 : for (el = wait_list; el; el = el->next)
4143 : : {
4144 : 134 : if (el->expr == NULL)
4145 : : {
4146 : 2 : gfc_error ("Invalid argument to !$ACC WAIT at %C");
4147 : 2 : return MATCH_ERROR;
4148 : : }
4149 : :
4150 : 132 : if (!gfc_resolve_expr (el->expr)
4151 : 132 : || el->expr->ts.type != BT_INTEGER || el->expr->rank != 0)
4152 : : {
4153 : 3 : gfc_error ("WAIT clause at %L requires a scalar INTEGER expression",
4154 : 3 : &el->expr->where);
4155 : :
4156 : 3 : return MATCH_ERROR;
4157 : : }
4158 : : }
4159 : 173 : c->wait_list = wait_list;
4160 : 173 : new_st.op = EXEC_OACC_WAIT;
4161 : 173 : new_st.ext.omp_clauses = c;
4162 : 173 : return MATCH_YES;
4163 : : }
4164 : :
4165 : :
4166 : : match
4167 : 90 : gfc_match_oacc_cache (void)
4168 : : {
4169 : 90 : bool readonly = false;
4170 : 90 : gfc_omp_clauses *c = gfc_get_omp_clauses ();
4171 : : /* The OpenACC cache directive explicitly only allows "array elements or
4172 : : subarrays", which we're currently not checking here. Either check this
4173 : : after the call of gfc_match_omp_variable_list, or add something like a
4174 : : only_sections variant next to its allow_sections parameter. */
4175 : 90 : match m = gfc_match (" ( ");
4176 : 90 : if (m != MATCH_YES)
4177 : : {
4178 : 0 : gfc_free_omp_clauses(c);
4179 : 0 : return m;
4180 : : }
4181 : :
4182 : 90 : if (gfc_match ("readonly : ") == MATCH_YES)
4183 : 8 : readonly = true;
4184 : :
4185 : 90 : gfc_omp_namelist **head = NULL;
4186 : 90 : m = gfc_match_omp_variable_list ("", &c->lists[OMP_LIST_CACHE], true,
4187 : : NULL, &head, true);
4188 : 90 : if (m != MATCH_YES)
4189 : : {
4190 : 1 : gfc_free_omp_clauses(c);
4191 : 1 : return m;
4192 : : }
4193 : :
4194 : 89 : if (readonly)
4195 : 24 : for (gfc_omp_namelist *n = *head; n; n = n->next)
4196 : 16 : n->u.map.readonly = true;
4197 : :
4198 : 89 : if (gfc_current_state() != COMP_DO
4199 : 56 : && gfc_current_state() != COMP_DO_CONCURRENT)
4200 : : {
4201 : 2 : gfc_error ("ACC CACHE directive must be inside of loop %C");
4202 : 2 : gfc_free_omp_clauses(c);
4203 : 2 : return MATCH_ERROR;
4204 : : }
4205 : :
4206 : 87 : new_st.op = EXEC_OACC_CACHE;
4207 : 87 : new_st.ext.omp_clauses = c;
4208 : 87 : return MATCH_YES;
4209 : : }
4210 : :
4211 : : /* Determine the OpenACC 'routine' directive's level of parallelism. */
4212 : :
4213 : : static oacc_routine_lop
4214 : 716 : gfc_oacc_routine_lop (gfc_omp_clauses *clauses)
4215 : : {
4216 : 716 : oacc_routine_lop ret = OACC_ROUTINE_LOP_SEQ;
4217 : :
4218 : 716 : if (clauses)
4219 : : {
4220 : 568 : unsigned n_lop_clauses = 0;
4221 : :
4222 : 568 : if (clauses->gang)
4223 : : {
4224 : 160 : ++n_lop_clauses;
4225 : 160 : ret = OACC_ROUTINE_LOP_GANG;
4226 : : }
4227 : 568 : if (clauses->worker)
4228 : : {
4229 : 110 : ++n_lop_clauses;
4230 : 110 : ret = OACC_ROUTINE_LOP_WORKER;
4231 : : }
4232 : 568 : if (clauses->vector)
4233 : : {
4234 : 112 : ++n_lop_clauses;
4235 : 112 : ret = OACC_ROUTINE_LOP_VECTOR;
4236 : : }
4237 : 568 : if (clauses->seq)
4238 : : {
4239 : 202 : ++n_lop_clauses;
4240 : 202 : ret = OACC_ROUTINE_LOP_SEQ;
4241 : : }
4242 : :
4243 : 568 : if (n_lop_clauses > 1)
4244 : 47 : ret = OACC_ROUTINE_LOP_ERROR;
4245 : : }
4246 : :
4247 : 716 : return ret;
4248 : : }
4249 : :
4250 : : match
4251 : 680 : gfc_match_oacc_routine (void)
4252 : : {
4253 : 680 : locus old_loc;
4254 : 680 : match m;
4255 : 680 : gfc_intrinsic_sym *isym = NULL;
4256 : 680 : gfc_symbol *sym = NULL;
4257 : 680 : gfc_omp_clauses *c = NULL;
4258 : 680 : gfc_oacc_routine_name *n = NULL;
4259 : 680 : oacc_routine_lop lop = OACC_ROUTINE_LOP_NONE;
4260 : 680 : bool nohost;
4261 : :
4262 : 680 : old_loc = gfc_current_locus;
4263 : :
4264 : 680 : m = gfc_match (" (");
4265 : :
4266 : 680 : if (gfc_current_ns->proc_name
4267 : 678 : && gfc_current_ns->proc_name->attr.if_source == IFSRC_IFBODY
4268 : 90 : && m == MATCH_YES)
4269 : : {
4270 : 3 : gfc_error ("Only the !$ACC ROUTINE form without "
4271 : : "list is allowed in interface block at %C");
4272 : 3 : goto cleanup;
4273 : : }
4274 : :
4275 : 590 : if (m == MATCH_YES)
4276 : : {
4277 : 279 : char buffer[GFC_MAX_SYMBOL_LEN + 1];
4278 : :
4279 : 279 : m = gfc_match_name (buffer);
4280 : 279 : if (m == MATCH_YES)
4281 : : {
4282 : 278 : gfc_symtree *st = NULL;
4283 : :
4284 : : /* First look for an intrinsic symbol. */
4285 : 278 : isym = gfc_find_function (buffer);
4286 : 278 : if (!isym)
4287 : 278 : isym = gfc_find_subroutine (buffer);
4288 : : /* If no intrinsic symbol found, search the current namespace. */
4289 : 278 : if (!isym)
4290 : 260 : st = gfc_find_symtree (gfc_current_ns->sym_root, buffer);
4291 : 260 : if (st)
4292 : : {
4293 : 254 : sym = st->n.sym;
4294 : : /* If the name in a 'routine' directive refers to the containing
4295 : : subroutine or function, then make sure that we'll later handle
4296 : : this accordingly. */
4297 : 254 : if (gfc_current_ns->proc_name != NULL
4298 : 254 : && strcmp (sym->name, gfc_current_ns->proc_name->name) == 0)
4299 : 278 : sym = NULL;
4300 : : }
4301 : :
4302 : 278 : if (isym == NULL && st == NULL)
4303 : : {
4304 : 6 : gfc_error ("Invalid NAME %qs in !$ACC ROUTINE ( NAME ) at %C",
4305 : : buffer);
4306 : 6 : gfc_current_locus = old_loc;
4307 : 9 : return MATCH_ERROR;
4308 : : }
4309 : : }
4310 : : else
4311 : : {
4312 : 1 : gfc_error ("Syntax error in !$ACC ROUTINE ( NAME ) at %C");
4313 : 1 : gfc_current_locus = old_loc;
4314 : 1 : return MATCH_ERROR;
4315 : : }
4316 : :
4317 : 272 : if (gfc_match_char (')') != MATCH_YES)
4318 : : {
4319 : 2 : gfc_error ("Syntax error in !$ACC ROUTINE ( NAME ) at %C, expecting"
4320 : : " %<)%> after NAME");
4321 : 2 : gfc_current_locus = old_loc;
4322 : 2 : return MATCH_ERROR;
4323 : : }
4324 : : }
4325 : :
4326 : 668 : if (gfc_match_omp_eos () != MATCH_YES
4327 : 668 : && (gfc_match_omp_clauses (&c, OACC_ROUTINE_CLAUSES, false, false, true)
4328 : : != MATCH_YES))
4329 : : return MATCH_ERROR;
4330 : :
4331 : 665 : lop = gfc_oacc_routine_lop (c);
4332 : 665 : if (lop == OACC_ROUTINE_LOP_ERROR)
4333 : : {
4334 : 47 : gfc_error ("Multiple loop axes specified for routine at %C");
4335 : 47 : goto cleanup;
4336 : : }
4337 : 618 : nohost = c ? c->nohost : false;
4338 : :
4339 : 618 : if (isym != NULL)
4340 : : {
4341 : : /* Diagnose any OpenACC 'routine' directive that doesn't match the
4342 : : (implicit) one with a 'seq' clause. */
4343 : 16 : if (c && (c->gang || c->worker || c->vector))
4344 : : {
4345 : 10 : gfc_error ("Intrinsic symbol specified in !$ACC ROUTINE ( NAME )"
4346 : : " at %C marked with incompatible GANG, WORKER, or VECTOR"
4347 : : " clause");
4348 : 10 : goto cleanup;
4349 : : }
4350 : : /* ..., and no 'nohost' clause. */
4351 : 6 : if (nohost)
4352 : : {
4353 : 2 : gfc_error ("Intrinsic symbol specified in !$ACC ROUTINE ( NAME )"
4354 : : " at %C marked with incompatible NOHOST clause");
4355 : 2 : goto cleanup;
4356 : : }
4357 : : }
4358 : 602 : else if (sym != NULL)
4359 : : {
4360 : 135 : bool add = true;
4361 : :
4362 : : /* For a repeated OpenACC 'routine' directive, diagnose if it doesn't
4363 : : match the first one. */
4364 : 135 : for (gfc_oacc_routine_name *n_p = gfc_current_ns->oacc_routine_names;
4365 : 306 : n_p;
4366 : 171 : n_p = n_p->next)
4367 : 211 : if (n_p->sym == sym)
4368 : : {
4369 : 51 : add = false;
4370 : 51 : bool nohost_p = n_p->clauses ? n_p->clauses->nohost : false;
4371 : 51 : if (lop != gfc_oacc_routine_lop (n_p->clauses)
4372 : 51 : || nohost != nohost_p)
4373 : : {
4374 : 40 : gfc_error ("!$ACC ROUTINE already applied at %C");
4375 : 40 : goto cleanup;
4376 : : }
4377 : : }
4378 : :
4379 : 95 : if (add)
4380 : : {
4381 : 84 : sym->attr.oacc_routine_lop = lop;
4382 : 84 : sym->attr.oacc_routine_nohost = nohost;
4383 : :
4384 : 84 : n = gfc_get_oacc_routine_name ();
4385 : 84 : n->sym = sym;
4386 : 84 : n->clauses = c;
4387 : 84 : n->next = gfc_current_ns->oacc_routine_names;
4388 : 84 : n->loc = old_loc;
4389 : 84 : gfc_current_ns->oacc_routine_names = n;
4390 : : }
4391 : : }
4392 : 467 : else if (gfc_current_ns->proc_name)
4393 : : {
4394 : : /* For a repeated OpenACC 'routine' directive, diagnose if it doesn't
4395 : : match the first one. */
4396 : 466 : oacc_routine_lop lop_p = gfc_current_ns->proc_name->attr.oacc_routine_lop;
4397 : 466 : bool nohost_p = gfc_current_ns->proc_name->attr.oacc_routine_nohost;
4398 : 466 : if (lop_p != OACC_ROUTINE_LOP_NONE
4399 : 86 : && (lop != lop_p
4400 : 86 : || nohost != nohost_p))
4401 : : {
4402 : 56 : gfc_error ("!$ACC ROUTINE already applied at %C");
4403 : 56 : goto cleanup;
4404 : : }
4405 : :
4406 : 410 : if (!gfc_add_omp_declare_target (&gfc_current_ns->proc_name->attr,
4407 : : gfc_current_ns->proc_name->name,
4408 : : &old_loc))
4409 : 1 : goto cleanup;
4410 : 409 : gfc_current_ns->proc_name->attr.oacc_routine_lop = lop;
4411 : 409 : gfc_current_ns->proc_name->attr.oacc_routine_nohost = nohost;
4412 : : }
4413 : : else
4414 : : /* Something has gone wrong, possibly a syntax error. */
4415 : 1 : goto cleanup;
4416 : :
4417 : 508 : if (gfc_pure (NULL) && c && (c->gang || c->worker || c->vector))
4418 : : {
4419 : 6 : gfc_error ("!$ACC ROUTINE with GANG, WORKER, or VECTOR clause is not "
4420 : : "permitted in PURE procedure at %C");
4421 : 6 : goto cleanup;
4422 : : }
4423 : :
4424 : :
4425 : 502 : if (n)
4426 : 84 : n->clauses = c;
4427 : 418 : else if (gfc_current_ns->oacc_routine)
4428 : 0 : gfc_current_ns->oacc_routine_clauses = c;
4429 : :
4430 : 502 : new_st.op = EXEC_OACC_ROUTINE;
4431 : 502 : new_st.ext.omp_clauses = c;
4432 : 502 : return MATCH_YES;
4433 : :
4434 : 166 : cleanup:
4435 : 166 : gfc_current_locus = old_loc;
4436 : 166 : return MATCH_ERROR;
4437 : : }
4438 : :
4439 : :
4440 : : #define OMP_PARALLEL_CLAUSES \
4441 : : (omp_mask (OMP_CLAUSE_PRIVATE) | OMP_CLAUSE_FIRSTPRIVATE \
4442 : : | OMP_CLAUSE_SHARED | OMP_CLAUSE_COPYIN | OMP_CLAUSE_REDUCTION \
4443 : : | OMP_CLAUSE_IF | OMP_CLAUSE_NUM_THREADS | OMP_CLAUSE_DEFAULT \
4444 : : | OMP_CLAUSE_PROC_BIND | OMP_CLAUSE_ALLOCATE)
4445 : : #define OMP_DECLARE_SIMD_CLAUSES \
4446 : : (omp_mask (OMP_CLAUSE_SIMDLEN) | OMP_CLAUSE_LINEAR \
4447 : : | OMP_CLAUSE_UNIFORM | OMP_CLAUSE_ALIGNED | OMP_CLAUSE_INBRANCH \
4448 : : | OMP_CLAUSE_NOTINBRANCH)
4449 : : #define OMP_DO_CLAUSES \
4450 : : (omp_mask (OMP_CLAUSE_PRIVATE) | OMP_CLAUSE_FIRSTPRIVATE \
4451 : : | OMP_CLAUSE_LASTPRIVATE | OMP_CLAUSE_REDUCTION \
4452 : : | OMP_CLAUSE_SCHEDULE | OMP_CLAUSE_ORDERED | OMP_CLAUSE_COLLAPSE \
4453 : : | OMP_CLAUSE_LINEAR | OMP_CLAUSE_ORDER | OMP_CLAUSE_ALLOCATE \
4454 : : | OMP_CLAUSE_NOWAIT)
4455 : : #define OMP_LOOP_CLAUSES \
4456 : : (omp_mask (OMP_CLAUSE_BIND) | OMP_CLAUSE_COLLAPSE | OMP_CLAUSE_ORDER \
4457 : : | OMP_CLAUSE_PRIVATE | OMP_CLAUSE_LASTPRIVATE | OMP_CLAUSE_REDUCTION)
4458 : :
4459 : : #define OMP_SCOPE_CLAUSES \
4460 : : (omp_mask (OMP_CLAUSE_PRIVATE) |OMP_CLAUSE_FIRSTPRIVATE \
4461 : : | OMP_CLAUSE_REDUCTION | OMP_CLAUSE_ALLOCATE | OMP_CLAUSE_NOWAIT)
4462 : : #define OMP_SECTIONS_CLAUSES \
4463 : : (omp_mask (OMP_CLAUSE_PRIVATE) | OMP_CLAUSE_FIRSTPRIVATE \
4464 : : | OMP_CLAUSE_LASTPRIVATE | OMP_CLAUSE_REDUCTION \
4465 : : | OMP_CLAUSE_ALLOCATE | OMP_CLAUSE_NOWAIT)
4466 : : #define OMP_SIMD_CLAUSES \
4467 : : (omp_mask (OMP_CLAUSE_PRIVATE) | OMP_CLAUSE_LASTPRIVATE \
4468 : : | OMP_CLAUSE_REDUCTION | OMP_CLAUSE_COLLAPSE | OMP_CLAUSE_SAFELEN \
4469 : : | OMP_CLAUSE_LINEAR | OMP_CLAUSE_ALIGNED | OMP_CLAUSE_SIMDLEN \
4470 : : | OMP_CLAUSE_IF | OMP_CLAUSE_ORDER | OMP_CLAUSE_NOTEMPORAL)
4471 : : #define OMP_TASK_CLAUSES \
4472 : : (omp_mask (OMP_CLAUSE_PRIVATE) | OMP_CLAUSE_FIRSTPRIVATE \
4473 : : | OMP_CLAUSE_SHARED | OMP_CLAUSE_IF | OMP_CLAUSE_DEFAULT \
4474 : : | OMP_CLAUSE_UNTIED | OMP_CLAUSE_FINAL | OMP_CLAUSE_MERGEABLE \
4475 : : | OMP_CLAUSE_DEPEND | OMP_CLAUSE_PRIORITY | OMP_CLAUSE_IN_REDUCTION \
4476 : : | OMP_CLAUSE_DETACH | OMP_CLAUSE_AFFINITY | OMP_CLAUSE_ALLOCATE)
4477 : : #define OMP_TASKLOOP_CLAUSES \
4478 : : (omp_mask (OMP_CLAUSE_PRIVATE) | OMP_CLAUSE_FIRSTPRIVATE \
4479 : : | OMP_CLAUSE_LASTPRIVATE | OMP_CLAUSE_SHARED | OMP_CLAUSE_IF \
4480 : : | OMP_CLAUSE_DEFAULT | OMP_CLAUSE_UNTIED | OMP_CLAUSE_FINAL \
4481 : : | OMP_CLAUSE_MERGEABLE | OMP_CLAUSE_PRIORITY | OMP_CLAUSE_GRAINSIZE \
4482 : : | OMP_CLAUSE_NUM_TASKS | OMP_CLAUSE_COLLAPSE | OMP_CLAUSE_NOGROUP \
4483 : : | OMP_CLAUSE_REDUCTION | OMP_CLAUSE_IN_REDUCTION | OMP_CLAUSE_ALLOCATE)
4484 : : #define OMP_TASKGROUP_CLAUSES \
4485 : : (omp_mask (OMP_CLAUSE_TASK_REDUCTION) | OMP_CLAUSE_ALLOCATE)
4486 : : #define OMP_TARGET_CLAUSES \
4487 : : (omp_mask (OMP_CLAUSE_DEVICE) | OMP_CLAUSE_MAP | OMP_CLAUSE_IF \
4488 : : | OMP_CLAUSE_DEPEND | OMP_CLAUSE_NOWAIT | OMP_CLAUSE_PRIVATE \
4489 : : | OMP_CLAUSE_FIRSTPRIVATE | OMP_CLAUSE_DEFAULTMAP \
4490 : : | OMP_CLAUSE_IS_DEVICE_PTR | OMP_CLAUSE_IN_REDUCTION \
4491 : : | OMP_CLAUSE_THREAD_LIMIT | OMP_CLAUSE_ALLOCATE \
4492 : : | OMP_CLAUSE_HAS_DEVICE_ADDR | OMP_CLAUSE_USES_ALLOCATORS)
4493 : : #define OMP_TARGET_DATA_CLAUSES \
4494 : : (omp_mask (OMP_CLAUSE_DEVICE) | OMP_CLAUSE_MAP | OMP_CLAUSE_IF \
4495 : : | OMP_CLAUSE_USE_DEVICE_PTR | OMP_CLAUSE_USE_DEVICE_ADDR)
4496 : : #define OMP_TARGET_ENTER_DATA_CLAUSES \
4497 : : (omp_mask (OMP_CLAUSE_DEVICE) | OMP_CLAUSE_MAP | OMP_CLAUSE_IF \
4498 : : | OMP_CLAUSE_DEPEND | OMP_CLAUSE_NOWAIT)
4499 : : #define OMP_TARGET_EXIT_DATA_CLAUSES \
4500 : : (omp_mask (OMP_CLAUSE_DEVICE) | OMP_CLAUSE_MAP | OMP_CLAUSE_IF \
4501 : : | OMP_CLAUSE_DEPEND | OMP_CLAUSE_NOWAIT)
4502 : : #define OMP_TARGET_UPDATE_CLAUSES \
4503 : : (omp_mask (OMP_CLAUSE_DEVICE) | OMP_CLAUSE_IF | OMP_CLAUSE_TO \
4504 : : | OMP_CLAUSE_FROM | OMP_CLAUSE_DEPEND | OMP_CLAUSE_NOWAIT)
4505 : : #define OMP_TEAMS_CLAUSES \
4506 : : (omp_mask (OMP_CLAUSE_NUM_TEAMS) | OMP_CLAUSE_THREAD_LIMIT \
4507 : : | OMP_CLAUSE_DEFAULT | OMP_CLAUSE_PRIVATE | OMP_CLAUSE_FIRSTPRIVATE \
4508 : : | OMP_CLAUSE_SHARED | OMP_CLAUSE_REDUCTION | OMP_CLAUSE_ALLOCATE)
4509 : : #define OMP_DISTRIBUTE_CLAUSES \
4510 : : (omp_mask (OMP_CLAUSE_PRIVATE) | OMP_CLAUSE_FIRSTPRIVATE \
4511 : : | OMP_CLAUSE_LASTPRIVATE | OMP_CLAUSE_COLLAPSE | OMP_CLAUSE_DIST_SCHEDULE \
4512 : : | OMP_CLAUSE_ORDER | OMP_CLAUSE_ALLOCATE)
4513 : : #define OMP_SINGLE_CLAUSES \
4514 : : (omp_mask (OMP_CLAUSE_PRIVATE) | OMP_CLAUSE_FIRSTPRIVATE \
4515 : : | OMP_CLAUSE_ALLOCATE | OMP_CLAUSE_NOWAIT | OMP_CLAUSE_COPYPRIVATE)
4516 : : #define OMP_ORDERED_CLAUSES \
4517 : : (omp_mask (OMP_CLAUSE_THREADS) | OMP_CLAUSE_SIMD)
4518 : : #define OMP_DECLARE_TARGET_CLAUSES \
4519 : : (omp_mask (OMP_CLAUSE_ENTER) | OMP_CLAUSE_LINK | OMP_CLAUSE_DEVICE_TYPE \
4520 : : | OMP_CLAUSE_TO | OMP_CLAUSE_INDIRECT)
4521 : : #define OMP_ATOMIC_CLAUSES \
4522 : : (omp_mask (OMP_CLAUSE_ATOMIC) | OMP_CLAUSE_CAPTURE | OMP_CLAUSE_HINT \
4523 : : | OMP_CLAUSE_MEMORDER | OMP_CLAUSE_COMPARE | OMP_CLAUSE_FAIL \
4524 : : | OMP_CLAUSE_WEAK)
4525 : : #define OMP_MASKED_CLAUSES \
4526 : : (omp_mask (OMP_CLAUSE_FILTER))
4527 : : #define OMP_ERROR_CLAUSES \
4528 : : (omp_mask (OMP_CLAUSE_AT) | OMP_CLAUSE_MESSAGE | OMP_CLAUSE_SEVERITY)
4529 : : #define OMP_WORKSHARE_CLAUSES \
4530 : : omp_mask (OMP_CLAUSE_NOWAIT)
4531 : : #define OMP_ALLOCATORS_CLAUSES \
4532 : : omp_mask (OMP_CLAUSE_ALLOCATE)
4533 : :
4534 : :
4535 : : static match
4536 : 14776 : match_omp (gfc_exec_op op, const omp_mask mask)
4537 : : {
4538 : 14776 : gfc_omp_clauses *c;
4539 : 14776 : if (gfc_match_omp_clauses (&c, mask, true, true, false, false,
4540 : : op == EXEC_OMP_TARGET) != MATCH_YES)
4541 : : return MATCH_ERROR;
4542 : 14591 : new_st.op = op;
4543 : 14591 : new_st.ext.omp_clauses = c;
4544 : 14591 : return MATCH_YES;
4545 : : }
4546 : :
4547 : : /* Handles both declarative and (deprecated) executable ALLOCATE directive;
4548 : : accepts optional list (for executable) and common blocks.
4549 : : If no variables have been provided, the single omp namelist has sym == NULL.
4550 : :
4551 : : Note that the executable ALLOCATE directive permits structure elements only
4552 : : in OpenMP 5.0 and 5.1 but not longer in 5.2. See also the comment on the
4553 : : 'omp allocators' directive below. The accidental change was reverted for
4554 : : OpenMP TR12, permitting them again. See also gfc_match_omp_allocators.
4555 : :
4556 : : Hence, structure elements are rejected for now, also to make resolving
4557 : : OMP_LIST_ALLOCATE simpler (check for duplicates, same symbol in
4558 : : Fortran allocate stmt). TODO: Permit structure elements. */
4559 : :
4560 : : match
4561 : 176 : gfc_match_omp_allocate (void)
4562 : : {
4563 : 176 : match m;
4564 : 176 : bool first = true;
4565 : 176 : gfc_omp_namelist *vars = NULL;
4566 : 176 : gfc_expr *align = NULL;
4567 : 176 : gfc_expr *allocator = NULL;
4568 : 176 : locus loc = gfc_current_locus;
4569 : :
4570 : 176 : m = gfc_match_omp_variable_list (" (", &vars, true, NULL, NULL, true, true,
4571 : : NULL, true);
4572 : :
4573 : 176 : if (m == MATCH_ERROR)
4574 : : return m;
4575 : :
4576 : 300 : while (true)
4577 : : {
4578 : 300 : gfc_gobble_whitespace ();
4579 : 300 : if (gfc_match_omp_eos () == MATCH_YES)
4580 : : break;
4581 : 130 : if (!first)
4582 : 21 : gfc_match (", ");
4583 : 130 : first = false;
4584 : 130 : if ((m = gfc_match_dupl_check (!align, "align", true, &align))
4585 : : != MATCH_NO)
4586 : : {
4587 : 55 : if (m == MATCH_ERROR)
4588 : 1 : goto error;
4589 : 54 : continue;
4590 : : }
4591 : 75 : if ((m = gfc_match_dupl_check (!allocator, "allocator",
4592 : : true, &allocator)) != MATCH_NO)
4593 : : {
4594 : 74 : if (m == MATCH_ERROR)
4595 : 1 : goto error;
4596 : 73 : continue;
4597 : : }
4598 : 1 : gfc_error ("Expected ALIGN or ALLOCATOR clause at %C");
4599 : 1 : return MATCH_ERROR;
4600 : : }
4601 : 342 : for (gfc_omp_namelist *n = vars; n; n = n->next)
4602 : 175 : if (n->expr)
4603 : : {
4604 : 3 : if ((n->expr->ref && n->expr->ref->type == REF_COMPONENT)
4605 : 3 : || (n->expr->ref->next && n->expr->ref->type == REF_COMPONENT))
4606 : 1 : gfc_error ("Sorry, structure-element list item at %L in ALLOCATE "
4607 : : "directive is not yet supported", &n->expr->where);
4608 : : else
4609 : 2 : gfc_error ("Unexpected expression as list item at %L in ALLOCATE "
4610 : : "directive", &n->expr->where);
4611 : :
4612 : 3 : gfc_free_omp_namelist (vars, false, true, false);
4613 : 3 : goto error;
4614 : : }
4615 : :
4616 : 167 : new_st.op = EXEC_OMP_ALLOCATE;
4617 : 167 : new_st.ext.omp_clauses = gfc_get_omp_clauses ();
4618 : 167 : if (vars == NULL)
4619 : : {
4620 : 27 : vars = gfc_get_omp_namelist ();
4621 : 27 : vars->where = loc;
4622 : 27 : vars->u.align = align;
4623 : 27 : vars->u2.allocator = allocator;
4624 : 27 : new_st.ext.omp_clauses->lists[OMP_LIST_ALLOCATE] = vars;
4625 : : }
4626 : : else
4627 : : {
4628 : 140 : new_st.ext.omp_clauses->lists[OMP_LIST_ALLOCATE] = vars;
4629 : 312 : for (; vars; vars = vars->next)
4630 : : {
4631 : 172 : vars->u.align = (align) ? gfc_copy_expr (align) : NULL;
4632 : 172 : vars->u2.allocator = allocator;
4633 : : }
4634 : 140 : gfc_free_expr (align);
4635 : : }
4636 : : return MATCH_YES;
4637 : :
4638 : 5 : error:
4639 : 5 : gfc_free_expr (align);
4640 : 5 : gfc_free_expr (allocator);
4641 : 5 : return MATCH_ERROR;
4642 : : }
4643 : :
4644 : : /* In line with OpenMP 5.2 derived-type components are rejected.
4645 : : See also comment before gfc_match_omp_allocate. */
4646 : :
4647 : : match
4648 : 25 : gfc_match_omp_allocators (void)
4649 : : {
4650 : 25 : return match_omp (EXEC_OMP_ALLOCATORS, OMP_ALLOCATORS_CLAUSES);
4651 : : }
4652 : :
4653 : :
4654 : : match
4655 : 17 : gfc_match_omp_assume (void)
4656 : : {
4657 : 17 : gfc_omp_clauses *c;
4658 : 17 : locus loc = gfc_current_locus;
4659 : 17 : if ((gfc_match_omp_clauses (&c, omp_mask (OMP_CLAUSE_ASSUMPTIONS))
4660 : : != MATCH_YES)
4661 : 17 : || (omp_verify_merge_absent_contains (ST_OMP_ASSUME, c->assume, NULL,
4662 : : &loc) != MATCH_YES))
4663 : 4 : return MATCH_ERROR;
4664 : 13 : new_st.op = EXEC_OMP_ASSUME;
4665 : 13 : new_st.ext.omp_clauses = c;
4666 : 13 : return MATCH_YES;
4667 : : }
4668 : :
4669 : :
4670 : : match
4671 : 28 : gfc_match_omp_assumes (void)
4672 : : {
4673 : 28 : gfc_omp_clauses *c;
4674 : 28 : locus loc = gfc_current_locus;
4675 : 28 : if (!gfc_current_ns->proc_name
4676 : 27 : || (gfc_current_ns->proc_name->attr.flavor != FL_MODULE
4677 : : && !gfc_current_ns->proc_name->attr.subroutine
4678 : 23 : && !gfc_current_ns->proc_name->attr.function))
4679 : : {
4680 : 2 : gfc_error ("!$OMP ASSUMES at %C must be in the specification part of a "
4681 : : "subprogram or module");
4682 : 2 : return MATCH_ERROR;
4683 : : }
4684 : 26 : if ((gfc_match_omp_clauses (&c, omp_mask (OMP_CLAUSE_ASSUMPTIONS))
4685 : : != MATCH_YES)
4686 : 26 : || (omp_verify_merge_absent_contains (ST_OMP_ASSUMES, c->assume,
4687 : : gfc_current_ns->omp_assumes, &loc)
4688 : : != MATCH_YES))
4689 : 5 : return MATCH_ERROR;
4690 : 21 : if (gfc_current_ns->omp_assumes == NULL)
4691 : : {
4692 : 19 : gfc_current_ns->omp_assumes = c->assume;
4693 : 19 : c->assume = NULL;
4694 : : }
4695 : 2 : else if (gfc_current_ns->omp_assumes && c->assume)
4696 : : {
4697 : 2 : gfc_current_ns->omp_assumes->no_openmp |= c->assume->no_openmp;
4698 : 2 : gfc_current_ns->omp_assumes->no_openmp_routines
4699 : 2 : |= c->assume->no_openmp_routines;
4700 : 2 : gfc_current_ns->omp_assumes->no_parallelism |= c->assume->no_parallelism;
4701 : 2 : if (gfc_current_ns->omp_assumes->holds && c->assume->holds)
4702 : : {
4703 : : gfc_expr_list *el = gfc_current_ns->omp_assumes->holds;
4704 : 1 : for ( ; el->next ; el = el->next)
4705 : : ;
4706 : 1 : el->next = c->assume->holds;
4707 : 1 : }
4708 : 1 : else if (c->assume->holds)
4709 : 0 : gfc_current_ns->omp_assumes->holds = c->assume->holds;
4710 : 2 : c->assume->holds = NULL;
4711 : : }
4712 : 21 : gfc_free_omp_clauses (c);
4713 : 21 : return MATCH_YES;
4714 : : }
4715 : :
4716 : :
4717 : : match
4718 : 162 : gfc_match_omp_critical (void)
4719 : : {
4720 : 162 : char n[GFC_MAX_SYMBOL_LEN+1];
4721 : 162 : gfc_omp_clauses *c = NULL;
4722 : :
4723 : 162 : if (gfc_match (" ( %n )", n) != MATCH_YES)
4724 : 115 : n[0] = '\0';
4725 : :
4726 : 162 : if (gfc_match_omp_clauses (&c, omp_mask (OMP_CLAUSE_HINT),
4727 : 162 : /* first = */ n[0] == '\0') != MATCH_YES)
4728 : : return MATCH_ERROR;
4729 : :
4730 : 160 : new_st.op = EXEC_OMP_CRITICAL;
4731 : 160 : new_st.ext.omp_clauses = c;
4732 : 160 : if (n[0])
4733 : 47 : c->critical_name = xstrdup (n);
4734 : : return MATCH_YES;
4735 : : }
4736 : :
4737 : :
4738 : : match
4739 : 160 : gfc_match_omp_end_critical (void)
4740 : : {
4741 : 160 : char n[GFC_MAX_SYMBOL_LEN+1];
4742 : :
4743 : 160 : if (gfc_match (" ( %n )", n) != MATCH_YES)
4744 : 113 : n[0] = '\0';
4745 : 160 : if (gfc_match_omp_eos () != MATCH_YES)
4746 : : {
4747 : 1 : gfc_error ("Unexpected junk after $OMP CRITICAL statement at %C");
4748 : 1 : return MATCH_ERROR;
4749 : : }
4750 : :
4751 : 159 : new_st.op = EXEC_OMP_END_CRITICAL;
4752 : 159 : new_st.ext.omp_name = n[0] ? xstrdup (n) : NULL;
4753 : 159 : return MATCH_YES;
4754 : : }
4755 : :
4756 : : /* depobj(depobj) depend(dep-type:loc)|destroy|update(dep-type)
4757 : : dep-type = in/out/inout/mutexinoutset/depobj/source/sink
4758 : : depend: !source, !sink
4759 : : update: !source, !sink, !depobj
4760 : : locator = exactly one list item .*/
4761 : : match
4762 : 123 : gfc_match_omp_depobj (void)
4763 : : {
4764 : 123 : gfc_omp_clauses *c = NULL;
4765 : 123 : gfc_expr *depobj;
4766 : :
4767 : 123 : if (gfc_match (" ( %v ) ", &depobj) != MATCH_YES)
4768 : : {
4769 : 2 : gfc_error ("Expected %<( depobj )%> at %C");
4770 : 2 : return MATCH_ERROR;
4771 : : }
4772 : 121 : if (gfc_match ("update ( ") == MATCH_YES)
4773 : : {
4774 : 12 : c = gfc_get_omp_clauses ();
4775 : 12 : if (gfc_match ("inoutset )") == MATCH_YES)
4776 : 2 : c->depobj_update = OMP_DEPEND_INOUTSET;
4777 : 10 : else if (gfc_match ("inout )") == MATCH_YES)
4778 : 1 : c->depobj_update = OMP_DEPEND_INOUT;
4779 : 9 : else if (gfc_match ("in )") == MATCH_YES)
4780 : 2 : c->depobj_update = OMP_DEPEND_IN;
4781 : 7 : else if (gfc_match ("out )") == MATCH_YES)
4782 : 2 : c->depobj_update = OMP_DEPEND_OUT;
4783 : 5 : else if (gfc_match ("mutexinoutset )") == MATCH_YES)
4784 : 2 : c->depobj_update = OMP_DEPEND_MUTEXINOUTSET;
4785 : : else
4786 : : {
4787 : 3 : gfc_error ("Expected IN, OUT, INOUT, INOUTSET or MUTEXINOUTSET "
4788 : : "followed by %<)%> at %C");
4789 : 3 : goto error;
4790 : : }
4791 : : }
4792 : 109 : else if (gfc_match ("destroy ") == MATCH_YES)
4793 : : {
4794 : 15 : gfc_expr *destroyobj = NULL;
4795 : 15 : c = gfc_get_omp_clauses ();
4796 : 15 : c->destroy = true;
4797 : :
4798 : 15 : if (gfc_match (" ( %v ) ", &destroyobj) == MATCH_YES)
4799 : : {
4800 : 3 : if (destroyobj->symtree != depobj->symtree)
4801 : 2 : gfc_warning (OPT_Wopenmp, "The same depend object should be used as"
4802 : : " DEPOBJ argument at %L and as DESTROY argument at %L",
4803 : : &depobj->where, &destroyobj->where);
4804 : 3 : gfc_free_expr (destroyobj);
4805 : : }
4806 : : }
4807 : 94 : else if (gfc_match_omp_clauses (&c, omp_mask (OMP_CLAUSE_DEPEND), true, false)
4808 : : != MATCH_YES)
4809 : 2 : goto error;
4810 : :
4811 : 116 : if (c->depobj_update == OMP_DEPEND_UNSET && !c->destroy)
4812 : : {
4813 : 92 : if (!c->doacross_source && !c->lists[OMP_LIST_DEPEND])
4814 : : {
4815 : 1 : gfc_error ("Expected DEPEND, UPDATE, or DESTROY clause at %C");
4816 : 1 : goto error;
4817 : : }
4818 : 91 : if (c->lists[OMP_LIST_DEPEND]->u.depend_doacross_op == OMP_DEPEND_DEPOBJ)
4819 : : {
4820 : 1 : gfc_error ("DEPEND clause at %L of OMP DEPOBJ construct shall not "
4821 : : "have dependence-type DEPOBJ",
4822 : : c->lists[OMP_LIST_DEPEND]
4823 : : ? &c->lists[OMP_LIST_DEPEND]->where : &gfc_current_locus);
4824 : 1 : goto error;
4825 : : }
4826 : 90 : if (c->lists[OMP_LIST_DEPEND]->next)
4827 : : {
4828 : 1 : gfc_error ("DEPEND clause at %L of OMP DEPOBJ construct shall have "
4829 : : "only a single locator",
4830 : : &c->lists[OMP_LIST_DEPEND]->next->where);
4831 : 1 : goto error;
4832 : : }
4833 : : }
4834 : :
4835 : 113 : c->depobj = depobj;
4836 : 113 : new_st.op = EXEC_OMP_DEPOBJ;
4837 : 113 : new_st.ext.omp_clauses = c;
4838 : 113 : return MATCH_YES;
4839 : :
4840 : 8 : error:
4841 : 8 : gfc_free_expr (depobj);
4842 : 8 : gfc_free_omp_clauses (c);
4843 : 8 : return MATCH_ERROR;
4844 : : }
4845 : :
4846 : : match
4847 : 57 : gfc_match_omp_distribute (void)
4848 : : {
4849 : 57 : return match_omp (EXEC_OMP_DISTRIBUTE, OMP_DISTRIBUTE_CLAUSES);
4850 : : }
4851 : :
4852 : :
4853 : : match
4854 : 36 : gfc_match_omp_distribute_parallel_do (void)
4855 : : {
4856 : 36 : return match_omp (EXEC_OMP_DISTRIBUTE_PARALLEL_DO,
4857 : 36 : (OMP_DISTRIBUTE_CLAUSES | OMP_PARALLEL_CLAUSES
4858 : 36 : | OMP_DO_CLAUSES)
4859 : 36 : & ~(omp_mask (OMP_CLAUSE_ORDERED)
4860 : 36 : | OMP_CLAUSE_LINEAR | OMP_CLAUSE_NOWAIT));
4861 : : }
4862 : :
4863 : :
4864 : : match
4865 : 34 : gfc_match_omp_distribute_parallel_do_simd (void)
4866 : : {
4867 : 34 : return match_omp (EXEC_OMP_DISTRIBUTE_PARALLEL_DO_SIMD,
4868 : 34 : (OMP_DISTRIBUTE_CLAUSES | OMP_PARALLEL_CLAUSES
4869 : 34 : | OMP_DO_CLAUSES | OMP_SIMD_CLAUSES)
4870 : 34 : & ~(omp_mask (OMP_CLAUSE_ORDERED) | OMP_CLAUSE_NOWAIT));
4871 : : }
4872 : :
4873 : :
4874 : : match
4875 : 52 : gfc_match_omp_distribute_simd (void)
4876 : : {
4877 : 52 : return match_omp (EXEC_OMP_DISTRIBUTE_SIMD,
4878 : 52 : OMP_DISTRIBUTE_CLAUSES | OMP_SIMD_CLAUSES);
4879 : : }
4880 : :
4881 : :
4882 : : match
4883 : 1155 : gfc_match_omp_do (void)
4884 : : {
4885 : 1155 : return match_omp (EXEC_OMP_DO, OMP_DO_CLAUSES);
4886 : : }
4887 : :
4888 : :
4889 : : match
4890 : 137 : gfc_match_omp_do_simd (void)
4891 : : {
4892 : 137 : return match_omp (EXEC_OMP_DO_SIMD, OMP_DO_CLAUSES | OMP_SIMD_CLAUSES);
4893 : : }
4894 : :
4895 : :
4896 : : match
4897 : 69 : gfc_match_omp_loop (void)
4898 : : {
4899 : 69 : return match_omp (EXEC_OMP_LOOP, OMP_LOOP_CLAUSES);
4900 : : }
4901 : :
4902 : :
4903 : : match
4904 : 12 : gfc_match_omp_teams_loop (void)
4905 : : {
4906 : 12 : return match_omp (EXEC_OMP_TEAMS_LOOP, OMP_TEAMS_CLAUSES | OMP_LOOP_CLAUSES);
4907 : : }
4908 : :
4909 : :
4910 : : match
4911 : 17 : gfc_match_omp_target_teams_loop (void)
4912 : : {
4913 : 17 : return match_omp (EXEC_OMP_TARGET_TEAMS_LOOP,
4914 : 17 : OMP_TARGET_CLAUSES | OMP_TEAMS_CLAUSES | OMP_LOOP_CLAUSES);
4915 : : }
4916 : :
4917 : :
4918 : : match
4919 : 15 : gfc_match_omp_parallel_loop (void)
4920 : : {
4921 : 15 : return match_omp (EXEC_OMP_PARALLEL_LOOP,
4922 : 15 : OMP_PARALLEL_CLAUSES | OMP_LOOP_CLAUSES);
4923 : : }
4924 : :
4925 : :
4926 : : match
4927 : 16 : gfc_match_omp_target_parallel_loop (void)
4928 : : {
4929 : 16 : return match_omp (EXEC_OMP_TARGET_PARALLEL_LOOP,
4930 : 16 : (OMP_TARGET_CLAUSES | OMP_PARALLEL_CLAUSES
4931 : 16 : | OMP_LOOP_CLAUSES));
4932 : : }
4933 : :
4934 : :
4935 : : match
4936 : 88 : gfc_match_omp_error (void)
4937 : : {
4938 : 88 : locus loc = gfc_current_locus;
4939 : 88 : match m = match_omp (EXEC_OMP_ERROR, OMP_ERROR_CLAUSES);
4940 : 88 : if (m != MATCH_YES)
4941 : : return m;
4942 : :
4943 : 69 : gfc_omp_clauses *c = new_st.ext.omp_clauses;
4944 : 69 : if (c->severity == OMP_SEVERITY_UNSET)
4945 : 32 : c->severity = OMP_SEVERITY_FATAL;
4946 : 69 : if (new_st.ext.omp_clauses->at == OMP_AT_EXECUTION)
4947 : : return MATCH_YES;
4948 : 36 : if (c->message
4949 : 36 : && (!gfc_resolve_expr (c->message)
4950 : 16 : || c->message->ts.type != BT_CHARACTER
4951 : 14 : || c->message->ts.kind != gfc_default_character_kind
4952 : 13 : || c->message->rank != 0))
4953 : : {
4954 : 4 : gfc_error ("MESSAGE clause at %L requires a scalar default-kind "
4955 : : "CHARACTER expression",
4956 : 4 : &new_st.ext.omp_clauses->message->where);
4957 : 4 : return MATCH_ERROR;
4958 : : }
4959 : 32 : if (c->message && !gfc_is_constant_expr (c->message))
4960 : : {
4961 : 2 : gfc_error ("Constant character expression required in MESSAGE clause "
4962 : 2 : "at %L", &new_st.ext.omp_clauses->message->where);
4963 : 2 : return MATCH_ERROR;
4964 : : }
4965 : 30 : if (c->message)
4966 : : {
4967 : 10 : const char *msg = G_("$OMP ERROR encountered at %L: %s");
4968 : 10 : gcc_assert (c->message->expr_type == EXPR_CONSTANT);
4969 : 10 : gfc_charlen_t slen = c->message->value.character.length;
4970 : 10 : int i = gfc_validate_kind (BT_CHARACTER, gfc_default_character_kind,
4971 : : false);
4972 : 10 : size_t size = slen * gfc_character_kinds[i].bit_size / 8;
4973 : 10 : unsigned char *s = XCNEWVAR (unsigned char, size + 1);
4974 : 10 : gfc_encode_character (gfc_default_character_kind, slen,
4975 : 10 : c->message->value.character.string,
4976 : : (unsigned char *) s, size);
4977 : 10 : s[size] = '\0';
4978 : 10 : if (c->severity == OMP_SEVERITY_WARNING)
4979 : 6 : gfc_warning_now (0, msg, &loc, s);
4980 : : else
4981 : 4 : gfc_error_now (msg, &loc, s);
4982 : 10 : free (s);
4983 : : }
4984 : : else
4985 : : {
4986 : 20 : const char *msg = G_("$OMP ERROR encountered at %L");
4987 : 20 : if (c->severity == OMP_SEVERITY_WARNING)
4988 : 7 : gfc_warning_now (0, msg, &loc);
4989 : : else
4990 : 13 : gfc_error_now (msg, &loc);
4991 : : }
4992 : : return MATCH_YES;
4993 : : }
4994 : :
4995 : : match
4996 : 83 : gfc_match_omp_flush (void)
4997 : : {
4998 : 83 : gfc_omp_namelist *list = NULL;
4999 : 83 : gfc_omp_clauses *c = NULL;
5000 : 83 : gfc_gobble_whitespace ();
5001 : 83 : enum gfc_omp_memorder mo = OMP_MEMORDER_UNSET;
5002 : 83 : if (gfc_match_omp_eos () == MATCH_NO && gfc_peek_ascii_char () != '(')
5003 : : {
5004 : 14 : if (gfc_match ("seq_cst") == MATCH_YES)
5005 : : mo = OMP_MEMORDER_SEQ_CST;
5006 : 11 : else if (gfc_match ("acq_rel") == MATCH_YES)
5007 : : mo = OMP_MEMORDER_ACQ_REL;
5008 : 8 : else if (gfc_match ("release") == MATCH_YES)
5009 : : mo = OMP_MEMORDER_RELEASE;
5010 : 5 : else if (gfc_match ("acquire") == MATCH_YES)
5011 : : mo = OMP_MEMORDER_ACQUIRE;
5012 : : else
5013 : : {
5014 : 2 : gfc_error ("Expected SEQ_CST, AQC_REL, RELEASE, or ACQUIRE at %C");
5015 : 2 : return MATCH_ERROR;
5016 : : }
5017 : 12 : c = gfc_get_omp_clauses ();
5018 : 12 : c->memorder = mo;
5019 : : }
5020 : 81 : gfc_match_omp_variable_list (" (", &list, true);
5021 : 81 : if (list && mo != OMP_MEMORDER_UNSET)
5022 : : {
5023 : 4 : gfc_error ("List specified together with memory order clause in FLUSH "
5024 : : "directive at %C");
5025 : 4 : gfc_free_omp_namelist (list, false, false, false);
5026 : 4 : gfc_free_omp_clauses (c);
5027 : 4 : return MATCH_ERROR;
5028 : : }
5029 : 77 : if (gfc_match_omp_eos () != MATCH_YES)
5030 : : {
5031 : 0 : gfc_error ("Unexpected junk after $OMP FLUSH statement at %C");
5032 : 0 : gfc_free_omp_namelist (list, false, false, false);
5033 : 0 : gfc_free_omp_clauses (c);
5034 : 0 : return MATCH_ERROR;
5035 : : }
5036 : 77 : new_st.op = EXEC_OMP_FLUSH;
5037 : 77 : new_st.ext.omp_namelist = list;
5038 : 77 : new_st.ext.omp_clauses = c;
5039 : 77 : return MATCH_YES;
5040 : : }
5041 : :
5042 : :
5043 : : match
5044 : 193 : gfc_match_omp_declare_simd (void)
5045 : : {
5046 : 193 : locus where = gfc_current_locus;
5047 : 193 : gfc_symbol *proc_name;
5048 : 193 : gfc_omp_clauses *c;
5049 : 193 : gfc_omp_declare_simd *ods;
5050 : 193 : bool needs_space = false;
5051 : :
5052 : 193 : switch (gfc_match (" ( "))
5053 : : {
5054 : 149 : case MATCH_YES:
5055 : 149 : if (gfc_match_symbol (&proc_name, /* host assoc = */ true) != MATCH_YES
5056 : 149 : || gfc_match (" ) ") != MATCH_YES)
5057 : 0 : return MATCH_ERROR;
5058 : : break;
5059 : 44 : case MATCH_NO: proc_name = NULL; needs_space = true; break;
5060 : : case MATCH_ERROR: return MATCH_ERROR;
5061 : : }
5062 : :
5063 : 193 : if (gfc_match_omp_clauses (&c, OMP_DECLARE_SIMD_CLAUSES, true,
5064 : : needs_space) != MATCH_YES)
5065 : : return MATCH_ERROR;
5066 : :
5067 : 188 : if (gfc_current_ns->is_block_data)
5068 : : {
5069 : 1 : gfc_free_omp_clauses (c);
5070 : 1 : return MATCH_YES;
5071 : : }
5072 : :
5073 : 187 : ods = gfc_get_omp_declare_simd ();
5074 : 187 : ods->where = where;
5075 : 187 : ods->proc_name = proc_name;
5076 : 187 : ods->clauses = c;
5077 : 187 : ods->next = gfc_current_ns->omp_declare_simd;
5078 : 187 : gfc_current_ns->omp_declare_simd = ods;
5079 : 187 : return MATCH_YES;
5080 : : }
5081 : :
5082 : :
5083 : : static bool
5084 : 877 : match_udr_expr (gfc_symtree *omp_sym1, gfc_symtree *omp_sym2)
5085 : : {
5086 : 877 : match m;
5087 : 877 : locus old_loc = gfc_current_locus;
5088 : 877 : char sname[GFC_MAX_SYMBOL_LEN + 1];
5089 : 877 : gfc_symbol *sym;
5090 : 877 : gfc_namespace *ns = gfc_current_ns;
5091 : 877 : gfc_expr *lvalue = NULL, *rvalue = NULL;
5092 : 877 : gfc_symtree *st;
5093 : 877 : gfc_actual_arglist *arglist;
5094 : :
5095 : 877 : m = gfc_match (" %v =", &lvalue);
5096 : 877 : if (m != MATCH_YES)
5097 : 200 : gfc_current_locus = old_loc;
5098 : : else
5099 : : {
5100 : 677 : m = gfc_match (" %e )", &rvalue);
5101 : 677 : if (m == MATCH_YES)
5102 : : {
5103 : 675 : ns->code = gfc_get_code (EXEC_ASSIGN);
5104 : 675 : ns->code->expr1 = lvalue;
5105 : 675 : ns->code->expr2 = rvalue;
5106 : 675 : ns->code->loc = old_loc;
5107 : 675 : return true;
5108 : : }
5109 : :
5110 : 2 : gfc_current_locus = old_loc;
5111 : 2 : gfc_free_expr (lvalue);
5112 : : }
5113 : :
5114 : 202 : m = gfc_match (" %n", sname);
5115 : 202 : if (m != MATCH_YES)
5116 : : return false;
5117 : :
5118 : 202 : if (strcmp (sname, omp_sym1->name) == 0
5119 : 200 : || strcmp (sname, omp_sym2->name) == 0)
5120 : : return false;
5121 : :
5122 : 200 : gfc_current_ns = ns->parent;
5123 : 200 : if (gfc_get_ha_sym_tree (sname, &st))
5124 : : return false;
5125 : :
5126 : 200 : sym = st->n.sym;
5127 : 200 : if (sym->attr.flavor != FL_PROCEDURE
5128 : 72 : && sym->attr.flavor != FL_UNKNOWN)
5129 : : return false;
5130 : :
5131 : 199 : if (!sym->attr.generic
5132 : : && !sym->attr.subroutine
5133 : 199 : && !sym->attr.function)
5134 : : {
5135 : 71 : if (!(sym->attr.external && !sym->attr.referenced))
5136 : : {
5137 : : /* ...create a symbol in this scope... */
5138 : 71 : if (sym->ns != gfc_current_ns
5139 : 71 : && gfc_get_sym_tree (sname, NULL, &st, false) == 1)
5140 : : return false;
5141 : :
5142 : 71 : if (sym != st->n.sym)
5143 : 71 : sym = st->n.sym;
5144 : : }
5145 : :
5146 : : /* ...and then to try to make the symbol into a subroutine. */
5147 : 71 : if (!gfc_add_subroutine (&sym->attr, sym->name, NULL))
5148 : : return false;
5149 : : }
5150 : :
5151 : 199 : gfc_set_sym_referenced (sym);
5152 : 199 : gfc_gobble_whitespace ();
5153 : 199 : if (gfc_peek_ascii_char () != '(')
5154 : : return false;
5155 : :
5156 : 195 : gfc_current_ns = ns;
5157 : 195 : m = gfc_match_actual_arglist (1, &arglist);
5158 : 195 : if (m != MATCH_YES)
5159 : : return false;
5160 : :
5161 : 195 : if (gfc_match_char (')') != MATCH_YES)
5162 : : return false;
5163 : :
5164 : 195 : ns->code = gfc_get_code (EXEC_CALL);
5165 : 195 : ns->code->symtree = st;
5166 : 195 : ns->code->ext.actual = arglist;
5167 : 195 : ns->code->loc = old_loc;
5168 : 195 : return true;
5169 : : }
5170 : :
5171 : : static bool
5172 : 1156 : gfc_omp_udr_predef (gfc_omp_reduction_op rop, const char *name,
5173 : : gfc_typespec *ts, const char **n)
5174 : : {
5175 : 1156 : if (!gfc_numeric_ts (ts) && ts->type != BT_LOGICAL)
5176 : : return false;
5177 : :
5178 : 648 : switch (rop)
5179 : : {
5180 : 21 : case OMP_REDUCTION_PLUS:
5181 : 21 : case OMP_REDUCTION_MINUS:
5182 : 21 : case OMP_REDUCTION_TIMES:
5183 : 21 : return ts->type != BT_LOGICAL;
5184 : 8 : case OMP_REDUCTION_AND:
5185 : 8 : case OMP_REDUCTION_OR:
5186 : 8 : case OMP_REDUCTION_EQV:
5187 : 8 : case OMP_REDUCTION_NEQV:
5188 : 8 : return ts->type == BT_LOGICAL;
5189 : 618 : case OMP_REDUCTION_USER:
5190 : 618 : if (name[0] != '.' && (ts->type == BT_INTEGER || ts->type == BT_REAL))
5191 : : {
5192 : 546 : gfc_symbol *sym;
5193 : :
5194 : 546 : gfc_find_symbol (name, NULL, 1, &sym);
5195 : 546 : if (sym != NULL)
5196 : : {
5197 : 93 : if (sym->attr.intrinsic)
5198 : 0 : *n = sym->name;
5199 : 93 : else if ((sym->attr.flavor != FL_UNKNOWN
5200 : 81 : && sym->attr.flavor != FL_PROCEDURE)
5201 : : || sym->attr.external
5202 : 69 : || sym->attr.generic
5203 : 54 : || sym->attr.entry
5204 : : || sym->attr.result
5205 : : || sym->attr.dummy
5206 : : || sym->attr.subroutine
5207 : : || sym->attr.pointer
5208 : 54 : || sym->attr.target
5209 : : || sym->attr.cray_pointer
5210 : 50 : || sym->attr.cray_pointee
5211 : 50 : || (sym->attr.proc != PROC_UNKNOWN
5212 : 0 : && sym->attr.proc != PROC_INTRINSIC)
5213 : 50 : || sym->attr.if_source != IFSRC_UNKNOWN
5214 : 50 : || sym == sym->ns->proc_name)
5215 : 43 : *n = NULL;
5216 : : else
5217 : 50 : *n = sym->name;
5218 : : }
5219 : : else
5220 : 453 : *n = name;
5221 : 546 : if (*n
5222 : 503 : && (strcmp (*n, "max") == 0 || strcmp (*n, "min") == 0))
5223 : 54 : return true;
5224 : 510 : else if (*n
5225 : 467 : && ts->type == BT_INTEGER
5226 : 383 : && (strcmp (*n, "iand") == 0
5227 : 377 : || strcmp (*n, "ior") == 0
5228 : 371 : || strcmp (*n, "ieor") == 0))
5229 : : return true;
5230 : : }
5231 : : break;
5232 : : default:
5233 : : break;
5234 : : }
5235 : : return false;
5236 : : }
5237 : :
5238 : : gfc_omp_udr *
5239 : 639 : gfc_omp_udr_find (gfc_symtree *st, gfc_typespec *ts)
5240 : : {
5241 : 639 : gfc_omp_udr *omp_udr;
5242 : :
5243 : 639 : if (st == NULL)
5244 : : return NULL;
5245 : :
5246 : 250 : for (omp_udr = st->n.omp_udr; omp_udr; omp_udr = omp_udr->next)
5247 : 154 : if (omp_udr->ts.type == ts->type
5248 : 89 : || ((omp_udr->ts.type == BT_DERIVED || omp_udr->ts.type == BT_CLASS)
5249 : 0 : && (ts->type == BT_DERIVED || ts->type == BT_CLASS)))
5250 : : {
5251 : 65 : if (omp_udr->ts.type == BT_DERIVED || omp_udr->ts.type == BT_CLASS)
5252 : : {
5253 : 12 : if (strcmp (omp_udr->ts.u.derived->name, ts->u.derived->name) == 0)
5254 : 6 : return omp_udr;
5255 : : }
5256 : 53 : else if (omp_udr->ts.kind == ts->kind)
5257 : : {
5258 : 19 : if (omp_udr->ts.type == BT_CHARACTER)
5259 : : {
5260 : 17 : if (omp_udr->ts.u.cl->length == NULL
5261 : 15 : || ts->u.cl->length == NULL)
5262 : 2 : return omp_udr;
5263 : 15 : if (omp_udr->ts.u.cl->length->expr_type != EXPR_CONSTANT)
5264 : 0 : return omp_udr;
5265 : 15 : if (ts->u.cl->length->expr_type != EXPR_CONSTANT)
5266 : 0 : return omp_udr;
5267 : 15 : if (omp_udr->ts.u.cl->length->ts.type != BT_INTEGER)
5268 : 0 : return omp_udr;
5269 : 15 : if (ts->u.cl->length->ts.type != BT_INTEGER)
5270 : 0 : return omp_udr;
5271 : 15 : if (gfc_compare_expr (omp_udr->ts.u.cl->length,
5272 : : ts->u.cl->length, INTRINSIC_EQ) != 0)
5273 : 15 : continue;
5274 : : }
5275 : 2 : return omp_udr;
5276 : : }
5277 : : }
5278 : : return NULL;
5279 : : }
5280 : :
5281 : : match
5282 : 532 : gfc_match_omp_declare_reduction (void)
5283 : : {
5284 : 532 : match m;
5285 : 532 : gfc_intrinsic_op op;
5286 : 532 : char name[GFC_MAX_SYMBOL_LEN + 3];
5287 : 532 : auto_vec<gfc_typespec, 5> tss;
5288 : 532 : gfc_typespec ts;
5289 : 532 : unsigned int i;
5290 : 532 : gfc_symtree *st;
5291 : 532 : locus where = gfc_current_locus;
5292 : 532 : locus end_loc = gfc_current_locus;
5293 : 532 : bool end_loc_set = false;
5294 : 532 : gfc_omp_reduction_op rop = OMP_REDUCTION_NONE;
5295 : :
5296 : 532 : if (gfc_match_char ('(') != MATCH_YES)
5297 : : return MATCH_ERROR;
5298 : :
5299 : 530 : m = gfc_match (" %o : ", &op);
5300 : 530 : if (m == MATCH_ERROR)
5301 : : return MATCH_ERROR;
5302 : 530 : if (m == MATCH_YES)
5303 : : {
5304 : 117 : snprintf (name, sizeof name, "operator %s", gfc_op2string (op));
5305 : 117 : rop = (gfc_omp_reduction_op) op;
5306 : : }
5307 : : else
5308 : : {
5309 : 413 : m = gfc_match_defined_op_name (name + 1, 1);
5310 : 413 : if (m == MATCH_ERROR)
5311 : : return MATCH_ERROR;
5312 : 413 : if (m == MATCH_YES)
5313 : : {
5314 : 41 : name[0] = '.';
5315 : 41 : strcat (name, ".");
5316 : 41 : if (gfc_match (" : ") != MATCH_YES)
5317 : : return MATCH_ERROR;
5318 : : }
5319 : : else
5320 : : {
5321 : 372 : if (gfc_match (" %n : ", name) != MATCH_YES)
5322 : : return MATCH_ERROR;
5323 : : }
5324 : : rop = OMP_REDUCTION_USER;
5325 : : }
5326 : :
5327 : 529 : m = gfc_match_type_spec (&ts);
5328 : 529 : if (m != MATCH_YES)
5329 : : return MATCH_ERROR;
5330 : : /* Treat len=: the same as len=*. */
5331 : 528 : if (ts.type == BT_CHARACTER)
5332 : 61 : ts.deferred = false;
5333 : 528 : tss.safe_push (ts);
5334 : :
5335 : 1093 : while (gfc_match_char (',') == MATCH_YES)
5336 : : {
5337 : 37 : m = gfc_match_type_spec (&ts);
5338 : 37 : if (m != MATCH_YES)
5339 : : return MATCH_ERROR;
5340 : 37 : tss.safe_push (ts);
5341 : : }
5342 : 528 : if (gfc_match_char (':') != MATCH_YES)
5343 : : return MATCH_ERROR;
5344 : :
5345 : 527 : st = gfc_find_symtree (gfc_current_ns->omp_udr_root, name);
5346 : 2168 : for (i = 0; i < tss.length (); i++)
5347 : : {
5348 : 564 : gfc_symtree *omp_out, *omp_in;
5349 : 564 : gfc_symtree *omp_priv = NULL, *omp_orig = NULL;
5350 : 564 : gfc_namespace *combiner_ns, *initializer_ns = NULL;
5351 : 564 : gfc_omp_udr *prev_udr, *omp_udr;
5352 : 564 : const char *predef_name = NULL;
5353 : :
5354 : 564 : omp_udr = gfc_get_omp_udr ();
5355 : 564 : omp_udr->name = gfc_get_string ("%s", name);
5356 : 564 : omp_udr->rop = rop;
5357 : 564 : omp_udr->ts = tss[i];
5358 : 564 : omp_udr->where = where;
5359 : :
5360 : 564 : gfc_current_ns = combiner_ns = gfc_get_namespace (gfc_current_ns, 1);
5361 : 564 : combiner_ns->proc_name = combiner_ns->parent->proc_name;
5362 : :
5363 : 564 : gfc_get_sym_tree ("omp_out", combiner_ns, &omp_out, false);
5364 : 564 : gfc_get_sym_tree ("omp_in", combiner_ns, &omp_in, false);
5365 : 564 : combiner_ns->omp_udr_ns = 1;
5366 : 564 : omp_out->n.sym->ts = tss[i];
5367 : 564 : omp_in->n.sym->ts = tss[i];
5368 : 564 : omp_out->n.sym->attr.omp_udr_artificial_var = 1;
5369 : 564 : omp_in->n.sym->attr.omp_udr_artificial_var = 1;
5370 : 564 : omp_out->n.sym->attr.flavor = FL_VARIABLE;
5371 : 564 : omp_in->n.sym->attr.flavor = FL_VARIABLE;
5372 : 564 : gfc_commit_symbols ();
5373 : 564 : omp_udr->combiner_ns = combiner_ns;
5374 : 564 : omp_udr->omp_out = omp_out->n.sym;
5375 : 564 : omp_udr->omp_in = omp_in->n.sym;
5376 : :
5377 : 564 : locus old_loc = gfc_current_locus;
5378 : :
5379 : 564 : if (!match_udr_expr (omp_out, omp_in))
5380 : : {
5381 : 4 : syntax:
5382 : 7 : gfc_current_locus = old_loc;
5383 : 7 : gfc_current_ns = combiner_ns->parent;
5384 : 7 : gfc_undo_symbols ();
5385 : 7 : gfc_free_omp_udr (omp_udr);
5386 : 7 : return MATCH_ERROR;
5387 : : }
5388 : :
5389 : 560 : if (gfc_match (" initializer ( ") == MATCH_YES)
5390 : : {
5391 : 313 : gfc_current_ns = combiner_ns->parent;
5392 : 313 : initializer_ns = gfc_get_namespace (gfc_current_ns, 1);
5393 : 313 : gfc_current_ns = initializer_ns;
5394 : 313 : initializer_ns->proc_name = initializer_ns->parent->proc_name;
5395 : :
5396 : 313 : gfc_get_sym_tree ("omp_priv", initializer_ns, &omp_priv, false);
5397 : 313 : gfc_get_sym_tree ("omp_orig", initializer_ns, &omp_orig, false);
5398 : 313 : initializer_ns->omp_udr_ns = 1;
5399 : 313 : omp_priv->n.sym->ts = tss[i];
5400 : 313 : omp_orig->n.sym->ts = tss[i];
5401 : 313 : omp_priv->n.sym->attr.omp_udr_artificial_var = 1;
5402 : 313 : omp_orig->n.sym->attr.omp_udr_artificial_var = 1;
5403 : 313 : omp_priv->n.sym->attr.flavor = FL_VARIABLE;
5404 : 313 : omp_orig->n.sym->attr.flavor = FL_VARIABLE;
5405 : 313 : gfc_commit_symbols ();
5406 : 313 : omp_udr->initializer_ns = initializer_ns;
5407 : 313 : omp_udr->omp_priv = omp_priv->n.sym;
5408 : 313 : omp_udr->omp_orig = omp_orig->n.sym;
5409 : :
5410 : 313 : if (!match_udr_expr (omp_priv, omp_orig))
5411 : 3 : goto syntax;
5412 : : }
5413 : :
5414 : 557 : gfc_current_ns = combiner_ns->parent;
5415 : 557 : if (!end_loc_set)
5416 : : {
5417 : 520 : end_loc_set = true;
5418 : 520 : end_loc = gfc_current_locus;
5419 : : }
5420 : 557 : gfc_current_locus = old_loc;
5421 : :
5422 : 557 : prev_udr = gfc_omp_udr_find (st, &tss[i]);
5423 : 557 : if (gfc_omp_udr_predef (rop, name, &tss[i], &predef_name)
5424 : : /* Don't error on !$omp declare reduction (min : integer : ...)
5425 : : just yet, there could be integer :: min afterwards,
5426 : : making it valid. When the UDR is resolved, we'll get
5427 : : to it again. */
5428 : 557 : && (rop != OMP_REDUCTION_USER || name[0] == '.'))
5429 : : {
5430 : 29 : if (predef_name)
5431 : 0 : gfc_error_now ("Redefinition of predefined %s "
5432 : : "!$OMP DECLARE REDUCTION at %L",
5433 : : predef_name, &where);
5434 : : else
5435 : 29 : gfc_error_now ("Redefinition of predefined "
5436 : : "!$OMP DECLARE REDUCTION at %L", &where);
5437 : : }
5438 : 528 : else if (prev_udr)
5439 : : {
5440 : 6 : gfc_error_now ("Redefinition of !$OMP DECLARE REDUCTION at %L",
5441 : : &where);
5442 : 6 : gfc_error_now ("Previous !$OMP DECLARE REDUCTION at %L",
5443 : : &prev_udr->where);
5444 : : }
5445 : 522 : else if (st)
5446 : : {
5447 : 96 : omp_udr->next = st->n.omp_udr;
5448 : 96 : st->n.omp_udr = omp_udr;
5449 : : }
5450 : : else
5451 : : {
5452 : 426 : st = gfc_new_symtree (&gfc_current_ns->omp_udr_root, name);
5453 : 426 : st->n.omp_udr = omp_udr;
5454 : : }
5455 : : }
5456 : :
5457 : 520 : if (end_loc_set)
5458 : : {
5459 : 520 : gfc_current_locus = end_loc;
5460 : 520 : if (gfc_match_omp_eos () != MATCH_YES)
5461 : : {
5462 : 1 : gfc_error ("Unexpected junk after !$OMP DECLARE REDUCTION at %C");
5463 : 1 : gfc_current_locus = where;
5464 : 1 : return MATCH_ERROR;
5465 : : }
5466 : :
5467 : : return MATCH_YES;
5468 : : }
5469 : 0 : gfc_clear_error ();
5470 : 0 : return MATCH_ERROR;
5471 : 532 : }
5472 : :
5473 : :
5474 : : match
5475 : 422 : gfc_match_omp_declare_target (void)
5476 : : {
5477 : 422 : locus old_loc;
5478 : 422 : match m;
5479 : 422 : gfc_omp_clauses *c = NULL;
5480 : 422 : int list;
5481 : 422 : gfc_omp_namelist *n;
5482 : 422 : gfc_symbol *s;
5483 : :
5484 : 422 : old_loc = gfc_current_locus;
5485 : :
5486 : 422 : if (gfc_current_ns->proc_name
5487 : 422 : && gfc_match_omp_eos () == MATCH_YES)
5488 : : {
5489 : 131 : if (!gfc_add_omp_declare_target (&gfc_current_ns->proc_name->attr,
5490 : 131 : gfc_current_ns->proc_name->name,
5491 : : &old_loc))
5492 : 0 : goto cleanup;
5493 : : return MATCH_YES;
5494 : : }
5495 : :
5496 : 291 : if (gfc_current_ns->proc_name
5497 : 291 : && gfc_current_ns->proc_name->attr.if_source == IFSRC_IFBODY)
5498 : : {
5499 : 2 : gfc_error ("Only the !$OMP DECLARE TARGET form without "
5500 : : "clauses is allowed in interface block at %C");
5501 : 2 : goto cleanup;
5502 : : }
5503 : :
5504 : 289 : m = gfc_match (" (");
5505 : 289 : if (m == MATCH_YES)
5506 : : {
5507 : 85 : c = gfc_get_omp_clauses ();
5508 : 85 : gfc_current_locus = old_loc;
5509 : 85 : m = gfc_match_omp_to_link (" (", &c->lists[OMP_LIST_ENTER]);
5510 : 85 : if (m != MATCH_YES)
5511 : 0 : goto syntax;
5512 : 85 : if (gfc_match_omp_eos () != MATCH_YES)
5513 : : {
5514 : 0 : gfc_error ("Unexpected junk after !$OMP DECLARE TARGET at %C");
5515 : 0 : goto cleanup;
5516 : : }
5517 : : }
5518 : 204 : else if (gfc_match_omp_clauses (&c, OMP_DECLARE_TARGET_CLAUSES) != MATCH_YES)
5519 : : return MATCH_ERROR;
5520 : :
5521 : 283 : gfc_buffer_error (false);
5522 : :
5523 : 283 : static const int to_enter_link_lists[]
5524 : : = { OMP_LIST_TO, OMP_LIST_ENTER, OMP_LIST_LINK };
5525 : 1132 : for (size_t listn = 0; listn < ARRAY_SIZE (to_enter_link_lists)
5526 : 1132 : && (list = to_enter_link_lists[listn], true); ++listn)
5527 : 1330 : for (n = c->lists[list]; n; n = n->next)
5528 : 481 : if (n->sym)
5529 : 456 : n->sym->mark = 0;
5530 : 25 : else if (n->u.common->head)
5531 : 25 : n->u.common->head->mark = 0;
5532 : :
5533 : 849 : for (size_t listn = 0; listn < ARRAY_SIZE (to_enter_link_lists)
5534 : 1132 : && (list = to_enter_link_lists[listn], true); ++listn)
5535 : 1330 : for (n = c->lists[list]; n; n = n->next)
5536 : 481 : if (n->sym)
5537 : : {
5538 : 456 : if (n->sym->attr.in_common)
5539 : 1 : gfc_error_now ("OMP DECLARE TARGET variable at %L is an "
5540 : : "element of a COMMON block", &n->where);
5541 : 455 : else if (n->sym->mark)
5542 : 9 : gfc_error_now ("Variable at %L mentioned multiple times in "
5543 : : "clauses of the same OMP DECLARE TARGET directive",
5544 : : &n->where);
5545 : 446 : else if (n->sym->attr.omp_declare_target
5546 : 446 : && n->sym->attr.omp_declare_target_link
5547 : 9 : && list != OMP_LIST_LINK)
5548 : 1 : gfc_error_now ("OMP DECLARE TARGET variable at %L previously "
5549 : : "mentioned in LINK clause and later in %s clause",
5550 : : &n->where, list == OMP_LIST_TO ? "TO" : "ENTER");
5551 : 445 : else if (n->sym->attr.omp_declare_target
5552 : : && !n->sym->attr.omp_declare_target_link
5553 : 14 : && list == OMP_LIST_LINK)
5554 : 1 : gfc_error_now ("OMP DECLARE TARGET variable at %L previously "
5555 : : "mentioned in TO or ENTER clause and later in "
5556 : : "LINK clause", &n->where);
5557 : 444 : else if (gfc_add_omp_declare_target (&n->sym->attr, n->sym->name,
5558 : : &n->sym->declared_at))
5559 : : {
5560 : 438 : if (list == OMP_LIST_LINK)
5561 : 20 : gfc_add_omp_declare_target_link (&n->sym->attr, n->sym->name,
5562 : 20 : &n->sym->declared_at);
5563 : : }
5564 : 456 : if (c->device_type != OMP_DEVICE_TYPE_UNSET)
5565 : : {
5566 : 43 : if (n->sym->attr.omp_device_type != OMP_DEVICE_TYPE_UNSET
5567 : 17 : && n->sym->attr.omp_device_type != c->device_type)
5568 : 13 : gfc_error_now ("List item %qs at %L set in previous OMP DECLARE "
5569 : : "TARGET directive to a different DEVICE_TYPE",
5570 : : n->sym->name, &n->where);
5571 : 43 : n->sym->attr.omp_device_type = c->device_type;
5572 : : }
5573 : 456 : if (c->indirect)
5574 : : {
5575 : 50 : if (n->sym->attr.omp_device_type != OMP_DEVICE_TYPE_UNSET
5576 : 1 : && n->sym->attr.omp_device_type != OMP_DEVICE_TYPE_ANY)
5577 : 1 : gfc_error_now ("DEVICE_TYPE must be ANY when used with "
5578 : : "INDIRECT at %L", &n->where);
5579 : 50 : n->sym->attr.omp_declare_target_indirect = c->indirect;
5580 : : }
5581 : :
5582 : 456 : n->sym->mark = 1;
5583 : : }
5584 : 25 : else if (n->u.common->omp_declare_target
5585 : 25 : && n->u.common->omp_declare_target_link
5586 : 6 : && list != OMP_LIST_LINK)
5587 : 2 : gfc_error_now ("OMP DECLARE TARGET COMMON at %L previously "
5588 : : "mentioned in LINK clause and later in %s clause",
5589 : : &n->where, list == OMP_LIST_TO ? "TO" : "ENTER");
5590 : 24 : else if (n->u.common->omp_declare_target
5591 : : && !n->u.common->omp_declare_target_link
5592 : 6 : && list == OMP_LIST_LINK)
5593 : 1 : gfc_error_now ("OMP DECLARE TARGET COMMON at %L previously "
5594 : : "mentioned in TO or ENTER clause and later in "
5595 : : "LINK clause", &n->where);
5596 : 23 : else if (n->u.common->head && n->u.common->head->mark)
5597 : 4 : gfc_error_now ("COMMON at %L mentioned multiple times in "
5598 : : "clauses of the same OMP DECLARE TARGET directive",
5599 : : &n->where);
5600 : : else
5601 : : {
5602 : 19 : n->u.common->omp_declare_target = 1;
5603 : 19 : n->u.common->omp_declare_target_link = (list == OMP_LIST_LINK);
5604 : 19 : if (n->u.common->omp_device_type != OMP_DEVICE_TYPE_UNSET
5605 : 0 : && n->u.common->omp_device_type != c->device_type)
5606 : 0 : gfc_error_now ("COMMON at %L set in previous OMP DECLARE "
5607 : : "TARGET directive to a different DEVICE_TYPE",
5608 : : &n->where);
5609 : 19 : n->u.common->omp_device_type = c->device_type;
5610 : :
5611 : 59 : for (s = n->u.common->head; s; s = s->common_next)
5612 : : {
5613 : 40 : s->mark = 1;
5614 : 40 : if (gfc_add_omp_declare_target (&s->attr, s->name,
5615 : : &s->declared_at))
5616 : : {
5617 : 40 : if (list == OMP_LIST_LINK)
5618 : 21 : gfc_add_omp_declare_target_link (&s->attr, s->name,
5619 : : &s->declared_at);
5620 : : }
5621 : 40 : if (s->attr.omp_device_type != OMP_DEVICE_TYPE_UNSET
5622 : 0 : && s->attr.omp_device_type != c->device_type)
5623 : 0 : gfc_error_now ("List item %qs at %L set in previous OMP DECLARE"
5624 : : " TARGET directive to a different DEVICE_TYPE",
5625 : : s->name, &n->where);
5626 : 40 : s->attr.omp_device_type = c->device_type;
5627 : :
5628 : 40 : if (c->indirect
5629 : 0 : && s->attr.omp_device_type != OMP_DEVICE_TYPE_UNSET
5630 : 0 : && s->attr.omp_device_type != OMP_DEVICE_TYPE_ANY)
5631 : 0 : gfc_error_now ("DEVICE_TYPE must be ANY when used with "
5632 : : "INDIRECT at %L", &n->where);
5633 : 40 : s->attr.omp_declare_target_indirect = c->indirect;
5634 : : }
5635 : : }
5636 : 283 : if ((c->device_type || c->indirect)
5637 : 99 : && !c->lists[OMP_LIST_ENTER]
5638 : 87 : && !c->lists[OMP_LIST_TO]
5639 : 19 : && !c->lists[OMP_LIST_LINK])
5640 : 2 : gfc_warning_now (OPT_Wopenmp,
5641 : : "OMP DECLARE TARGET directive at %L with only "
5642 : : "DEVICE_TYPE or INDIRECT clauses is ignored",
5643 : : &old_loc);
5644 : :
5645 : 283 : gfc_buffer_error (true);
5646 : :
5647 : 283 : if (c)
5648 : 283 : gfc_free_omp_clauses (c);
5649 : 283 : return MATCH_YES;
5650 : :
5651 : 0 : syntax:
5652 : 0 : gfc_error ("Syntax error in !$OMP DECLARE TARGET list at %C");
5653 : :
5654 : 2 : cleanup:
5655 : 2 : gfc_current_locus = old_loc;
5656 : 2 : if (c)
5657 : 0 : gfc_free_omp_clauses (c);
5658 : : return MATCH_ERROR;
5659 : : }
5660 : :
5661 : : /* Skip over and ignore trait-property-extensions.
5662 : :
5663 : : trait-property-extension :
5664 : : trait-property-name
5665 : : identifier (trait-property-extension[, trait-property-extension[, ...]])
5666 : : constant integer expression
5667 : : */
5668 : :
5669 : : static match gfc_ignore_trait_property_extension_list (void);
5670 : :
5671 : : static match
5672 : 7 : gfc_ignore_trait_property_extension (void)
5673 : : {
5674 : 7 : char buf[GFC_MAX_SYMBOL_LEN + 1];
5675 : 7 : gfc_expr *expr;
5676 : :
5677 : : /* Identifier form of trait-property name, possibly followed by
5678 : : a list of (recursive) trait-property-extensions. */
5679 : 7 : if (gfc_match_name (buf) == MATCH_YES)
5680 : : {
5681 : 0 : if (gfc_match (" (") == MATCH_YES)
5682 : 0 : return gfc_ignore_trait_property_extension_list ();
5683 : : return MATCH_YES;
5684 : : }
5685 : :
5686 : : /* Literal constant. */
5687 : 7 : if (gfc_match_literal_constant (&expr, 0) == MATCH_YES)
5688 : : return MATCH_YES;
5689 : :
5690 : : /* FIXME: constant integer expressions. */
5691 : 0 : gfc_error ("Expected trait-property-extension at %C");
5692 : 0 : return MATCH_ERROR;
5693 : : }
5694 : :
5695 : : static match
5696 : 5 : gfc_ignore_trait_property_extension_list (void)
5697 : : {
5698 : 9 : while (1)
5699 : : {
5700 : 7 : if (gfc_ignore_trait_property_extension () != MATCH_YES)
5701 : : return MATCH_ERROR;
5702 : 7 : if (gfc_match (" ,") == MATCH_YES)
5703 : 2 : continue;
5704 : 5 : if (gfc_match (" )") == MATCH_YES)
5705 : : return MATCH_YES;
5706 : 0 : gfc_error ("expected %<)%> at %C");
5707 : 0 : return MATCH_ERROR;
5708 : : }
5709 : : }
5710 : :
5711 : : /* OpenMP 5.0:
5712 : :
5713 : : trait-selector:
5714 : : trait-selector-name[([trait-score:]trait-property[,trait-property[,...]])]
5715 : :
5716 : : trait-score:
5717 : : score(score-expression) */
5718 : :
5719 : : match
5720 : 345 : gfc_match_omp_context_selector (gfc_omp_set_selector *oss)
5721 : : {
5722 : 445 : do
5723 : : {
5724 : 445 : char selector[GFC_MAX_SYMBOL_LEN + 1];
5725 : :
5726 : 445 : if (gfc_match_name (selector) != MATCH_YES)
5727 : : {
5728 : 2 : gfc_error ("expected trait selector name at %C");
5729 : 37 : return MATCH_ERROR;
5730 : : }
5731 : :
5732 : 443 : gfc_omp_selector *os = gfc_get_omp_selector ();
5733 : 443 : if (oss->code == OMP_TRAIT_SET_CONSTRUCT
5734 : 190 : && !strcmp (selector, "do"))
5735 : 45 : os->code = OMP_TRAIT_CONSTRUCT_FOR;
5736 : 398 : else if (oss->code == OMP_TRAIT_SET_CONSTRUCT
5737 : 145 : && !strcmp (selector, "for"))
5738 : 1 : os->code = OMP_TRAIT_INVALID;
5739 : : else
5740 : 397 : os->code = omp_lookup_ts_code (oss->code, selector);
5741 : 443 : os->next = oss->trait_selectors;
5742 : 443 : oss->trait_selectors = os;
5743 : :
5744 : 443 : if (os->code == OMP_TRAIT_INVALID)
5745 : : {
5746 : 18 : gfc_warning (OPT_Wopenmp,
5747 : : "unknown selector %qs for context selector set %qs "
5748 : : "at %C",
5749 : 18 : selector, omp_tss_map[oss->code]);
5750 : 18 : if (gfc_match (" (") == MATCH_YES
5751 : 18 : && gfc_ignore_trait_property_extension_list () != MATCH_YES)
5752 : : return MATCH_ERROR;
5753 : 18 : if (gfc_match (" ,") == MATCH_YES)
5754 : 1 : continue;
5755 : 308 : break;
5756 : : }
5757 : :
5758 : 425 : enum omp_tp_type property_kind = omp_ts_map[os->code].tp_type;
5759 : 425 : bool allow_score = omp_ts_map[os->code].allow_score;
5760 : :
5761 : 425 : if (gfc_match (" (") == MATCH_YES)
5762 : : {
5763 : 247 : if (property_kind == OMP_TRAIT_PROPERTY_NONE)
5764 : : {
5765 : 6 : gfc_error ("selector %qs does not accept any properties at %C",
5766 : : selector);
5767 : 6 : return MATCH_ERROR;
5768 : : }
5769 : :
5770 : 241 : if (gfc_match (" score") == MATCH_YES)
5771 : : {
5772 : 55 : if (!allow_score)
5773 : : {
5774 : 3 : gfc_error ("%<score%> cannot be specified in traits "
5775 : : "in the %qs trait-selector-set at %C",
5776 : 3 : omp_tss_map[oss->code]);
5777 : 3 : return MATCH_ERROR;
5778 : : }
5779 : 52 : if (gfc_match (" (") != MATCH_YES)
5780 : : {
5781 : 0 : gfc_error ("expected %<(%> at %C");
5782 : 0 : return MATCH_ERROR;
5783 : : }
5784 : 52 : if (gfc_match_expr (&os->score) != MATCH_YES
5785 : 51 : || !gfc_resolve_expr (os->score)
5786 : 51 : || os->score->ts.type != BT_INTEGER
5787 : 103 : || os->score->rank != 0)
5788 : : {
5789 : 1 : gfc_error ("%<score%> argument must be constant integer "
5790 : : "expression at %C");
5791 : 1 : return MATCH_ERROR;
5792 : : }
5793 : :
5794 : 51 : if (os->score->expr_type == EXPR_CONSTANT
5795 : 51 : && mpz_sgn (os->score->value.integer) < 0)
5796 : : {
5797 : 1 : gfc_error ("%<score%> argument must be non-negative at %C");
5798 : 1 : return MATCH_ERROR;
5799 : : }
5800 : :
5801 : 50 : if (gfc_match (" )") != MATCH_YES)
5802 : : {
5803 : 0 : gfc_error ("expected %<)%> at %C");
5804 : 0 : return MATCH_ERROR;
5805 : : }
5806 : :
5807 : 50 : if (gfc_match (" :") != MATCH_YES)
5808 : : {
5809 : 0 : gfc_error ("expected : at %C");
5810 : 0 : return MATCH_ERROR;
5811 : : }
5812 : : }
5813 : :
5814 : 236 : gfc_omp_trait_property *otp = gfc_get_omp_trait_property ();
5815 : 236 : otp->property_kind = property_kind;
5816 : 236 : otp->next = os->properties;
5817 : 236 : os->properties = otp;
5818 : :
5819 : 236 : switch (property_kind)
5820 : : {
5821 : 25 : case OMP_TRAIT_PROPERTY_ID:
5822 : 25 : {
5823 : 25 : char buf[GFC_MAX_SYMBOL_LEN + 1];
5824 : 25 : if (gfc_match_name (buf) == MATCH_YES)
5825 : : {
5826 : 24 : otp->name = XNEWVEC (char, strlen (buf) + 1);
5827 : 24 : strcpy (otp->name, buf);
5828 : : }
5829 : : else
5830 : : {
5831 : 1 : gfc_error ("expected identifier at %C");
5832 : 1 : return MATCH_ERROR;
5833 : : }
5834 : : }
5835 : 24 : break;
5836 : 196 : case OMP_TRAIT_PROPERTY_NAME_LIST:
5837 : 242 : do
5838 : : {
5839 : 196 : char buf[GFC_MAX_SYMBOL_LEN + 1];
5840 : 196 : if (gfc_match_name (buf) == MATCH_YES)
5841 : : {
5842 : 149 : otp->name = XNEWVEC (char, strlen (buf) + 1);
5843 : 149 : strcpy (otp->name, buf);
5844 : 149 : otp->is_name = true;
5845 : : }
5846 : 47 : else if (gfc_match_literal_constant (&otp->expr, 0)
5847 : : != MATCH_YES
5848 : 47 : || otp->expr->ts.type != BT_CHARACTER)
5849 : : {
5850 : 5 : gfc_error ("expected identifier or string literal "
5851 : : "at %C");
5852 : 5 : return MATCH_ERROR;
5853 : : }
5854 : :
5855 : 191 : if (gfc_match (" ,") == MATCH_YES)
5856 : : {
5857 : 46 : otp = gfc_get_omp_trait_property ();
5858 : 46 : otp->property_kind = property_kind;
5859 : 46 : otp->next = os->properties;
5860 : 46 : os->properties = otp;
5861 : : }
5862 : : else
5863 : : break;
5864 : 46 : }
5865 : : while (1);
5866 : 145 : break;
5867 : 46 : case OMP_TRAIT_PROPERTY_DEV_NUM_EXPR:
5868 : 46 : case OMP_TRAIT_PROPERTY_BOOL_EXPR:
5869 : 46 : if (gfc_match_expr (&otp->expr) != MATCH_YES)
5870 : : {
5871 : 3 : gfc_error ("expected expression at %C");
5872 : 3 : return MATCH_ERROR;
5873 : : }
5874 : 43 : if (!gfc_resolve_expr (otp->expr)
5875 : 42 : || (property_kind == OMP_TRAIT_PROPERTY_BOOL_EXPR
5876 : 37 : && otp->expr->ts.type != BT_LOGICAL)
5877 : 41 : || (property_kind == OMP_TRAIT_PROPERTY_DEV_NUM_EXPR
5878 : 5 : && otp->expr->ts.type != BT_INTEGER)
5879 : 41 : || otp->expr->rank != 0
5880 : 84 : || otp->expr->expr_type != EXPR_CONSTANT)
5881 : : {
5882 : 3 : if (property_kind == OMP_TRAIT_PROPERTY_BOOL_EXPR)
5883 : 2 : gfc_error ("property must be a constant logical expression "
5884 : : "at %C");
5885 : : else
5886 : 1 : gfc_error ("property must be a constant integer expression "
5887 : : "at %C");
5888 : 3 : return MATCH_ERROR;
5889 : : }
5890 : : /* Device number must be conforming, which includes
5891 : : omp_initial_device (-1) and omp_invalid_device (-4). */
5892 : 40 : if (property_kind == OMP_TRAIT_PROPERTY_DEV_NUM_EXPR
5893 : : && otp->expr->expr_type == EXPR_CONSTANT
5894 : 5 : && mpz_sgn (otp->expr->value.integer) < 0
5895 : 3 : && mpz_cmp_si (otp->expr->value.integer, -1) != 0
5896 : 2 : && mpz_cmp_si (otp->expr->value.integer, -4) != 0)
5897 : : {
5898 : 1 : gfc_error ("property must be a conforming device number "
5899 : : "at %C");
5900 : 1 : return MATCH_ERROR;
5901 : : }
5902 : : break;
5903 : 15 : case OMP_TRAIT_PROPERTY_CLAUSE_LIST:
5904 : 15 : {
5905 : 15 : if (os->code == OMP_TRAIT_CONSTRUCT_SIMD)
5906 : : {
5907 : 15 : if (gfc_match_omp_clauses (&otp->clauses,
5908 : 15 : OMP_DECLARE_SIMD_CLAUSES,
5909 : : true, false, false, true)
5910 : : != MATCH_YES)
5911 : : {
5912 : 1 : gfc_error ("expected simd clause at %C");
5913 : 1 : return MATCH_ERROR;
5914 : : }
5915 : : }
5916 : 0 : else if (os->code == OMP_TRAIT_IMPLEMENTATION_REQUIRES)
5917 : : {
5918 : : /* FIXME: The "requires" selector was added in OpenMP 5.1.
5919 : : Currently only the now-deprecated syntax
5920 : : from OpenMP 5.0 is supported. */
5921 : 0 : sorry ("%<requires%> selector is not supported yet");
5922 : 0 : return MATCH_ERROR;
5923 : : }
5924 : : else
5925 : 0 : gcc_unreachable ();
5926 : : break;
5927 : : }
5928 : 0 : default:
5929 : 0 : gcc_unreachable ();
5930 : : }
5931 : :
5932 : 222 : if (gfc_match (" )") != MATCH_YES)
5933 : : {
5934 : 2 : gfc_error ("expected %<)%> at %C");
5935 : 2 : return MATCH_ERROR;
5936 : : }
5937 : : }
5938 : 178 : else if (property_kind != OMP_TRAIT_PROPERTY_NONE
5939 : 178 : && property_kind != OMP_TRAIT_PROPERTY_CLAUSE_LIST
5940 : 8 : && property_kind != OMP_TRAIT_PROPERTY_EXTENSION)
5941 : : {
5942 : 8 : if (gfc_match (" (") != MATCH_YES)
5943 : : {
5944 : 8 : gfc_error ("expected %<(%> at %C");
5945 : 8 : return MATCH_ERROR;
5946 : : }
5947 : : }
5948 : :
5949 : 390 : if (gfc_match (" ,") != MATCH_YES)
5950 : : break;
5951 : : }
5952 : : while (1);
5953 : :
5954 : 308 : return MATCH_YES;
5955 : : }
5956 : :
5957 : : /* OpenMP 5.0:
5958 : :
5959 : : trait-set-selector[,trait-set-selector[,...]]
5960 : :
5961 : : trait-set-selector:
5962 : : trait-set-selector-name = { trait-selector[, trait-selector[, ...]] }
5963 : :
5964 : : trait-set-selector-name:
5965 : : constructor
5966 : : device
5967 : : implementation
5968 : : user */
5969 : :
5970 : : match
5971 : 303 : gfc_match_omp_context_selector_specification (gfc_omp_declare_variant *odv)
5972 : : {
5973 : 403 : do
5974 : : {
5975 : 353 : match m;
5976 : 353 : char buf[GFC_MAX_SYMBOL_LEN + 1];
5977 : 353 : enum omp_tss_code set = OMP_TRAIT_SET_INVALID;
5978 : :
5979 : 353 : m = gfc_match_name (buf);
5980 : 353 : if (m == MATCH_YES)
5981 : 351 : set = omp_lookup_tss_code (buf);
5982 : :
5983 : 351 : if (set == OMP_TRAIT_SET_INVALID)
5984 : : {
5985 : 5 : gfc_error ("expected context selector set name at %C");
5986 : 45 : return MATCH_ERROR;
5987 : : }
5988 : :
5989 : 348 : m = gfc_match (" =");
5990 : 348 : if (m != MATCH_YES)
5991 : : {
5992 : 1 : gfc_error ("expected %<=%> at %C");
5993 : 1 : return MATCH_ERROR;
5994 : : }
5995 : :
5996 : 347 : m = gfc_match (" {");
5997 : 347 : if (m != MATCH_YES)
5998 : : {
5999 : 2 : gfc_error ("expected %<{%> at %C");
6000 : 2 : return MATCH_ERROR;
6001 : : }
6002 : :
6003 : 345 : gfc_omp_set_selector *oss = gfc_get_omp_set_selector ();
6004 : 345 : oss->next = odv->set_selectors;
6005 : 345 : oss->code = set;
6006 : 345 : odv->set_selectors = oss;
6007 : :
6008 : 345 : if (gfc_match_omp_context_selector (oss) != MATCH_YES)
6009 : : return MATCH_ERROR;
6010 : :
6011 : 308 : m = gfc_match (" }");
6012 : 308 : if (m != MATCH_YES)
6013 : : {
6014 : 0 : gfc_error ("expected %<}%> at %C");
6015 : 0 : return MATCH_ERROR;
6016 : : }
6017 : :
6018 : 308 : m = gfc_match (" ,");
6019 : 308 : if (m != MATCH_YES)
6020 : : break;
6021 : 50 : }
6022 : : while (1);
6023 : :
6024 : 258 : return MATCH_YES;
6025 : : }
6026 : :
6027 : :
6028 : : match
6029 : 311 : gfc_match_omp_declare_variant (void)
6030 : : {
6031 : 311 : bool first_p = true;
6032 : 311 : char buf[GFC_MAX_SYMBOL_LEN + 1];
6033 : :
6034 : 311 : if (gfc_match (" (") != MATCH_YES)
6035 : : {
6036 : 2 : gfc_error ("expected %<(%> at %C");
6037 : 2 : return MATCH_ERROR;
6038 : : }
6039 : :
6040 : 309 : gfc_symtree *base_proc_st, *variant_proc_st;
6041 : 309 : if (gfc_match_name (buf) != MATCH_YES)
6042 : : {
6043 : 2 : gfc_error ("expected name at %C");
6044 : 2 : return MATCH_ERROR;
6045 : : }
6046 : :
6047 : 307 : if (gfc_get_ha_sym_tree (buf, &base_proc_st))
6048 : : return MATCH_ERROR;
6049 : :
6050 : 307 : if (gfc_match (" :") == MATCH_YES)
6051 : : {
6052 : 10 : if (gfc_match_name (buf) != MATCH_YES)
6053 : : {
6054 : 0 : gfc_error ("expected variant name at %C");
6055 : 0 : return MATCH_ERROR;
6056 : : }
6057 : :
6058 : 10 : if (gfc_get_ha_sym_tree (buf, &variant_proc_st))
6059 : : return MATCH_ERROR;
6060 : : }
6061 : : else
6062 : : {
6063 : : /* Base procedure not specified. */
6064 : 297 : variant_proc_st = base_proc_st;
6065 : 297 : base_proc_st = NULL;
6066 : : }
6067 : :
6068 : 307 : gfc_omp_declare_variant *odv;
6069 : 307 : odv = gfc_get_omp_declare_variant ();
6070 : 307 : odv->where = gfc_current_locus;
6071 : 307 : odv->variant_proc_symtree = variant_proc_st;
6072 : 307 : odv->base_proc_symtree = base_proc_st;
6073 : 307 : odv->next = NULL;
6074 : 307 : odv->error_p = false;
6075 : :
6076 : : /* Add the new declare variant to the end of the list. */
6077 : 307 : gfc_omp_declare_variant **prev_next = &gfc_current_ns->omp_declare_variant;
6078 : 422 : while (*prev_next)
6079 : 115 : prev_next = &((*prev_next)->next);
6080 : 307 : *prev_next = odv;
6081 : :
6082 : 307 : if (gfc_match (" )") != MATCH_YES)
6083 : : {
6084 : 0 : gfc_error ("expected %<)%> at %C");
6085 : 0 : return MATCH_ERROR;
6086 : : }
6087 : :
6088 : 565 : for (;;)
6089 : : {
6090 : 565 : if (gfc_match (" match") != MATCH_YES)
6091 : : {
6092 : 261 : if (first_p)
6093 : : {
6094 : 3 : gfc_error ("expected %<match%> at %C");
6095 : 3 : return MATCH_ERROR;
6096 : : }
6097 : : else
6098 : : break;
6099 : : }
6100 : :
6101 : 304 : if (gfc_match (" (") != MATCH_YES)
6102 : : {
6103 : 1 : gfc_error ("expected %<(%> at %C");
6104 : 1 : return MATCH_ERROR;
6105 : : }
6106 : :
6107 : 303 : if (gfc_match_omp_context_selector_specification (odv) != MATCH_YES)
6108 : : return MATCH_ERROR;
6109 : :
6110 : 258 : if (gfc_match (" )") != MATCH_YES)
6111 : : {
6112 : 0 : gfc_error ("expected %<)%> at %C");
6113 : 0 : return MATCH_ERROR;
6114 : : }
6115 : :
6116 : : first_p = false;
6117 : : }
6118 : :
6119 : : return MATCH_YES;
6120 : : }
6121 : :
6122 : :
6123 : : match
6124 : 203 : gfc_match_omp_threadprivate (void)
6125 : : {
6126 : 203 : locus old_loc;
6127 : 203 : char n[GFC_MAX_SYMBOL_LEN+1];
6128 : 203 : gfc_symbol *sym;
6129 : 203 : match m;
6130 : 203 : gfc_symtree *st;
6131 : :
6132 : 203 : old_loc = gfc_current_locus;
6133 : :
6134 : 203 : m = gfc_match (" (");
6135 : 203 : if (m != MATCH_YES)
6136 : : return m;
6137 : :
6138 : 245 : for (;;)
6139 : : {
6140 : 245 : m = gfc_match_symbol (&sym, 0);
6141 : 245 : switch (m)
6142 : : {
6143 : 174 : case MATCH_YES:
6144 : 174 : if (sym->attr.in_common)
6145 : 0 : gfc_error_now ("Threadprivate variable at %C is an element of "
6146 : : "a COMMON block");
6147 : 174 : else if (!gfc_add_threadprivate (&sym->attr, sym->name, &sym->declared_at))
6148 : 1 : goto cleanup;
6149 : 173 : goto next_item;
6150 : : case MATCH_NO:
6151 : : break;
6152 : 0 : case MATCH_ERROR:
6153 : 0 : goto cleanup;
6154 : : }
6155 : :
6156 : 71 : m = gfc_match (" / %n /", n);
6157 : 71 : if (m == MATCH_ERROR)
6158 : 0 : goto cleanup;
6159 : 71 : if (m == MATCH_NO || n[0] == '\0')
6160 : 0 : goto syntax;
6161 : :
6162 : 71 : st = gfc_find_symtree (gfc_current_ns->common_root, n);
6163 : 71 : if (st == NULL)
6164 : : {
6165 : 2 : gfc_error ("COMMON block /%s/ not found at %C", n);
6166 : 2 : goto cleanup;
6167 : : }
6168 : 69 : st->n.common->threadprivate = 1;
6169 : 176 : for (sym = st->n.common->head; sym; sym = sym->common_next)
6170 : 107 : if (!gfc_add_threadprivate (&sym->attr, sym->name, &sym->declared_at))
6171 : 0 : goto cleanup;
6172 : :
6173 : 69 : next_item:
6174 : 242 : if (gfc_match_char (')') == MATCH_YES)
6175 : : break;
6176 : 42 : if (gfc_match_char (',') != MATCH_YES)
6177 : 0 : goto syntax;
6178 : : }
6179 : :
6180 : 200 : if (gfc_match_omp_eos () != MATCH_YES)
6181 : : {
6182 : 0 : gfc_error ("Unexpected junk after OMP THREADPRIVATE at %C");
6183 : 0 : goto cleanup;
6184 : : }
6185 : :
6186 : : return MATCH_YES;
6187 : :
6188 : 0 : syntax:
6189 : 0 : gfc_error ("Syntax error in !$OMP THREADPRIVATE list at %C");
6190 : :
6191 : 3 : cleanup:
6192 : 3 : gfc_current_locus = old_loc;
6193 : 3 : return MATCH_ERROR;
6194 : : }
6195 : :
6196 : :
6197 : : match
6198 : 2088 : gfc_match_omp_parallel (void)
6199 : : {
6200 : 2088 : return match_omp (EXEC_OMP_PARALLEL, OMP_PARALLEL_CLAUSES);
6201 : : }
6202 : :
6203 : :
6204 : : match
6205 : 904 : gfc_match_omp_parallel_do (void)
6206 : : {
6207 : 904 : return match_omp (EXEC_OMP_PARALLEL_DO,
6208 : 904 : (OMP_PARALLEL_CLAUSES | OMP_DO_CLAUSES)
6209 : 904 : & ~(omp_mask (OMP_CLAUSE_NOWAIT)));
6210 : : }
6211 : :
6212 : :
6213 : : match
6214 : 290 : gfc_match_omp_parallel_do_simd (void)
6215 : : {
6216 : 290 : return match_omp (EXEC_OMP_PARALLEL_DO_SIMD,
6217 : 290 : (OMP_PARALLEL_CLAUSES | OMP_DO_CLAUSES | OMP_SIMD_CLAUSES)
6218 : 290 : & ~(omp_mask (OMP_CLAUSE_NOWAIT)));
6219 : : }
6220 : :
6221 : :
6222 : : match
6223 : 14 : gfc_match_omp_parallel_masked (void)
6224 : : {
6225 : 14 : return match_omp (EXEC_OMP_PARALLEL_MASKED,
6226 : 14 : OMP_PARALLEL_CLAUSES | OMP_MASKED_CLAUSES);
6227 : : }
6228 : :
6229 : : match
6230 : 10 : gfc_match_omp_parallel_masked_taskloop (void)
6231 : : {
6232 : 10 : return match_omp (EXEC_OMP_PARALLEL_MASKED_TASKLOOP,
6233 : 10 : (OMP_PARALLEL_CLAUSES | OMP_MASKED_CLAUSES
6234 : 10 : | OMP_TASKLOOP_CLAUSES)
6235 : 10 : & ~(omp_mask (OMP_CLAUSE_IN_REDUCTION)));
6236 : : }
6237 : :
6238 : : match
6239 : 13 : gfc_match_omp_parallel_masked_taskloop_simd (void)
6240 : : {
6241 : 13 : return match_omp (EXEC_OMP_PARALLEL_MASKED_TASKLOOP_SIMD,
6242 : 13 : (OMP_PARALLEL_CLAUSES | OMP_MASKED_CLAUSES
6243 : 13 : | OMP_TASKLOOP_CLAUSES | OMP_SIMD_CLAUSES)
6244 : 13 : & ~(omp_mask (OMP_CLAUSE_IN_REDUCTION)));
6245 : : }
6246 : :
6247 : : match
6248 : 14 : gfc_match_omp_parallel_master (void)
6249 : : {
6250 : 14 : return match_omp (EXEC_OMP_PARALLEL_MASTER, OMP_PARALLEL_CLAUSES);
6251 : : }
6252 : :
6253 : : match
6254 : 15 : gfc_match_omp_parallel_master_taskloop (void)
6255 : : {
6256 : 15 : return match_omp (EXEC_OMP_PARALLEL_MASTER_TASKLOOP,
6257 : 15 : (OMP_PARALLEL_CLAUSES | OMP_TASKLOOP_CLAUSES)
6258 : 15 : & ~(omp_mask (OMP_CLAUSE_IN_REDUCTION)));
6259 : : }
6260 : :
6261 : : match
6262 : 20 : gfc_match_omp_parallel_master_taskloop_simd (void)
6263 : : {
6264 : 20 : return match_omp (EXEC_OMP_PARALLEL_MASTER_TASKLOOP_SIMD,
6265 : 20 : (OMP_PARALLEL_CLAUSES | OMP_TASKLOOP_CLAUSES
6266 : 20 : | OMP_SIMD_CLAUSES)
6267 : 20 : & ~(omp_mask (OMP_CLAUSE_IN_REDUCTION)));
6268 : : }
6269 : :
6270 : : match
6271 : 59 : gfc_match_omp_parallel_sections (void)
6272 : : {
6273 : 59 : return match_omp (EXEC_OMP_PARALLEL_SECTIONS,
6274 : 59 : (OMP_PARALLEL_CLAUSES | OMP_SECTIONS_CLAUSES)
6275 : 59 : & ~(omp_mask (OMP_CLAUSE_NOWAIT)));
6276 : : }
6277 : :
6278 : :
6279 : : match
6280 : 56 : gfc_match_omp_parallel_workshare (void)
6281 : : {
6282 : 56 : return match_omp (EXEC_OMP_PARALLEL_WORKSHARE, OMP_PARALLEL_CLAUSES);
6283 : : }
6284 : :
6285 : : void
6286 : 45859 : gfc_check_omp_requires (gfc_namespace *ns, int ref_omp_requires)
6287 : : {
6288 : 45859 : if (ns->omp_target_seen
6289 : 922 : && (ns->omp_requires & OMP_REQ_TARGET_MASK)
6290 : 922 : != (ref_omp_requires & OMP_REQ_TARGET_MASK))
6291 : : {
6292 : 3 : gcc_assert (ns->proc_name);
6293 : 3 : if ((ref_omp_requires & OMP_REQ_REVERSE_OFFLOAD)
6294 : 3 : && !(ns->omp_requires & OMP_REQ_REVERSE_OFFLOAD))
6295 : 2 : gfc_error ("Program unit at %L has OpenMP device constructs/routines "
6296 : : "but does not set !$OMP REQUIRES REVERSE_OFFLOAD but other "
6297 : : "program units do", &ns->proc_name->declared_at);
6298 : 3 : if ((ref_omp_requires & OMP_REQ_UNIFIED_ADDRESS)
6299 : 1 : && !(ns->omp_requires & OMP_REQ_UNIFIED_ADDRESS))
6300 : 1 : gfc_error ("Program unit at %L has OpenMP device constructs/routines "
6301 : : "but does not set !$OMP REQUIRES UNIFIED_ADDRESS but other "
6302 : 1 : "program units do", &ns->proc_name->declared_at);
6303 : 3 : if ((ref_omp_requires & OMP_REQ_UNIFIED_SHARED_MEMORY)
6304 : 3 : && !(ns->omp_requires & OMP_REQ_UNIFIED_SHARED_MEMORY))
6305 : 2 : gfc_error ("Program unit at %L has OpenMP device constructs/routines "
6306 : : "but does not set !$OMP REQUIRES UNIFIED_SHARED_MEMORY but "
6307 : 2 : "other program units do", &ns->proc_name->declared_at);
6308 : : }
6309 : 45859 : }
6310 : :
6311 : : bool
6312 : 117 : gfc_omp_requires_add_clause (gfc_omp_requires_kind clause,
6313 : : const char *clause_name, locus *loc,
6314 : : const char *module_name)
6315 : : {
6316 : 117 : gfc_namespace *prog_unit = gfc_current_ns;
6317 : 141 : while (prog_unit->parent)
6318 : : {
6319 : 25 : if (gfc_state_stack->previous
6320 : 25 : && gfc_state_stack->previous->state == COMP_INTERFACE)
6321 : : break;
6322 : : prog_unit = prog_unit->parent;
6323 : : }
6324 : :
6325 : : /* Requires added after use. */
6326 : 117 : if (prog_unit->omp_target_seen
6327 : 24 : && (clause & OMP_REQ_TARGET_MASK)
6328 : 24 : && !(prog_unit->omp_requires & clause))
6329 : : {
6330 : 0 : if (module_name)
6331 : 0 : gfc_error ("!$OMP REQUIRES clause %qs specified via module %qs use "
6332 : : "at %L comes after using a device construct/routine",
6333 : : clause_name, module_name, loc);
6334 : : else
6335 : 0 : gfc_error ("!$OMP REQUIRES clause %qs specified at %L comes after "
6336 : : "using a device construct/routine", clause_name, loc);
6337 : 0 : return false;
6338 : : }
6339 : :
6340 : : /* Overriding atomic_default_mem_order clause value. */
6341 : 117 : if ((clause & OMP_REQ_ATOMIC_MEM_ORDER_MASK)
6342 : 34 : && (prog_unit->omp_requires & OMP_REQ_ATOMIC_MEM_ORDER_MASK)
6343 : 6 : && (prog_unit->omp_requires & OMP_REQ_ATOMIC_MEM_ORDER_MASK)
6344 : 6 : != (int) clause)
6345 : : {
6346 : 3 : const char *other;
6347 : 3 : switch (prog_unit->omp_requires & OMP_REQ_ATOMIC_MEM_ORDER_MASK)
6348 : : {
6349 : : case OMP_REQ_ATOMIC_MEM_ORDER_SEQ_CST: other = "seq_cst"; break;
6350 : 0 : case OMP_REQ_ATOMIC_MEM_ORDER_ACQ_REL: other = "acq_rel"; break;
6351 : 1 : case OMP_REQ_ATOMIC_MEM_ORDER_ACQUIRE: other = "acquire"; break;
6352 : 1 : case OMP_REQ_ATOMIC_MEM_ORDER_RELAXED: other = "relaxed"; break;
6353 : 0 : case OMP_REQ_ATOMIC_MEM_ORDER_RELEASE: other = "release"; break;
6354 : 0 : default: gcc_unreachable ();
6355 : : }
6356 : :
6357 : 3 : if (module_name)
6358 : 0 : gfc_error ("!$OMP REQUIRES clause %<atomic_default_mem_order(%s)%> "
6359 : : "specified via module %qs use at %L overrides a previous "
6360 : : "%<atomic_default_mem_order(%s)%> (which might be through "
6361 : : "using a module)", clause_name, module_name, loc, other);
6362 : : else
6363 : 3 : gfc_error ("!$OMP REQUIRES clause %<atomic_default_mem_order(%s)%> "
6364 : : "specified at %L overrides a previous "
6365 : : "%<atomic_default_mem_order(%s)%> (which might be through "
6366 : : "using a module)", clause_name, loc, other);
6367 : 3 : return false;
6368 : : }
6369 : :
6370 : : /* Requires via module not at program-unit level and not repeating clause. */
6371 : 114 : if (prog_unit != gfc_current_ns && !(prog_unit->omp_requires & clause))
6372 : : {
6373 : 0 : if (clause & OMP_REQ_ATOMIC_MEM_ORDER_MASK)
6374 : 0 : gfc_error ("!$OMP REQUIRES clause %<atomic_default_mem_order(%s)%> "
6375 : : "specified via module %qs use at %L but same clause is "
6376 : : "not specified for the program unit", clause_name,
6377 : : module_name, loc);
6378 : : else
6379 : 0 : gfc_error ("!$OMP REQUIRES clause %qs specified via module %qs use at "
6380 : : "%L but same clause is not specified for the program unit",
6381 : : clause_name, module_name, loc);
6382 : 0 : return false;
6383 : : }
6384 : :
6385 : 114 : if (!gfc_state_stack->previous
6386 : 106 : || gfc_state_stack->previous->state != COMP_INTERFACE)
6387 : 113 : prog_unit->omp_requires |= clause;
6388 : : return true;
6389 : : }
6390 : :
6391 : : match
6392 : 90 : gfc_match_omp_requires (void)
6393 : : {
6394 : 90 : static const char *clauses[] = {"reverse_offload",
6395 : : "unified_address",
6396 : : "unified_shared_memory",
6397 : : "dynamic_allocators",
6398 : : "atomic_default"};
6399 : 90 : const char *clause = NULL;
6400 : 90 : int requires_clauses = 0;
6401 : 90 : bool first = true;
6402 : 90 : locus old_loc;
6403 : :
6404 : 90 : if (gfc_current_ns->parent
6405 : 7 : && (!gfc_state_stack->previous
6406 : 7 : || gfc_state_stack->previous->state != COMP_INTERFACE))
6407 : : {
6408 : 6 : gfc_error ("!$OMP REQUIRES at %C must appear in the specification part "
6409 : : "of a program unit");
6410 : 6 : return MATCH_ERROR;
6411 : : }
6412 : :
6413 : 252 : while (true)
6414 : : {
6415 : 168 : old_loc = gfc_current_locus;
6416 : 168 : gfc_omp_requires_kind requires_clause;
6417 : 84 : if ((first || gfc_match_char (',') != MATCH_YES)
6418 : 168 : && (first && gfc_match_space () != MATCH_YES))
6419 : 0 : goto error;
6420 : 168 : first = false;
6421 : 168 : gfc_gobble_whitespace ();
6422 : 168 : old_loc = gfc_current_locus;
6423 : :
6424 : 168 : if (gfc_match_omp_eos () != MATCH_NO)
6425 : : break;
6426 : 95 : if (gfc_match (clauses[0]) == MATCH_YES)
6427 : : {
6428 : 33 : clause = clauses[0];
6429 : 33 : requires_clause = OMP_REQ_REVERSE_OFFLOAD;
6430 : 33 : if (requires_clauses & OMP_REQ_REVERSE_OFFLOAD)
6431 : 1 : goto duplicate_clause;
6432 : : }
6433 : 62 : else if (gfc_match (clauses[1]) == MATCH_YES)
6434 : : {
6435 : 9 : clause = clauses[1];
6436 : 9 : requires_clause = OMP_REQ_UNIFIED_ADDRESS;
6437 : 9 : if (requires_clauses & OMP_REQ_UNIFIED_ADDRESS)
6438 : 1 : goto duplicate_clause;
6439 : : }
6440 : 53 : else if (gfc_match (clauses[2]) == MATCH_YES)
6441 : : {
6442 : 14 : clause = clauses[2];
6443 : 14 : requires_clause = OMP_REQ_UNIFIED_SHARED_MEMORY;
6444 : 14 : if (requires_clauses & OMP_REQ_UNIFIED_SHARED_MEMORY)
6445 : 1 : goto duplicate_clause;
6446 : : }
6447 : 39 : else if (gfc_match (clauses[3]) == MATCH_YES)
6448 : : {
6449 : 7 : clause = clauses[3];
6450 : 7 : requires_clause = OMP_REQ_DYNAMIC_ALLOCATORS;
6451 : 7 : if (requires_clauses & OMP_REQ_DYNAMIC_ALLOCATORS)
6452 : 1 : goto duplicate_clause;
6453 : : }
6454 : 32 : else if (gfc_match ("atomic_default_mem_order (") == MATCH_YES)
6455 : : {
6456 : 31 : clause = clauses[4];
6457 : 31 : if (requires_clauses & OMP_REQ_ATOMIC_MEM_ORDER_MASK)
6458 : 1 : goto duplicate_clause;
6459 : 30 : if (gfc_match (" seq_cst )") == MATCH_YES)
6460 : : {
6461 : : clause = "seq_cst";
6462 : : requires_clause = OMP_REQ_ATOMIC_MEM_ORDER_SEQ_CST;
6463 : : }
6464 : 18 : else if (gfc_match (" acq_rel )") == MATCH_YES)
6465 : : {
6466 : : clause = "acq_rel";
6467 : : requires_clause = OMP_REQ_ATOMIC_MEM_ORDER_ACQ_REL;
6468 : : }
6469 : 12 : else if (gfc_match (" acquire )") == MATCH_YES)
6470 : : {
6471 : : clause = "acquire";
6472 : : requires_clause = OMP_REQ_ATOMIC_MEM_ORDER_ACQUIRE;
6473 : : }
6474 : 9 : else if (gfc_match (" relaxed )") == MATCH_YES)
6475 : : {
6476 : : clause = "relaxed";
6477 : : requires_clause = OMP_REQ_ATOMIC_MEM_ORDER_RELAXED;
6478 : : }
6479 : 5 : else if (gfc_match (" release )") == MATCH_YES)
6480 : : {
6481 : : clause = "release";
6482 : : requires_clause = OMP_REQ_ATOMIC_MEM_ORDER_RELEASE;
6483 : : }
6484 : : else
6485 : : {
6486 : 2 : gfc_error ("Expected ACQ_REL, ACQUIRE, RELAXED, RELEASE or "
6487 : : "SEQ_CST for ATOMIC_DEFAULT_MEM_ORDER clause at %C");
6488 : 2 : goto error;
6489 : : }
6490 : : }
6491 : : else
6492 : 1 : goto error;
6493 : :
6494 : 87 : if (!gfc_omp_requires_add_clause (requires_clause, clause, &old_loc, NULL))
6495 : 3 : goto error;
6496 : 84 : requires_clauses |= requires_clause;
6497 : 84 : }
6498 : :
6499 : 73 : if (requires_clauses == 0)
6500 : : {
6501 : 1 : if (!gfc_error_flag_test ())
6502 : 1 : gfc_error ("Clause expected at %C");
6503 : 1 : goto error;
6504 : : }
6505 : : return MATCH_YES;
6506 : :
6507 : 5 : duplicate_clause:
6508 : 5 : gfc_error ("%qs clause at %L specified more than once", clause, &old_loc);
6509 : 12 : error:
6510 : 12 : if (!gfc_error_flag_test ())
6511 : 1 : gfc_error ("Expected UNIFIED_ADDRESS, UNIFIED_SHARED_MEMORY, "
6512 : : "DYNAMIC_ALLOCATORS, REVERSE_OFFLOAD, or "
6513 : : "ATOMIC_DEFAULT_MEM_ORDER clause at %L", &old_loc);
6514 : : return MATCH_ERROR;
6515 : : }
6516 : :
6517 : :
6518 : : match
6519 : 47 : gfc_match_omp_scan (void)
6520 : : {
6521 : 47 : bool incl;
6522 : 47 : gfc_omp_clauses *c = gfc_get_omp_clauses ();
6523 : 47 : gfc_gobble_whitespace ();
6524 : 47 : if ((incl = (gfc_match ("inclusive") == MATCH_YES))
6525 : 47 : || gfc_match ("exclusive") == MATCH_YES)
6526 : : {
6527 : 64 : if (gfc_match_omp_variable_list (" (", &c->lists[incl ? OMP_LIST_SCAN_IN
6528 : : : OMP_LIST_SCAN_EX],
6529 : : false) != MATCH_YES)
6530 : : {
6531 : 0 : gfc_free_omp_clauses (c);
6532 : 0 : return MATCH_ERROR;
6533 : : }
6534 : : }
6535 : : else
6536 : : {
6537 : 1 : gfc_error ("Expected INCLUSIVE or EXCLUSIVE clause at %C");
6538 : 1 : gfc_free_omp_clauses (c);
6539 : 1 : return MATCH_ERROR;
6540 : : }
6541 : 46 : if (gfc_match_omp_eos () != MATCH_YES)
6542 : : {
6543 : 1 : gfc_error ("Unexpected junk after !$OMP SCAN at %C");
6544 : 1 : gfc_free_omp_clauses (c);
6545 : 1 : return MATCH_ERROR;
6546 : : }
6547 : :
6548 : 45 : new_st.op = EXEC_OMP_SCAN;
6549 : 45 : new_st.ext.omp_clauses = c;
6550 : 45 : return MATCH_YES;
6551 : : }
6552 : :
6553 : :
6554 : : match
6555 : 58 : gfc_match_omp_scope (void)
6556 : : {
6557 : 58 : return match_omp (EXEC_OMP_SCOPE, OMP_SCOPE_CLAUSES);
6558 : : }
6559 : :
6560 : :
6561 : : match
6562 : 82 : gfc_match_omp_sections (void)
6563 : : {
6564 : 82 : return match_omp (EXEC_OMP_SECTIONS, OMP_SECTIONS_CLAUSES);
6565 : : }
6566 : :
6567 : :
6568 : : match
6569 : 755 : gfc_match_omp_simd (void)
6570 : : {
6571 : 755 : return match_omp (EXEC_OMP_SIMD, OMP_SIMD_CLAUSES);
6572 : : }
6573 : :
6574 : :
6575 : : match
6576 : 579 : gfc_match_omp_single (void)
6577 : : {
6578 : 579 : return match_omp (EXEC_OMP_SINGLE, OMP_SINGLE_CLAUSES);
6579 : : }
6580 : :
6581 : :
6582 : : match
6583 : 1680 : gfc_match_omp_target (void)
6584 : : {
6585 : 1680 : return match_omp (EXEC_OMP_TARGET, OMP_TARGET_CLAUSES);
6586 : : }
6587 : :
6588 : :
6589 : : match
6590 : 1389 : gfc_match_omp_target_data (void)
6591 : : {
6592 : 1389 : return match_omp (EXEC_OMP_TARGET_DATA, OMP_TARGET_DATA_CLAUSES);
6593 : : }
6594 : :
6595 : :
6596 : : match
6597 : 289 : gfc_match_omp_target_enter_data (void)
6598 : : {
6599 : 289 : return match_omp (EXEC_OMP_TARGET_ENTER_DATA, OMP_TARGET_ENTER_DATA_CLAUSES);
6600 : : }
6601 : :
6602 : :
6603 : : match
6604 : 211 : gfc_match_omp_target_exit_data (void)
6605 : : {
6606 : 211 : return match_omp (EXEC_OMP_TARGET_EXIT_DATA, OMP_TARGET_EXIT_DATA_CLAUSES);
6607 : : }
6608 : :
6609 : :
6610 : : match
6611 : 23 : gfc_match_omp_target_parallel (void)
6612 : : {
6613 : 23 : return match_omp (EXEC_OMP_TARGET_PARALLEL,
6614 : 23 : (OMP_TARGET_CLAUSES | OMP_PARALLEL_CLAUSES)
6615 : 23 : & ~(omp_mask (OMP_CLAUSE_COPYIN)));
6616 : : }
6617 : :
6618 : :
6619 : : match
6620 : 45 : gfc_match_omp_target_parallel_do (void)
6621 : : {
6622 : 45 : return match_omp (EXEC_OMP_TARGET_PARALLEL_DO,
6623 : 45 : (OMP_TARGET_CLAUSES | OMP_PARALLEL_CLAUSES
6624 : 45 : | OMP_DO_CLAUSES) & ~(omp_mask (OMP_CLAUSE_COPYIN)));
6625 : : }
6626 : :
6627 : :
6628 : : match
6629 : 19 : gfc_match_omp_target_parallel_do_simd (void)
6630 : : {
6631 : 19 : return match_omp (EXEC_OMP_TARGET_PARALLEL_DO_SIMD,
6632 : 19 : (OMP_TARGET_CLAUSES | OMP_PARALLEL_CLAUSES | OMP_DO_CLAUSES
6633 : 19 : | OMP_SIMD_CLAUSES) & ~(omp_mask (OMP_CLAUSE_COPYIN)));
6634 : : }
6635 : :
6636 : :
6637 : : match
6638 : 34 : gfc_match_omp_target_simd (void)
6639 : : {
6640 : 34 : return match_omp (EXEC_OMP_TARGET_SIMD,
6641 : 34 : OMP_TARGET_CLAUSES | OMP_SIMD_CLAUSES);
6642 : : }
6643 : :
6644 : :
6645 : : match
6646 : 66 : gfc_match_omp_target_teams (void)
6647 : : {
6648 : 66 : return match_omp (EXEC_OMP_TARGET_TEAMS,
6649 : 66 : OMP_TARGET_CLAUSES | OMP_TEAMS_CLAUSES);
6650 : : }
6651 : :
6652 : :
6653 : : match
6654 : 16 : gfc_match_omp_target_teams_distribute (void)
6655 : : {
6656 : 16 : return match_omp (EXEC_OMP_TARGET_TEAMS_DISTRIBUTE,
6657 : 16 : OMP_TARGET_CLAUSES | OMP_TEAMS_CLAUSES
6658 : 16 : | OMP_DISTRIBUTE_CLAUSES);
6659 : : }
6660 : :
6661 : :
6662 : : match
6663 : 53 : gfc_match_omp_target_teams_distribute_parallel_do (void)
6664 : : {
6665 : 53 : return match_omp (EXEC_OMP_TARGET_TEAMS_DISTRIBUTE_PARALLEL_DO,
6666 : 53 : (OMP_TARGET_CLAUSES | OMP_TEAMS_CLAUSES
6667 : 53 : | OMP_DISTRIBUTE_CLAUSES | OMP_PARALLEL_CLAUSES
6668 : 53 : | OMP_DO_CLAUSES)
6669 : 53 : & ~(omp_mask (OMP_CLAUSE_ORDERED))
6670 : 53 : & ~(omp_mask (OMP_CLAUSE_LINEAR)));
6671 : : }
6672 : :
6673 : :
6674 : : match
6675 : 33 : gfc_match_omp_target_teams_distribute_parallel_do_simd (void)
6676 : : {
6677 : 33 : return match_omp (EXEC_OMP_TARGET_TEAMS_DISTRIBUTE_PARALLEL_DO_SIMD,
6678 : 33 : (OMP_TARGET_CLAUSES | OMP_TEAMS_CLAUSES
6679 : 33 : | OMP_DISTRIBUTE_CLAUSES | OMP_PARALLEL_CLAUSES
6680 : 33 : | OMP_DO_CLAUSES | OMP_SIMD_CLAUSES)
6681 : 33 : & ~(omp_mask (OMP_CLAUSE_ORDERED)));
6682 : : }
6683 : :
6684 : :
6685 : : match
6686 : 21 : gfc_match_omp_target_teams_distribute_simd (void)
6687 : : {
6688 : 21 : return match_omp (EXEC_OMP_TARGET_TEAMS_DISTRIBUTE_SIMD,
6689 : 21 : OMP_TARGET_CLAUSES | OMP_TEAMS_CLAUSES
6690 : 21 : | OMP_DISTRIBUTE_CLAUSES | OMP_SIMD_CLAUSES);
6691 : : }
6692 : :
6693 : :
6694 : : match
6695 : 1708 : gfc_match_omp_target_update (void)
6696 : : {
6697 : 1708 : return match_omp (EXEC_OMP_TARGET_UPDATE, OMP_TARGET_UPDATE_CLAUSES);
6698 : : }
6699 : :
6700 : :
6701 : : match
6702 : 1179 : gfc_match_omp_task (void)
6703 : : {
6704 : 1179 : return match_omp (EXEC_OMP_TASK, OMP_TASK_CLAUSES);
6705 : : }
6706 : :
6707 : :
6708 : : match
6709 : 87 : gfc_match_omp_taskloop (void)
6710 : : {
6711 : 87 : return match_omp (EXEC_OMP_TASKLOOP, OMP_TASKLOOP_CLAUSES);
6712 : : }
6713 : :
6714 : :
6715 : : match
6716 : 39 : gfc_match_omp_taskloop_simd (void)
6717 : : {
6718 : 39 : return match_omp (EXEC_OMP_TASKLOOP_SIMD,
6719 : 39 : OMP_TASKLOOP_CLAUSES | OMP_SIMD_CLAUSES);
6720 : : }
6721 : :
6722 : :
6723 : : match
6724 : 144 : gfc_match_omp_taskwait (void)
6725 : : {
6726 : 144 : if (gfc_match_omp_eos () == MATCH_YES)
6727 : : {
6728 : 132 : new_st.op = EXEC_OMP_TASKWAIT;
6729 : 132 : new_st.ext.omp_clauses = NULL;
6730 : 132 : return MATCH_YES;
6731 : : }
6732 : 12 : return match_omp (EXEC_OMP_TASKWAIT,
6733 : 12 : omp_mask (OMP_CLAUSE_DEPEND) | OMP_CLAUSE_NOWAIT);
6734 : : }
6735 : :
6736 : :
6737 : : match
6738 : 10 : gfc_match_omp_taskyield (void)
6739 : : {
6740 : 10 : if (gfc_match_omp_eos () != MATCH_YES)
6741 : : {
6742 : 0 : gfc_error ("Unexpected junk after TASKYIELD clause at %C");
6743 : 0 : return MATCH_ERROR;
6744 : : }
6745 : 10 : new_st.op = EXEC_OMP_TASKYIELD;
6746 : 10 : new_st.ext.omp_clauses = NULL;
6747 : 10 : return MATCH_YES;
6748 : : }
6749 : :
6750 : :
6751 : : match
6752 : 147 : gfc_match_omp_teams (void)
6753 : : {
6754 : 147 : return match_omp (EXEC_OMP_TEAMS, OMP_TEAMS_CLAUSES);
6755 : : }
6756 : :
6757 : :
6758 : : match
6759 : 22 : gfc_match_omp_teams_distribute (void)
6760 : : {
6761 : 22 : return match_omp (EXEC_OMP_TEAMS_DISTRIBUTE,
6762 : 22 : OMP_TEAMS_CLAUSES | OMP_DISTRIBUTE_CLAUSES);
6763 : : }
6764 : :
6765 : :
6766 : : match
6767 : 39 : gfc_match_omp_teams_distribute_parallel_do (void)
6768 : : {
6769 : 39 : return match_omp (EXEC_OMP_TEAMS_DISTRIBUTE_PARALLEL_DO,
6770 : 39 : (OMP_TEAMS_CLAUSES | OMP_DISTRIBUTE_CLAUSES
6771 : 39 : | OMP_PARALLEL_CLAUSES | OMP_DO_CLAUSES)
6772 : 39 : & ~(omp_mask (OMP_CLAUSE_ORDERED)
6773 : 39 : | OMP_CLAUSE_LINEAR | OMP_CLAUSE_NOWAIT));
6774 : : }
6775 : :
6776 : :
6777 : : match
6778 : 62 : gfc_match_omp_teams_distribute_parallel_do_simd (void)
6779 : : {
6780 : 62 : return match_omp (EXEC_OMP_TEAMS_DISTRIBUTE_PARALLEL_DO_SIMD,
6781 : 62 : (OMP_TEAMS_CLAUSES | OMP_DISTRIBUTE_CLAUSES
6782 : 62 : | OMP_PARALLEL_CLAUSES | OMP_DO_CLAUSES
6783 : 62 : | OMP_SIMD_CLAUSES)
6784 : 62 : & ~(omp_mask (OMP_CLAUSE_ORDERED) | OMP_CLAUSE_NOWAIT));
6785 : : }
6786 : :
6787 : :
6788 : : match
6789 : 44 : gfc_match_omp_teams_distribute_simd (void)
6790 : : {
6791 : 44 : return match_omp (EXEC_OMP_TEAMS_DISTRIBUTE_SIMD,
6792 : 44 : OMP_TEAMS_CLAUSES | OMP_DISTRIBUTE_CLAUSES
6793 : 44 : | OMP_SIMD_CLAUSES);
6794 : : }
6795 : :
6796 : :
6797 : : match
6798 : 39 : gfc_match_omp_workshare (void)
6799 : : {
6800 : 39 : return match_omp (EXEC_OMP_WORKSHARE, OMP_WORKSHARE_CLAUSES);
6801 : : }
6802 : :
6803 : :
6804 : : match
6805 : 48 : gfc_match_omp_masked (void)
6806 : : {
6807 : 48 : return match_omp (EXEC_OMP_MASKED, OMP_MASKED_CLAUSES);
6808 : : }
6809 : :
6810 : : match
6811 : 10 : gfc_match_omp_masked_taskloop (void)
6812 : : {
6813 : 10 : return match_omp (EXEC_OMP_MASKED_TASKLOOP,
6814 : 10 : OMP_MASKED_CLAUSES | OMP_TASKLOOP_CLAUSES);
6815 : : }
6816 : :
6817 : : match
6818 : 15 : gfc_match_omp_masked_taskloop_simd (void)
6819 : : {
6820 : 15 : return match_omp (EXEC_OMP_MASKED_TASKLOOP_SIMD,
6821 : 15 : (OMP_MASKED_CLAUSES | OMP_TASKLOOP_CLAUSES
6822 : 15 : | OMP_SIMD_CLAUSES));
6823 : : }
6824 : :
6825 : : match
6826 : 110 : gfc_match_omp_master (void)
6827 : : {
6828 : 110 : if (gfc_match_omp_eos () != MATCH_YES)
6829 : : {
6830 : 1 : gfc_error ("Unexpected junk after $OMP MASTER statement at %C");
6831 : 1 : return MATCH_ERROR;
6832 : : }
6833 : 109 : new_st.op = EXEC_OMP_MASTER;
6834 : 109 : new_st.ext.omp_clauses = NULL;
6835 : 109 : return MATCH_YES;
6836 : : }
6837 : :
6838 : : match
6839 : 16 : gfc_match_omp_master_taskloop (void)
6840 : : {
6841 : 16 : return match_omp (EXEC_OMP_MASTER_TASKLOOP, OMP_TASKLOOP_CLAUSES);
6842 : : }
6843 : :
6844 : : match
6845 : 22 : gfc_match_omp_master_taskloop_simd (void)
6846 : : {
6847 : 22 : return match_omp (EXEC_OMP_MASTER_TASKLOOP_SIMD,
6848 : 22 : OMP_TASKLOOP_CLAUSES | OMP_SIMD_CLAUSES);
6849 : : }
6850 : :
6851 : : match
6852 : 235 : gfc_match_omp_ordered (void)
6853 : : {
6854 : 235 : return match_omp (EXEC_OMP_ORDERED, OMP_ORDERED_CLAUSES);
6855 : : }
6856 : :
6857 : : match
6858 : 8 : gfc_match_omp_nothing (void)
6859 : : {
6860 : 8 : if (gfc_match_omp_eos () != MATCH_YES)
6861 : : {
6862 : 1 : gfc_error ("Unexpected junk after $OMP NOTHING statement at %C");
6863 : 1 : return MATCH_ERROR;
6864 : : }
6865 : : /* Will use ST_NONE; therefore, no EXEC_OMP_ is needed. */
6866 : : return MATCH_YES;
6867 : : }
6868 : :
6869 : : match
6870 : 315 : gfc_match_omp_ordered_depend (void)
6871 : : {
6872 : 315 : return match_omp (EXEC_OMP_ORDERED, omp_mask (OMP_CLAUSE_DOACROSS));
6873 : : }
6874 : :
6875 : :
6876 : : /* omp atomic [clause-list]
6877 : : - atomic-clause: read | write | update
6878 : : - capture
6879 : : - memory-order-clause: seq_cst | acq_rel | release | acquire | relaxed
6880 : : - hint(hint-expr)
6881 : : - OpenMP 5.1: compare | fail (seq_cst | acquire | relaxed ) | weak
6882 : : */
6883 : :
6884 : : match
6885 : 2160 : gfc_match_omp_atomic (void)
6886 : : {
6887 : 2160 : gfc_omp_clauses *c;
6888 : 2160 : locus loc = gfc_current_locus;
6889 : :
6890 : 2160 : if (gfc_match_omp_clauses (&c, OMP_ATOMIC_CLAUSES, true, true) != MATCH_YES)
6891 : : return MATCH_ERROR;
6892 : :
6893 : 2142 : if (c->atomic_op == GFC_OMP_ATOMIC_UNSET)
6894 : 1003 : c->atomic_op = GFC_OMP_ATOMIC_UPDATE;
6895 : :
6896 : 2142 : if (c->capture && c->atomic_op != GFC_OMP_ATOMIC_UPDATE)
6897 : 3 : gfc_error ("!$OMP ATOMIC at %L with %s clause is incompatible with "
6898 : : "READ or WRITE", &loc, "CAPTURE");
6899 : 2142 : if (c->compare && c->atomic_op != GFC_OMP_ATOMIC_UPDATE)
6900 : 3 : gfc_error ("!$OMP ATOMIC at %L with %s clause is incompatible with "
6901 : : "READ or WRITE", &loc, "COMPARE");
6902 : 2142 : if (c->fail != OMP_MEMORDER_UNSET && c->atomic_op != GFC_OMP_ATOMIC_UPDATE)
6903 : 2 : gfc_error ("!$OMP ATOMIC at %L with %s clause is incompatible with "
6904 : : "READ or WRITE", &loc, "FAIL");
6905 : 2142 : if (c->weak && !c->compare)
6906 : : {
6907 : 5 : gfc_error ("!$OMP ATOMIC at %L with %s clause requires %s clause", &loc,
6908 : : "WEAK", "COMPARE");
6909 : 5 : c->weak = false;
6910 : : }
6911 : :
6912 : 2142 : if (c->memorder == OMP_MEMORDER_UNSET)
6913 : : {
6914 : 1958 : gfc_namespace *prog_unit = gfc_current_ns;
6915 : 2510 : while (prog_unit->parent)
6916 : : prog_unit = prog_unit->parent;
6917 : 1958 : switch (prog_unit->omp_requires & OMP_REQ_ATOMIC_MEM_ORDER_MASK)
6918 : : {
6919 : 1925 : case 0:
6920 : 1925 : case OMP_REQ_ATOMIC_MEM_ORDER_RELAXED:
6921 : 1925 : c->memorder = OMP_MEMORDER_RELAXED;
6922 : 1925 : break;
6923 : 7 : case OMP_REQ_ATOMIC_MEM_ORDER_SEQ_CST:
6924 : 7 : c->memorder = OMP_MEMORDER_SEQ_CST;
6925 : 7 : break;
6926 : 16 : case OMP_REQ_ATOMIC_MEM_ORDER_ACQ_REL:
6927 : 16 : if (c->capture)
6928 : 5 : c->memorder = OMP_MEMORDER_ACQ_REL;
6929 : 11 : else if (c->atomic_op == GFC_OMP_ATOMIC_READ)
6930 : 3 : c->memorder = OMP_MEMORDER_ACQUIRE;
6931 : : else
6932 : 8 : c->memorder = OMP_MEMORDER_RELEASE;
6933 : : break;
6934 : 5 : case OMP_REQ_ATOMIC_MEM_ORDER_ACQUIRE:
6935 : 5 : if (c->atomic_op == GFC_OMP_ATOMIC_WRITE)
6936 : : {
6937 : 1 : gfc_error ("!$OMP ATOMIC WRITE at %L incompatible with "
6938 : : "ACQUIRES clause implicitly provided by a "
6939 : : "REQUIRES directive", &loc);
6940 : 1 : c->memorder = OMP_MEMORDER_SEQ_CST;
6941 : : }
6942 : : else
6943 : 4 : c->memorder = OMP_MEMORDER_ACQUIRE;
6944 : : break;
6945 : 5 : case OMP_REQ_ATOMIC_MEM_ORDER_RELEASE:
6946 : 5 : if (c->atomic_op == GFC_OMP_ATOMIC_READ)
6947 : : {
6948 : 1 : gfc_error ("!$OMP ATOMIC READ at %L incompatible with "
6949 : : "RELEASE clause implicitly provided by a "
6950 : : "REQUIRES directive", &loc);
6951 : 1 : c->memorder = OMP_MEMORDER_SEQ_CST;
6952 : : }
6953 : : else
6954 : 4 : c->memorder = OMP_MEMORDER_RELEASE;
6955 : : break;
6956 : 0 : default:
6957 : 0 : gcc_unreachable ();
6958 : : }
6959 : : }
6960 : : else
6961 : 184 : switch (c->atomic_op)
6962 : : {
6963 : 29 : case GFC_OMP_ATOMIC_READ:
6964 : 29 : if (c->memorder == OMP_MEMORDER_RELEASE)
6965 : : {
6966 : 1 : gfc_error ("!$OMP ATOMIC READ at %L incompatible with "
6967 : : "RELEASE clause", &loc);
6968 : 1 : c->memorder = OMP_MEMORDER_SEQ_CST;
6969 : : }
6970 : 28 : else if (c->memorder == OMP_MEMORDER_ACQ_REL)
6971 : 1 : c->memorder = OMP_MEMORDER_ACQUIRE;
6972 : : break;
6973 : 35 : case GFC_OMP_ATOMIC_WRITE:
6974 : 35 : if (c->memorder == OMP_MEMORDER_ACQUIRE)
6975 : : {
6976 : 1 : gfc_error ("!$OMP ATOMIC WRITE at %L incompatible with "
6977 : : "ACQUIRE clause", &loc);
6978 : 1 : c->memorder = OMP_MEMORDER_SEQ_CST;
6979 : : }
6980 : 34 : else if (c->memorder == OMP_MEMORDER_ACQ_REL)
6981 : 1 : c->memorder = OMP_MEMORDER_RELEASE;
6982 : : break;
6983 : : default:
6984 : : break;
6985 : : }
6986 : 2142 : gfc_error_check ();
6987 : 2142 : new_st.ext.omp_clauses = c;
6988 : 2142 : new_st.op = EXEC_OMP_ATOMIC;
6989 : 2142 : return MATCH_YES;
6990 : : }
6991 : :
6992 : :
6993 : : /* acc atomic [ read | write | update | capture] */
6994 : :
6995 : : match
6996 : 552 : gfc_match_oacc_atomic (void)
6997 : : {
6998 : 552 : gfc_omp_clauses *c = gfc_get_omp_clauses ();
6999 : 552 : c->atomic_op = GFC_OMP_ATOMIC_UPDATE;
7000 : 552 : c->memorder = OMP_MEMORDER_RELAXED;
7001 : 552 : gfc_gobble_whitespace ();
7002 : 552 : if (gfc_match ("update") == MATCH_YES)
7003 : : ;
7004 : 373 : else if (gfc_match ("read") == MATCH_YES)
7005 : 17 : c->atomic_op = GFC_OMP_ATOMIC_READ;
7006 : 356 : else if (gfc_match ("write") == MATCH_YES)
7007 : 13 : c->atomic_op = GFC_OMP_ATOMIC_WRITE;
7008 : 343 : else if (gfc_match ("capture") == MATCH_YES)
7009 : 319 : c->capture = true;
7010 : 552 : gfc_gobble_whitespace ();
7011 : 552 : if (gfc_match_omp_eos () != MATCH_YES)
7012 : : {
7013 : 9 : gfc_error ("Unexpected junk after !$ACC ATOMIC statement at %C");
7014 : 9 : gfc_free_omp_clauses (c);
7015 : 9 : return MATCH_ERROR;
7016 : : }
7017 : 543 : new_st.ext.omp_clauses = c;
7018 : 543 : new_st.op = EXEC_OACC_ATOMIC;
7019 : 543 : return MATCH_YES;
7020 : : }
7021 : :
7022 : :
7023 : : match
7024 : 605 : gfc_match_omp_barrier (void)
7025 : : {
7026 : 605 : if (gfc_match_omp_eos () != MATCH_YES)
7027 : : {
7028 : 0 : gfc_error ("Unexpected junk after $OMP BARRIER statement at %C");
7029 : 0 : return MATCH_ERROR;
7030 : : }
7031 : 605 : new_st.op = EXEC_OMP_BARRIER;
7032 : 605 : new_st.ext.omp_clauses = NULL;
7033 : 605 : return MATCH_YES;
7034 : : }
7035 : :
7036 : :
7037 : : match
7038 : 188 : gfc_match_omp_taskgroup (void)
7039 : : {
7040 : 188 : return match_omp (EXEC_OMP_TASKGROUP, OMP_TASKGROUP_CLAUSES);
7041 : : }
7042 : :
7043 : :
7044 : : static enum gfc_omp_cancel_kind
7045 : 494 : gfc_match_omp_cancel_kind (void)
7046 : : {
7047 : 494 : if (gfc_match_space () != MATCH_YES)
7048 : : return OMP_CANCEL_UNKNOWN;
7049 : 492 : if (gfc_match ("parallel") == MATCH_YES)
7050 : : return OMP_CANCEL_PARALLEL;
7051 : 352 : if (gfc_match ("sections") == MATCH_YES)
7052 : : return OMP_CANCEL_SECTIONS;
7053 : 253 : if (gfc_match ("do") == MATCH_YES)
7054 : : return OMP_CANCEL_DO;
7055 : 123 : if (gfc_match ("taskgroup") == MATCH_YES)
7056 : : return OMP_CANCEL_TASKGROUP;
7057 : : return OMP_CANCEL_UNKNOWN;
7058 : : }
7059 : :
7060 : :
7061 : : match
7062 : 321 : gfc_match_omp_cancel (void)
7063 : : {
7064 : 321 : gfc_omp_clauses *c;
7065 : 321 : enum gfc_omp_cancel_kind kind = gfc_match_omp_cancel_kind ();
7066 : 321 : if (kind == OMP_CANCEL_UNKNOWN)
7067 : : return MATCH_ERROR;
7068 : 319 : if (gfc_match_omp_clauses (&c, omp_mask (OMP_CLAUSE_IF), false) != MATCH_YES)
7069 : : return MATCH_ERROR;
7070 : 316 : c->cancel = kind;
7071 : 316 : new_st.op = EXEC_OMP_CANCEL;
7072 : 316 : new_st.ext.omp_clauses = c;
7073 : 316 : return MATCH_YES;
7074 : : }
7075 : :
7076 : :
7077 : : match
7078 : 173 : gfc_match_omp_cancellation_point (void)
7079 : : {
7080 : 173 : gfc_omp_clauses *c;
7081 : 173 : enum gfc_omp_cancel_kind kind = gfc_match_omp_cancel_kind ();
7082 : 173 : if (kind == OMP_CANCEL_UNKNOWN)
7083 : : {
7084 : 2 : gfc_error ("Expected construct-type PARALLEL, SECTIONS, DO or TASKGROUP "
7085 : : "in $OMP CANCELLATION POINT statement at %C");
7086 : 2 : return MATCH_ERROR;
7087 : : }
7088 : 171 : if (gfc_match_omp_eos () != MATCH_YES)
7089 : : {
7090 : 0 : gfc_error ("Unexpected junk after $OMP CANCELLATION POINT statement "
7091 : : "at %C");
7092 : 0 : return MATCH_ERROR;
7093 : : }
7094 : 171 : c = gfc_get_omp_clauses ();
7095 : 171 : c->cancel = kind;
7096 : 171 : new_st.op = EXEC_OMP_CANCELLATION_POINT;
7097 : 171 : new_st.ext.omp_clauses = c;
7098 : 171 : return MATCH_YES;
7099 : : }
7100 : :
7101 : :
7102 : : match
7103 : 2197 : gfc_match_omp_end_nowait (void)
7104 : : {
7105 : 2197 : bool nowait = false;
7106 : 2197 : if (gfc_match ("% nowait") == MATCH_YES)
7107 : 255 : nowait = true;
7108 : 2197 : if (gfc_match_omp_eos () != MATCH_YES)
7109 : : {
7110 : 4 : if (nowait)
7111 : 3 : gfc_error ("Unexpected junk after NOWAIT clause at %C");
7112 : : else
7113 : 1 : gfc_error ("Unexpected junk at %C");
7114 : 4 : return MATCH_ERROR;
7115 : : }
7116 : 2193 : new_st.op = EXEC_OMP_END_NOWAIT;
7117 : 2193 : new_st.ext.omp_bool = nowait;
7118 : 2193 : return MATCH_YES;
7119 : : }
7120 : :
7121 : :
7122 : : match
7123 : 575 : gfc_match_omp_end_single (void)
7124 : : {
7125 : 575 : gfc_omp_clauses *c;
7126 : 575 : if (gfc_match_omp_clauses (&c, omp_mask (OMP_CLAUSE_COPYPRIVATE)
7127 : : | OMP_CLAUSE_NOWAIT) != MATCH_YES)
7128 : : return MATCH_ERROR;
7129 : 575 : new_st.op = EXEC_OMP_END_SINGLE;
7130 : 575 : new_st.ext.omp_clauses = c;
7131 : 575 : return MATCH_YES;
7132 : : }
7133 : :
7134 : :
7135 : : static bool
7136 : 33495 : oacc_is_loop (gfc_code *code)
7137 : : {
7138 : 33495 : return code->op == EXEC_OACC_PARALLEL_LOOP
7139 : : || code->op == EXEC_OACC_KERNELS_LOOP
7140 : 17931 : || code->op == EXEC_OACC_SERIAL_LOOP
7141 : 12437 : || code->op == EXEC_OACC_LOOP;
7142 : : }
7143 : :
7144 : : static void
7145 : 5170 : resolve_scalar_int_expr (gfc_expr *expr, const char *clause)
7146 : : {
7147 : 5170 : if (!gfc_resolve_expr (expr)
7148 : 5170 : || expr->ts.type != BT_INTEGER
7149 : 10276 : || expr->rank != 0)
7150 : 78 : gfc_error ("%s clause at %L requires a scalar INTEGER expression",
7151 : : clause, &expr->where);
7152 : 5170 : }
7153 : :
7154 : : static void
7155 : 3907 : resolve_positive_int_expr (gfc_expr *expr, const char *clause)
7156 : : {
7157 : 3907 : resolve_scalar_int_expr (expr, clause);
7158 : 3907 : if (expr->expr_type == EXPR_CONSTANT
7159 : 3469 : && expr->ts.type == BT_INTEGER
7160 : 3436 : && mpz_sgn (expr->value.integer) <= 0)
7161 : 52 : gfc_warning ((flag_openmp || flag_openmp_simd) ? OPT_Wopenmp : 0,
7162 : : "INTEGER expression of %s clause at %L must be positive",
7163 : : clause, &expr->where);
7164 : 3907 : }
7165 : :
7166 : : static void
7167 : 76 : resolve_nonnegative_int_expr (gfc_expr *expr, const char *clause)
7168 : : {
7169 : 76 : resolve_scalar_int_expr (expr, clause);
7170 : 76 : if (expr->expr_type == EXPR_CONSTANT
7171 : 8 : && expr->ts.type == BT_INTEGER
7172 : 7 : && mpz_sgn (expr->value.integer) < 0)
7173 : 2 : gfc_warning ((flag_openmp || flag_openmp_simd) ? OPT_Wopenmp : 0,
7174 : : "INTEGER expression of %s clause at %L must be non-negative",
7175 : : clause, &expr->where);
7176 : 76 : }
7177 : :
7178 : : /* Emits error when symbol is pointer, cray pointer or cray pointee
7179 : : of derived of polymorphic type. */
7180 : :
7181 : : static void
7182 : 98 : check_symbol_not_pointer (gfc_symbol *sym, locus loc, const char *name)
7183 : : {
7184 : 98 : if (sym->ts.type == BT_DERIVED && sym->attr.cray_pointer)
7185 : 0 : gfc_error ("Cray pointer object %qs of derived type in %s clause at %L",
7186 : : sym->name, name, &loc);
7187 : 98 : if (sym->ts.type == BT_DERIVED && sym->attr.cray_pointee)
7188 : 0 : gfc_error ("Cray pointee object %qs of derived type in %s clause at %L",
7189 : : sym->name, name, &loc);
7190 : :
7191 : 98 : if ((sym->ts.type == BT_ASSUMED && sym->attr.pointer)
7192 : 98 : || (sym->ts.type == BT_CLASS && CLASS_DATA (sym)
7193 : 0 : && CLASS_DATA (sym)->attr.pointer))
7194 : 0 : gfc_error ("POINTER object %qs of polymorphic type in %s clause at %L",
7195 : : sym->name, name, &loc);
7196 : 98 : if ((sym->ts.type == BT_ASSUMED && sym->attr.cray_pointer)
7197 : 98 : || (sym->ts.type == BT_CLASS && CLASS_DATA (sym)
7198 : 0 : && CLASS_DATA (sym)->attr.cray_pointer))
7199 : 0 : gfc_error ("Cray pointer object %qs of polymorphic type in %s clause at %L",
7200 : : sym->name, name, &loc);
7201 : 98 : if ((sym->ts.type == BT_ASSUMED && sym->attr.cray_pointee)
7202 : 98 : || (sym->ts.type == BT_CLASS && CLASS_DATA (sym)
7203 : 0 : && CLASS_DATA (sym)->attr.cray_pointee))
7204 : 0 : gfc_error ("Cray pointee object %qs of polymorphic type in %s clause at %L",
7205 : : sym->name, name, &loc);
7206 : 98 : }
7207 : :
7208 : : /* Emits error when symbol represents assumed size/rank array. */
7209 : :
7210 : : static void
7211 : 13555 : check_array_not_assumed (gfc_symbol *sym, locus loc, const char *name)
7212 : : {
7213 : 13555 : if (sym->as && sym->as->type == AS_ASSUMED_SIZE)
7214 : 10 : gfc_error ("Assumed size array %qs in %s clause at %L",
7215 : : sym->name, name, &loc);
7216 : 13555 : if (sym->as && sym->as->type == AS_ASSUMED_RANK)
7217 : 9 : gfc_error ("Assumed rank array %qs in %s clause at %L",
7218 : : sym->name, name, &loc);
7219 : 13555 : }
7220 : :
7221 : : static void
7222 : 5588 : resolve_oacc_data_clauses (gfc_symbol *sym, locus loc, const char *name)
7223 : : {
7224 : 0 : check_array_not_assumed (sym, loc, name);
7225 : 0 : }
7226 : :
7227 : : static void
7228 : 50 : resolve_oacc_deviceptr_clause (gfc_symbol *sym, locus loc, const char *name)
7229 : : {
7230 : 50 : if (sym->attr.pointer
7231 : 49 : || (sym->ts.type == BT_CLASS && CLASS_DATA (sym)
7232 : 0 : && CLASS_DATA (sym)->attr.class_pointer))
7233 : 1 : gfc_error ("POINTER object %qs in %s clause at %L",
7234 : : sym->name, name, &loc);
7235 : 50 : if (sym->attr.cray_pointer
7236 : 48 : || (sym->ts.type == BT_CLASS && CLASS_DATA (sym)
7237 : 0 : && CLASS_DATA (sym)->attr.cray_pointer))
7238 : 2 : gfc_error ("Cray pointer object %qs in %s clause at %L",
7239 : : sym->name, name, &loc);
7240 : 50 : if (sym->attr.cray_pointee
7241 : 48 : || (sym->ts.type == BT_CLASS && CLASS_DATA (sym)
7242 : 0 : && CLASS_DATA (sym)->attr.cray_pointee))
7243 : 2 : gfc_error ("Cray pointee object %qs in %s clause at %L",
7244 : : sym->name, name, &loc);
7245 : 50 : if (sym->attr.allocatable
7246 : 49 : || (sym->ts.type == BT_CLASS && CLASS_DATA (sym)
7247 : 0 : && CLASS_DATA (sym)->attr.allocatable))
7248 : 1 : gfc_error ("ALLOCATABLE object %qs in %s clause at %L",
7249 : : sym->name, name, &loc);
7250 : 50 : if (sym->attr.value)
7251 : 1 : gfc_error ("VALUE object %qs in %s clause at %L",
7252 : : sym->name, name, &loc);
7253 : 50 : check_array_not_assumed (sym, loc, name);
7254 : 50 : }
7255 : :
7256 : :
7257 : : struct resolve_omp_udr_callback_data
7258 : : {
7259 : : gfc_symbol *sym1, *sym2;
7260 : : };
7261 : :
7262 : :
7263 : : static int
7264 : 1413 : resolve_omp_udr_callback (gfc_expr **e, int *, void *data)
7265 : : {
7266 : 1413 : struct resolve_omp_udr_callback_data *rcd
7267 : : = (struct resolve_omp_udr_callback_data *) data;
7268 : 1413 : if ((*e)->expr_type == EXPR_VARIABLE
7269 : 801 : && ((*e)->symtree->n.sym == rcd->sym1
7270 : 255 : || (*e)->symtree->n.sym == rcd->sym2))
7271 : : {
7272 : 801 : gfc_ref *ref = gfc_get_ref ();
7273 : 801 : ref->type = REF_ARRAY;
7274 : 801 : ref->u.ar.where = (*e)->where;
7275 : 801 : ref->u.ar.as = (*e)->symtree->n.sym->as;
7276 : 801 : ref->u.ar.type = AR_FULL;
7277 : 801 : ref->u.ar.dimen = 0;
7278 : 801 : ref->next = (*e)->ref;
7279 : 801 : (*e)->ref = ref;
7280 : : }
7281 : 1413 : return 0;
7282 : : }
7283 : :
7284 : :
7285 : : static int
7286 : 2990 : resolve_omp_udr_callback2 (gfc_expr **e, int *, void *)
7287 : : {
7288 : 2990 : if ((*e)->expr_type == EXPR_FUNCTION
7289 : 360 : && (*e)->value.function.isym == NULL)
7290 : : {
7291 : 174 : gfc_symbol *sym = (*e)->symtree->n.sym;
7292 : 174 : if (!sym->attr.intrinsic
7293 : 174 : && sym->attr.if_source == IFSRC_UNKNOWN)
7294 : 4 : gfc_error ("Implicitly declared function %s used in "
7295 : : "!$OMP DECLARE REDUCTION at %L", sym->name, &(*e)->where);
7296 : : }
7297 : 2990 : return 0;
7298 : : }
7299 : :
7300 : :
7301 : : static gfc_code *
7302 : 797 : resolve_omp_udr_clause (gfc_omp_namelist *n, gfc_namespace *ns,
7303 : : gfc_symbol *sym1, gfc_symbol *sym2)
7304 : : {
7305 : 797 : gfc_code *copy;
7306 : 797 : gfc_symbol sym1_copy, sym2_copy;
7307 : :
7308 : 797 : if (ns->code->op == EXEC_ASSIGN)
7309 : : {
7310 : 625 : copy = gfc_get_code (EXEC_ASSIGN);
7311 : 625 : copy->expr1 = gfc_copy_expr (ns->code->expr1);
7312 : 625 : copy->expr2 = gfc_copy_expr (ns->code->expr2);
7313 : : }
7314 : : else
7315 : : {
7316 : 172 : copy = gfc_get_code (EXEC_CALL);
7317 : 172 : copy->symtree = ns->code->symtree;
7318 : 172 : copy->ext.actual = gfc_copy_actual_arglist (ns->code->ext.actual);
7319 : : }
7320 : 797 : copy->loc = ns->code->loc;
7321 : 797 : sym1_copy = *sym1;
7322 : 797 : sym2_copy = *sym2;
7323 : 797 : *sym1 = *n->sym;
7324 : 797 : *sym2 = *n->sym;
7325 : 797 : sym1->name = sym1_copy.name;
7326 : 797 : sym2->name = sym2_copy.name;
7327 : 797 : ns->proc_name = ns->parent->proc_name;
7328 : 797 : if (n->sym->attr.dimension)
7329 : : {
7330 : 348 : struct resolve_omp_udr_callback_data rcd;
7331 : 348 : rcd.sym1 = sym1;
7332 : 348 : rcd.sym2 = sym2;
7333 : 348 : gfc_code_walker (©, gfc_dummy_code_callback,
7334 : : resolve_omp_udr_callback, &rcd);
7335 : : }
7336 : 797 : gfc_resolve_code (copy, gfc_current_ns);
7337 : 797 : if (copy->op == EXEC_CALL && copy->resolved_isym == NULL)
7338 : : {
7339 : 172 : gfc_symbol *sym = copy->resolved_sym;
7340 : 172 : if (sym
7341 : 170 : && !sym->attr.intrinsic
7342 : 170 : && sym->attr.if_source == IFSRC_UNKNOWN)
7343 : 4 : gfc_error ("Implicitly declared subroutine %s used in "
7344 : : "!$OMP DECLARE REDUCTION at %L", sym->name,
7345 : : ©->loc);
7346 : : }
7347 : 797 : gfc_code_walker (©, gfc_dummy_code_callback,
7348 : : resolve_omp_udr_callback2, NULL);
7349 : 797 : *sym1 = sym1_copy;
7350 : 797 : *sym2 = sym2_copy;
7351 : 797 : return copy;
7352 : : }
7353 : :
7354 : : /* Assume that a constant expression in the range 1 (omp_default_mem_alloc)
7355 : : to 8 (omp_thread_mem_alloc) range is fine. The original symbol name is
7356 : : already lost during matching via gfc_match_expr. */
7357 : : static bool
7358 : 35 : is_predefined_allocator (gfc_expr *expr)
7359 : : {
7360 : 35 : return (gfc_resolve_expr (expr)
7361 : 34 : && expr->rank == 0
7362 : 29 : && expr->ts.type == BT_INTEGER
7363 : 24 : && expr->ts.kind == gfc_c_intptr_kind
7364 : 19 : && expr->expr_type == EXPR_CONSTANT
7365 : 14 : && mpz_sgn (expr->value.integer) > 0
7366 : 47 : && mpz_cmp_si (expr->value.integer, 8) <= 0);
7367 : : }
7368 : :
7369 : : /* Resolve declarative ALLOCATE statement. Note: Common block vars only appear
7370 : : as /block/ not individual, which is ensured during parsing. */
7371 : :
7372 : : void
7373 : 48 : gfc_resolve_omp_allocate (gfc_namespace *ns, gfc_omp_namelist *list)
7374 : : {
7375 : 169 : for (gfc_omp_namelist *n = list; n; n = n->next)
7376 : : {
7377 : 121 : if (n->sym->attr.result || n->sym->result == n->sym)
7378 : : {
7379 : 1 : gfc_error ("Unexpected function-result variable %qs at %L in "
7380 : : "declarative !$OMP ALLOCATE", n->sym->name, &n->where);
7381 : 31 : continue;
7382 : : }
7383 : 120 : if (ns->omp_allocate->sym->attr.proc_pointer)
7384 : : {
7385 : 0 : gfc_error ("Procedure pointer %qs not supported with !$OMP "
7386 : : "ALLOCATE at %L", n->sym->name, &n->where);
7387 : 0 : continue;
7388 : : }
7389 : 120 : if (n->sym->attr.flavor != FL_VARIABLE)
7390 : : {
7391 : 3 : gfc_error ("Argument %qs at %L to declarative !$OMP ALLOCATE "
7392 : : "directive must be a variable", n->sym->name,
7393 : : &n->where);
7394 : 3 : continue;
7395 : : }
7396 : 117 : if (ns != n->sym->ns || n->sym->attr.use_assoc || n->sym->attr.imported)
7397 : : {
7398 : 8 : gfc_error ("Argument %qs at %L to declarative !$OMP ALLOCATE shall be"
7399 : : " in the same scope as the variable declaration",
7400 : : n->sym->name, &n->where);
7401 : 8 : continue;
7402 : : }
7403 : 109 : if (n->sym->attr.dummy)
7404 : : {
7405 : 3 : gfc_error ("Unexpected dummy argument %qs as argument at %L to "
7406 : : "declarative !$OMP ALLOCATE", n->sym->name, &n->where);
7407 : 3 : continue;
7408 : : }
7409 : 106 : if (n->sym->attr.codimension)
7410 : : {
7411 : 0 : gfc_error ("Unexpected coarray argument %qs as argument at %L to "
7412 : : "declarative !$OMP ALLOCATE", n->sym->name, &n->where);
7413 : 0 : continue;
7414 : : }
7415 : 106 : if (n->sym->attr.omp_allocate)
7416 : : {
7417 : 5 : if (n->sym->attr.in_common)
7418 : : {
7419 : 1 : gfc_error ("Duplicated common block %</%s/%> in !$OMP ALLOCATE "
7420 : 1 : "at %L", n->sym->common_head->name, &n->where);
7421 : 3 : while (n->next && n->next->sym
7422 : 4 : && n->sym->common_head == n->next->sym->common_head)
7423 : : n = n->next;
7424 : : }
7425 : : else
7426 : 4 : gfc_error ("Duplicated variable %qs in !$OMP ALLOCATE at %L",
7427 : : n->sym->name, &n->where);
7428 : 5 : continue;
7429 : : }
7430 : : /* For 'equivalence(a,b)', a 'union_type {<type> a,b} equiv.0' is created
7431 : : with a value expression for 'a' as 'equiv.0.a' (likewise for b); while
7432 : : this can be handled, EQUIVALENCE is marked as obsolescent since Fortran
7433 : : 2018 and also not widely used. However, it could be supported,
7434 : : if needed. */
7435 : 101 : if (n->sym->attr.in_equivalence)
7436 : : {
7437 : 2 : gfc_error ("Sorry, EQUIVALENCE object %qs not supported with !$OMP "
7438 : : "ALLOCATE at %L", n->sym->name, &n->where);
7439 : 2 : continue;
7440 : : }
7441 : : /* Similar for Cray pointer/pointee - they could be implemented but as
7442 : : common vendor extension but nowadays rarely used and requiring
7443 : : -fcray-pointer, there is no need to support them. */
7444 : 99 : if (n->sym->attr.cray_pointer || n->sym->attr.cray_pointee)
7445 : : {
7446 : 2 : gfc_error ("Sorry, Cray pointers and pointees such as %qs are not "
7447 : : "supported with !$OMP ALLOCATE at %L",
7448 : : n->sym->name, &n->where);
7449 : 2 : continue;
7450 : : }
7451 : 97 : n->sym->attr.omp_allocate = 1;
7452 : 97 : if ((n->sym->ts.type == BT_CLASS && n->sym->attr.class_ok
7453 : 0 : && CLASS_DATA (n->sym)->attr.allocatable)
7454 : 97 : || (n->sym->ts.type != BT_CLASS && n->sym->attr.allocatable))
7455 : 1 : gfc_error ("Unexpected allocatable variable %qs at %L in declarative "
7456 : : "!$OMP ALLOCATE directive", n->sym->name, &n->where);
7457 : 96 : else if ((n->sym->ts.type == BT_CLASS && n->sym->attr.class_ok
7458 : 0 : && CLASS_DATA (n->sym)->attr.class_pointer)
7459 : 96 : || (n->sym->ts.type != BT_CLASS && n->sym->attr.pointer))
7460 : 1 : gfc_error ("Unexpected pointer variable %qs at %L in declarative "
7461 : : "!$OMP ALLOCATE directive", n->sym->name, &n->where);
7462 : 97 : HOST_WIDE_INT alignment = 0;
7463 : 103 : if (n->u.align
7464 : 97 : && (!gfc_resolve_expr (n->u.align)
7465 : 21 : || n->u.align->ts.type != BT_INTEGER
7466 : 20 : || n->u.align->rank != 0
7467 : 18 : || n->u.align->expr_type != EXPR_CONSTANT
7468 : 17 : || gfc_extract_hwi (n->u.align, &alignment)
7469 : 17 : || !pow2p_hwi (alignment)))
7470 : : {
7471 : 6 : gfc_error ("ALIGN requires a scalar positive constant integer "
7472 : : "alignment expression at %L that is a power of two",
7473 : 6 : &n->u.align->where);
7474 : 6 : while (n->sym->attr.in_common && n->next && n->next->sym
7475 : 6 : && n->sym->common_head == n->next->sym->common_head)
7476 : : n = n->next;
7477 : 6 : continue;
7478 : : }
7479 : 91 : if (n->sym->attr.in_common || n->sym->attr.save || n->sym->ns->save_all
7480 : 55 : || (n->sym->ns->proc_name
7481 : 55 : && (n->sym->ns->proc_name->attr.flavor == FL_PROGRAM
7482 : 55 : || n->sym->ns->proc_name->attr.flavor == FL_MODULE)))
7483 : : {
7484 : 36 : bool com = n->sym->attr.in_common;
7485 : 36 : if (!n->u2.allocator)
7486 : 1 : gfc_error ("An ALLOCATOR clause is required as the list item "
7487 : : "%<%s%s%s%> at %L has the SAVE attribute", com ? "/" : "",
7488 : 0 : com ? n->sym->common_head->name : n->sym->name,
7489 : : com ? "/" : "", &n->where);
7490 : 35 : else if (!is_predefined_allocator (n->u2.allocator))
7491 : 24 : gfc_error ("Predefined allocator required in ALLOCATOR clause at %L"
7492 : : " as the list item %<%s%s%s%> at %L has the SAVE attribute",
7493 : 24 : &n->u2.allocator->where, com ? "/" : "",
7494 : 24 : com ? n->sym->common_head->name : n->sym->name,
7495 : : com ? "/" : "", &n->where);
7496 : 13 : while (n->sym->attr.in_common && n->next && n->next->sym
7497 : 51 : && n->sym->common_head == n->next->sym->common_head)
7498 : : n = n->next;
7499 : : }
7500 : 55 : else if (n->u2.allocator
7501 : 55 : && (!gfc_resolve_expr (n->u2.allocator)
7502 : 20 : || n->u2.allocator->ts.type != BT_INTEGER
7503 : 19 : || n->u2.allocator->rank != 0
7504 : 18 : || n->u2.allocator->ts.kind != gfc_c_intptr_kind))
7505 : 3 : gfc_error ("Expected integer expression of the "
7506 : : "%<omp_allocator_handle_kind%> kind at %L",
7507 : 3 : &n->u2.allocator->where);
7508 : : }
7509 : 48 : }
7510 : :
7511 : : /* Resolve ASSUME's and ASSUMES' assumption clauses. Note that absent/contains
7512 : : is handled during parse time in omp_verify_merge_absent_contains. */
7513 : :
7514 : : void
7515 : 26 : gfc_resolve_omp_assumptions (gfc_omp_assumptions *assume)
7516 : : {
7517 : 42 : for (gfc_expr_list *el = assume->holds; el; el = el->next)
7518 : 16 : if (!gfc_resolve_expr (el->expr)
7519 : 16 : || el->expr->ts.type != BT_LOGICAL
7520 : 30 : || el->expr->rank != 0)
7521 : 4 : gfc_error ("HOLDS expression at %L must be a scalar logical expression",
7522 : 4 : &el->expr->where);
7523 : 26 : }
7524 : :
7525 : :
7526 : : /* OpenMP directive resolving routines. */
7527 : :
7528 : : static void
7529 : 29112 : resolve_omp_clauses (gfc_code *code, gfc_omp_clauses *omp_clauses,
7530 : : gfc_namespace *ns, bool openacc = false)
7531 : : {
7532 : 29112 : gfc_omp_namelist *n, *last;
7533 : 29112 : gfc_expr_list *el;
7534 : 29112 : int list;
7535 : 29112 : int ifc;
7536 : 29112 : bool if_without_mod = false;
7537 : 29112 : gfc_omp_linear_op linear_op = OMP_LINEAR_DEFAULT;
7538 : 29112 : static const char *clause_names[]
7539 : : = { "PRIVATE", "FIRSTPRIVATE", "LASTPRIVATE", "COPYPRIVATE", "SHARED",
7540 : : "COPYIN", "UNIFORM", "AFFINITY", "ALIGNED", "LINEAR", "DEPEND", "MAP",
7541 : : "TO", "FROM", "INCLUSIVE", "EXCLUSIVE",
7542 : : "REDUCTION", "REDUCTION" /*inscan*/, "REDUCTION" /*task*/,
7543 : : "IN_REDUCTION", "TASK_REDUCTION",
7544 : : "DEVICE_RESIDENT", "LINK", "USE_DEVICE",
7545 : : "CACHE", "IS_DEVICE_PTR", "USE_DEVICE_PTR", "USE_DEVICE_ADDR",
7546 : : "NONTEMPORAL", "ALLOCATE", "HAS_DEVICE_ADDR", "ENTER",
7547 : : "USES_ALLOCATORS" };
7548 : 29112 : STATIC_ASSERT (ARRAY_SIZE (clause_names) == OMP_LIST_NUM);
7549 : :
7550 : 29112 : if (omp_clauses == NULL)
7551 : : return;
7552 : :
7553 : 29112 : if (ns == NULL)
7554 : 28824 : ns = gfc_current_ns;
7555 : :
7556 : 29112 : if (omp_clauses->orderedc && omp_clauses->orderedc < omp_clauses->collapse)
7557 : 0 : gfc_error ("ORDERED clause parameter is less than COLLAPSE at %L",
7558 : : &code->loc);
7559 : 29112 : if (omp_clauses->order_concurrent && omp_clauses->ordered)
7560 : 4 : gfc_error ("ORDER clause must not be used together ORDERED at %L",
7561 : : &code->loc);
7562 : 29112 : if (omp_clauses->if_expr)
7563 : : {
7564 : 1160 : gfc_expr *expr = omp_clauses->if_expr;
7565 : 1160 : if (!gfc_resolve_expr (expr)
7566 : 1160 : || expr->ts.type != BT_LOGICAL || expr->rank != 0)
7567 : 14 : gfc_error ("IF clause at %L requires a scalar LOGICAL expression",
7568 : : &expr->where);
7569 : : if_without_mod = true;
7570 : : }
7571 : 320232 : for (ifc = 0; ifc < OMP_IF_LAST; ifc++)
7572 : 291120 : if (omp_clauses->if_exprs[ifc])
7573 : : {
7574 : 137 : gfc_expr *expr = omp_clauses->if_exprs[ifc];
7575 : 137 : bool ok = true;
7576 : 137 : if (!gfc_resolve_expr (expr)
7577 : 137 : || expr->ts.type != BT_LOGICAL || expr->rank != 0)
7578 : 0 : gfc_error ("IF clause at %L requires a scalar LOGICAL expression",
7579 : : &expr->where);
7580 : 137 : else if (if_without_mod)
7581 : : {
7582 : 1 : gfc_error ("IF clause without modifier at %L used together with "
7583 : : "IF clauses with modifiers",
7584 : 1 : &omp_clauses->if_expr->where);
7585 : 1 : if_without_mod = false;
7586 : : }
7587 : : else
7588 : 136 : switch (code->op)
7589 : : {
7590 : 13 : case EXEC_OMP_CANCEL:
7591 : 13 : ok = ifc == OMP_IF_CANCEL;
7592 : 13 : break;
7593 : :
7594 : 16 : case EXEC_OMP_PARALLEL:
7595 : 16 : case EXEC_OMP_PARALLEL_DO:
7596 : 16 : case EXEC_OMP_PARALLEL_LOOP:
7597 : 16 : case EXEC_OMP_PARALLEL_MASKED:
7598 : 16 : case EXEC_OMP_PARALLEL_MASTER:
7599 : 16 : case EXEC_OMP_PARALLEL_SECTIONS:
7600 : 16 : case EXEC_OMP_PARALLEL_WORKSHARE:
7601 : 16 : case EXEC_OMP_DISTRIBUTE_PARALLEL_DO:
7602 : 16 : case EXEC_OMP_TEAMS_DISTRIBUTE_PARALLEL_DO:
7603 : 16 : ok = ifc == OMP_IF_PARALLEL;
7604 : 16 : break;
7605 : :
7606 : 28 : case EXEC_OMP_PARALLEL_DO_SIMD:
7607 : 28 : case EXEC_OMP_DISTRIBUTE_PARALLEL_DO_SIMD:
7608 : 28 : case EXEC_OMP_TEAMS_DISTRIBUTE_PARALLEL_DO_SIMD:
7609 : 28 : ok = ifc == OMP_IF_PARALLEL || ifc == OMP_IF_SIMD;
7610 : 28 : break;
7611 : :
7612 : 8 : case EXEC_OMP_PARALLEL_MASKED_TASKLOOP:
7613 : 8 : case EXEC_OMP_PARALLEL_MASTER_TASKLOOP:
7614 : 8 : ok = ifc == OMP_IF_PARALLEL || ifc == OMP_IF_TASKLOOP;
7615 : 8 : break;
7616 : :
7617 : 12 : case EXEC_OMP_PARALLEL_MASKED_TASKLOOP_SIMD:
7618 : 12 : case EXEC_OMP_PARALLEL_MASTER_TASKLOOP_SIMD:
7619 : 12 : ok = (ifc == OMP_IF_PARALLEL
7620 : 12 : || ifc == OMP_IF_TASKLOOP
7621 : 12 : || ifc == OMP_IF_SIMD);
7622 : : break;
7623 : :
7624 : 0 : case EXEC_OMP_SIMD:
7625 : 0 : case EXEC_OMP_DO_SIMD:
7626 : 0 : case EXEC_OMP_DISTRIBUTE_SIMD:
7627 : 0 : case EXEC_OMP_TEAMS_DISTRIBUTE_SIMD:
7628 : 0 : ok = ifc == OMP_IF_SIMD;
7629 : 0 : break;
7630 : :
7631 : 1 : case EXEC_OMP_TASK:
7632 : 1 : ok = ifc == OMP_IF_TASK;
7633 : 1 : break;
7634 : :
7635 : 5 : case EXEC_OMP_TASKLOOP:
7636 : 5 : case EXEC_OMP_MASKED_TASKLOOP:
7637 : 5 : case EXEC_OMP_MASTER_TASKLOOP:
7638 : 5 : ok = ifc == OMP_IF_TASKLOOP;
7639 : 5 : break;
7640 : :
7641 : 20 : case EXEC_OMP_TASKLOOP_SIMD:
7642 : 20 : case EXEC_OMP_MASKED_TASKLOOP_SIMD:
7643 : 20 : case EXEC_OMP_MASTER_TASKLOOP_SIMD:
7644 : 20 : ok = ifc == OMP_IF_TASKLOOP || ifc == OMP_IF_SIMD;
7645 : 20 : break;
7646 : :
7647 : 5 : case EXEC_OMP_TARGET:
7648 : 5 : case EXEC_OMP_TARGET_TEAMS:
7649 : 5 : case EXEC_OMP_TARGET_TEAMS_DISTRIBUTE:
7650 : 5 : case EXEC_OMP_TARGET_TEAMS_LOOP:
7651 : 5 : ok = ifc == OMP_IF_TARGET;
7652 : 5 : break;
7653 : :
7654 : 4 : case EXEC_OMP_TARGET_TEAMS_DISTRIBUTE_SIMD:
7655 : 4 : case EXEC_OMP_TARGET_SIMD:
7656 : 4 : ok = ifc == OMP_IF_TARGET || ifc == OMP_IF_SIMD;
7657 : 4 : break;
7658 : :
7659 : 1 : case EXEC_OMP_TARGET_DATA:
7660 : 1 : ok = ifc == OMP_IF_TARGET_DATA;
7661 : 1 : break;
7662 : :
7663 : 1 : case EXEC_OMP_TARGET_UPDATE:
7664 : 1 : ok = ifc == OMP_IF_TARGET_UPDATE;
7665 : 1 : break;
7666 : :
7667 : 1 : case EXEC_OMP_TARGET_ENTER_DATA:
7668 : 1 : ok = ifc == OMP_IF_TARGET_ENTER_DATA;
7669 : 1 : break;
7670 : :
7671 : 1 : case EXEC_OMP_TARGET_EXIT_DATA:
7672 : 1 : ok = ifc == OMP_IF_TARGET_EXIT_DATA;
7673 : 1 : break;
7674 : :
7675 : 10 : case EXEC_OMP_TARGET_TEAMS_DISTRIBUTE_PARALLEL_DO:
7676 : 10 : case EXEC_OMP_TARGET_PARALLEL:
7677 : 10 : case EXEC_OMP_TARGET_PARALLEL_DO:
7678 : 10 : case EXEC_OMP_TARGET_PARALLEL_LOOP:
7679 : 10 : ok = ifc == OMP_IF_TARGET || ifc == OMP_IF_PARALLEL;
7680 : 10 : break;
7681 : :
7682 : 10 : case EXEC_OMP_TARGET_PARALLEL_DO_SIMD:
7683 : 10 : case EXEC_OMP_TARGET_TEAMS_DISTRIBUTE_PARALLEL_DO_SIMD:
7684 : 10 : ok = (ifc == OMP_IF_TARGET
7685 : 10 : || ifc == OMP_IF_PARALLEL
7686 : 10 : || ifc == OMP_IF_SIMD);
7687 : : break;
7688 : :
7689 : : default:
7690 : : ok = false;
7691 : : break;
7692 : : }
7693 : 137 : if (!ok)
7694 : : {
7695 : 2 : static const char *ifs[] = {
7696 : : "CANCEL",
7697 : : "PARALLEL",
7698 : : "SIMD",
7699 : : "TASK",
7700 : : "TASKLOOP",
7701 : : "TARGET",
7702 : : "TARGET DATA",
7703 : : "TARGET UPDATE",
7704 : : "TARGET ENTER DATA",
7705 : : "TARGET EXIT DATA"
7706 : : };
7707 : 2 : gfc_error ("IF clause modifier %s at %L not appropriate for "
7708 : : "the current OpenMP construct", ifs[ifc], &expr->where);
7709 : : }
7710 : : }
7711 : :
7712 : 29112 : if (omp_clauses->self_expr)
7713 : : {
7714 : 176 : gfc_expr *expr = omp_clauses->self_expr;
7715 : 176 : if (!gfc_resolve_expr (expr)
7716 : 176 : || expr->ts.type != BT_LOGICAL || expr->rank != 0)
7717 : 6 : gfc_error ("SELF clause at %L requires a scalar LOGICAL expression",
7718 : : &expr->where);
7719 : : }
7720 : :
7721 : 29112 : if (omp_clauses->final_expr)
7722 : : {
7723 : 64 : gfc_expr *expr = omp_clauses->final_expr;
7724 : 64 : if (!gfc_resolve_expr (expr)
7725 : 64 : || expr->ts.type != BT_LOGICAL || expr->rank != 0)
7726 : 0 : gfc_error ("FINAL clause at %L requires a scalar LOGICAL expression",
7727 : : &expr->where);
7728 : : }
7729 : 29112 : if (omp_clauses->num_threads)
7730 : 949 : resolve_positive_int_expr (omp_clauses->num_threads, "NUM_THREADS");
7731 : 29112 : if (omp_clauses->chunk_size)
7732 : : {
7733 : 504 : gfc_expr *expr = omp_clauses->chunk_size;
7734 : 504 : if (!gfc_resolve_expr (expr)
7735 : 504 : || expr->ts.type != BT_INTEGER || expr->rank != 0)
7736 : 0 : gfc_error ("SCHEDULE clause's chunk_size at %L requires "
7737 : : "a scalar INTEGER expression", &expr->where);
7738 : 504 : else if (expr->expr_type == EXPR_CONSTANT
7739 : : && expr->ts.type == BT_INTEGER
7740 : 479 : && mpz_sgn (expr->value.integer) <= 0)
7741 : 2 : gfc_warning (OPT_Wopenmp, "INTEGER expression of SCHEDULE clause's "
7742 : : "chunk_size at %L must be positive", &expr->where);
7743 : : }
7744 : 29112 : if (omp_clauses->sched_kind != OMP_SCHED_NONE
7745 : 773 : && omp_clauses->sched_nonmonotonic)
7746 : : {
7747 : 34 : if (omp_clauses->sched_monotonic)
7748 : 2 : gfc_error ("Both MONOTONIC and NONMONOTONIC schedule modifiers "
7749 : : "specified at %L", &code->loc);
7750 : 32 : else if (omp_clauses->ordered)
7751 : 4 : gfc_error ("NONMONOTONIC schedule modifier specified with ORDERED "
7752 : : "clause at %L", &code->loc);
7753 : : }
7754 : :
7755 : 29112 : if (omp_clauses->depobj
7756 : 29112 : && (!gfc_resolve_expr (omp_clauses->depobj)
7757 : 113 : || omp_clauses->depobj->ts.type != BT_INTEGER
7758 : 112 : || omp_clauses->depobj->ts.kind != 2 * gfc_index_integer_kind
7759 : 111 : || omp_clauses->depobj->rank != 0))
7760 : 4 : gfc_error ("DEPOBJ in DEPOBJ construct at %L shall be a scalar integer "
7761 : 4 : "of OMP_DEPEND_KIND kind", &omp_clauses->depobj->where);
7762 : :
7763 : : /* Check that no symbol appears on multiple clauses, except that
7764 : : a symbol can appear on both firstprivate and lastprivate. */
7765 : 989808 : for (list = 0; list < OMP_LIST_NUM; list++)
7766 : 1002389 : for (n = omp_clauses->lists[list]; n; n = n->next)
7767 : : {
7768 : 41693 : if (!n->sym) /* omp_all_memory. */
7769 : 47 : continue;
7770 : 41646 : n->sym->mark = 0;
7771 : 41646 : n->sym->comp_mark = 0;
7772 : 41646 : n->sym->data_mark = 0;
7773 : 41646 : n->sym->dev_mark = 0;
7774 : 41646 : n->sym->gen_mark = 0;
7775 : 41646 : n->sym->reduc_mark = 0;
7776 : 41646 : if (n->sym->attr.flavor == FL_VARIABLE
7777 : 237 : || n->sym->attr.proc_pointer
7778 : 196 : || (!code && (!n->sym->attr.dummy || n->sym->ns != ns)))
7779 : : {
7780 : 41450 : if (!code && (!n->sym->attr.dummy || n->sym->ns != ns))
7781 : 0 : gfc_error ("Variable %qs is not a dummy argument at %L",
7782 : : n->sym->name, &n->where);
7783 : 41450 : continue;
7784 : : }
7785 : 196 : if (n->sym->attr.flavor == FL_PROCEDURE
7786 : 138 : && n->sym->result == n->sym
7787 : 124 : && n->sym->attr.function)
7788 : : {
7789 : 124 : if (ns->proc_name == n->sym
7790 : 44 : || (ns->parent && ns->parent->proc_name == n->sym))
7791 : 87 : continue;
7792 : 37 : if (ns->proc_name->attr.entry_master)
7793 : : {
7794 : 32 : gfc_entry_list *el = ns->entries;
7795 : 51 : for (; el; el = el->next)
7796 : 51 : if (el->sym == n->sym)
7797 : : break;
7798 : 32 : if (el)
7799 : 32 : continue;
7800 : : }
7801 : 5 : if (ns->parent
7802 : 3 : && ns->parent->proc_name->attr.entry_master)
7803 : : {
7804 : 2 : gfc_entry_list *el = ns->parent->entries;
7805 : 3 : for (; el; el = el->next)
7806 : 3 : if (el->sym == n->sym)
7807 : : break;
7808 : 2 : if (el)
7809 : 2 : continue;
7810 : : }
7811 : : }
7812 : 75 : if (list == OMP_LIST_MAP
7813 : 13 : && n->sym->attr.flavor == FL_PARAMETER)
7814 : : {
7815 : 7 : if (openacc)
7816 : 5 : gfc_error ("Object %qs is not a variable at %L; parameters"
7817 : : " cannot be and need not be copied", n->sym->name,
7818 : : &n->where);
7819 : : else
7820 : 2 : gfc_error ("Object %qs is not a variable at %L; parameters"
7821 : : " cannot be and need not be mapped", n->sym->name,
7822 : : &n->where);
7823 : : }
7824 : 68 : else if (list != OMP_LIST_USES_ALLOCATORS)
7825 : 29 : gfc_error ("Object %qs is not a variable at %L", n->sym->name,
7826 : : &n->where);
7827 : : }
7828 : 29112 : if (omp_clauses->lists[OMP_LIST_REDUCTION_INSCAN])
7829 : : {
7830 : 65 : locus *loc = &omp_clauses->lists[OMP_LIST_REDUCTION_INSCAN]->where;
7831 : 65 : if (code->op != EXEC_OMP_DO
7832 : : && code->op != EXEC_OMP_SIMD
7833 : : && code->op != EXEC_OMP_DO_SIMD
7834 : : && code->op != EXEC_OMP_PARALLEL_DO
7835 : : && code->op != EXEC_OMP_PARALLEL_DO_SIMD)
7836 : 23 : gfc_error ("%<inscan%> REDUCTION clause on construct other than DO, "
7837 : : "SIMD, DO SIMD, PARALLEL DO, PARALLEL DO SIMD at %L",
7838 : : loc);
7839 : 65 : if (omp_clauses->ordered)
7840 : 2 : gfc_error ("ORDERED clause specified together with %<inscan%> "
7841 : : "REDUCTION clause at %L", loc);
7842 : 65 : if (omp_clauses->sched_kind != OMP_SCHED_NONE)
7843 : 3 : gfc_error ("SCHEDULE clause specified together with %<inscan%> "
7844 : : "REDUCTION clause at %L", loc);
7845 : : }
7846 : :
7847 : 989808 : for (list = 0; list < OMP_LIST_NUM; list++)
7848 : 960696 : if (list != OMP_LIST_FIRSTPRIVATE
7849 : 960696 : && list != OMP_LIST_LASTPRIVATE
7850 : 960696 : && list != OMP_LIST_ALIGNED
7851 : 873360 : && list != OMP_LIST_DEPEND
7852 : 873360 : && list != OMP_LIST_FROM
7853 : 815136 : && list != OMP_LIST_TO
7854 : 786024 : && (list != OMP_LIST_REDUCTION || !openacc)
7855 : 774314 : && list != OMP_LIST_ALLOCATE)
7856 : 776728 : for (n = omp_clauses->lists[list]; n; n = n->next)
7857 : : {
7858 : 31526 : bool component_ref_p = false;
7859 : :
7860 : : /* Allow multiple components of the same (e.g. derived-type)
7861 : : variable here. Duplicate components are detected elsewhere. */
7862 : 31526 : if (n->expr && n->expr->expr_type == EXPR_VARIABLE)
7863 : 13143 : for (gfc_ref *ref = n->expr->ref; ref; ref = ref->next)
7864 : 7652 : if (ref->type == REF_COMPONENT)
7865 : 2242 : component_ref_p = true;
7866 : 31526 : if ((list == OMP_LIST_IS_DEVICE_PTR
7867 : 31526 : || list == OMP_LIST_HAS_DEVICE_ADDR)
7868 : 260 : && !component_ref_p)
7869 : : {
7870 : 260 : if (n->sym->gen_mark
7871 : : || n->sym->dev_mark
7872 : : || n->sym->reduc_mark
7873 : 260 : || n->sym->mark)
7874 : 5 : gfc_error ("Symbol %qs present on multiple clauses at %L",
7875 : : n->sym->name, &n->where);
7876 : : else
7877 : 255 : n->sym->dev_mark = 1;
7878 : : }
7879 : 31266 : else if ((list == OMP_LIST_USE_DEVICE_PTR
7880 : 31266 : || list == OMP_LIST_USE_DEVICE_ADDR
7881 : 31266 : || list == OMP_LIST_PRIVATE
7882 : : || list == OMP_LIST_SHARED)
7883 : 11582 : && !component_ref_p)
7884 : : {
7885 : 11582 : if (n->sym->gen_mark || n->sym->dev_mark || n->sym->reduc_mark)
7886 : 10 : gfc_error ("Symbol %qs present on multiple clauses at %L",
7887 : : n->sym->name, &n->where);
7888 : : else
7889 : : {
7890 : 11572 : n->sym->gen_mark = 1;
7891 : : /* Set both generic and device bits if we have
7892 : : use_device_*(x) or shared(x). This allows us to diagnose
7893 : : "map(x) private(x)" below. */
7894 : 11572 : if (list != OMP_LIST_PRIVATE)
7895 : 3420 : n->sym->dev_mark = 1;
7896 : : }
7897 : : }
7898 : 19684 : else if ((list == OMP_LIST_REDUCTION
7899 : 19684 : || list == OMP_LIST_REDUCTION_TASK
7900 : 17302 : || list == OMP_LIST_REDUCTION_INSCAN
7901 : 17302 : || list == OMP_LIST_IN_REDUCTION
7902 : 17093 : || list == OMP_LIST_TASK_REDUCTION)
7903 : 2591 : && !component_ref_p)
7904 : : {
7905 : : /* Attempts to mix reduction types are diagnosed below. */
7906 : 2591 : if (n->sym->gen_mark || n->sym->dev_mark)
7907 : 2 : gfc_error ("Symbol %qs present on multiple clauses at %L",
7908 : : n->sym->name, &n->where);
7909 : 2591 : n->sym->reduc_mark = 1;
7910 : : }
7911 : 17093 : else if ((!component_ref_p && n->sym->comp_mark)
7912 : 1995 : || (component_ref_p && n->sym->mark))
7913 : : {
7914 : 28 : if (openacc)
7915 : 3 : gfc_error ("Symbol %qs has mixed component and non-component "
7916 : 3 : "accesses at %L", n->sym->name, &n->where);
7917 : : }
7918 : 17065 : else if (n->sym->mark)
7919 : 83 : gfc_error ("Symbol %qs present on multiple clauses at %L",
7920 : : n->sym->name, &n->where);
7921 : : else
7922 : : {
7923 : 16982 : if (component_ref_p)
7924 : 1968 : n->sym->comp_mark = 1;
7925 : : else
7926 : 15014 : n->sym->mark = 1;
7927 : : }
7928 : : }
7929 : :
7930 : : /* Detect specifically the case where we have "map(x) private(x)" and raise
7931 : : an error. If we have "...simd" combined directives though, the "private"
7932 : : applies to the simd part, so this is permitted though. */
7933 : 37269 : for (n = omp_clauses->lists[OMP_LIST_PRIVATE]; n; n = n->next)
7934 : 8157 : if (n->sym->mark
7935 : : && n->sym->gen_mark
7936 : : && !n->sym->dev_mark
7937 : 8157 : && !n->sym->reduc_mark
7938 : 5 : && code->op != EXEC_OMP_TARGET_SIMD
7939 : : && code->op != EXEC_OMP_TARGET_PARALLEL_DO_SIMD
7940 : : && code->op != EXEC_OMP_TARGET_TEAMS_DISTRIBUTE_SIMD
7941 : : && code->op != EXEC_OMP_TARGET_TEAMS_DISTRIBUTE_PARALLEL_DO_SIMD)
7942 : 1 : gfc_error ("Symbol %qs present on multiple clauses at %L",
7943 : : n->sym->name, &n->where);
7944 : :
7945 : : gcc_assert (OMP_LIST_LASTPRIVATE == OMP_LIST_FIRSTPRIVATE + 1);
7946 : 87336 : for (list = OMP_LIST_FIRSTPRIVATE; list <= OMP_LIST_LASTPRIVATE; list++)
7947 : 62245 : for (n = omp_clauses->lists[list]; n; n = n->next)
7948 : 4021 : if (n->sym->data_mark || n->sym->gen_mark || n->sym->dev_mark)
7949 : : {
7950 : 8 : gfc_error ("Symbol %qs present on multiple clauses at %L",
7951 : : n->sym->name, &n->where);
7952 : 8 : n->sym->data_mark = n->sym->gen_mark = n->sym->dev_mark = 0;
7953 : : }
7954 : 4013 : else if (n->sym->mark
7955 : 16 : && code->op != EXEC_OMP_TARGET_TEAMS
7956 : : && code->op != EXEC_OMP_TARGET_TEAMS_DISTRIBUTE
7957 : : && code->op != EXEC_OMP_TARGET_TEAMS_LOOP
7958 : : && code->op != EXEC_OMP_TARGET_TEAMS_DISTRIBUTE_SIMD
7959 : : && code->op != EXEC_OMP_TARGET_TEAMS_DISTRIBUTE_PARALLEL_DO
7960 : : && code->op != EXEC_OMP_TARGET_PARALLEL
7961 : : && code->op != EXEC_OMP_TARGET_PARALLEL_DO
7962 : : && code->op != EXEC_OMP_TARGET_PARALLEL_LOOP
7963 : : && code->op != EXEC_OMP_TARGET_PARALLEL_DO_SIMD
7964 : : && code->op != EXEC_OMP_TARGET_TEAMS_DISTRIBUTE_PARALLEL_DO_SIMD)
7965 : 5 : gfc_error ("Symbol %qs present on both data and map clauses "
7966 : : "at %L", n->sym->name, &n->where);
7967 : :
7968 : 30869 : for (n = omp_clauses->lists[OMP_LIST_FIRSTPRIVATE]; n; n = n->next)
7969 : : {
7970 : 1757 : if (n->sym->data_mark || n->sym->gen_mark || n->sym->dev_mark)
7971 : 4 : gfc_error ("Symbol %qs present on multiple clauses at %L",
7972 : : n->sym->name, &n->where);
7973 : : else
7974 : 1753 : n->sym->data_mark = 1;
7975 : : }
7976 : 31376 : for (n = omp_clauses->lists[OMP_LIST_LASTPRIVATE]; n; n = n->next)
7977 : 2264 : n->sym->data_mark = 0;
7978 : :
7979 : 31376 : for (n = omp_clauses->lists[OMP_LIST_LASTPRIVATE]; n; n = n->next)
7980 : : {
7981 : 2264 : if (n->sym->data_mark || n->sym->gen_mark || n->sym->dev_mark)
7982 : 0 : gfc_error ("Symbol %qs present on multiple clauses at %L",
7983 : : n->sym->name, &n->where);
7984 : : else
7985 : 2264 : n->sym->data_mark = 1;
7986 : : }
7987 : :
7988 : 29262 : for (n = omp_clauses->lists[OMP_LIST_ALIGNED]; n; n = n->next)
7989 : 150 : n->sym->mark = 0;
7990 : :
7991 : 29262 : for (n = omp_clauses->lists[OMP_LIST_ALIGNED]; n; n = n->next)
7992 : : {
7993 : 150 : if (n->sym->mark)
7994 : 0 : gfc_error ("Symbol %qs present on multiple clauses at %L",
7995 : : n->sym->name, &n->where);
7996 : : else
7997 : 150 : n->sym->mark = 1;
7998 : : }
7999 : :
8000 : 29112 : if (omp_clauses->lists[OMP_LIST_ALLOCATE])
8001 : : {
8002 : 680 : for (n = omp_clauses->lists[OMP_LIST_ALLOCATE]; n; n = n->next)
8003 : : {
8004 : 454 : if (n->u2.allocator
8005 : 454 : && (!gfc_resolve_expr (n->u2.allocator)
8006 : 230 : || n->u2.allocator->ts.type != BT_INTEGER
8007 : 228 : || n->u2.allocator->rank != 0
8008 : 227 : || n->u2.allocator->ts.kind != gfc_c_intptr_kind))
8009 : : {
8010 : 8 : gfc_error ("Expected integer expression of the "
8011 : : "%<omp_allocator_handle_kind%> kind at %L",
8012 : 8 : &n->u2.allocator->where);
8013 : 28 : break;
8014 : : }
8015 : 446 : if (!n->u.align)
8016 : 388 : continue;
8017 : 58 : HOST_WIDE_INT alignment = 0;
8018 : 58 : if (!gfc_resolve_expr (n->u.align)
8019 : 58 : || n->u.align->ts.type != BT_INTEGER
8020 : 55 : || n->u.align->rank != 0
8021 : 52 : || n->u.align->expr_type != EXPR_CONSTANT
8022 : 49 : || gfc_extract_hwi (n->u.align, &alignment)
8023 : 49 : || alignment <= 0
8024 : 107 : || !pow2p_hwi (alignment))
8025 : : {
8026 : 12 : gfc_error ("ALIGN requires a scalar positive constant integer "
8027 : : "alignment expression at %L that is a power of two",
8028 : 12 : &n->u.align->where);
8029 : 12 : break;
8030 : : }
8031 : : }
8032 : :
8033 : : /* Check for 2 things here.
8034 : : 1. There is no duplication of variable in allocate clause.
8035 : : 2. Variable in allocate clause are also present in some
8036 : : privatization clase (non-composite case). */
8037 : 700 : for (n = omp_clauses->lists[OMP_LIST_ALLOCATE]; n; n = n->next)
8038 : 454 : if (n->sym)
8039 : 428 : n->sym->mark = 0;
8040 : :
8041 : : gfc_omp_namelist *prev = NULL;
8042 : 700 : for (n = omp_clauses->lists[OMP_LIST_ALLOCATE]; n; )
8043 : : {
8044 : 454 : if (n->sym == NULL)
8045 : : {
8046 : 26 : n = n->next;
8047 : 26 : continue;
8048 : : }
8049 : 428 : if (n->sym->mark == 1)
8050 : : {
8051 : 3 : gfc_warning (OPT_Wopenmp, "%qs appears more than once in "
8052 : : "%<allocate%> at %L" , n->sym->name, &n->where);
8053 : : /* We have already seen this variable so it is a duplicate.
8054 : : Remove it. */
8055 : 3 : if (prev != NULL && prev->next == n)
8056 : : {
8057 : 3 : prev->next = n->next;
8058 : 3 : n->next = NULL;
8059 : 3 : gfc_free_omp_namelist (n, false, true, false);
8060 : 3 : n = prev->next;
8061 : : }
8062 : 3 : continue;
8063 : : }
8064 : 425 : n->sym->mark = 1;
8065 : 425 : prev = n;
8066 : 425 : n = n->next;
8067 : : }
8068 : :
8069 : : /* Non-composite constructs. */
8070 : 246 : if (code && code->op < EXEC_OMP_DO_SIMD)
8071 : : {
8072 : 3876 : for (list = 0; list < OMP_LIST_NUM; list++)
8073 : 3762 : switch (list)
8074 : : {
8075 : 1026 : case OMP_LIST_PRIVATE:
8076 : 1026 : case OMP_LIST_FIRSTPRIVATE:
8077 : 1026 : case OMP_LIST_LASTPRIVATE:
8078 : 1026 : case OMP_LIST_REDUCTION:
8079 : 1026 : case OMP_LIST_REDUCTION_INSCAN:
8080 : 1026 : case OMP_LIST_REDUCTION_TASK:
8081 : 1026 : case OMP_LIST_IN_REDUCTION:
8082 : 1026 : case OMP_LIST_TASK_REDUCTION:
8083 : 1026 : case OMP_LIST_LINEAR:
8084 : 1317 : for (n = omp_clauses->lists[list]; n; n = n->next)
8085 : 291 : n->sym->mark = 0;
8086 : : break;
8087 : : default:
8088 : : break;
8089 : : }
8090 : :
8091 : 397 : for (n = omp_clauses->lists[OMP_LIST_ALLOCATE]; n; n = n->next)
8092 : 283 : if (n->sym->mark == 1)
8093 : 4 : gfc_error ("%qs specified in %<allocate%> clause at %L but not "
8094 : : "in an explicit privatization clause",
8095 : : n->sym->name, &n->where);
8096 : : }
8097 : : if (code
8098 : 246 : && (code->op == EXEC_OMP_ALLOCATORS || code->op == EXEC_OMP_ALLOCATE)
8099 : 69 : && code->block
8100 : 68 : && code->block->next
8101 : 67 : && code->block->next->op == EXEC_ALLOCATE)
8102 : : {
8103 : 64 : gfc_alloc *a;
8104 : 64 : gfc_omp_namelist *n_null = NULL;
8105 : 64 : bool missing_allocator = false;
8106 : 64 : gfc_symbol *missing_allocator_sym = NULL;
8107 : 153 : for (n = omp_clauses->lists[OMP_LIST_ALLOCATE]; n; n = n->next)
8108 : : {
8109 : 89 : if (n->u2.allocator == NULL)
8110 : : {
8111 : 76 : if (!missing_allocator_sym)
8112 : 58 : missing_allocator_sym = n->sym;
8113 : : missing_allocator = true;
8114 : : }
8115 : 89 : if (n->sym == NULL)
8116 : : {
8117 : 26 : n_null = n;
8118 : 26 : continue;
8119 : : }
8120 : 63 : if (n->sym->attr.codimension)
8121 : 2 : gfc_error ("Unexpected coarray %qs in %<allocate%> at %L",
8122 : : n->sym->name, &n->where);
8123 : 99 : for (a = code->block->next->ext.alloc.list; a; a = a->next)
8124 : 97 : if (a->expr->expr_type == EXPR_VARIABLE
8125 : 97 : && a->expr->symtree->n.sym == n->sym)
8126 : : {
8127 : 61 : gfc_ref *ref;
8128 : 74 : for (ref = a->expr->ref; ref; ref = ref->next)
8129 : 13 : if (ref->type == REF_COMPONENT)
8130 : : break;
8131 : : if (ref == NULL)
8132 : : break;
8133 : : }
8134 : 63 : if (a == NULL)
8135 : 2 : gfc_error ("%qs specified in %<allocate%> at %L but not "
8136 : : "in the associated ALLOCATE statement",
8137 : 2 : n->sym->name, &n->where);
8138 : : }
8139 : : /* If there is an ALLOCATE directive without list argument, a
8140 : : namelist with its allocator/align clauses and n->sym = NULL is
8141 : : created during parsing; here, we add all not otherwise specified
8142 : : items from the Fortran allocate to that list.
8143 : : For an ALLOCATORS directive, not listed items use the normal
8144 : : Fortran way.
8145 : : The behavior of an ALLOCATE directive that does not list all
8146 : : arguments but there is no directive without list argument is not
8147 : : well specified. Thus, we reject such code below. In OpenMP 5.2
8148 : : the executable ALLOCATE directive is deprecated and in 6.0
8149 : : deleted such that no spec clarification is to be expected. */
8150 : 117 : for (a = code->block->next->ext.alloc.list; a; a = a->next)
8151 : 85 : if (a->expr->expr_type == EXPR_VARIABLE)
8152 : : {
8153 : 150 : for (n = omp_clauses->lists[OMP_LIST_ALLOCATE]; n; n = n->next)
8154 : 118 : if (a->expr->symtree->n.sym == n->sym)
8155 : : {
8156 : 53 : gfc_ref *ref;
8157 : 64 : for (ref = a->expr->ref; ref; ref = ref->next)
8158 : 11 : if (ref->type == REF_COMPONENT)
8159 : : break;
8160 : : if (ref == NULL)
8161 : : break;
8162 : : }
8163 : 85 : if (n == NULL && n_null == NULL)
8164 : : {
8165 : : /* OK for ALLOCATORS but for ALLOCATE: Unspecified whether
8166 : : that should use the default allocator of OpenMP or the
8167 : : Fortran allocator. Thus, just reject it. */
8168 : 7 : if (code->op == EXEC_OMP_ALLOCATE)
8169 : 1 : gfc_error ("%qs listed in %<allocate%> statement at %L "
8170 : : "but it is neither explicitly in listed in "
8171 : : "the %<!$OMP ALLOCATE%> directive nor exists"
8172 : : " a directive without argument list",
8173 : 1 : a->expr->symtree->n.sym->name,
8174 : : &a->expr->where);
8175 : : break;
8176 : : }
8177 : 78 : if (n == NULL)
8178 : : {
8179 : 25 : if (a->expr->symtree->n.sym->attr.codimension)
8180 : 1 : gfc_error ("Unexpected coarray %qs in %<allocate%> at "
8181 : : "%L, implicitly listed in %<!$OMP ALLOCATE%>"
8182 : : " at %L", a->expr->symtree->n.sym->name,
8183 : : &a->expr->where, &n_null->where);
8184 : : break;
8185 : : }
8186 : : }
8187 : 64 : gfc_namespace *prog_unit = ns;
8188 : 82 : while (prog_unit->parent)
8189 : : prog_unit = prog_unit->parent;
8190 : : gfc_namespace *fn_ns = ns;
8191 : 66 : while (fn_ns)
8192 : : {
8193 : 65 : if (ns->proc_name
8194 : 65 : && (ns->proc_name->attr.subroutine
8195 : 65 : || ns->proc_name->attr.function))
8196 : : break;
8197 : 2 : fn_ns = fn_ns->parent;
8198 : : }
8199 : 64 : if (missing_allocator
8200 : 57 : && !(prog_unit->omp_requires & OMP_REQ_DYNAMIC_ALLOCATORS)
8201 : 57 : && ((fn_ns && fn_ns->proc_name->attr.omp_declare_target)
8202 : 54 : || omp_clauses->contained_in_target_construct))
8203 : : {
8204 : 6 : if (code->op == EXEC_OMP_ALLOCATORS)
8205 : 2 : gfc_error ("ALLOCATORS directive at %L inside a target region "
8206 : : "must specify an ALLOCATOR modifier for %qs",
8207 : : &code->loc, missing_allocator_sym->name);
8208 : 4 : else if (missing_allocator_sym)
8209 : 2 : gfc_error ("ALLOCATE directive at %L inside a target region "
8210 : : "must specify an ALLOCATOR clause for %qs",
8211 : : &code->loc, missing_allocator_sym->name);
8212 : : else
8213 : 2 : gfc_error ("ALLOCATE directive at %L inside a target region "
8214 : : "must specify an ALLOCATOR clause", &code->loc);
8215 : : }
8216 : :
8217 : : }
8218 : : }
8219 : :
8220 : : /* OpenACC reductions. */
8221 : 29112 : if (openacc)
8222 : : {
8223 : 13532 : for (n = omp_clauses->lists[OMP_LIST_REDUCTION]; n; n = n->next)
8224 : 1822 : n->sym->mark = 0;
8225 : :
8226 : 13532 : for (n = omp_clauses->lists[OMP_LIST_REDUCTION]; n; n = n->next)
8227 : : {
8228 : 1822 : if (n->sym->mark)
8229 : 0 : gfc_error ("Symbol %qs present on multiple clauses at %L",
8230 : : n->sym->name, &n->where);
8231 : : else
8232 : 1822 : n->sym->mark = 1;
8233 : :
8234 : : /* OpenACC does not support reductions on arrays. */
8235 : 1822 : if (n->sym->as)
8236 : 37 : gfc_error ("Array %qs is not permitted in reduction at %L",
8237 : : n->sym->name, &n->where);
8238 : : }
8239 : : }
8240 : :
8241 : 29869 : for (n = omp_clauses->lists[OMP_LIST_TO]; n; n = n->next)
8242 : 757 : n->sym->mark = 0;
8243 : 30141 : for (n = omp_clauses->lists[OMP_LIST_FROM]; n; n = n->next)
8244 : 1029 : if (n->expr == NULL)
8245 : 1013 : n->sym->mark = 1;
8246 : 29869 : for (n = omp_clauses->lists[OMP_LIST_TO]; n; n = n->next)
8247 : : {
8248 : 757 : if (n->expr == NULL && n->sym->mark)
8249 : 0 : gfc_error ("Symbol %qs present on both FROM and TO clauses at %L",
8250 : : n->sym->name, &n->where);
8251 : : else
8252 : 757 : n->sym->mark = 1;
8253 : : }
8254 : :
8255 : : bool has_inscan = false, has_notinscan = false;
8256 : 989808 : for (list = 0; list < OMP_LIST_NUM; list++)
8257 : 960696 : if ((n = omp_clauses->lists[list]) != NULL)
8258 : : {
8259 : 26692 : const char *name = clause_names[list];
8260 : :
8261 : 26692 : switch (list)
8262 : : {
8263 : : case OMP_LIST_COPYIN:
8264 : 267 : for (; n != NULL; n = n->next)
8265 : : {
8266 : 170 : if (!n->sym->attr.threadprivate)
8267 : 0 : gfc_error ("Non-THREADPRIVATE object %qs in COPYIN clause"
8268 : : " at %L", n->sym->name, &n->where);
8269 : : }
8270 : : break;
8271 : 83 : case OMP_LIST_COPYPRIVATE:
8272 : 83 : if (omp_clauses->nowait)
8273 : 6 : gfc_error ("NOWAIT clause must not be used with COPYPRIVATE "
8274 : : "clause at %L", &n->where);
8275 : 376 : for (; n != NULL; n = n->next)
8276 : : {
8277 : 293 : if (n->sym->as && n->sym->as->type == AS_ASSUMED_SIZE)
8278 : 0 : gfc_error ("Assumed size array %qs in COPYPRIVATE clause "
8279 : : "at %L", n->sym->name, &n->where);
8280 : 293 : if (n->sym->attr.pointer && n->sym->attr.intent == INTENT_IN)
8281 : 1 : gfc_error ("INTENT(IN) POINTER %qs in COPYPRIVATE clause "
8282 : : "at %L", n->sym->name, &n->where);
8283 : : }
8284 : : break;
8285 : : case OMP_LIST_SHARED:
8286 : 2554 : for (; n != NULL; n = n->next)
8287 : : {
8288 : 1611 : if (n->sym->attr.threadprivate)
8289 : 0 : gfc_error ("THREADPRIVATE object %qs in SHARED clause at "
8290 : : "%L", n->sym->name, &n->where);
8291 : 1611 : if (n->sym->attr.cray_pointee)
8292 : 1 : gfc_error ("Cray pointee %qs in SHARED clause at %L",
8293 : : n->sym->name, &n->where);
8294 : 1611 : if (n->sym->attr.associate_var)
8295 : 8 : gfc_error ("Associate name %qs in SHARED clause at %L",
8296 : 8 : n->sym->attr.select_type_temporary
8297 : 4 : ? n->sym->assoc->target->symtree->n.sym->name
8298 : : : n->sym->name, &n->where);
8299 : 1611 : if (omp_clauses->detach
8300 : 1 : && n->sym == omp_clauses->detach->symtree->n.sym)
8301 : 1 : gfc_error ("DETACH event handle %qs in SHARED clause at %L",
8302 : : n->sym->name, &n->where);
8303 : : }
8304 : : break;
8305 : : case OMP_LIST_ALIGNED:
8306 : 256 : for (; n != NULL; n = n->next)
8307 : : {
8308 : 150 : if (!n->sym->attr.pointer
8309 : 150 : && !n->sym->attr.allocatable
8310 : 30 : && !n->sym->attr.cray_pointer
8311 : 18 : && (n->sym->ts.type != BT_DERIVED
8312 : 18 : || (n->sym->ts.u.derived->from_intmod
8313 : : != INTMOD_ISO_C_BINDING)
8314 : 18 : || (n->sym->ts.u.derived->intmod_sym_id
8315 : : != ISOCBINDING_PTR)))
8316 : 0 : gfc_error ("%qs in ALIGNED clause must be POINTER, "
8317 : : "ALLOCATABLE, Cray pointer or C_PTR at %L",
8318 : : n->sym->name, &n->where);
8319 : 150 : else if (n->expr)
8320 : : {
8321 : 147 : if (!gfc_resolve_expr (n->expr)
8322 : 147 : || n->expr->ts.type != BT_INTEGER
8323 : 146 : || n->expr->rank != 0
8324 : 146 : || n->expr->expr_type != EXPR_CONSTANT
8325 : 292 : || mpz_sgn (n->expr->value.integer) <= 0)
8326 : 4 : gfc_error ("%qs in ALIGNED clause at %L requires a scalar"
8327 : : " positive constant integer alignment "
8328 : 4 : "expression", n->sym->name, &n->where);
8329 : : }
8330 : : }
8331 : : break;
8332 : : case OMP_LIST_AFFINITY:
8333 : : case OMP_LIST_DEPEND:
8334 : : case OMP_LIST_MAP:
8335 : : case OMP_LIST_TO:
8336 : : case OMP_LIST_FROM:
8337 : : case OMP_LIST_CACHE:
8338 : 30368 : for (; n != NULL; n = n->next)
8339 : : {
8340 : 19034 : if ((list == OMP_LIST_DEPEND || list == OMP_LIST_AFFINITY)
8341 : 1969 : && n->u2.ns && !n->u2.ns->resolved)
8342 : : {
8343 : 53 : n->u2.ns->resolved = 1;
8344 : 53 : for (gfc_symbol *sym = n->u2.ns->omp_affinity_iterators;
8345 : 110 : sym; sym = sym->tlink)
8346 : : {
8347 : 57 : gfc_constructor *c;
8348 : 57 : c = gfc_constructor_first (sym->value->value.constructor);
8349 : 57 : if (!gfc_resolve_expr (c->expr)
8350 : 57 : || c->expr->ts.type != BT_INTEGER
8351 : 112 : || c->expr->rank != 0)
8352 : 2 : gfc_error ("Scalar integer expression for range begin"
8353 : 2 : " expected at %L", &c->expr->where);
8354 : 57 : c = gfc_constructor_next (c);
8355 : 57 : if (!gfc_resolve_expr (c->expr)
8356 : 57 : || c->expr->ts.type != BT_INTEGER
8357 : 112 : || c->expr->rank != 0)
8358 : 2 : gfc_error ("Scalar integer expression for range end "
8359 : 2 : "expected at %L", &c->expr->where);
8360 : 57 : c = gfc_constructor_next (c);
8361 : 57 : if (c && (!gfc_resolve_expr (c->expr)
8362 : 16 : || c->expr->ts.type != BT_INTEGER
8363 : 14 : || c->expr->rank != 0))
8364 : 2 : gfc_error ("Scalar integer expression for range step "
8365 : 2 : "expected at %L", &c->expr->where);
8366 : 55 : else if (c
8367 : 14 : && c->expr->expr_type == EXPR_CONSTANT
8368 : 12 : && mpz_cmp_si (c->expr->value.integer, 0) == 0)
8369 : 2 : gfc_error ("Nonzero range step expected at %L",
8370 : : &c->expr->where);
8371 : : }
8372 : : }
8373 : :
8374 : 1969 : if (list == OMP_LIST_DEPEND)
8375 : : {
8376 : 3166 : if (n->u.depend_doacross_op == OMP_DEPEND_SINK_FIRST
8377 : : || n->u.depend_doacross_op == OMP_DOACROSS_SINK_FIRST
8378 : 1934 : || n->u.depend_doacross_op == OMP_DOACROSS_SINK)
8379 : : {
8380 : 1232 : if (omp_clauses->doacross_source)
8381 : : {
8382 : 0 : gfc_error ("Dependence-type SINK used together with"
8383 : : " SOURCE on the same construct at %L",
8384 : : &n->where);
8385 : 0 : omp_clauses->doacross_source = false;
8386 : : }
8387 : 1232 : else if (n->expr)
8388 : : {
8389 : 571 : if (!gfc_resolve_expr (n->expr)
8390 : 571 : || n->expr->ts.type != BT_INTEGER
8391 : 1142 : || n->expr->rank != 0)
8392 : 0 : gfc_error ("SINK addend not a constant integer "
8393 : : "at %L", &n->where);
8394 : : }
8395 : 1232 : if (n->sym == NULL
8396 : 4 : && (n->expr == NULL
8397 : 3 : || mpz_cmp_si (n->expr->value.integer, -1) != 0))
8398 : 2 : gfc_error ("omp_cur_iteration at %L requires %<-1%> "
8399 : : "as logical offset", &n->where);
8400 : 1232 : continue;
8401 : : }
8402 : 702 : else if (n->u.depend_doacross_op == OMP_DEPEND_DEPOBJ
8403 : 35 : && !n->expr
8404 : 22 : && (n->sym->ts.type != BT_INTEGER
8405 : 22 : || n->sym->ts.kind
8406 : 22 : != 2 * gfc_index_integer_kind
8407 : 22 : || n->sym->attr.dimension))
8408 : 0 : gfc_error ("Locator %qs at %L in DEPEND clause of depobj "
8409 : : "type shall be a scalar integer of "
8410 : : "OMP_DEPEND_KIND kind", n->sym->name,
8411 : : &n->where);
8412 : 702 : else if (n->u.depend_doacross_op == OMP_DEPEND_DEPOBJ
8413 : 35 : && n->expr
8414 : 715 : && (!gfc_resolve_expr (n->expr)
8415 : 13 : || n->expr->ts.type != BT_INTEGER
8416 : 13 : || n->expr->ts.kind
8417 : 13 : != 2 * gfc_index_integer_kind
8418 : 13 : || n->expr->rank != 0))
8419 : 0 : gfc_error ("Locator at %L in DEPEND clause of depobj "
8420 : : "type shall be a scalar integer of "
8421 : 0 : "OMP_DEPEND_KIND kind", &n->expr->where);
8422 : : }
8423 : 17802 : gfc_ref *lastref = NULL, *lastslice = NULL;
8424 : 17802 : bool resolved = false;
8425 : 17802 : if (n->expr)
8426 : : {
8427 : 5736 : lastref = n->expr->ref;
8428 : 5736 : resolved = gfc_resolve_expr (n->expr);
8429 : :
8430 : : /* Look through component refs to find last array
8431 : : reference. */
8432 : 5736 : if (resolved)
8433 : : {
8434 : 13635 : for (gfc_ref *ref = n->expr->ref; ref; ref = ref->next)
8435 : 7914 : if (ref->type == REF_COMPONENT
8436 : : || ref->type == REF_SUBSTRING
8437 : 7914 : || ref->type == REF_INQUIRY)
8438 : : lastref = ref;
8439 : 5626 : else if (ref->type == REF_ARRAY)
8440 : : {
8441 : 11690 : for (int i = 0; i < ref->u.ar.dimen; i++)
8442 : 6064 : if (ref->u.ar.dimen_type[i] == DIMEN_RANGE)
8443 : 5300 : lastslice = ref;
8444 : :
8445 : : lastref = ref;
8446 : : }
8447 : :
8448 : : /* The "!$acc cache" directive allows rectangular
8449 : : subarrays to be specified, with some restrictions
8450 : : on the form of bounds (not implemented).
8451 : : Only raise an error here if we're really sure the
8452 : : array isn't contiguous. An expression such as
8453 : : arr(-n:n,-n:n) could be contiguous even if it looks
8454 : : like it may not be. */
8455 : 5721 : if (code->op != EXEC_OACC_UPDATE
8456 : 4939 : && list != OMP_LIST_CACHE
8457 : 4939 : && list != OMP_LIST_DEPEND
8458 : 4624 : && !gfc_is_simply_contiguous (n->expr, false, true)
8459 : 1363 : && gfc_is_not_contiguous (n->expr)
8460 : 5733 : && !(lastslice
8461 : 12 : && (lastslice->next
8462 : 2 : || lastslice->type != REF_ARRAY)))
8463 : 2 : gfc_error ("Array is not contiguous at %L",
8464 : : &n->where);
8465 : : }
8466 : : }
8467 : 17802 : if (openacc
8468 : 17802 : && list == OMP_LIST_MAP
8469 : 9281 : && (n->u.map.op == OMP_MAP_ATTACH
8470 : 9215 : || n->u.map.op == OMP_MAP_DETACH))
8471 : : {
8472 : 109 : symbol_attribute attr;
8473 : 109 : if (n->expr)
8474 : 99 : attr = gfc_expr_attr (n->expr);
8475 : : else
8476 : 10 : attr = n->sym->attr;
8477 : 109 : if (!attr.pointer && !attr.allocatable)
8478 : 7 : gfc_error ("%qs clause argument must be ALLOCATABLE or "
8479 : : "a POINTER at %L",
8480 : 7 : (n->u.map.op == OMP_MAP_ATTACH) ? "attach"
8481 : : : "detach", &n->where);
8482 : : }
8483 : 17802 : if (lastref
8484 : 12078 : || (n->expr
8485 : 12 : && (!resolved || n->expr->expr_type != EXPR_VARIABLE)))
8486 : : {
8487 : 5736 : if (!lastslice
8488 : 5736 : && lastref
8489 : 834 : && lastref->type == REF_SUBSTRING)
8490 : 11 : gfc_error ("Unexpected substring reference in %s clause "
8491 : : "at %L", name, &n->where);
8492 : 5725 : else if (!lastslice
8493 : : && lastref
8494 : 823 : && lastref->type == REF_INQUIRY)
8495 : : {
8496 : 12 : gcc_assert (lastref->u.i == INQUIRY_RE
8497 : : || lastref->u.i == INQUIRY_IM);
8498 : 12 : gfc_error ("Unexpected complex-parts designator "
8499 : : "reference in %s clause at %L",
8500 : : name, &n->where);
8501 : : }
8502 : 5713 : else if (!resolved
8503 : 5698 : || n->expr->expr_type != EXPR_VARIABLE
8504 : 5686 : || (lastslice
8505 : 4890 : && (lastslice->next
8506 : 4874 : || lastslice->type != REF_ARRAY)))
8507 : 43 : gfc_error ("%qs in %s clause at %L is not a proper "
8508 : 43 : "array section", n->sym->name, name,
8509 : : &n->where);
8510 : : else if (lastslice)
8511 : : {
8512 : : int i;
8513 : : gfc_array_ref *ar = &lastslice->u.ar;
8514 : 10171 : for (i = 0; i < ar->dimen; i++)
8515 : 5298 : if (ar->stride[i] && code->op != EXEC_OACC_UPDATE)
8516 : : {
8517 : 1 : gfc_error ("Stride should not be specified for "
8518 : : "array section in %s clause at %L",
8519 : : name, &n->where);
8520 : 1 : break;
8521 : : }
8522 : 5297 : else if (ar->dimen_type[i] != DIMEN_ELEMENT
8523 : 5297 : && ar->dimen_type[i] != DIMEN_RANGE)
8524 : : {
8525 : 0 : gfc_error ("%qs in %s clause at %L is not a "
8526 : : "proper array section",
8527 : 0 : n->sym->name, name, &n->where);
8528 : 0 : break;
8529 : : }
8530 : 5297 : else if ((list == OMP_LIST_DEPEND
8531 : : || list == OMP_LIST_AFFINITY)
8532 : 159 : && ar->start[i]
8533 : 133 : && ar->start[i]->expr_type == EXPR_CONSTANT
8534 : 97 : && ar->end[i]
8535 : 72 : && ar->end[i]->expr_type == EXPR_CONSTANT
8536 : 72 : && mpz_cmp (ar->start[i]->value.integer,
8537 : 72 : ar->end[i]->value.integer) > 0)
8538 : : {
8539 : 0 : gfc_error ("%qs in %s clause at %L is a "
8540 : : "zero size array section",
8541 : 0 : n->sym->name,
8542 : : list == OMP_LIST_DEPEND
8543 : : ? "DEPEND" : "AFFINITY", &n->where);
8544 : 0 : break;
8545 : : }
8546 : : }
8547 : : }
8548 : 12066 : else if (openacc)
8549 : : {
8550 : 5638 : if (list == OMP_LIST_MAP
8551 : 5629 : && n->u.map.op == OMP_MAP_FORCE_DEVICEPTR)
8552 : 50 : resolve_oacc_deviceptr_clause (n->sym, n->where, name);
8553 : : else
8554 : 5588 : resolve_oacc_data_clauses (n->sym, n->where, name);
8555 : : }
8556 : 6428 : else if (list != OMP_LIST_DEPEND
8557 : 5956 : && n->sym->as
8558 : 2884 : && n->sym->as->type == AS_ASSUMED_SIZE)
8559 : 5 : gfc_error ("Assumed size array %qs in %s clause at %L",
8560 : : n->sym->name, name, &n->where);
8561 : 17802 : if (!openacc
8562 : 17802 : && list == OMP_LIST_MAP
8563 : 5903 : && n->sym->ts.type == BT_DERIVED
8564 : 1365 : && n->sym->ts.u.derived->attr.alloc_comp)
8565 : 1 : gfc_error ("List item %qs with allocatable components is not "
8566 : : "permitted in map clause at %L", n->sym->name,
8567 : : &n->where);
8568 : 17802 : if (list == OMP_LIST_MAP && !openacc)
8569 : 5903 : switch (code->op)
8570 : : {
8571 : 4981 : case EXEC_OMP_TARGET:
8572 : 4981 : case EXEC_OMP_TARGET_DATA:
8573 : 4981 : switch (n->u.map.op)
8574 : : {
8575 : : case OMP_MAP_TO:
8576 : : case OMP_MAP_ALWAYS_TO:
8577 : : case OMP_MAP_PRESENT_TO:
8578 : : case OMP_MAP_ALWAYS_PRESENT_TO:
8579 : : case OMP_MAP_FROM:
8580 : : case OMP_MAP_ALWAYS_FROM:
8581 : : case OMP_MAP_PRESENT_FROM:
8582 : : case OMP_MAP_ALWAYS_PRESENT_FROM:
8583 : : case OMP_MAP_TOFROM:
8584 : : case OMP_MAP_ALWAYS_TOFROM:
8585 : : case OMP_MAP_PRESENT_TOFROM:
8586 : : case OMP_MAP_ALWAYS_PRESENT_TOFROM:
8587 : : case OMP_MAP_ALLOC:
8588 : : case OMP_MAP_PRESENT_ALLOC:
8589 : : break;
8590 : 1 : default:
8591 : 1 : gfc_error ("TARGET%s with map-type other than TO, "
8592 : : "FROM, TOFROM, or ALLOC on MAP clause "
8593 : : "at %L",
8594 : : code->op == EXEC_OMP_TARGET
8595 : : ? "" : " DATA", &n->where);
8596 : 1 : break;
8597 : : }
8598 : : break;
8599 : 373 : case EXEC_OMP_TARGET_ENTER_DATA:
8600 : 373 : switch (n->u.map.op)
8601 : : {
8602 : : case OMP_MAP_TO:
8603 : : case OMP_MAP_ALWAYS_TO:
8604 : : case OMP_MAP_PRESENT_TO:
8605 : : case OMP_MAP_ALWAYS_PRESENT_TO:
8606 : : case OMP_MAP_ALLOC:
8607 : : case OMP_MAP_PRESENT_ALLOC:
8608 : : break;
8609 : 47 : case OMP_MAP_TOFROM:
8610 : 47 : n->u.map.op = OMP_MAP_TO;
8611 : 47 : break;
8612 : 3 : case OMP_MAP_ALWAYS_TOFROM:
8613 : 3 : n->u.map.op = OMP_MAP_ALWAYS_TO;
8614 : 3 : break;
8615 : 2 : case OMP_MAP_PRESENT_TOFROM:
8616 : 2 : n->u.map.op = OMP_MAP_PRESENT_TO;
8617 : 2 : break;
8618 : 2 : case OMP_MAP_ALWAYS_PRESENT_TOFROM:
8619 : 2 : n->u.map.op = OMP_MAP_ALWAYS_PRESENT_TO;
8620 : 2 : break;
8621 : 2 : default:
8622 : 2 : gfc_error ("TARGET ENTER DATA with map-type other "
8623 : : "than TO, TOFROM or ALLOC on MAP clause "
8624 : : "at %L", &n->where);
8625 : 2 : break;
8626 : : }
8627 : : break;
8628 : 267 : case EXEC_OMP_TARGET_EXIT_DATA:
8629 : 267 : switch (n->u.map.op)
8630 : : {
8631 : : case OMP_MAP_FROM:
8632 : : case OMP_MAP_ALWAYS_FROM:
8633 : : case OMP_MAP_PRESENT_FROM:
8634 : : case OMP_MAP_ALWAYS_PRESENT_FROM:
8635 : : case OMP_MAP_RELEASE:
8636 : : case OMP_MAP_DELETE:
8637 : : break;
8638 : 9 : case OMP_MAP_TOFROM:
8639 : 9 : n->u.map.op = OMP_MAP_FROM;
8640 : 9 : break;
8641 : 1 : case OMP_MAP_ALWAYS_TOFROM:
8642 : 1 : n->u.map.op = OMP_MAP_ALWAYS_FROM;
8643 : 1 : break;
8644 : 0 : case OMP_MAP_PRESENT_TOFROM:
8645 : 0 : n->u.map.op = OMP_MAP_PRESENT_FROM;
8646 : 0 : break;
8647 : 0 : case OMP_MAP_ALWAYS_PRESENT_TOFROM:
8648 : 0 : n->u.map.op = OMP_MAP_ALWAYS_PRESENT_FROM;
8649 : 0 : break;
8650 : 2 : default:
8651 : 2 : gfc_error ("TARGET EXIT DATA with map-type other "
8652 : : "than FROM, TOFROM, RELEASE, or DELETE on "
8653 : : "MAP clause at %L", &n->where);
8654 : 2 : break;
8655 : : }
8656 : : break;
8657 : : default:
8658 : : break;
8659 : : }
8660 : : }
8661 : :
8662 : 11334 : if (list != OMP_LIST_DEPEND)
8663 : 27612 : for (n = omp_clauses->lists[list]; n != NULL; n = n->next)
8664 : : {
8665 : 17100 : n->sym->attr.referenced = 1;
8666 : 17100 : if (n->sym->attr.threadprivate)
8667 : 1 : gfc_error ("THREADPRIVATE object %qs in %s clause at %L",
8668 : : n->sym->name, name, &n->where);
8669 : 17100 : if (n->sym->attr.cray_pointee)
8670 : 12 : gfc_error ("Cray pointee %qs in %s clause at %L",
8671 : : n->sym->name, name, &n->where);
8672 : : }
8673 : : break;
8674 : : case OMP_LIST_IS_DEVICE_PTR:
8675 : : last = NULL;
8676 : 318 : for (n = omp_clauses->lists[list]; n != NULL; )
8677 : : {
8678 : 217 : if (n->sym->ts.type == BT_DERIVED
8679 : 33 : && n->sym->ts.u.derived->ts.is_iso_c
8680 : 33 : && code->op != EXEC_OMP_TARGET)
8681 : : /* Non-TARGET (i.e. DISPATCH) requires a C_PTR. */
8682 : 0 : gfc_error ("List item %qs in %s clause at %L must be of "
8683 : : "TYPE(C_PTR)", n->sym->name, name, &n->where);
8684 : 217 : else if (n->sym->ts.type != BT_DERIVED
8685 : 33 : || !n->sym->ts.u.derived->ts.is_iso_c)
8686 : : {
8687 : : /* For TARGET, non-C_PTR are deprecated and handled as
8688 : : has_device_addr. */
8689 : 184 : gfc_omp_namelist *n2 = n;
8690 : 184 : n = n->next;
8691 : 184 : if (last)
8692 : 0 : last->next = n;
8693 : : else
8694 : 184 : omp_clauses->lists[list] = n;
8695 : 184 : n2->next = omp_clauses->lists[OMP_LIST_HAS_DEVICE_ADDR];
8696 : 184 : omp_clauses->lists[OMP_LIST_HAS_DEVICE_ADDR] = n2;
8697 : 184 : continue;
8698 : 184 : }
8699 : 33 : last = n;
8700 : 33 : n = n->next;
8701 : : }
8702 : : break;
8703 : : case OMP_LIST_HAS_DEVICE_ADDR:
8704 : : case OMP_LIST_USE_DEVICE_ADDR:
8705 : : break;
8706 : : case OMP_LIST_USE_DEVICE_PTR:
8707 : : /* Non-C_PTR are deprecated and handled as use_device_ADDR. */
8708 : : last = NULL;
8709 : 468 : for (n = omp_clauses->lists[list]; n != NULL; )
8710 : : {
8711 : 307 : gfc_omp_namelist *n2 = n;
8712 : 307 : if (n->sym->ts.type != BT_DERIVED
8713 : 14 : || !n->sym->ts.u.derived->ts.is_iso_c)
8714 : : {
8715 : 293 : n = n->next;
8716 : 293 : if (last)
8717 : 0 : last->next = n;
8718 : : else
8719 : 293 : omp_clauses->lists[list] = n;
8720 : 293 : n2->next = omp_clauses->lists[OMP_LIST_USE_DEVICE_ADDR];
8721 : 293 : omp_clauses->lists[OMP_LIST_USE_DEVICE_ADDR] = n2;
8722 : 293 : continue;
8723 : : }
8724 : 14 : last = n;
8725 : 14 : n = n->next;
8726 : : }
8727 : : break;
8728 : 39 : case OMP_LIST_USES_ALLOCATORS:
8729 : 39 : {
8730 : 39 : if (n != NULL
8731 : 39 : && n->u.memspace_sym
8732 : 13 : && (n->u.memspace_sym->attr.flavor != FL_PARAMETER
8733 : 12 : || n->u.memspace_sym->ts.type != BT_INTEGER
8734 : 12 : || n->u.memspace_sym->ts.kind != gfc_c_intptr_kind
8735 : 12 : || n->u.memspace_sym->attr.dimension
8736 : 12 : || (!startswith (n->u.memspace_sym->name, "omp_")
8737 : 0 : && !startswith (n->u.memspace_sym->name, "ompx_"))
8738 : 12 : || !endswith (n->u.memspace_sym->name, "_mem_space")))
8739 : 2 : gfc_error ("Memspace %qs at %L in USES_ALLOCATORS must be "
8740 : : "a predefined memory space",
8741 : : n->u.memspace_sym->name, &n->where);
8742 : 117 : for (; n != NULL; n = n->next)
8743 : : {
8744 : 84 : if (n->sym->ts.type != BT_INTEGER
8745 : 84 : || n->sym->ts.kind != gfc_c_intptr_kind
8746 : 83 : || n->sym->attr.dimension)
8747 : 2 : gfc_error ("Allocator %qs at %L in USES_ALLOCATORS must "
8748 : : "be a scalar integer of kind "
8749 : : "%<omp_allocator_handle_kind%>", n->sym->name,
8750 : : &n->where);
8751 : 82 : else if (n->sym->attr.flavor != FL_VARIABLE
8752 : 82 : && ((!startswith (n->sym->name, "omp_")
8753 : 0 : && !startswith (n->sym->name, "ompx_"))
8754 : 39 : || !endswith (n->sym->name, "_mem_alloc")))
8755 : 1 : gfc_error ("Allocator %qs at %L in USES_ALLOCATORS must "
8756 : : "either a variable or a predefined allocator",
8757 : : n->sym->name, &n->where);
8758 : 81 : else if ((n->u.memspace_sym || n->u2.traits_sym)
8759 : 42 : && n->sym->attr.flavor != FL_VARIABLE)
8760 : 3 : gfc_error ("A memory space or traits array may not be "
8761 : : "specified for predefined allocator %qs at %L",
8762 : : n->sym->name, &n->where);
8763 : 84 : if (n->u2.traits_sym
8764 : 37 : && (n->u2.traits_sym->attr.flavor != FL_PARAMETER
8765 : 35 : || !n->u2.traits_sym->attr.dimension
8766 : 33 : || n->u2.traits_sym->as->rank != 1
8767 : 33 : || n->u2.traits_sym->ts.type != BT_DERIVED
8768 : 31 : || strcmp (n->u2.traits_sym->ts.u.derived->name,
8769 : : "omp_alloctrait") != 0))
8770 : : {
8771 : 6 : gfc_error ("Traits array %qs in USES_ALLOCATORS %L must "
8772 : : "be a one-dimensional named constant array of "
8773 : : "type %<omp_alloctrait%>",
8774 : : n->u2.traits_sym->name, &n->where);
8775 : 6 : break;
8776 : : }
8777 : : }
8778 : : break;
8779 : : }
8780 : : default:
8781 : 31062 : for (; n != NULL; n = n->next)
8782 : : {
8783 : 18274 : if (n->sym == NULL)
8784 : : {
8785 : 26 : gcc_assert (code->op == EXEC_OMP_ALLOCATORS
8786 : : || code->op == EXEC_OMP_ALLOCATE);
8787 : 26 : continue;
8788 : : }
8789 : 18248 : bool bad = false;
8790 : 18248 : bool is_reduction = (list == OMP_LIST_REDUCTION
8791 : : || list == OMP_LIST_REDUCTION_INSCAN
8792 : : || list == OMP_LIST_REDUCTION_TASK
8793 : : || list == OMP_LIST_IN_REDUCTION
8794 : 18248 : || list == OMP_LIST_TASK_REDUCTION);
8795 : 18248 : if (list == OMP_LIST_REDUCTION_INSCAN)
8796 : : has_inscan = true;
8797 : 18180 : else if (is_reduction)
8798 : 4345 : has_notinscan = true;
8799 : 18248 : if (has_inscan && has_notinscan && is_reduction)
8800 : : {
8801 : 3 : gfc_error ("%<inscan%> and non-%<inscan%> %<reduction%> "
8802 : : "clauses on the same construct at %L",
8803 : : &n->where);
8804 : 3 : break;
8805 : : }
8806 : 18245 : if (n->sym->attr.threadprivate)
8807 : 1 : gfc_error ("THREADPRIVATE object %qs in %s clause at %L",
8808 : : n->sym->name, name, &n->where);
8809 : 18245 : if (n->sym->attr.cray_pointee)
8810 : 10 : gfc_error ("Cray pointee %qs in %s clause at %L",
8811 : : n->sym->name, name, &n->where);
8812 : 18245 : if (n->sym->attr.associate_var)
8813 : 22 : gfc_error ("Associate name %qs in %s clause at %L",
8814 : 22 : n->sym->attr.select_type_temporary
8815 : 4 : ? n->sym->assoc->target->symtree->n.sym->name
8816 : : : n->sym->name, name, &n->where);
8817 : 18245 : if (list != OMP_LIST_PRIVATE && is_reduction)
8818 : : {
8819 : 4410 : if (n->sym->attr.proc_pointer)
8820 : 1 : gfc_error ("Procedure pointer %qs in %s clause at %L",
8821 : : n->sym->name, name, &n->where);
8822 : 4410 : if (n->sym->attr.pointer)
8823 : 2 : gfc_error ("POINTER object %qs in %s clause at %L",
8824 : : n->sym->name, name, &n->where);
8825 : 4410 : if (n->sym->attr.cray_pointer)
8826 : 3 : gfc_error ("Cray pointer %qs in %s clause at %L",
8827 : : n->sym->name, name, &n->where);
8828 : : }
8829 : 18245 : if (code
8830 : 18245 : && (oacc_is_loop (code)
8831 : : || code->op == EXEC_OACC_PARALLEL
8832 : : || code->op == EXEC_OACC_SERIAL))
8833 : 7731 : check_array_not_assumed (n->sym, n->where, name);
8834 : 10514 : else if (list != OMP_LIST_UNIFORM
8835 : 10372 : && n->sym->as && n->sym->as->type == AS_ASSUMED_SIZE)
8836 : 2 : gfc_error ("Assumed size array %qs in %s clause at %L",
8837 : : n->sym->name, name, &n->where);
8838 : 18245 : if (n->sym->attr.in_namelist && !is_reduction)
8839 : 0 : gfc_error ("Variable %qs in %s clause is used in "
8840 : : "NAMELIST statement at %L",
8841 : : n->sym->name, name, &n->where);
8842 : 18245 : if (n->sym->attr.pointer && n->sym->attr.intent == INTENT_IN)
8843 : 3 : switch (list)
8844 : : {
8845 : 3 : case OMP_LIST_PRIVATE:
8846 : 3 : case OMP_LIST_LASTPRIVATE:
8847 : 3 : case OMP_LIST_LINEAR:
8848 : : /* case OMP_LIST_REDUCTION: */
8849 : 3 : gfc_error ("INTENT(IN) POINTER %qs in %s clause at %L",
8850 : : n->sym->name, name, &n->where);
8851 : 3 : break;
8852 : : default:
8853 : : break;
8854 : : }
8855 : 18245 : if (omp_clauses->detach
8856 : 3 : && (list == OMP_LIST_PRIVATE
8857 : : || list == OMP_LIST_FIRSTPRIVATE
8858 : : || list == OMP_LIST_LASTPRIVATE)
8859 : 3 : && n->sym == omp_clauses->detach->symtree->n.sym)
8860 : 1 : gfc_error ("DETACH event handle %qs in %s clause at %L",
8861 : : n->sym->name, name, &n->where);
8862 : 18245 : switch (list)
8863 : : {
8864 : 103 : case OMP_LIST_REDUCTION_TASK:
8865 : 103 : if (code
8866 : 103 : && (code->op == EXEC_OMP_LOOP
8867 : : || code->op == EXEC_OMP_TASKLOOP
8868 : : || code->op == EXEC_OMP_TASKLOOP_SIMD
8869 : : || code->op == EXEC_OMP_MASKED_TASKLOOP
8870 : : || code->op == EXEC_OMP_MASKED_TASKLOOP_SIMD
8871 : : || code->op == EXEC_OMP_MASTER_TASKLOOP
8872 : : || code->op == EXEC_OMP_MASTER_TASKLOOP_SIMD
8873 : : || code->op == EXEC_OMP_PARALLEL_LOOP
8874 : : || code->op == EXEC_OMP_PARALLEL_MASKED_TASKLOOP
8875 : : || code->op == EXEC_OMP_PARALLEL_MASKED_TASKLOOP_SIMD
8876 : : || code->op == EXEC_OMP_PARALLEL_MASTER_TASKLOOP
8877 : : || code->op == EXEC_OMP_PARALLEL_MASTER_TASKLOOP_SIMD
8878 : : || code->op == EXEC_OMP_TARGET_PARALLEL_LOOP
8879 : : || code->op == EXEC_OMP_TARGET_TEAMS_LOOP
8880 : : || code->op == EXEC_OMP_TEAMS
8881 : : || code->op == EXEC_OMP_TEAMS_DISTRIBUTE
8882 : : || code->op == EXEC_OMP_TEAMS_LOOP))
8883 : : {
8884 : 17 : gfc_error ("Only DEFAULT permitted as reduction-"
8885 : : "modifier in REDUCTION clause at %L",
8886 : : &n->where);
8887 : 17 : break;
8888 : : }
8889 : 4393 : gcc_fallthrough ();
8890 : 4393 : case OMP_LIST_REDUCTION:
8891 : 4393 : case OMP_LIST_IN_REDUCTION:
8892 : 4393 : case OMP_LIST_TASK_REDUCTION:
8893 : 4393 : case OMP_LIST_REDUCTION_INSCAN:
8894 : 4393 : switch (n->u.reduction_op)
8895 : : {
8896 : 2325 : case OMP_REDUCTION_PLUS:
8897 : 2325 : case OMP_REDUCTION_TIMES:
8898 : 2325 : case OMP_REDUCTION_MINUS:
8899 : 2325 : if (!gfc_numeric_ts (&n->sym->ts))
8900 : : bad = true;
8901 : : break;
8902 : 1088 : case OMP_REDUCTION_AND:
8903 : 1088 : case OMP_REDUCTION_OR:
8904 : 1088 : case OMP_REDUCTION_EQV:
8905 : 1088 : case OMP_REDUCTION_NEQV:
8906 : 1088 : if (n->sym->ts.type != BT_LOGICAL)
8907 : : bad = true;
8908 : : break;
8909 : 458 : case OMP_REDUCTION_MAX:
8910 : 458 : case OMP_REDUCTION_MIN:
8911 : 458 : if (n->sym->ts.type != BT_INTEGER
8912 : 201 : && n->sym->ts.type != BT_REAL)
8913 : : bad = true;
8914 : : break;
8915 : 172 : case OMP_REDUCTION_IAND:
8916 : 172 : case OMP_REDUCTION_IOR:
8917 : 172 : case OMP_REDUCTION_IEOR:
8918 : 172 : if (n->sym->ts.type != BT_INTEGER)
8919 : : bad = true;
8920 : : break;
8921 : : case OMP_REDUCTION_USER:
8922 : : bad = true;
8923 : : break;
8924 : : default:
8925 : : break;
8926 : : }
8927 : : if (!bad)
8928 : 3856 : n->u2.udr = NULL;
8929 : : else
8930 : : {
8931 : 537 : const char *udr_name = NULL;
8932 : 537 : if (n->u2.udr)
8933 : : {
8934 : 467 : udr_name = n->u2.udr->udr->name;
8935 : 467 : n->u2.udr->udr
8936 : 934 : = gfc_find_omp_udr (NULL, udr_name,
8937 : 467 : &n->sym->ts);
8938 : 467 : if (n->u2.udr->udr == NULL)
8939 : : {
8940 : 0 : free (n->u2.udr);
8941 : 0 : n->u2.udr = NULL;
8942 : : }
8943 : : }
8944 : 537 : if (n->u2.udr == NULL)
8945 : : {
8946 : 70 : if (udr_name == NULL)
8947 : 70 : switch (n->u.reduction_op)
8948 : : {
8949 : 34 : case OMP_REDUCTION_PLUS:
8950 : 34 : case OMP_REDUCTION_TIMES:
8951 : 34 : case OMP_REDUCTION_MINUS:
8952 : 34 : case OMP_REDUCTION_AND:
8953 : 34 : case OMP_REDUCTION_OR:
8954 : 34 : case OMP_REDUCTION_EQV:
8955 : 34 : case OMP_REDUCTION_NEQV:
8956 : 34 : udr_name = gfc_op2string ((gfc_intrinsic_op)
8957 : : n->u.reduction_op);
8958 : 34 : break;
8959 : : case OMP_REDUCTION_MAX:
8960 : : udr_name = "max";
8961 : : break;
8962 : 6 : case OMP_REDUCTION_MIN:
8963 : 6 : udr_name = "min";
8964 : 6 : break;
8965 : 8 : case OMP_REDUCTION_IAND:
8966 : 8 : udr_name = "iand";
8967 : 8 : break;
8968 : 8 : case OMP_REDUCTION_IOR:
8969 : 8 : udr_name = "ior";
8970 : 8 : break;
8971 : 6 : case OMP_REDUCTION_IEOR:
8972 : 6 : udr_name = "ieor";
8973 : 6 : break;
8974 : 0 : default:
8975 : 0 : gcc_unreachable ();
8976 : : }
8977 : 70 : gfc_error ("!$OMP DECLARE REDUCTION %s not found "
8978 : : "for type %s at %L", udr_name,
8979 : 70 : gfc_typename (&n->sym->ts), &n->where);
8980 : : }
8981 : : else
8982 : : {
8983 : 467 : gfc_omp_udr *udr = n->u2.udr->udr;
8984 : 467 : n->u.reduction_op = OMP_REDUCTION_USER;
8985 : 467 : n->u2.udr->combiner
8986 : 467 : = resolve_omp_udr_clause (n, udr->combiner_ns,
8987 : : udr->omp_out,
8988 : : udr->omp_in);
8989 : 467 : if (udr->initializer_ns)
8990 : 330 : n->u2.udr->initializer
8991 : 330 : = resolve_omp_udr_clause (n,
8992 : : udr->initializer_ns,
8993 : : udr->omp_priv,
8994 : : udr->omp_orig);
8995 : : }
8996 : : }
8997 : : break;
8998 : 898 : case OMP_LIST_LINEAR:
8999 : 898 : if (code
9000 : 726 : && n->u.linear.op != OMP_LINEAR_DEFAULT
9001 : 23 : && n->u.linear.op != linear_op)
9002 : : {
9003 : 23 : if (n->u.linear.old_modifier)
9004 : : {
9005 : 9 : gfc_error ("LINEAR clause modifier used on DO or "
9006 : : "SIMD construct at %L", &n->where);
9007 : 9 : linear_op = n->u.linear.op;
9008 : : }
9009 : 14 : else if (n->u.linear.op != OMP_LINEAR_VAL)
9010 : : {
9011 : 6 : gfc_error ("LINEAR clause modifier other than VAL "
9012 : : "used on DO or SIMD construct at %L",
9013 : : &n->where);
9014 : 6 : linear_op = n->u.linear.op;
9015 : : }
9016 : : }
9017 : 875 : else if (n->u.linear.op != OMP_LINEAR_REF
9018 : 825 : && n->sym->ts.type != BT_INTEGER)
9019 : 1 : gfc_error ("LINEAR variable %qs must be INTEGER "
9020 : : "at %L", n->sym->name, &n->where);
9021 : 874 : else if ((n->u.linear.op == OMP_LINEAR_REF
9022 : 824 : || n->u.linear.op == OMP_LINEAR_UVAL)
9023 : 61 : && n->sym->attr.value)
9024 : 0 : gfc_error ("LINEAR dummy argument %qs with VALUE "
9025 : : "attribute with %s modifier at %L",
9026 : : n->sym->name,
9027 : : n->u.linear.op == OMP_LINEAR_REF
9028 : : ? "REF" : "UVAL", &n->where);
9029 : 874 : else if (n->expr)
9030 : : {
9031 : 855 : gfc_expr *expr = n->expr;
9032 : 855 : if (!gfc_resolve_expr (expr)
9033 : 855 : || expr->ts.type != BT_INTEGER
9034 : 1710 : || expr->rank != 0)
9035 : 0 : gfc_error ("%qs in LINEAR clause at %L requires "
9036 : : "a scalar integer linear-step expression",
9037 : 0 : n->sym->name, &n->where);
9038 : 855 : else if (!code && expr->expr_type != EXPR_CONSTANT)
9039 : : {
9040 : 11 : if (expr->expr_type == EXPR_VARIABLE
9041 : 7 : && expr->symtree->n.sym->attr.dummy
9042 : 6 : && expr->symtree->n.sym->ns == ns)
9043 : : {
9044 : 6 : gfc_omp_namelist *n2;
9045 : 6 : for (n2 = omp_clauses->lists[OMP_LIST_UNIFORM];
9046 : 6 : n2; n2 = n2->next)
9047 : 6 : if (n2->sym == expr->symtree->n.sym)
9048 : : break;
9049 : 6 : if (n2)
9050 : : break;
9051 : : }
9052 : 5 : gfc_error ("%qs in LINEAR clause at %L requires "
9053 : : "a constant integer linear-step "
9054 : : "expression or dummy argument "
9055 : : "specified in UNIFORM clause",
9056 : 5 : n->sym->name, &n->where);
9057 : : }
9058 : : }
9059 : : break;
9060 : : /* Workaround for PR middle-end/26316, nothing really needs
9061 : : to be done here for OMP_LIST_PRIVATE. */
9062 : 8157 : case OMP_LIST_PRIVATE:
9063 : 8157 : gcc_assert (code && code->op != EXEC_NOP);
9064 : : break;
9065 : 98 : case OMP_LIST_USE_DEVICE:
9066 : 98 : if (n->sym->attr.allocatable
9067 : 98 : || (n->sym->ts.type == BT_CLASS && CLASS_DATA (n->sym)
9068 : 0 : && CLASS_DATA (n->sym)->attr.allocatable))
9069 : 0 : gfc_error ("ALLOCATABLE object %qs in %s clause at %L",
9070 : : n->sym->name, name, &n->where);
9071 : 98 : if (n->sym->ts.type == BT_CLASS
9072 : 0 : && CLASS_DATA (n->sym)
9073 : 0 : && CLASS_DATA (n->sym)->attr.class_pointer)
9074 : 0 : gfc_error ("POINTER object %qs of polymorphic type in "
9075 : : "%s clause at %L", n->sym->name, name,
9076 : : &n->where);
9077 : 98 : if (n->sym->attr.cray_pointer)
9078 : 2 : gfc_error ("Cray pointer object %qs in %s clause at %L",
9079 : : n->sym->name, name, &n->where);
9080 : 96 : else if (n->sym->attr.cray_pointee)
9081 : 2 : gfc_error ("Cray pointee object %qs in %s clause at %L",
9082 : : n->sym->name, name, &n->where);
9083 : 94 : else if (n->sym->attr.flavor == FL_VARIABLE
9084 : 93 : && !n->sym->as
9085 : 54 : && !n->sym->attr.pointer)
9086 : 13 : gfc_error ("%s clause variable %qs at %L is neither "
9087 : : "a POINTER nor an array", name,
9088 : : n->sym->name, &n->where);
9089 : : /* FALLTHRU */
9090 : 98 : case OMP_LIST_DEVICE_RESIDENT:
9091 : 98 : check_symbol_not_pointer (n->sym, n->where, name);
9092 : 98 : check_array_not_assumed (n->sym, n->where, name);
9093 : 98 : break;
9094 : : default:
9095 : : break;
9096 : : }
9097 : : }
9098 : : break;
9099 : : }
9100 : : }
9101 : : /* OpenMP 5.1: use_device_ptr acts like use_device_addr, except for
9102 : : type(c_ptr). */
9103 : 29112 : if (omp_clauses->lists[OMP_LIST_USE_DEVICE_PTR])
9104 : : {
9105 : 8 : gfc_omp_namelist *n_prev, *n_next, *n_addr;
9106 : 8 : n_addr = omp_clauses->lists[OMP_LIST_USE_DEVICE_ADDR];
9107 : 27 : for (; n_addr && n_addr->next; n_addr = n_addr->next)
9108 : : ;
9109 : : n_prev = NULL;
9110 : : n = omp_clauses->lists[OMP_LIST_USE_DEVICE_PTR];
9111 : 22 : while (n)
9112 : : {
9113 : 14 : n_next = n->next;
9114 : 14 : if (n->sym->ts.type != BT_DERIVED
9115 : 14 : || n->sym->ts.u.derived->ts.f90_type != BT_VOID)
9116 : : {
9117 : 0 : n->next = NULL;
9118 : 0 : if (n_addr)
9119 : 0 : n_addr->next = n;
9120 : : else
9121 : 0 : omp_clauses->lists[OMP_LIST_USE_DEVICE_ADDR] = n;
9122 : 0 : n_addr = n;
9123 : 0 : if (n_prev)
9124 : 0 : n_prev->next = n_next;
9125 : : else
9126 : 0 : omp_clauses->lists[OMP_LIST_USE_DEVICE_PTR] = n_next;
9127 : : }
9128 : : else
9129 : : n_prev = n;
9130 : : n = n_next;
9131 : : }
9132 : : }
9133 : 29112 : if (omp_clauses->safelen_expr)
9134 : 93 : resolve_positive_int_expr (omp_clauses->safelen_expr, "SAFELEN");
9135 : 29112 : if (omp_clauses->simdlen_expr)
9136 : 123 : resolve_positive_int_expr (omp_clauses->simdlen_expr, "SIMDLEN");
9137 : 29112 : if (omp_clauses->num_teams_lower)
9138 : 21 : resolve_positive_int_expr (omp_clauses->num_teams_lower, "NUM_TEAMS");
9139 : 29112 : if (omp_clauses->num_teams_upper)
9140 : 127 : resolve_positive_int_expr (omp_clauses->num_teams_upper, "NUM_TEAMS");
9141 : 29112 : if (omp_clauses->num_teams_lower
9142 : 21 : && omp_clauses->num_teams_lower->expr_type == EXPR_CONSTANT
9143 : 7 : && omp_clauses->num_teams_upper->expr_type == EXPR_CONSTANT
9144 : 7 : && mpz_cmp (omp_clauses->num_teams_lower->value.integer,
9145 : 7 : omp_clauses->num_teams_upper->value.integer) > 0)
9146 : 2 : gfc_warning (OPT_Wopenmp, "NUM_TEAMS lower bound at %L larger than upper "
9147 : : "bound at %L", &omp_clauses->num_teams_lower->where,
9148 : : &omp_clauses->num_teams_upper->where);
9149 : 29112 : if (omp_clauses->device)
9150 : 234 : resolve_scalar_int_expr (omp_clauses->device, "DEVICE");
9151 : 29112 : if (omp_clauses->filter)
9152 : 42 : resolve_nonnegative_int_expr (omp_clauses->filter, "FILTER");
9153 : 29112 : if (omp_clauses->hint)
9154 : : {
9155 : 42 : resolve_scalar_int_expr (omp_clauses->hint, "HINT");
9156 : 42 : if (omp_clauses->hint->ts.type != BT_INTEGER
9157 : 40 : || omp_clauses->hint->expr_type != EXPR_CONSTANT
9158 : 38 : || mpz_sgn (omp_clauses->hint->value.integer) < 0)
9159 : 5 : gfc_error ("Value of HINT clause at %L shall be a valid "
9160 : : "constant hint expression", &omp_clauses->hint->where);
9161 : : }
9162 : 29112 : if (omp_clauses->priority)
9163 : 34 : resolve_nonnegative_int_expr (omp_clauses->priority, "PRIORITY");
9164 : 29112 : if (omp_clauses->dist_chunk_size)
9165 : : {
9166 : 83 : gfc_expr *expr = omp_clauses->dist_chunk_size;
9167 : 83 : if (!gfc_resolve_expr (expr)
9168 : 83 : || expr->ts.type != BT_INTEGER || expr->rank != 0)
9169 : 0 : gfc_error ("DIST_SCHEDULE clause's chunk_size at %L requires "
9170 : : "a scalar INTEGER expression", &expr->where);
9171 : : }
9172 : 29112 : if (omp_clauses->thread_limit)
9173 : 72 : resolve_positive_int_expr (omp_clauses->thread_limit, "THREAD_LIMIT");
9174 : 29112 : if (omp_clauses->grainsize)
9175 : 43 : resolve_positive_int_expr (omp_clauses->grainsize, "GRAINSIZE");
9176 : 29112 : if (omp_clauses->num_tasks)
9177 : 35 : resolve_positive_int_expr (omp_clauses->num_tasks, "NUM_TASKS");
9178 : 29112 : if (omp_clauses->async)
9179 : 584 : if (omp_clauses->async_expr)
9180 : 584 : resolve_scalar_int_expr (omp_clauses->async_expr, "ASYNC");
9181 : 29112 : if (omp_clauses->num_gangs_expr)
9182 : 682 : resolve_positive_int_expr (omp_clauses->num_gangs_expr, "NUM_GANGS");
9183 : 29112 : if (omp_clauses->num_workers_expr)
9184 : 599 : resolve_positive_int_expr (omp_clauses->num_workers_expr, "NUM_WORKERS");
9185 : 29112 : if (omp_clauses->vector_length_expr)
9186 : 569 : resolve_positive_int_expr (omp_clauses->vector_length_expr,
9187 : : "VECTOR_LENGTH");
9188 : 29112 : if (omp_clauses->gang_num_expr)
9189 : 110 : resolve_positive_int_expr (omp_clauses->gang_num_expr, "GANG");
9190 : 29112 : if (omp_clauses->gang_static_expr)
9191 : 88 : resolve_positive_int_expr (omp_clauses->gang_static_expr, "GANG");
9192 : 29112 : if (omp_clauses->worker_expr)
9193 : 97 : resolve_positive_int_expr (omp_clauses->worker_expr, "WORKER");
9194 : 29112 : if (omp_clauses->vector_expr)
9195 : 128 : resolve_positive_int_expr (omp_clauses->vector_expr, "VECTOR");
9196 : 29439 : for (el = omp_clauses->wait_list; el; el = el->next)
9197 : 327 : resolve_scalar_int_expr (el->expr, "WAIT");
9198 : 29112 : if (omp_clauses->collapse && omp_clauses->tile_list)
9199 : 4 : gfc_error ("Incompatible use of TILE and COLLAPSE at %L", &code->loc);
9200 : 29112 : if (omp_clauses->message)
9201 : : {
9202 : 23 : gfc_expr *expr = omp_clauses->message;
9203 : 23 : if (!gfc_resolve_expr (expr)
9204 : 23 : || expr->ts.kind != gfc_default_character_kind
9205 : 43 : || expr->ts.type != BT_CHARACTER || expr->rank != 0)
9206 : 4 : gfc_error ("MESSAGE clause at %L requires a scalar default-kind "
9207 : : "CHARACTER expression", &expr->where);
9208 : : }
9209 : 29112 : if (!openacc
9210 : 29112 : && code
9211 : 17159 : && omp_clauses->lists[OMP_LIST_MAP] == NULL
9212 : 14125 : && omp_clauses->lists[OMP_LIST_USE_DEVICE_PTR] == NULL
9213 : 14123 : && omp_clauses->lists[OMP_LIST_USE_DEVICE_ADDR] == NULL)
9214 : : {
9215 : 14101 : const char *p = NULL;
9216 : 14101 : switch (code->op)
9217 : : {
9218 : 1 : case EXEC_OMP_TARGET_ENTER_DATA: p = "TARGET ENTER DATA"; break;
9219 : 1 : case EXEC_OMP_TARGET_EXIT_DATA: p = "TARGET EXIT DATA"; break;
9220 : : default: break;
9221 : : }
9222 : 14101 : if (code->op == EXEC_OMP_TARGET_DATA)
9223 : 1 : gfc_error ("TARGET DATA must contain at least one MAP, USE_DEVICE_PTR, "
9224 : : "or USE_DEVICE_ADDR clause at %L", &code->loc);
9225 : 14100 : else if (p)
9226 : 2 : gfc_error ("%s must contain at least one MAP clause at %L",
9227 : : p, &code->loc);
9228 : : }
9229 : :
9230 : 29112 : if (!openacc && omp_clauses->detach)
9231 : : {
9232 : 125 : if (!gfc_resolve_expr (omp_clauses->detach)
9233 : 125 : || omp_clauses->detach->ts.type != BT_INTEGER
9234 : 124 : || omp_clauses->detach->ts.kind != gfc_c_intptr_kind
9235 : 248 : || omp_clauses->detach->rank != 0)
9236 : 3 : gfc_error ("%qs at %L should be a scalar of type "
9237 : : "integer(kind=omp_event_handle_kind)",
9238 : 3 : omp_clauses->detach->symtree->n.sym->name,
9239 : 3 : &omp_clauses->detach->where);
9240 : 122 : else if (omp_clauses->detach->symtree->n.sym->attr.dimension > 0)
9241 : 1 : gfc_error ("The event handle at %L must not be an array element",
9242 : : &omp_clauses->detach->where);
9243 : 121 : else if (omp_clauses->detach->symtree->n.sym->ts.type == BT_DERIVED
9244 : 120 : || omp_clauses->detach->symtree->n.sym->ts.type == BT_CLASS)
9245 : 1 : gfc_error ("The event handle at %L must not be part of "
9246 : : "a derived type or class", &omp_clauses->detach->where);
9247 : :
9248 : 125 : if (omp_clauses->mergeable)
9249 : 2 : gfc_error ("%<DETACH%> clause at %L must not be used together with "
9250 : 2 : "%<MERGEABLE%> clause", &omp_clauses->detach->where);
9251 : : }
9252 : :
9253 : 11710 : if (openacc
9254 : 11710 : && code->op == EXEC_OACC_HOST_DATA
9255 : 60 : && omp_clauses->lists[OMP_LIST_USE_DEVICE] == NULL)
9256 : 1 : gfc_error ("%<host_data%> construct at %L requires %<use_device%> clause",
9257 : : &code->loc);
9258 : :
9259 : 29112 : if (omp_clauses->assume)
9260 : 13 : gfc_resolve_omp_assumptions (omp_clauses->assume);
9261 : : }
9262 : :
9263 : :
9264 : : /* Return true if SYM is ever referenced in EXPR except in the SE node. */
9265 : :
9266 : : static bool
9267 : 4991 : expr_references_sym (gfc_expr *e, gfc_symbol *s, gfc_expr *se)
9268 : : {
9269 : 6617 : gfc_actual_arglist *arg;
9270 : 6617 : if (e == NULL || e == se)
9271 : : return false;
9272 : 5380 : switch (e->expr_type)
9273 : : {
9274 : 3134 : case EXPR_CONSTANT:
9275 : 3134 : case EXPR_NULL:
9276 : 3134 : case EXPR_VARIABLE:
9277 : 3134 : case EXPR_STRUCTURE:
9278 : 3134 : case EXPR_ARRAY:
9279 : 3134 : if (e->symtree != NULL
9280 : 1166 : && e->symtree->n.sym == s)
9281 : : return true;
9282 : : return false;
9283 : 0 : case EXPR_SUBSTRING:
9284 : 0 : if (e->ref != NULL
9285 : 0 : && (expr_references_sym (e->ref->u.ss.start, s, se)
9286 : 0 : || expr_references_sym (e->ref->u.ss.end, s, se)))
9287 : 0 : return true;
9288 : : return false;
9289 : 1735 : case EXPR_OP:
9290 : 1735 : if (expr_references_sym (e->value.op.op2, s, se))
9291 : : return true;
9292 : 1626 : return expr_references_sym (e->value.op.op1, s, se);
9293 : 511 : case EXPR_FUNCTION:
9294 : 896 : for (arg = e->value.function.actual; arg; arg = arg->next)
9295 : 586 : if (expr_references_sym (arg->expr, s, se))
9296 : : return true;
9297 : : return false;
9298 : 0 : default:
9299 : 0 : gcc_unreachable ();
9300 : : }
9301 : : }
9302 : :
9303 : :
9304 : : /* If EXPR is a conversion function that widens the type
9305 : : if WIDENING is true or narrows the type if NARROW is true,
9306 : : return the inner expression, otherwise return NULL. */
9307 : :
9308 : : static gfc_expr *
9309 : 5925 : is_conversion (gfc_expr *expr, bool narrowing, bool widening)
9310 : : {
9311 : 5925 : gfc_typespec *ts1, *ts2;
9312 : :
9313 : 5925 : if (expr->expr_type != EXPR_FUNCTION
9314 : 917 : || expr->value.function.isym == NULL
9315 : 894 : || expr->value.function.esym != NULL
9316 : 894 : || expr->value.function.isym->id != GFC_ISYM_CONVERSION
9317 : 388 : || (!narrowing && !widening))
9318 : : return NULL;
9319 : :
9320 : 388 : if (narrowing && widening)
9321 : 267 : return expr->value.function.actual->expr;
9322 : :
9323 : 121 : if (widening)
9324 : : {
9325 : 121 : ts1 = &expr->ts;
9326 : 121 : ts2 = &expr->value.function.actual->expr->ts;
9327 : : }
9328 : : else
9329 : : {
9330 : 0 : ts1 = &expr->value.function.actual->expr->ts;
9331 : 0 : ts2 = &expr->ts;
9332 : : }
9333 : :
9334 : 121 : if (ts1->type > ts2->type
9335 : 49 : || (ts1->type == ts2->type && ts1->kind > ts2->kind))
9336 : 121 : return expr->value.function.actual->expr;
9337 : :
9338 : : return NULL;
9339 : : }
9340 : :
9341 : : static bool
9342 : 6855 : is_scalar_intrinsic_expr (gfc_expr *expr, bool must_be_var, bool conv_ok)
9343 : : {
9344 : 6855 : if (must_be_var
9345 : 4034 : && (expr->expr_type != EXPR_VARIABLE || !expr->symtree))
9346 : : {
9347 : 37 : if (!conv_ok)
9348 : : return false;
9349 : 37 : gfc_expr *conv = is_conversion (expr, true, true);
9350 : 37 : if (!conv)
9351 : : return false;
9352 : 36 : if (conv->expr_type != EXPR_VARIABLE || !conv->symtree)
9353 : : return false;
9354 : : }
9355 : 6852 : return (expr->rank == 0
9356 : 6848 : && !gfc_is_coindexed (expr)
9357 : 13700 : && (expr->ts.type == BT_INTEGER
9358 : : || expr->ts.type == BT_REAL
9359 : : || expr->ts.type == BT_COMPLEX
9360 : : || expr->ts.type == BT_LOGICAL));
9361 : : }
9362 : :
9363 : : static void
9364 : 2683 : resolve_omp_atomic (gfc_code *code)
9365 : : {
9366 : 2683 : gfc_code *atomic_code = code->block;
9367 : 2683 : gfc_symbol *var;
9368 : 2683 : gfc_expr *stmt_expr2, *capt_expr2;
9369 : 2683 : gfc_omp_atomic_op aop
9370 : 2683 : = (gfc_omp_atomic_op) (atomic_code->ext.omp_clauses->atomic_op
9371 : : & GFC_OMP_ATOMIC_MASK);
9372 : 2683 : gfc_code *stmt = NULL, *capture_stmt = NULL, *tailing_stmt = NULL;
9373 : 2683 : gfc_expr *comp_cond = NULL;
9374 : 2683 : locus *loc = NULL;
9375 : :
9376 : 2683 : code = code->block->next;
9377 : : /* resolve_blocks asserts this is initially EXEC_ASSIGN or EXEC_IF
9378 : : If it changed to EXEC_NOP, assume an error has been emitted already. */
9379 : 2683 : if (code->op == EXEC_NOP)
9380 : : return;
9381 : :
9382 : 2682 : if (atomic_code->ext.omp_clauses->compare
9383 : 2682 : && atomic_code->ext.omp_clauses->capture)
9384 : : {
9385 : : /* Must be either "if (x == e) then; x = d; else; v = x; end if"
9386 : : or "v = expr" followed/preceded by
9387 : : "if (x == e) then; x = d; end if" or "if (x == e) x = d". */
9388 : 103 : gfc_code *next = code;
9389 : 103 : if (code->op == EXEC_ASSIGN)
9390 : : {
9391 : 19 : capture_stmt = code;
9392 : 19 : next = code->next;
9393 : : }
9394 : 103 : if (next->op == EXEC_IF
9395 : 103 : && next->block
9396 : 103 : && next->block->op == EXEC_IF
9397 : 103 : && next->block->next
9398 : 102 : && next->block->next->op == EXEC_ASSIGN)
9399 : : {
9400 : 102 : comp_cond = next->block->expr1;
9401 : 102 : stmt = next->block->next;
9402 : 102 : if (stmt->next)
9403 : : {
9404 : 0 : loc = &stmt->loc;
9405 : 0 : goto unexpected;
9406 : : }
9407 : : }
9408 : 1 : else if (capture_stmt)
9409 : : {
9410 : 0 : gfc_error ("Expected IF at %L in atomic compare capture",
9411 : : &next->loc);
9412 : 0 : return;
9413 : : }
9414 : 103 : if (stmt && !capture_stmt && next->block->block)
9415 : : {
9416 : 64 : if (next->block->block->expr1)
9417 : : {
9418 : 0 : gfc_error ("Expected ELSE at %L in atomic compare capture",
9419 : : &next->block->block->expr1->where);
9420 : 0 : return;
9421 : : }
9422 : 64 : if (!code->block->block->next
9423 : 64 : || code->block->block->next->op != EXEC_ASSIGN)
9424 : : {
9425 : 0 : loc = (code->block->block->next ? &code->block->block->next->loc
9426 : : : &code->block->block->loc);
9427 : 0 : goto unexpected;
9428 : : }
9429 : 64 : capture_stmt = code->block->block->next;
9430 : 64 : if (capture_stmt->next)
9431 : : {
9432 : 0 : loc = &capture_stmt->next->loc;
9433 : 0 : goto unexpected;
9434 : : }
9435 : : }
9436 : 103 : if (stmt && !capture_stmt && next->next->op == EXEC_ASSIGN)
9437 : : capture_stmt = next->next;
9438 : 84 : else if (!capture_stmt)
9439 : : {
9440 : 1 : loc = &code->loc;
9441 : 1 : goto unexpected;
9442 : : }
9443 : : }
9444 : 2579 : else if (atomic_code->ext.omp_clauses->compare)
9445 : : {
9446 : : /* Must be: "if (x == e) then; x = d; end if" or "if (x == e) x = d". */
9447 : 53 : if (code->op == EXEC_IF
9448 : 53 : && code->block
9449 : 53 : && code->block->op == EXEC_IF
9450 : 53 : && code->block->next
9451 : 51 : && code->block->next->op == EXEC_ASSIGN)
9452 : : {
9453 : 51 : comp_cond = code->block->expr1;
9454 : 51 : stmt = code->block->next;
9455 : 51 : if (stmt->next || code->block->block)
9456 : : {
9457 : 0 : loc = stmt->next ? &stmt->next->loc : &code->block->block->loc;
9458 : 0 : goto unexpected;
9459 : : }
9460 : : }
9461 : : else
9462 : : {
9463 : 2 : loc = &code->loc;
9464 : 2 : goto unexpected;
9465 : : }
9466 : : }
9467 : 2526 : else if (atomic_code->ext.omp_clauses->capture)
9468 : : {
9469 : : /* Must be: "v = x" followed/preceded by "x = ...". */
9470 : 503 : if (code->op != EXEC_ASSIGN)
9471 : 0 : goto unexpected;
9472 : 503 : if (code->next->op != EXEC_ASSIGN)
9473 : : {
9474 : 0 : loc = &code->next->loc;
9475 : 0 : goto unexpected;
9476 : : }
9477 : 503 : gfc_expr *expr2, *expr2_next;
9478 : 503 : expr2 = is_conversion (code->expr2, true, true);
9479 : 503 : if (expr2 == NULL)
9480 : 461 : expr2 = code->expr2;
9481 : 503 : expr2_next = is_conversion (code->next->expr2, true, true);
9482 : 503 : if (expr2_next == NULL)
9483 : 492 : expr2_next = code->next->expr2;
9484 : 503 : if (code->expr1->expr_type == EXPR_VARIABLE
9485 : 503 : && code->next->expr1->expr_type == EXPR_VARIABLE
9486 : 503 : && expr2->expr_type == EXPR_VARIABLE
9487 : 263 : && expr2_next->expr_type == EXPR_VARIABLE)
9488 : : {
9489 : 1 : if (code->expr1->symtree->n.sym == expr2_next->symtree->n.sym)
9490 : : {
9491 : : stmt = code;
9492 : : capture_stmt = code->next;
9493 : : }
9494 : : else
9495 : : {
9496 : 262 : capture_stmt = code;
9497 : 262 : stmt = code->next;
9498 : : }
9499 : : }
9500 : 502 : else if (expr2->expr_type == EXPR_VARIABLE)
9501 : : {
9502 : : capture_stmt = code;
9503 : : stmt = code->next;
9504 : : }
9505 : : else
9506 : : {
9507 : 503 : stmt = code;
9508 : 503 : capture_stmt = code->next;
9509 : : }
9510 : : /* Shall be NULL but can happen for invalid code. */
9511 : 503 : tailing_stmt = code->next->next;
9512 : : }
9513 : : else
9514 : : {
9515 : : /* x = ... */
9516 : 2023 : stmt = code;
9517 : 2023 : if (!atomic_code->ext.omp_clauses->compare && stmt->op != EXEC_ASSIGN)
9518 : 1 : goto unexpected;
9519 : : /* Shall be NULL but can happen for invalid code. */
9520 : 2022 : tailing_stmt = code->next;
9521 : : }
9522 : :
9523 : 2678 : if (comp_cond)
9524 : : {
9525 : 153 : if (comp_cond->expr_type != EXPR_OP
9526 : 153 : || (comp_cond->value.op.op != INTRINSIC_EQ
9527 : : && comp_cond->value.op.op != INTRINSIC_EQ_OS
9528 : : && comp_cond->value.op.op != INTRINSIC_EQV))
9529 : : {
9530 : 0 : gfc_error ("Expected %<==%>, %<.EQ.%> or %<.EQV.%> atomic comparison "
9531 : : "expression at %L", &comp_cond->where);
9532 : 0 : return;
9533 : : }
9534 : 153 : if (!is_scalar_intrinsic_expr (comp_cond->value.op.op1, true, true))
9535 : : {
9536 : 1 : gfc_error ("Expected scalar intrinsic variable at %L in atomic "
9537 : 1 : "comparison", &comp_cond->value.op.op1->where);
9538 : 1 : return;
9539 : : }
9540 : 152 : if (!gfc_resolve_expr (comp_cond->value.op.op2))
9541 : : return;
9542 : 152 : if (!is_scalar_intrinsic_expr (comp_cond->value.op.op2, false, false))
9543 : : {
9544 : 0 : gfc_error ("Expected scalar intrinsic expression at %L in atomic "
9545 : 0 : "comparison", &comp_cond->value.op.op1->where);
9546 : 0 : return;
9547 : : }
9548 : : }
9549 : :
9550 : 2677 : if (!is_scalar_intrinsic_expr (stmt->expr1, true, false))
9551 : : {
9552 : 4 : gfc_error ("!$OMP ATOMIC statement must set a scalar variable of "
9553 : 4 : "intrinsic type at %L", &stmt->expr1->where);
9554 : 4 : return;
9555 : : }
9556 : :
9557 : 2673 : if (!gfc_resolve_expr (stmt->expr2))
9558 : : return;
9559 : 2669 : if (!is_scalar_intrinsic_expr (stmt->expr2, false, false))
9560 : : {
9561 : 0 : gfc_error ("!$OMP ATOMIC statement must assign an expression of "
9562 : 0 : "intrinsic type at %L", &stmt->expr2->where);
9563 : 0 : return;
9564 : : }
9565 : :
9566 : 2669 : if (gfc_expr_attr (stmt->expr1).allocatable)
9567 : : {
9568 : 0 : gfc_error ("!$OMP ATOMIC with ALLOCATABLE variable at %L",
9569 : 0 : &stmt->expr1->where);
9570 : 0 : return;
9571 : : }
9572 : :
9573 : : /* Should be diagnosed above already. */
9574 : 2669 : gcc_assert (tailing_stmt == NULL);
9575 : :
9576 : 2669 : var = stmt->expr1->symtree->n.sym;
9577 : 2669 : stmt_expr2 = is_conversion (stmt->expr2, true, true);
9578 : 2669 : if (stmt_expr2 == NULL)
9579 : 2513 : stmt_expr2 = stmt->expr2;
9580 : :
9581 : 2669 : switch (aop)
9582 : : {
9583 : 503 : case GFC_OMP_ATOMIC_READ:
9584 : 503 : if (stmt_expr2->expr_type != EXPR_VARIABLE)
9585 : 0 : gfc_error ("!$OMP ATOMIC READ statement must read from a scalar "
9586 : : "variable of intrinsic type at %L", &stmt_expr2->where);
9587 : : return;
9588 : 421 : case GFC_OMP_ATOMIC_WRITE:
9589 : 421 : if (expr_references_sym (stmt_expr2, var, NULL))
9590 : 0 : gfc_error ("expr in !$OMP ATOMIC WRITE assignment var = expr "
9591 : : "must be scalar and cannot reference var at %L",
9592 : : &stmt_expr2->where);
9593 : : return;
9594 : 1745 : default:
9595 : 1745 : break;
9596 : : }
9597 : :
9598 : 1745 : if (atomic_code->ext.omp_clauses->capture)
9599 : : {
9600 : 602 : if (!is_scalar_intrinsic_expr (capture_stmt->expr1, true, false))
9601 : : {
9602 : 0 : gfc_error ("!$OMP ATOMIC capture-statement must set a scalar "
9603 : : "variable of intrinsic type at %L",
9604 : 0 : &capture_stmt->expr1->where);
9605 : 0 : return;
9606 : : }
9607 : :
9608 : 602 : if (!is_scalar_intrinsic_expr (capture_stmt->expr2, true, true))
9609 : : {
9610 : 2 : gfc_error ("!$OMP ATOMIC capture-statement requires a scalar variable"
9611 : 2 : " of intrinsic type at %L", &capture_stmt->expr2->where);
9612 : 2 : return;
9613 : : }
9614 : 600 : capt_expr2 = is_conversion (capture_stmt->expr2, true, true);
9615 : 600 : if (capt_expr2 == NULL)
9616 : 578 : capt_expr2 = capture_stmt->expr2;
9617 : :
9618 : 600 : if (capt_expr2->symtree->n.sym != var)
9619 : : {
9620 : 1 : gfc_error ("!$OMP ATOMIC CAPTURE capture statement reads from "
9621 : : "different variable than update statement writes "
9622 : : "into at %L", &capture_stmt->expr2->where);
9623 : 1 : return;
9624 : : }
9625 : : }
9626 : :
9627 : 1742 : if (atomic_code->ext.omp_clauses->compare)
9628 : : {
9629 : 149 : gfc_expr *var_expr;
9630 : 149 : if (comp_cond->value.op.op1->expr_type == EXPR_VARIABLE)
9631 : : var_expr = comp_cond->value.op.op1;
9632 : : else
9633 : 12 : var_expr = comp_cond->value.op.op1->value.function.actual->expr;
9634 : 149 : if (var_expr->symtree->n.sym != var)
9635 : : {
9636 : 2 : gfc_error ("For !$OMP ATOMIC COMPARE, the first operand in comparison"
9637 : : " at %L must be the variable %qs that the update statement"
9638 : : " writes into at %L", &var_expr->where, var->name,
9639 : 2 : &stmt->expr1->where);
9640 : 2 : return;
9641 : : }
9642 : 147 : if (stmt_expr2->rank != 0 || expr_references_sym (stmt_expr2, var, NULL))
9643 : : {
9644 : 1 : gfc_error ("expr in !$OMP ATOMIC COMPARE assignment var = expr "
9645 : : "must be scalar and cannot reference var at %L",
9646 : : &stmt_expr2->where);
9647 : 1 : return;
9648 : : }
9649 : : }
9650 : 1593 : else if (atomic_code->ext.omp_clauses->capture
9651 : 1593 : && !expr_references_sym (stmt_expr2, var, NULL))
9652 : 22 : atomic_code->ext.omp_clauses->atomic_op
9653 : 22 : = (gfc_omp_atomic_op) (atomic_code->ext.omp_clauses->atomic_op
9654 : : | GFC_OMP_ATOMIC_SWAP);
9655 : 1571 : else if (stmt_expr2->expr_type == EXPR_OP)
9656 : : {
9657 : 1215 : gfc_expr *v = NULL, *e, *c;
9658 : 1215 : gfc_intrinsic_op op = stmt_expr2->value.op.op;
9659 : 1215 : gfc_intrinsic_op alt_op = INTRINSIC_NONE;
9660 : :
9661 : 1215 : if (atomic_code->ext.omp_clauses->fail != OMP_MEMORDER_UNSET)
9662 : 3 : gfc_error ("!$OMP ATOMIC UPDATE at %L with FAIL clause requiries either"
9663 : : " the COMPARE clause or using the intrinsic MIN/MAX "
9664 : : "procedure", &atomic_code->loc);
9665 : 1215 : switch (op)
9666 : : {
9667 : 728 : case INTRINSIC_PLUS:
9668 : 728 : alt_op = INTRINSIC_MINUS;
9669 : 728 : break;
9670 : 94 : case INTRINSIC_TIMES:
9671 : 94 : alt_op = INTRINSIC_DIVIDE;
9672 : 94 : break;
9673 : 120 : case INTRINSIC_MINUS:
9674 : 120 : alt_op = INTRINSIC_PLUS;
9675 : 120 : break;
9676 : 94 : case INTRINSIC_DIVIDE:
9677 : 94 : alt_op = INTRINSIC_TIMES;
9678 : 94 : break;
9679 : : case INTRINSIC_AND:
9680 : : case INTRINSIC_OR:
9681 : : break;
9682 : 43 : case INTRINSIC_EQV:
9683 : 43 : alt_op = INTRINSIC_NEQV;
9684 : 43 : break;
9685 : 43 : case INTRINSIC_NEQV:
9686 : 43 : alt_op = INTRINSIC_EQV;
9687 : 43 : break;
9688 : 1 : default:
9689 : 1 : gfc_error ("!$OMP ATOMIC assignment operator must be binary "
9690 : : "+, *, -, /, .AND., .OR., .EQV. or .NEQV. at %L",
9691 : : &stmt_expr2->where);
9692 : 1 : return;
9693 : : }
9694 : :
9695 : : /* Check for var = var op expr resp. var = expr op var where
9696 : : expr doesn't reference var and var op expr is mathematically
9697 : : equivalent to var op (expr) resp. expr op var equivalent to
9698 : : (expr) op var. We rely here on the fact that the matcher
9699 : : for x op1 y op2 z where op1 and op2 have equal precedence
9700 : : returns (x op1 y) op2 z. */
9701 : 1214 : e = stmt_expr2->value.op.op2;
9702 : 1214 : if (e->expr_type == EXPR_VARIABLE
9703 : 288 : && e->symtree != NULL
9704 : 288 : && e->symtree->n.sym == var)
9705 : : v = e;
9706 : 985 : else if ((c = is_conversion (e, false, true)) != NULL
9707 : 48 : && c->expr_type == EXPR_VARIABLE
9708 : 48 : && c->symtree != NULL
9709 : 1033 : && c->symtree->n.sym == var)
9710 : : v = c;
9711 : : else
9712 : : {
9713 : 937 : gfc_expr **p = NULL, **q;
9714 : 1035 : for (q = &stmt_expr2->value.op.op1; (e = *q) != NULL; )
9715 : 1035 : if (e->expr_type == EXPR_VARIABLE
9716 : 934 : && e->symtree != NULL
9717 : 934 : && e->symtree->n.sym == var)
9718 : : {
9719 : : v = e;
9720 : : break;
9721 : : }
9722 : 101 : else if ((c = is_conversion (e, false, true)) != NULL)
9723 : 60 : q = &e->value.function.actual->expr;
9724 : 41 : else if (e->expr_type != EXPR_OP
9725 : 41 : || (e->value.op.op != op
9726 : 15 : && e->value.op.op != alt_op)
9727 : 38 : || e->rank != 0)
9728 : : break;
9729 : : else
9730 : : {
9731 : 38 : p = q;
9732 : 38 : q = &e->value.op.op1;
9733 : : }
9734 : :
9735 : 937 : if (v == NULL)
9736 : : {
9737 : 3 : gfc_error ("!$OMP ATOMIC assignment must be var = var op expr "
9738 : : "or var = expr op var at %L", &stmt_expr2->where);
9739 : 3 : return;
9740 : : }
9741 : :
9742 : 934 : if (p != NULL)
9743 : : {
9744 : 38 : e = *p;
9745 : 38 : switch (e->value.op.op)
9746 : : {
9747 : 8 : case INTRINSIC_MINUS:
9748 : 8 : case INTRINSIC_DIVIDE:
9749 : 8 : case INTRINSIC_EQV:
9750 : 8 : case INTRINSIC_NEQV:
9751 : 8 : gfc_error ("!$OMP ATOMIC var = var op expr not "
9752 : : "mathematically equivalent to var = var op "
9753 : : "(expr) at %L", &stmt_expr2->where);
9754 : 8 : break;
9755 : : default:
9756 : : break;
9757 : : }
9758 : :
9759 : : /* Canonicalize into var = var op (expr). */
9760 : 38 : *p = e->value.op.op2;
9761 : 38 : e->value.op.op2 = stmt_expr2;
9762 : 38 : e->ts = stmt_expr2->ts;
9763 : 38 : if (stmt->expr2 == stmt_expr2)
9764 : 26 : stmt->expr2 = stmt_expr2 = e;
9765 : : else
9766 : 12 : stmt->expr2->value.function.actual->expr = stmt_expr2 = e;
9767 : :
9768 : 38 : if (!gfc_compare_types (&stmt_expr2->value.op.op1->ts,
9769 : : &stmt_expr2->ts))
9770 : : {
9771 : 24 : for (p = &stmt_expr2->value.op.op1; *p != v;
9772 : 12 : p = &(*p)->value.function.actual->expr)
9773 : : ;
9774 : 12 : *p = NULL;
9775 : 12 : gfc_free_expr (stmt_expr2->value.op.op1);
9776 : 12 : stmt_expr2->value.op.op1 = v;
9777 : 12 : gfc_convert_type (v, &stmt_expr2->ts, 2);
9778 : : }
9779 : : }
9780 : : }
9781 : :
9782 : 1211 : if (e->rank != 0 || expr_references_sym (stmt->expr2, var, v))
9783 : : {
9784 : 1 : gfc_error ("expr in !$OMP ATOMIC assignment var = var op expr "
9785 : : "must be scalar and cannot reference var at %L",
9786 : : &stmt_expr2->where);
9787 : 1 : return;
9788 : : }
9789 : : }
9790 : 356 : else if (stmt_expr2->expr_type == EXPR_FUNCTION
9791 : 355 : && stmt_expr2->value.function.isym != NULL
9792 : 355 : && stmt_expr2->value.function.esym == NULL
9793 : 355 : && stmt_expr2->value.function.actual != NULL
9794 : 355 : && stmt_expr2->value.function.actual->next != NULL)
9795 : : {
9796 : 355 : gfc_actual_arglist *arg, *var_arg;
9797 : :
9798 : 355 : switch (stmt_expr2->value.function.isym->id)
9799 : : {
9800 : : case GFC_ISYM_MIN:
9801 : : case GFC_ISYM_MAX:
9802 : : break;
9803 : 147 : case GFC_ISYM_IAND:
9804 : 147 : case GFC_ISYM_IOR:
9805 : 147 : case GFC_ISYM_IEOR:
9806 : 147 : if (stmt_expr2->value.function.actual->next->next != NULL)
9807 : : {
9808 : 0 : gfc_error ("!$OMP ATOMIC assignment intrinsic IAND, IOR "
9809 : : "or IEOR must have two arguments at %L",
9810 : : &stmt_expr2->where);
9811 : 0 : return;
9812 : : }
9813 : : break;
9814 : 1 : default:
9815 : 1 : gfc_error ("!$OMP ATOMIC assignment intrinsic must be "
9816 : : "MIN, MAX, IAND, IOR or IEOR at %L",
9817 : : &stmt_expr2->where);
9818 : 1 : return;
9819 : : }
9820 : :
9821 : : var_arg = NULL;
9822 : 1088 : for (arg = stmt_expr2->value.function.actual; arg; arg = arg->next)
9823 : : {
9824 : 741 : gfc_expr *e = NULL;
9825 : 741 : if (arg == stmt_expr2->value.function.actual
9826 : 387 : || (var_arg == NULL && arg->next == NULL))
9827 : : {
9828 : 527 : e = is_conversion (arg->expr, false, true);
9829 : 527 : if (!e)
9830 : 514 : e = arg->expr;
9831 : 527 : if (e->expr_type == EXPR_VARIABLE
9832 : 453 : && e->symtree != NULL
9833 : 453 : && e->symtree->n.sym == var)
9834 : 741 : var_arg = arg;
9835 : : }
9836 : 741 : if ((!var_arg || !e) && expr_references_sym (arg->expr, var, NULL))
9837 : : {
9838 : 7 : gfc_error ("!$OMP ATOMIC intrinsic arguments except one must "
9839 : : "not reference %qs at %L",
9840 : : var->name, &arg->expr->where);
9841 : 7 : return;
9842 : : }
9843 : 734 : if (arg->expr->rank != 0)
9844 : : {
9845 : 0 : gfc_error ("!$OMP ATOMIC intrinsic arguments must be scalar "
9846 : : "at %L", &arg->expr->where);
9847 : 0 : return;
9848 : : }
9849 : : }
9850 : :
9851 : 347 : if (var_arg == NULL)
9852 : : {
9853 : 1 : gfc_error ("First or last !$OMP ATOMIC intrinsic argument must "
9854 : : "be %qs at %L", var->name, &stmt_expr2->where);
9855 : 1 : return;
9856 : : }
9857 : :
9858 : 346 : if (var_arg != stmt_expr2->value.function.actual)
9859 : : {
9860 : : /* Canonicalize, so that var comes first. */
9861 : 172 : gcc_assert (var_arg->next == NULL);
9862 : : for (arg = stmt_expr2->value.function.actual;
9863 : 185 : arg->next != var_arg; arg = arg->next)
9864 : : ;
9865 : 172 : var_arg->next = stmt_expr2->value.function.actual;
9866 : 172 : stmt_expr2->value.function.actual = var_arg;
9867 : 172 : arg->next = NULL;
9868 : : }
9869 : : }
9870 : : else
9871 : 1 : gfc_error ("!$OMP ATOMIC assignment must have an operator or "
9872 : : "intrinsic on right hand side at %L", &stmt_expr2->where);
9873 : : return;
9874 : :
9875 : 4 : unexpected:
9876 : 4 : gfc_error ("unexpected !$OMP ATOMIC expression at %L",
9877 : : loc ? loc : &code->loc);
9878 : 4 : return;
9879 : : }
9880 : :
9881 : :
9882 : : static struct fortran_omp_context
9883 : : {
9884 : : gfc_code *code;
9885 : : hash_set<gfc_symbol *> *sharing_clauses;
9886 : : hash_set<gfc_symbol *> *private_iterators;
9887 : : struct fortran_omp_context *previous;
9888 : : bool is_openmp;
9889 : : } *omp_current_ctx;
9890 : : static gfc_code *omp_current_do_code;
9891 : : static int omp_current_do_collapse;
9892 : :
9893 : : /* Forward declaration for mutually recursive functions. */
9894 : : static gfc_code *
9895 : : find_nested_loop_in_block (gfc_code *block);
9896 : :
9897 : : /* Return the first nested DO loop in CHAIN, or NULL if there
9898 : : isn't one. Does no error checking on intervening code. */
9899 : :
9900 : : static gfc_code *
9901 : 25661 : find_nested_loop_in_chain (gfc_code *chain)
9902 : : {
9903 : 25661 : gfc_code *code;
9904 : :
9905 : 25661 : if (!chain)
9906 : : return NULL;
9907 : :
9908 : 29754 : for (code = chain; code; code = code->next)
9909 : : {
9910 : 29336 : if (code->op == EXEC_DO)
9911 : 24867 : return code;
9912 : 4469 : else if (code->op == EXEC_BLOCK)
9913 : : {
9914 : 621 : gfc_code *c = find_nested_loop_in_block (code);
9915 : 621 : if (c)
9916 : 375 : return c;
9917 : : }
9918 : : }
9919 : : return NULL;
9920 : : }
9921 : :
9922 : : /* Return the first nested DO loop in BLOCK, or NULL if there
9923 : : isn't one. Does no error checking on intervening code. */
9924 : : static gfc_code *
9925 : 938 : find_nested_loop_in_block (gfc_code *block)
9926 : : {
9927 : 938 : gfc_namespace *ns;
9928 : 938 : gcc_assert (block->op == EXEC_BLOCK);
9929 : 938 : ns = block->ext.block.ns;
9930 : 938 : gcc_assert (ns);
9931 : 938 : return find_nested_loop_in_chain (ns->code);
9932 : : }
9933 : :
9934 : : void
9935 : 4110 : gfc_resolve_omp_do_blocks (gfc_code *code, gfc_namespace *ns)
9936 : : {
9937 : 4110 : if (code->block->next && code->block->next->op == EXEC_DO)
9938 : : {
9939 : 4105 : int i;
9940 : :
9941 : 4105 : omp_current_do_code = code->block->next;
9942 : 4105 : if (code->ext.omp_clauses->orderedc)
9943 : 140 : omp_current_do_collapse = code->ext.omp_clauses->orderedc;
9944 : 3965 : else if (code->ext.omp_clauses->collapse)
9945 : 1047 : omp_current_do_collapse = code->ext.omp_clauses->collapse;
9946 : : else
9947 : 2918 : omp_current_do_collapse = 1;
9948 : 4105 : if (code->ext.omp_clauses->lists[OMP_LIST_REDUCTION_INSCAN])
9949 : : {
9950 : : /* Checking that there is a matching EXEC_OMP_SCAN in the
9951 : : innermost body cannot be deferred to resolve_omp_do because
9952 : : we process directives nested in the loop before we get
9953 : : there. */
9954 : 58 : locus *loc
9955 : : = &code->ext.omp_clauses->lists[OMP_LIST_REDUCTION_INSCAN]->where;
9956 : 58 : gfc_code *c;
9957 : :
9958 : 78 : for (i = 1, c = omp_current_do_code;
9959 : 78 : i < omp_current_do_collapse; i++)
9960 : : {
9961 : 20 : c = find_nested_loop_in_chain (c->block->next);
9962 : 20 : if (!c || c->op != EXEC_DO || c->block == NULL)
9963 : : break;
9964 : : }
9965 : :
9966 : : /* Skip this if we don't have enough nested loops. That
9967 : : problem will be diagnosed elsewhere. */
9968 : 58 : if (c && c->op == EXEC_DO)
9969 : : {
9970 : 58 : gfc_code *block = c->block ? c->block->next : NULL;
9971 : 58 : if (block && block->op != EXEC_OMP_SCAN)
9972 : 54 : while (block && block->next
9973 : 54 : && block->next->op != EXEC_OMP_SCAN)
9974 : : block = block->next;
9975 : 43 : if (!block
9976 : 46 : || (block->op != EXEC_OMP_SCAN
9977 : 43 : && (!block->next || block->next->op != EXEC_OMP_SCAN)))
9978 : 19 : gfc_error ("With INSCAN at %L, expected loop body with "
9979 : : "!$OMP SCAN between two "
9980 : : "structured block sequences", loc);
9981 : : else
9982 : : {
9983 : 39 : if (block->op == EXEC_OMP_SCAN)
9984 : 3 : gfc_warning (OPT_Wopenmp,
9985 : : "!$OMP SCAN at %L with zero executable "
9986 : : "statements in preceding structured block "
9987 : : "sequence", &block->loc);
9988 : 39 : if ((block->op == EXEC_OMP_SCAN && !block->next)
9989 : 38 : || (block->next && block->next->op == EXEC_OMP_SCAN
9990 : 36 : && !block->next->next))
9991 : 3 : gfc_warning (OPT_Wopenmp,
9992 : : "!$OMP SCAN at %L with zero executable "
9993 : : "statements in succeeding structured block "
9994 : : "sequence", block->op == EXEC_OMP_SCAN
9995 : 1 : ? &block->loc : &block->next->loc);
9996 : : }
9997 : 58 : if (block && block->op != EXEC_OMP_SCAN)
9998 : 43 : block = block->next;
9999 : 46 : if (block && block->op == EXEC_OMP_SCAN)
10000 : : /* Mark 'omp scan' as checked; flag will be unset later. */
10001 : 39 : block->ext.omp_clauses->if_present = true;
10002 : : }
10003 : : }
10004 : : }
10005 : 4110 : gfc_resolve_blocks (code->block, ns);
10006 : 4110 : omp_current_do_collapse = 0;
10007 : 4110 : omp_current_do_code = NULL;
10008 : 4110 : }
10009 : :
10010 : :
10011 : : void
10012 : 5469 : gfc_resolve_omp_parallel_blocks (gfc_code *code, gfc_namespace *ns)
10013 : : {
10014 : 5469 : struct fortran_omp_context ctx;
10015 : 5469 : gfc_omp_clauses *omp_clauses = code->ext.omp_clauses;
10016 : 5469 : gfc_omp_namelist *n;
10017 : 5469 : int list;
10018 : :
10019 : 5469 : ctx.code = code;
10020 : 5469 : ctx.sharing_clauses = new hash_set<gfc_symbol *>;
10021 : 5469 : ctx.private_iterators = new hash_set<gfc_symbol *>;
10022 : 5469 : ctx.previous = omp_current_ctx;
10023 : 5469 : ctx.is_openmp = true;
10024 : 5469 : omp_current_ctx = &ctx;
10025 : :
10026 : 185946 : for (list = 0; list < OMP_LIST_NUM; list++)
10027 : 180477 : switch (list)
10028 : : {
10029 : 54690 : case OMP_LIST_SHARED:
10030 : 54690 : case OMP_LIST_PRIVATE:
10031 : 54690 : case OMP_LIST_FIRSTPRIVATE:
10032 : 54690 : case OMP_LIST_LASTPRIVATE:
10033 : 54690 : case OMP_LIST_REDUCTION:
10034 : 54690 : case OMP_LIST_REDUCTION_INSCAN:
10035 : 54690 : case OMP_LIST_REDUCTION_TASK:
10036 : 54690 : case OMP_LIST_IN_REDUCTION:
10037 : 54690 : case OMP_LIST_TASK_REDUCTION:
10038 : 54690 : case OMP_LIST_LINEAR:
10039 : 63213 : for (n = omp_clauses->lists[list]; n; n = n->next)
10040 : 8523 : ctx.sharing_clauses->add (n->sym);
10041 : : break;
10042 : : default:
10043 : : break;
10044 : : }
10045 : :
10046 : 5469 : switch (code->op)
10047 : : {
10048 : 1880 : case EXEC_OMP_DISTRIBUTE_PARALLEL_DO:
10049 : 1880 : case EXEC_OMP_DISTRIBUTE_PARALLEL_DO_SIMD:
10050 : 1880 : case EXEC_OMP_MASKED_TASKLOOP:
10051 : 1880 : case EXEC_OMP_MASKED_TASKLOOP_SIMD:
10052 : 1880 : case EXEC_OMP_MASTER_TASKLOOP:
10053 : 1880 : case EXEC_OMP_MASTER_TASKLOOP_SIMD:
10054 : 1880 : case EXEC_OMP_PARALLEL_DO:
10055 : 1880 : case EXEC_OMP_PARALLEL_DO_SIMD:
10056 : 1880 : case EXEC_OMP_PARALLEL_LOOP:
10057 : 1880 : case EXEC_OMP_PARALLEL_MASKED_TASKLOOP:
10058 : 1880 : case EXEC_OMP_PARALLEL_MASKED_TASKLOOP_SIMD:
10059 : 1880 : case EXEC_OMP_PARALLEL_MASTER_TASKLOOP:
10060 : 1880 : case EXEC_OMP_PARALLEL_MASTER_TASKLOOP_SIMD:
10061 : 1880 : case EXEC_OMP_TARGET_PARALLEL_DO:
10062 : 1880 : case EXEC_OMP_TARGET_PARALLEL_DO_SIMD:
10063 : 1880 : case EXEC_OMP_TARGET_PARALLEL_LOOP:
10064 : 1880 : case EXEC_OMP_TARGET_TEAMS_DISTRIBUTE:
10065 : 1880 : case EXEC_OMP_TARGET_TEAMS_DISTRIBUTE_PARALLEL_DO:
10066 : 1880 : case EXEC_OMP_TARGET_TEAMS_DISTRIBUTE_PARALLEL_DO_SIMD:
10067 : 1880 : case EXEC_OMP_TARGET_TEAMS_DISTRIBUTE_SIMD:
10068 : 1880 : case EXEC_OMP_TARGET_TEAMS_LOOP:
10069 : 1880 : case EXEC_OMP_TASKLOOP:
10070 : 1880 : case EXEC_OMP_TASKLOOP_SIMD:
10071 : 1880 : case EXEC_OMP_TEAMS_DISTRIBUTE:
10072 : 1880 : case EXEC_OMP_TEAMS_DISTRIBUTE_PARALLEL_DO:
10073 : 1880 : case EXEC_OMP_TEAMS_DISTRIBUTE_PARALLEL_DO_SIMD:
10074 : 1880 : case EXEC_OMP_TEAMS_DISTRIBUTE_SIMD:
10075 : 1880 : case EXEC_OMP_TEAMS_LOOP:
10076 : 1880 : gfc_resolve_omp_do_blocks (code, ns);
10077 : 1880 : break;
10078 : 3589 : default:
10079 : 3589 : gfc_resolve_blocks (code->block, ns);
10080 : : }
10081 : :
10082 : 5469 : omp_current_ctx = ctx.previous;
10083 : 10938 : delete ctx.sharing_clauses;
10084 : 10938 : delete ctx.private_iterators;
10085 : 5469 : }
10086 : :
10087 : :
10088 : : /* Save and clear openmp.cc private state. */
10089 : :
10090 : : void
10091 : 242793 : gfc_omp_save_and_clear_state (struct gfc_omp_saved_state *state)
10092 : : {
10093 : 242793 : state->ptrs[0] = omp_current_ctx;
10094 : 242793 : state->ptrs[1] = omp_current_do_code;
10095 : 242793 : state->ints[0] = omp_current_do_collapse;
10096 : 242793 : omp_current_ctx = NULL;
10097 : 242793 : omp_current_do_code = NULL;
10098 : 242793 : omp_current_do_collapse = 0;
10099 : 242793 : }
10100 : :
10101 : :
10102 : : /* Restore openmp.cc private state from the saved state. */
10103 : :
10104 : : void
10105 : 242792 : gfc_omp_restore_state (struct gfc_omp_saved_state *state)
10106 : : {
10107 : 242792 : omp_current_ctx = (struct fortran_omp_context *) state->ptrs[0];
10108 : 242792 : omp_current_do_code = (gfc_code *) state->ptrs[1];
10109 : 242792 : omp_current_do_collapse = state->ints[0];
10110 : 242792 : }
10111 : :
10112 : :
10113 : : /* Note a DO iterator variable. This is special in !$omp parallel
10114 : : construct, where they are predetermined private. */
10115 : :
10116 : : void
10117 : 30142 : gfc_resolve_do_iterator (gfc_code *code, gfc_symbol *sym, bool add_clause)
10118 : : {
10119 : 30142 : if (omp_current_ctx == NULL)
10120 : : return;
10121 : :
10122 : 11677 : int i = omp_current_do_collapse;
10123 : 11677 : gfc_code *c = omp_current_do_code;
10124 : :
10125 : 11677 : if (sym->attr.threadprivate)
10126 : : return;
10127 : :
10128 : : /* !$omp do and !$omp parallel do iteration variable is predetermined
10129 : : private just in the !$omp do resp. !$omp parallel do construct,
10130 : : with no implications for the outer parallel constructs. */
10131 : :
10132 : 16416 : while (i-- >= 1 && c)
10133 : : {
10134 : 8796 : if (code == c)
10135 : : return;
10136 : 4739 : c = find_nested_loop_in_chain (c->block->next);
10137 : : }
10138 : :
10139 : : /* An openacc context may represent a data clause. Abort if so. */
10140 : 7620 : if (!omp_current_ctx->is_openmp && !oacc_is_loop (omp_current_ctx->code))
10141 : : return;
10142 : :
10143 : 6687 : if (omp_current_ctx->sharing_clauses->contains (sym))
10144 : : return;
10145 : :
10146 : 5772 : if (! omp_current_ctx->private_iterators->add (sym) && add_clause)
10147 : : {
10148 : 5582 : gfc_omp_clauses *omp_clauses = omp_current_ctx->code->ext.omp_clauses;
10149 : 5582 : gfc_omp_namelist *p;
10150 : :
10151 : 5582 : p = gfc_get_omp_namelist ();
10152 : 5582 : p->sym = sym;
10153 : 5582 : p->where = omp_current_ctx->code->loc;
10154 : 5582 : p->next = omp_clauses->lists[OMP_LIST_PRIVATE];
10155 : 5582 : omp_clauses->lists[OMP_LIST_PRIVATE] = p;
10156 : : }
10157 : : }
10158 : :
10159 : : static void
10160 : 714 : handle_local_var (gfc_symbol *sym)
10161 : : {
10162 : 714 : if (sym->attr.flavor != FL_VARIABLE
10163 : 201 : || sym->as != NULL
10164 : 169 : || (sym->ts.type != BT_INTEGER && sym->ts.type != BT_REAL))
10165 : : return;
10166 : 106 : gfc_resolve_do_iterator (sym->ns->code, sym, false);
10167 : : }
10168 : :
10169 : : void
10170 : 281927 : gfc_resolve_omp_local_vars (gfc_namespace *ns)
10171 : : {
10172 : 281927 : if (omp_current_ctx)
10173 : 454 : gfc_traverse_ns (ns, handle_local_var);
10174 : 281927 : }
10175 : :
10176 : :
10177 : : /* Error checking on intervening code uses a code walker. */
10178 : :
10179 : : struct icode_error_state
10180 : : {
10181 : : const char *name;
10182 : : bool errorp;
10183 : : gfc_code *nested;
10184 : : gfc_code *next;
10185 : : };
10186 : :
10187 : : static int
10188 : 846 : icode_code_error_callback (gfc_code **codep,
10189 : : int *walk_subtrees ATTRIBUTE_UNUSED, void *opaque)
10190 : : {
10191 : 846 : gfc_code *code = *codep;
10192 : 846 : icode_error_state *state = (icode_error_state *)opaque;
10193 : :
10194 : : /* gfc_code_walker walks down CODE's next chain as well as
10195 : : walking things that are actually nested in CODE. We need to
10196 : : special-case traversal of outer blocks, so stop immediately if we
10197 : : are heading down such a next chain. */
10198 : 846 : if (code == state->next)
10199 : : return 1;
10200 : :
10201 : 583 : switch (code->op)
10202 : : {
10203 : 1 : case EXEC_DO:
10204 : 1 : case EXEC_DO_WHILE:
10205 : 1 : case EXEC_DO_CONCURRENT:
10206 : 1 : gfc_error ("%s cannot contain loop in intervening code at %L",
10207 : : state->name, &code->loc);
10208 : 1 : state->errorp = true;
10209 : 1 : break;
10210 : 0 : case EXEC_CYCLE:
10211 : 0 : case EXEC_EXIT:
10212 : : /* Errors have already been diagnosed in match_exit_cycle. */
10213 : 0 : state->errorp = true;
10214 : 0 : break;
10215 : 1 : case EXEC_OMP_CRITICAL:
10216 : 1 : case EXEC_OMP_DO:
10217 : 1 : case EXEC_OMP_FLUSH:
10218 : 1 : case EXEC_OMP_MASTER:
10219 : 1 : case EXEC_OMP_ORDERED:
10220 : 1 : case EXEC_OMP_PARALLEL:
10221 : 1 : case EXEC_OMP_PARALLEL_DO:
10222 : 1 : case EXEC_OMP_PARALLEL_SECTIONS:
10223 : 1 : case EXEC_OMP_PARALLEL_WORKSHARE:
10224 : 1 : case EXEC_OMP_SECTIONS:
10225 : 1 : case EXEC_OMP_SINGLE:
10226 : 1 : case EXEC_OMP_WORKSHARE:
10227 : 1 : case EXEC_OMP_ATOMIC:
10228 : 1 : case EXEC_OMP_BARRIER:
10229 : 1 : case EXEC_OMP_END_NOWAIT:
10230 : 1 : case EXEC_OMP_END_SINGLE:
10231 : 1 : case EXEC_OMP_TASK:
10232 : 1 : case EXEC_OMP_TASKWAIT:
10233 : 1 : case EXEC_OMP_TASKYIELD:
10234 : 1 : case EXEC_OMP_CANCEL:
10235 : 1 : case EXEC_OMP_CANCELLATION_POINT:
10236 : 1 : case EXEC_OMP_TASKGROUP:
10237 : 1 : case EXEC_OMP_SIMD:
10238 : 1 : case EXEC_OMP_DO_SIMD:
10239 : 1 : case EXEC_OMP_PARALLEL_DO_SIMD:
10240 : 1 : case EXEC_OMP_TARGET:
10241 : 1 : case EXEC_OMP_TARGET_DATA:
10242 : 1 : case EXEC_OMP_TEAMS:
10243 : 1 : case EXEC_OMP_DISTRIBUTE:
10244 : 1 : case EXEC_OMP_DISTRIBUTE_SIMD:
10245 : 1 : case EXEC_OMP_DISTRIBUTE_PARALLEL_DO:
10246 : 1 : case EXEC_OMP_DISTRIBUTE_PARALLEL_DO_SIMD:
10247 : 1 : case EXEC_OMP_TARGET_TEAMS:
10248 : 1 : case EXEC_OMP_TEAMS_DISTRIBUTE:
10249 : 1 : case EXEC_OMP_TEAMS_DISTRIBUTE_SIMD:
10250 : 1 : case EXEC_OMP_TARGET_TEAMS_DISTRIBUTE:
10251 : 1 : case EXEC_OMP_TARGET_TEAMS_DISTRIBUTE_SIMD:
10252 : 1 : case EXEC_OMP_TEAMS_DISTRIBUTE_PARALLEL_DO:
10253 : 1 : case EXEC_OMP_TARGET_TEAMS_DISTRIBUTE_PARALLEL_DO:
10254 : 1 : case EXEC_OMP_TEAMS_DISTRIBUTE_PARALLEL_DO_SIMD:
10255 : 1 : case EXEC_OMP_TARGET_TEAMS_DISTRIBUTE_PARALLEL_DO_SIMD:
10256 : 1 : case EXEC_OMP_TARGET_UPDATE:
10257 : 1 : case EXEC_OMP_END_CRITICAL:
10258 : 1 : case EXEC_OMP_TARGET_ENTER_DATA:
10259 : 1 : case EXEC_OMP_TARGET_EXIT_DATA:
10260 : 1 : case EXEC_OMP_TARGET_PARALLEL:
10261 : 1 : case EXEC_OMP_TARGET_PARALLEL_DO:
10262 : 1 : case EXEC_OMP_TARGET_PARALLEL_DO_SIMD:
10263 : 1 : case EXEC_OMP_TARGET_SIMD:
10264 : 1 : case EXEC_OMP_TASKLOOP:
10265 : 1 : case EXEC_OMP_TASKLOOP_SIMD:
10266 : 1 : case EXEC_OMP_SCAN:
10267 : 1 : case EXEC_OMP_DEPOBJ:
10268 : 1 : case EXEC_OMP_PARALLEL_MASTER:
10269 : 1 : case EXEC_OMP_PARALLEL_MASTER_TASKLOOP:
10270 : 1 : case EXEC_OMP_PARALLEL_MASTER_TASKLOOP_SIMD:
10271 : 1 : case EXEC_OMP_MASTER_TASKLOOP:
10272 : 1 : case EXEC_OMP_MASTER_TASKLOOP_SIMD:
10273 : 1 : case EXEC_OMP_LOOP:
10274 : 1 : case EXEC_OMP_PARALLEL_LOOP:
10275 : 1 : case EXEC_OMP_TEAMS_LOOP:
10276 : 1 : case EXEC_OMP_TARGET_PARALLEL_LOOP:
10277 : 1 : case EXEC_OMP_TARGET_TEAMS_LOOP:
10278 : 1 : case EXEC_OMP_MASKED:
10279 : 1 : case EXEC_OMP_PARALLEL_MASKED:
10280 : 1 : case EXEC_OMP_PARALLEL_MASKED_TASKLOOP:
10281 : 1 : case EXEC_OMP_PARALLEL_MASKED_TASKLOOP_SIMD:
10282 : 1 : case EXEC_OMP_MASKED_TASKLOOP:
10283 : 1 : case EXEC_OMP_MASKED_TASKLOOP_SIMD:
10284 : 1 : case EXEC_OMP_SCOPE:
10285 : 1 : case EXEC_OMP_ERROR:
10286 : 1 : gfc_error ("%s cannot contain OpenMP directive in intervening code "
10287 : : "at %L",
10288 : : state->name, &code->loc);
10289 : 1 : state->errorp = true;
10290 : 1 : break;
10291 : 417 : case EXEC_CALL:
10292 : : /* Per OpenMP 5.2, the "omp_" prefix is reserved, so we don't have to
10293 : : consider the possibility that some locally-bound definition
10294 : : overrides the runtime routine. */
10295 : 417 : if (code->resolved_sym
10296 : 417 : && omp_runtime_api_procname (code->resolved_sym->name))
10297 : : {
10298 : 1 : gfc_error ("%s cannot contain OpenMP API call in intervening code "
10299 : : "at %L",
10300 : : state->name, &code->loc);
10301 : 1 : state->errorp = true;
10302 : : }
10303 : : break;
10304 : : default:
10305 : : break;
10306 : : }
10307 : : return 0;
10308 : : }
10309 : :
10310 : : static int
10311 : 934 : icode_expr_error_callback (gfc_expr **expr,
10312 : : int *walk_subtrees ATTRIBUTE_UNUSED, void *opaque)
10313 : : {
10314 : 934 : icode_error_state *state = (icode_error_state *)opaque;
10315 : :
10316 : 934 : switch ((*expr)->expr_type)
10317 : : {
10318 : : /* As for EXPR_CALL with "omp_"-prefixed symbols. */
10319 : 1 : case EXPR_FUNCTION:
10320 : 1 : {
10321 : 1 : gfc_symbol *sym = (*expr)->value.function.esym;
10322 : 1 : if (sym && omp_runtime_api_procname (sym->name))
10323 : : {
10324 : 1 : gfc_error ("%s cannot contain OpenMP API call in intervening code "
10325 : : "at %L",
10326 : 1 : state->name, &((*expr)->where));
10327 : 1 : state->errorp = true;
10328 : : }
10329 : : }
10330 : :
10331 : : break;
10332 : : default:
10333 : : break;
10334 : : }
10335 : :
10336 : : /* FIXME: The description of canonical loop form in the OpenMP standard
10337 : : also says "array expressions" are not permitted in intervening code.
10338 : : That term is not defined in either the OpenMP spec or the Fortran
10339 : : standard, although the latter uses it informally to refer to any
10340 : : expression that is not scalar-valued. It is also apparently not the
10341 : : thing GCC internally calls EXPR_ARRAY. It seems the intent of the
10342 : : OpenMP restriction is to disallow elemental operations/intrinsics
10343 : : (including things that are not expressions, like assignment
10344 : : statements) that generate implicit loops over array operands
10345 : : (even if the result is a scalar), but even if the spec said
10346 : : that there is no list of all the cases that would be forbidden.
10347 : : This is OpenMP issue 3326. */
10348 : :
10349 : 934 : return 0;
10350 : : }
10351 : :
10352 : : static void
10353 : 233 : diagnose_intervening_code_errors_1 (gfc_code *chain,
10354 : : struct icode_error_state *state)
10355 : : {
10356 : 233 : gfc_code *code;
10357 : 949 : for (code = chain; code; code = code->next)
10358 : : {
10359 : 716 : if (code == state->nested)
10360 : : /* Do not walk the nested loop or its body, we are only
10361 : : interested in intervening code. */
10362 : : ;
10363 : 572 : else if (code->op == EXEC_BLOCK
10364 : 572 : && find_nested_loop_in_block (code) == state->nested)
10365 : : /* This block contains the nested loop, recurse on its
10366 : : statements. */
10367 : : {
10368 : 89 : gfc_namespace* ns = code->ext.block.ns;
10369 : 89 : diagnose_intervening_code_errors_1 (ns->code, state);
10370 : : }
10371 : : else
10372 : : /* Treat the whole statement as a unit. */
10373 : : {
10374 : 483 : gfc_code *temp = state->next;
10375 : 483 : state->next = code->next;
10376 : 483 : gfc_code_walker (&code, icode_code_error_callback,
10377 : : icode_expr_error_callback, state);
10378 : 483 : state->next = temp;
10379 : : }
10380 : : }
10381 : 233 : }
10382 : :
10383 : : /* Diagnose intervening code errors in BLOCK with nested loop NESTED.
10384 : : NAME is the user-friendly name of the OMP directive, used for error
10385 : : messages. Returns true if any error was found. */
10386 : : static bool
10387 : 144 : diagnose_intervening_code_errors (gfc_code *chain, const char *name,
10388 : : gfc_code *nested)
10389 : : {
10390 : 144 : struct icode_error_state state;
10391 : 144 : state.name = name;
10392 : 144 : state.errorp = false;
10393 : 144 : state.nested = nested;
10394 : 144 : state.next = NULL;
10395 : 0 : diagnose_intervening_code_errors_1 (chain, &state);
10396 : 144 : return state.errorp;
10397 : : }
10398 : :
10399 : : /* Helper function for restructure_intervening_code: wrap CHAIN in
10400 : : a marker to indicate that it is a structured block sequence. That
10401 : : information will be used later on (in omp-low.cc) for error checking. */
10402 : : static gfc_code *
10403 : 407 : make_structured_block (gfc_code *chain)
10404 : : {
10405 : 407 : gcc_assert (chain);
10406 : 407 : gfc_namespace *ns = gfc_build_block_ns (gfc_current_ns);
10407 : 407 : gfc_code *result = gfc_get_code (EXEC_BLOCK);
10408 : 407 : result->op = EXEC_BLOCK;
10409 : 407 : result->ext.block.ns = ns;
10410 : 407 : result->ext.block.assoc = NULL;
10411 : 407 : result->loc = chain->loc;
10412 : 407 : ns->omp_structured_block = 1;
10413 : 407 : ns->code = chain;
10414 : 407 : return result;
10415 : : }
10416 : :
10417 : : /* Push intervening code surrounding a loop, including nested scopes,
10418 : : into the body of the loop. CHAINP is the pointer to the head of
10419 : : the next-chain to scan, OUTER_LOOP is the EXEC_DO for the next outer
10420 : : loop level, and COLLAPSE is the number of nested loops we need to
10421 : : process.
10422 : : Note that CHAINP may point at outer_loop->block->next when we
10423 : : are scanning the body of a loop, but if there is an intervening block
10424 : : CHAINP points into the block's chain rather than its enclosing outer
10425 : : loop. This is why OUTER_LOOP is passed separately. */
10426 : : static gfc_code *
10427 : 6122 : restructure_intervening_code (gfc_code **chainp, gfc_code *outer_loop,
10428 : : int count)
10429 : : {
10430 : 6122 : gfc_code *code;
10431 : 6122 : gfc_code *head = *chainp;
10432 : 6122 : gfc_code *tail = NULL;
10433 : 6122 : gfc_code *innermost_loop = NULL;
10434 : :
10435 : 6361 : for (code = *chainp; code; code = code->next, chainp = &((*chainp)->next))
10436 : : {
10437 : 6361 : if (code->op == EXEC_DO)
10438 : : {
10439 : : /* Cut CODE free from its chain, leaving the ends dangling. */
10440 : 6038 : *chainp = NULL;
10441 : 6038 : tail = code->next;
10442 : 6038 : code->next = NULL;
10443 : :
10444 : 6038 : if (count == 1)
10445 : : innermost_loop = code;
10446 : : else
10447 : 1964 : innermost_loop
10448 : 1964 : = restructure_intervening_code (&(code->block->next),
10449 : : code, count - 1);
10450 : : break;
10451 : : }
10452 : 323 : else if (code->op == EXEC_BLOCK
10453 : 323 : && find_nested_loop_in_block (code))
10454 : : {
10455 : 84 : gfc_namespace *ns = code->ext.block.ns;
10456 : :
10457 : : /* Cut CODE free from its chain, leaving the ends dangling. */
10458 : 84 : *chainp = NULL;
10459 : 84 : tail = code->next;
10460 : 84 : code->next = NULL;
10461 : :
10462 : 84 : innermost_loop
10463 : 84 : = restructure_intervening_code (&(ns->code), outer_loop,
10464 : : count);
10465 : :
10466 : : /* At this point we have already pulled out the nested loop and
10467 : : pointed outer_loop at it, and moved the intervening code that
10468 : : was previously in the block into the body of innermost_loop.
10469 : : Now we want to move the BLOCK itself so it wraps the entire
10470 : : current body of innermost_loop. */
10471 : 84 : ns->code = innermost_loop->block->next;
10472 : 84 : innermost_loop->block->next = code;
10473 : 84 : break;
10474 : : }
10475 : : }
10476 : :
10477 : 2048 : gcc_assert (innermost_loop);
10478 : :
10479 : : /* Now we have split the intervening code into two parts:
10480 : : head is the start of the part before the loop/block, terminating
10481 : : at *chainp, and tail is the part after it. Mark each part as
10482 : : a structured block sequence, and splice the two parts around the
10483 : : existing body of the innermost loop. */
10484 : 6122 : if (head != code)
10485 : : {
10486 : 197 : gfc_code *block = make_structured_block (head);
10487 : 197 : if (innermost_loop->block->next)
10488 : 196 : gfc_append_code (block, innermost_loop->block->next);
10489 : 197 : innermost_loop->block->next = block;
10490 : : }
10491 : 6122 : if (tail)
10492 : : {
10493 : 210 : gfc_code *block = make_structured_block (tail);
10494 : 210 : if (innermost_loop->block->next)
10495 : 208 : gfc_append_code (innermost_loop->block->next, block);
10496 : : else
10497 : 2 : innermost_loop->block->next = block;
10498 : : }
10499 : :
10500 : : /* For loops, finally splice CODE into OUTER_LOOP. We already handled
10501 : : relinking EXEC_BLOCK above. */
10502 : 6122 : if (code->op == EXEC_DO && outer_loop)
10503 : 6038 : outer_loop->block->next = code;
10504 : :
10505 : 6122 : return innermost_loop;
10506 : : }
10507 : :
10508 : : /* CODE is an OMP loop construct. Return true if VAR matches an iteration
10509 : : variable outer to level DEPTH. */
10510 : : static bool
10511 : 6597 : is_outer_iteration_variable (gfc_code *code, int depth, gfc_symbol *var)
10512 : : {
10513 : 6597 : int i;
10514 : 6597 : gfc_code *do_code = code;
10515 : :
10516 : 10755 : for (i = 1; i < depth; i++)
10517 : : {
10518 : 4655 : do_code = find_nested_loop_in_chain (do_code->block->next);
10519 : 4655 : gcc_assert (do_code);
10520 : 4655 : gfc_symbol *ivar = do_code->ext.iterator->var->symtree->n.sym;
10521 : 4655 : if (var == ivar)
10522 : : return true;
10523 : : }
10524 : : return false;
10525 : : }
10526 : :
10527 : : /* Forward declaration for recursive functions. */
10528 : : static gfc_code *
10529 : : check_nested_loop_in_block (gfc_code *block, gfc_expr *expr, gfc_symbol *sym,
10530 : : bool *bad);
10531 : :
10532 : : /* Like find_nested_loop_in_chain, but additionally check that EXPR
10533 : : does not reference any variables bound in intervening EXEC_BLOCKs
10534 : : and that SYM is not bound in such intervening blocks. Either EXPR or SYM
10535 : : may be null. Sets *BAD to true if either test fails. */
10536 : : static gfc_code *
10537 : 41000 : check_nested_loop_in_chain (gfc_code *chain, gfc_expr *expr, gfc_symbol *sym,
10538 : : bool *bad)
10539 : : {
10540 : 42782 : for (gfc_code *code = chain; code; code = code->next)
10541 : : {
10542 : 42494 : if (code->op == EXEC_DO)
10543 : 40197 : return code;
10544 : 2297 : else if (code->op == EXEC_BLOCK)
10545 : : {
10546 : 803 : gfc_code *c = check_nested_loop_in_block (code, expr, sym, bad);
10547 : 803 : if (c)
10548 : 515 : return c;
10549 : : }
10550 : : }
10551 : : return NULL;
10552 : : }
10553 : :
10554 : : /* Code walker for block symtrees. It doesn't take any kind of state
10555 : : argument, so use a static variable. */
10556 : : static struct check_nested_loop_in_block_state_t {
10557 : : gfc_expr *expr;
10558 : : gfc_symbol *sym;
10559 : : bool *bad;
10560 : : } check_nested_loop_in_block_state;
10561 : :
10562 : : static void
10563 : 754 : check_nested_loop_in_block_symbol (gfc_symbol *sym)
10564 : : {
10565 : 754 : if (sym == check_nested_loop_in_block_state.sym
10566 : 754 : || (check_nested_loop_in_block_state.expr
10567 : 558 : && gfc_find_sym_in_expr (sym,
10568 : : check_nested_loop_in_block_state.expr)))
10569 : 5 : *check_nested_loop_in_block_state.bad = true;
10570 : 754 : }
10571 : :
10572 : : /* Return the first nested DO loop in BLOCK, or NULL if there
10573 : : isn't one. Set *BAD to true if EXPR references any variables in BLOCK, or
10574 : : SYM is bound in BLOCK. Either EXPR or SYM may be null. */
10575 : : static gfc_code *
10576 : 803 : check_nested_loop_in_block (gfc_code *block, gfc_expr *expr,
10577 : : gfc_symbol *sym, bool *bad)
10578 : : {
10579 : 803 : gfc_namespace *ns;
10580 : 803 : gcc_assert (block->op == EXEC_BLOCK);
10581 : 803 : ns = block->ext.block.ns;
10582 : 803 : gcc_assert (ns);
10583 : :
10584 : : /* Skip the check if this block doesn't contain the nested loop, or
10585 : : if we already know it's bad. */
10586 : 803 : gfc_code *result = check_nested_loop_in_chain (ns->code, expr, sym, bad);
10587 : 803 : if (result && !*bad)
10588 : : {
10589 : 515 : check_nested_loop_in_block_state.expr = expr;
10590 : 515 : check_nested_loop_in_block_state.sym = sym;
10591 : 515 : check_nested_loop_in_block_state.bad = bad;
10592 : 515 : gfc_traverse_ns (ns, check_nested_loop_in_block_symbol);
10593 : 515 : check_nested_loop_in_block_state.expr = NULL;
10594 : 515 : check_nested_loop_in_block_state.sym = NULL;
10595 : 515 : check_nested_loop_in_block_state.bad = NULL;
10596 : : }
10597 : 803 : return result;
10598 : : }
10599 : :
10600 : : /* CODE is an OMP loop construct. Return true if EXPR references
10601 : : any variables bound in intervening code, to level DEPTH. */
10602 : : static bool
10603 : 18280 : expr_uses_intervening_var (gfc_code *code, int depth, gfc_expr *expr)
10604 : : {
10605 : 18280 : int i;
10606 : 18280 : gfc_code *do_code = code;
10607 : :
10608 : 48414 : for (i = 0; i < depth; i++)
10609 : : {
10610 : 30137 : bool bad = false;
10611 : 30137 : do_code = check_nested_loop_in_chain (do_code->block->next,
10612 : : expr, NULL, &bad);
10613 : 30137 : if (bad)
10614 : 3 : return true;
10615 : : }
10616 : : return false;
10617 : : }
10618 : :
10619 : : /* CODE is an OMP loop construct. Return true if SYM is bound in
10620 : : intervening code, to level DEPTH. */
10621 : : static bool
10622 : 6100 : is_intervening_var (gfc_code *code, int depth, gfc_symbol *sym)
10623 : : {
10624 : 6100 : int i;
10625 : 6100 : gfc_code *do_code = code;
10626 : :
10627 : 16158 : for (i = 0; i < depth; i++)
10628 : : {
10629 : 10060 : bool bad = false;
10630 : 10060 : do_code = check_nested_loop_in_chain (do_code->block->next,
10631 : : NULL, sym, &bad);
10632 : 10060 : if (bad)
10633 : 2 : return true;
10634 : : }
10635 : : return false;
10636 : : }
10637 : :
10638 : : /* CODE is an OMP loop construct. Return true if EXPR does not reference
10639 : : any iteration variables outer to level DEPTH. */
10640 : : static bool
10641 : 19343 : expr_is_invariant (gfc_code *code, int depth, gfc_expr *expr)
10642 : : {
10643 : 19343 : int i;
10644 : 19343 : gfc_code *do_code = code;
10645 : :
10646 : 31608 : for (i = 1; i < depth; i++)
10647 : : {
10648 : 13309 : do_code = find_nested_loop_in_chain (do_code->block->next);
10649 : 13309 : gcc_assert (do_code);
10650 : 13309 : gfc_symbol *ivar = do_code->ext.iterator->var->symtree->n.sym;
10651 : 13309 : if (gfc_find_sym_in_expr (ivar, expr))
10652 : : return false;
10653 : : }
10654 : : return true;
10655 : : }
10656 : :
10657 : : /* CODE is an OMP loop construct. Return true if EXPR matches one of the
10658 : : canonical forms for a bound expression. It may include references to
10659 : : an iteration variable outer to level DEPTH; set OUTER_VARP if so. */
10660 : : static bool
10661 : 12193 : bound_expr_is_canonical (gfc_code *code, int depth, gfc_expr *expr,
10662 : : gfc_symbol **outer_varp)
10663 : : {
10664 : 12193 : gfc_expr *expr2 = NULL;
10665 : :
10666 : : /* Rectangular case. */
10667 : 12193 : if (depth == 0 || expr_is_invariant (code, depth, expr))
10668 : 11638 : return true;
10669 : :
10670 : : /* Any simple variable that didn't pass expr_is_invariant must be
10671 : : an outer_var. */
10672 : 555 : if (expr->expr_type == EXPR_VARIABLE && expr->rank == 0)
10673 : : {
10674 : 56 : *outer_varp = expr->symtree->n.sym;
10675 : 56 : return true;
10676 : : }
10677 : :
10678 : : /* All other permitted forms are binary operators. */
10679 : 499 : if (expr->expr_type != EXPR_OP)
10680 : : return false;
10681 : :
10682 : : /* Check for plus/minus a loop invariant expr. */
10683 : 498 : if (expr->value.op.op == INTRINSIC_PLUS
10684 : 498 : || expr->value.op.op == INTRINSIC_MINUS)
10685 : : {
10686 : 481 : if (expr_is_invariant (code, depth, expr->value.op.op1))
10687 : 48 : expr2 = expr->value.op.op2;
10688 : 433 : else if (expr_is_invariant (code, depth, expr->value.op.op2))
10689 : 432 : expr2 = expr->value.op.op1;
10690 : : else
10691 : : return false;
10692 : : }
10693 : : else
10694 : : expr2 = expr;
10695 : :
10696 : : /* Check for a product with a loop-invariant expr. */
10697 : 497 : if (expr2->expr_type == EXPR_OP
10698 : 92 : && expr2->value.op.op == INTRINSIC_TIMES)
10699 : : {
10700 : 92 : if (expr_is_invariant (code, depth, expr2->value.op.op1))
10701 : 40 : expr2 = expr2->value.op.op2;
10702 : 52 : else if (expr_is_invariant (code, depth, expr2->value.op.op2))
10703 : 51 : expr2 = expr2->value.op.op1;
10704 : : else
10705 : : return false;
10706 : : }
10707 : :
10708 : : /* What's left must be a reference to an outer loop variable. */
10709 : 496 : if (expr2->expr_type == EXPR_VARIABLE
10710 : 496 : && expr2->rank == 0
10711 : 992 : && is_outer_iteration_variable (code, depth, expr2->symtree->n.sym))
10712 : : {
10713 : 496 : *outer_varp = expr2->symtree->n.sym;
10714 : 496 : return true;
10715 : : }
10716 : :
10717 : : return false;
10718 : : }
10719 : :
10720 : : static void
10721 : 4110 : resolve_omp_do (gfc_code *code)
10722 : : {
10723 : 4110 : gfc_code *do_code, *next;
10724 : 4110 : int list, i, count;
10725 : 4110 : gfc_omp_namelist *n;
10726 : 4110 : gfc_symbol *dovar;
10727 : 4110 : const char *name;
10728 : 4110 : bool is_simd = false;
10729 : 4110 : bool errorp = false;
10730 : 4110 : bool perfect_nesting_errorp = false;
10731 : :
10732 : 4110 : switch (code->op)
10733 : : {
10734 : : case EXEC_OMP_DISTRIBUTE: name = "!$OMP DISTRIBUTE"; break;
10735 : 34 : case EXEC_OMP_DISTRIBUTE_PARALLEL_DO:
10736 : 34 : name = "!$OMP DISTRIBUTE PARALLEL DO";
10737 : 34 : break;
10738 : 32 : case EXEC_OMP_DISTRIBUTE_PARALLEL_DO_SIMD:
10739 : 32 : name = "!$OMP DISTRIBUTE PARALLEL DO SIMD";
10740 : 32 : is_simd = true;
10741 : 32 : break;
10742 : 50 : case EXEC_OMP_DISTRIBUTE_SIMD:
10743 : 50 : name = "!$OMP DISTRIBUTE SIMD";
10744 : 50 : is_simd = true;
10745 : 50 : break;
10746 : 1148 : case EXEC_OMP_DO: name = "!$OMP DO"; break;
10747 : 134 : case EXEC_OMP_DO_SIMD: name = "!$OMP DO SIMD"; is_simd = true; break;
10748 : 63 : case EXEC_OMP_LOOP: name = "!$OMP LOOP"; break;
10749 : 900 : case EXEC_OMP_PARALLEL_DO: name = "!$OMP PARALLEL DO"; break;
10750 : 288 : case EXEC_OMP_PARALLEL_DO_SIMD:
10751 : 288 : name = "!$OMP PARALLEL DO SIMD";
10752 : 288 : is_simd = true;
10753 : 288 : break;
10754 : 14 : case EXEC_OMP_PARALLEL_LOOP: name = "!$OMP PARALLEL LOOP"; break;
10755 : 7 : case EXEC_OMP_PARALLEL_MASKED_TASKLOOP:
10756 : 7 : name = "!$OMP PARALLEL MASKED TASKLOOP";
10757 : 7 : break;
10758 : 10 : case EXEC_OMP_PARALLEL_MASKED_TASKLOOP_SIMD:
10759 : 10 : name = "!$OMP PARALLEL MASKED TASKLOOP SIMD";
10760 : 10 : is_simd = true;
10761 : 10 : break;
10762 : 12 : case EXEC_OMP_PARALLEL_MASTER_TASKLOOP:
10763 : 12 : name = "!$OMP PARALLEL MASTER TASKLOOP";
10764 : 12 : break;
10765 : 17 : case EXEC_OMP_PARALLEL_MASTER_TASKLOOP_SIMD:
10766 : 17 : name = "!$OMP PARALLEL MASTER TASKLOOP SIMD";
10767 : 17 : is_simd = true;
10768 : 17 : break;
10769 : 8 : case EXEC_OMP_MASKED_TASKLOOP: name = "!$OMP MASKED TASKLOOP"; break;
10770 : 13 : case EXEC_OMP_MASKED_TASKLOOP_SIMD:
10771 : 13 : name = "!$OMP MASKED TASKLOOP SIMD";
10772 : 13 : is_simd = true;
10773 : 13 : break;
10774 : 14 : case EXEC_OMP_MASTER_TASKLOOP: name = "!$OMP MASTER TASKLOOP"; break;
10775 : 20 : case EXEC_OMP_MASTER_TASKLOOP_SIMD:
10776 : 20 : name = "!$OMP MASTER TASKLOOP SIMD";
10777 : 20 : is_simd = true;
10778 : 20 : break;
10779 : 748 : case EXEC_OMP_SIMD: name = "!$OMP SIMD"; is_simd = true; break;
10780 : 45 : case EXEC_OMP_TARGET_PARALLEL_DO: name = "!$OMP TARGET PARALLEL DO"; break;
10781 : 19 : case EXEC_OMP_TARGET_PARALLEL_DO_SIMD:
10782 : 19 : name = "!$OMP TARGET PARALLEL DO SIMD";
10783 : 19 : is_simd = true;
10784 : 19 : break;
10785 : 16 : case EXEC_OMP_TARGET_PARALLEL_LOOP:
10786 : 16 : name = "!$OMP TARGET PARALLEL LOOP";
10787 : 16 : break;
10788 : 33 : case EXEC_OMP_TARGET_SIMD:
10789 : 33 : name = "!$OMP TARGET SIMD";
10790 : 33 : is_simd = true;
10791 : 33 : break;
10792 : 16 : case EXEC_OMP_TARGET_TEAMS_DISTRIBUTE:
10793 : 16 : name = "!$OMP TARGET TEAMS DISTRIBUTE";
10794 : 16 : break;
10795 : 53 : case EXEC_OMP_TARGET_TEAMS_DISTRIBUTE_PARALLEL_DO:
10796 : 53 : name = "!$OMP TARGET TEAMS DISTRIBUTE PARALLEL DO";
10797 : 53 : break;
10798 : 33 : case EXEC_OMP_TARGET_TEAMS_DISTRIBUTE_PARALLEL_DO_SIMD:
10799 : 33 : name = "!$OMP TARGET TEAMS DISTRIBUTE PARALLEL DO SIMD";
10800 : 33 : is_simd = true;
10801 : 33 : break;
10802 : 20 : case EXEC_OMP_TARGET_TEAMS_DISTRIBUTE_SIMD:
10803 : 20 : name = "!$OMP TARGET TEAMS DISTRIBUTE SIMD";
10804 : 20 : is_simd = true;
10805 : 20 : break;
10806 : 17 : case EXEC_OMP_TARGET_TEAMS_LOOP: name = "!$OMP TARGET TEAMS LOOP"; break;
10807 : 84 : case EXEC_OMP_TASKLOOP: name = "!$OMP TASKLOOP"; break;
10808 : 37 : case EXEC_OMP_TASKLOOP_SIMD:
10809 : 37 : name = "!$OMP TASKLOOP SIMD";
10810 : 37 : is_simd = true;
10811 : 37 : break;
10812 : 20 : case EXEC_OMP_TEAMS_DISTRIBUTE: name = "!$OMP TEAMS DISTRIBUTE"; break;
10813 : 37 : case EXEC_OMP_TEAMS_DISTRIBUTE_PARALLEL_DO:
10814 : 37 : name = "!$OMP TEAMS DISTRIBUTE PARALLEL DO";
10815 : 37 : break;
10816 : 60 : case EXEC_OMP_TEAMS_DISTRIBUTE_PARALLEL_DO_SIMD:
10817 : 60 : name = "!$OMP TEAMS DISTRIBUTE PARALLEL DO SIMD";
10818 : 60 : is_simd = true;
10819 : 60 : break;
10820 : 42 : case EXEC_OMP_TEAMS_DISTRIBUTE_SIMD:
10821 : 42 : name = "!$OMP TEAMS DISTRIBUTE SIMD";
10822 : 42 : is_simd = true;
10823 : 42 : break;
10824 : 12 : case EXEC_OMP_TEAMS_LOOP: name = "!$OMP TEAMS LOOP"; break;
10825 : 0 : default: gcc_unreachable ();
10826 : : }
10827 : :
10828 : 4110 : if (code->ext.omp_clauses)
10829 : 4110 : resolve_omp_clauses (code, code->ext.omp_clauses, NULL);
10830 : :
10831 : 4110 : do_code = code->block->next;
10832 : 4110 : if (code->ext.omp_clauses->orderedc)
10833 : : count = code->ext.omp_clauses->orderedc;
10834 : : else
10835 : : {
10836 : 3970 : count = code->ext.omp_clauses->collapse;
10837 : 3970 : if (count <= 0)
10838 : : count = 1;
10839 : : }
10840 : :
10841 : : /* While the spec defines the loop nest depth independently of the COLLAPSE
10842 : : clause, in practice the middle end only pays attention to the COLLAPSE
10843 : : depth and treats any further inner loops as the final-loop-body. So
10844 : : here we also check canonical loop nest form only for the number of
10845 : : outer loops specified by the COLLAPSE clause too. */
10846 : 6106 : for (i = 1; i <= count; i++)
10847 : : {
10848 : 6106 : gfc_symbol *start_var = NULL, *end_var = NULL;
10849 : : /* Parse errors are not recoverable. */
10850 : 6106 : if (do_code->op == EXEC_DO_WHILE)
10851 : : {
10852 : 4 : gfc_error ("%s cannot be a DO WHILE or DO without loop control "
10853 : : "at %L", name, &do_code->loc);
10854 : 13 : return;
10855 : : }
10856 : 6102 : if (do_code->op == EXEC_DO_CONCURRENT)
10857 : : {
10858 : 1 : gfc_error ("%s cannot be a DO CONCURRENT loop at %L", name,
10859 : : &do_code->loc);
10860 : 1 : return;
10861 : : }
10862 : 6101 : gcc_assert (do_code->op == EXEC_DO);
10863 : 6101 : if (do_code->ext.iterator->var->ts.type != BT_INTEGER)
10864 : : {
10865 : 3 : gfc_error ("%s iteration variable must be of type integer at %L",
10866 : : name, &do_code->loc);
10867 : 3 : errorp = true;
10868 : : }
10869 : 6101 : dovar = do_code->ext.iterator->var->symtree->n.sym;
10870 : 6101 : if (dovar->attr.threadprivate)
10871 : : {
10872 : 0 : gfc_error ("%s iteration variable must not be THREADPRIVATE "
10873 : : "at %L", name, &do_code->loc);
10874 : 0 : errorp = true;
10875 : : }
10876 : 6101 : if (code->ext.omp_clauses)
10877 : 207434 : for (list = 0; list < OMP_LIST_NUM; list++)
10878 : 80487 : if (!is_simd || code->ext.omp_clauses->collapse > 1
10879 : 201333 : ? (list != OMP_LIST_PRIVATE && list != OMP_LIST_LASTPRIVATE
10880 : 167871 : && list != OMP_LIST_ALLOCATE)
10881 : 33462 : : (list != OMP_LIST_PRIVATE && list != OMP_LIST_LASTPRIVATE
10882 : 33462 : && list != OMP_LIST_ALLOCATE && list != OMP_LIST_LINEAR))
10883 : 186225 : for (n = code->ext.omp_clauses->lists[list]; n; n = n->next)
10884 : 4209 : if (dovar == n->sym)
10885 : : {
10886 : 5 : if (!is_simd || code->ext.omp_clauses->collapse > 1)
10887 : 4 : gfc_error ("%s iteration variable present on clause "
10888 : : "other than PRIVATE, LASTPRIVATE or "
10889 : : "ALLOCATE at %L", name, &do_code->loc);
10890 : : else
10891 : 1 : gfc_error ("%s iteration variable present on clause "
10892 : : "other than PRIVATE, LASTPRIVATE, ALLOCATE or "
10893 : : "LINEAR at %L", name, &do_code->loc);
10894 : : errorp = true;
10895 : : }
10896 : 6101 : if (is_outer_iteration_variable (code, i, dovar))
10897 : : {
10898 : 1 : gfc_error ("%s iteration variable used in more than one loop at %L",
10899 : : name, &do_code->loc);
10900 : 1 : errorp = true;
10901 : : }
10902 : 6100 : else if (is_intervening_var (code, i, dovar))
10903 : : {
10904 : 2 : gfc_error ("%s iteration variable at %L is bound in "
10905 : : "intervening code",
10906 : : name, &do_code->loc);
10907 : 2 : errorp = true;
10908 : : }
10909 : 6098 : else if (!bound_expr_is_canonical (code, i,
10910 : 6098 : do_code->ext.iterator->start,
10911 : : &start_var))
10912 : : {
10913 : 2 : gfc_error ("%s loop start expression not in canonical form at %L",
10914 : : name, &do_code->loc);
10915 : 2 : errorp = true;
10916 : : }
10917 : 6096 : else if (expr_uses_intervening_var (code, i,
10918 : 6096 : do_code->ext.iterator->start))
10919 : : {
10920 : 1 : gfc_error ("%s loop start expression at %L uses variable bound in "
10921 : : "intervening code",
10922 : : name, &do_code->loc);
10923 : 1 : errorp = true;
10924 : : }
10925 : 6095 : else if (!bound_expr_is_canonical (code, i,
10926 : 6095 : do_code->ext.iterator->end,
10927 : : &end_var))
10928 : : {
10929 : 1 : gfc_error ("%s loop end expression not in canonical form at %L",
10930 : : name, &do_code->loc);
10931 : 1 : errorp = true;
10932 : : }
10933 : 6094 : else if (expr_uses_intervening_var (code, i,
10934 : 6094 : do_code->ext.iterator->end))
10935 : : {
10936 : 1 : gfc_error ("%s loop end expression at %L uses variable bound in "
10937 : : "intervening code",
10938 : : name, &do_code->loc);
10939 : 1 : errorp = true;
10940 : : }
10941 : 6093 : else if (start_var && end_var && start_var != end_var)
10942 : : {
10943 : 1 : gfc_error ("%s loop bounds reference different "
10944 : : "iteration variables at %L", name, &do_code->loc);
10945 : 1 : errorp = true;
10946 : : }
10947 : 6092 : else if (!expr_is_invariant (code, i, do_code->ext.iterator->step))
10948 : : {
10949 : 2 : gfc_error ("%s loop increment not in canonical form at %L",
10950 : : name, &do_code->loc);
10951 : 2 : errorp = true;
10952 : : }
10953 : 6090 : else if (expr_uses_intervening_var (code, i,
10954 : 6090 : do_code->ext.iterator->step))
10955 : : {
10956 : 1 : gfc_error ("%s loop increment expression at %L uses variable "
10957 : : "bound in intervening code",
10958 : : name, &do_code->loc);
10959 : 1 : errorp = true;
10960 : : }
10961 : 6101 : if (start_var || end_var)
10962 : 520 : code->ext.omp_clauses->non_rectangular = 1;
10963 : :
10964 : : /* Only parse loop body into nested loop and intervening code if
10965 : : there are supposed to be more loops in the nest to collapse. */
10966 : 6101 : if (i == count)
10967 : : break;
10968 : :
10969 : 2000 : next = find_nested_loop_in_chain (do_code->block->next);
10970 : :
10971 : 2000 : if (!next)
10972 : : {
10973 : : /* Parse error, can't recover from this. */
10974 : 4 : gfc_error ("not enough DO loops for collapsed %s (level %d) at %L",
10975 : : name, i, &code->loc);
10976 : 4 : return;
10977 : : }
10978 : 1996 : else if (next != do_code->block->next || next->next)
10979 : : /* Imperfectly nested loop found. */
10980 : : {
10981 : : /* Only diagnose violation of imperfect nesting constraints once. */
10982 : 144 : if (!perfect_nesting_errorp)
10983 : : {
10984 : 143 : if (code->ext.omp_clauses->orderedc)
10985 : : {
10986 : 3 : gfc_error ("%s inner loops must be perfectly nested with "
10987 : : "ORDERED clause at %L",
10988 : : name, &code->loc);
10989 : 3 : perfect_nesting_errorp = true;
10990 : : }
10991 : 140 : else if (code->ext.omp_clauses->lists[OMP_LIST_REDUCTION_INSCAN])
10992 : : {
10993 : 2 : gfc_error ("%s inner loops must be perfectly nested with "
10994 : : "REDUCTION INSCAN clause at %L",
10995 : : name, &code->loc);
10996 : 2 : perfect_nesting_errorp = true;
10997 : : }
10998 : : /* FIXME: Also diagnose for TILE directives. */
10999 : 5 : if (perfect_nesting_errorp)
11000 : : errorp = true;
11001 : : }
11002 : 144 : if (diagnose_intervening_code_errors (do_code->block->next,
11003 : : name, next))
11004 : 4 : errorp = true;
11005 : : }
11006 : 1996 : do_code = next;
11007 : : }
11008 : :
11009 : : /* Give up now if we found any constraint violations. */
11010 : 4101 : if (errorp)
11011 : : return;
11012 : :
11013 : 4074 : restructure_intervening_code (&(code->block->next), code, count);
11014 : : }
11015 : :
11016 : :
11017 : : static gfc_statement
11018 : 63 : omp_code_to_statement (gfc_code *code)
11019 : : {
11020 : 63 : switch (code->op)
11021 : : {
11022 : : case EXEC_OMP_PARALLEL:
11023 : : return ST_OMP_PARALLEL;
11024 : 0 : case EXEC_OMP_PARALLEL_MASKED:
11025 : 0 : return ST_OMP_PARALLEL_MASKED;
11026 : 0 : case EXEC_OMP_PARALLEL_MASKED_TASKLOOP:
11027 : 0 : return ST_OMP_PARALLEL_MASKED_TASKLOOP;
11028 : 0 : case EXEC_OMP_PARALLEL_MASKED_TASKLOOP_SIMD:
11029 : 0 : return ST_OMP_PARALLEL_MASKED_TASKLOOP_SIMD;
11030 : 0 : case EXEC_OMP_PARALLEL_MASTER:
11031 : 0 : return ST_OMP_PARALLEL_MASTER;
11032 : 0 : case EXEC_OMP_PARALLEL_MASTER_TASKLOOP:
11033 : 0 : return ST_OMP_PARALLEL_MASTER_TASKLOOP;
11034 : 0 : case EXEC_OMP_PARALLEL_MASTER_TASKLOOP_SIMD:
11035 : 0 : return ST_OMP_PARALLEL_MASTER_TASKLOOP_SIMD;
11036 : 1 : case EXEC_OMP_PARALLEL_SECTIONS:
11037 : 1 : return ST_OMP_PARALLEL_SECTIONS;
11038 : 1 : case EXEC_OMP_SECTIONS:
11039 : 1 : return ST_OMP_SECTIONS;
11040 : 1 : case EXEC_OMP_ORDERED:
11041 : 1 : return ST_OMP_ORDERED;
11042 : 1 : case EXEC_OMP_CRITICAL:
11043 : 1 : return ST_OMP_CRITICAL;
11044 : 0 : case EXEC_OMP_MASKED:
11045 : 0 : return ST_OMP_MASKED;
11046 : 0 : case EXEC_OMP_MASKED_TASKLOOP:
11047 : 0 : return ST_OMP_MASKED_TASKLOOP;
11048 : 0 : case EXEC_OMP_MASKED_TASKLOOP_SIMD:
11049 : 0 : return ST_OMP_MASKED_TASKLOOP_SIMD;
11050 : 1 : case EXEC_OMP_MASTER:
11051 : 1 : return ST_OMP_MASTER;
11052 : 0 : case EXEC_OMP_MASTER_TASKLOOP:
11053 : 0 : return ST_OMP_MASTER_TASKLOOP;
11054 : 0 : case EXEC_OMP_MASTER_TASKLOOP_SIMD:
11055 : 0 : return ST_OMP_MASTER_TASKLOOP_SIMD;
11056 : 1 : case EXEC_OMP_SINGLE:
11057 : 1 : return ST_OMP_SINGLE;
11058 : 1 : case EXEC_OMP_TASK:
11059 : 1 : return ST_OMP_TASK;
11060 : 1 : case EXEC_OMP_WORKSHARE:
11061 : 1 : return ST_OMP_WORKSHARE;
11062 : 1 : case EXEC_OMP_PARALLEL_WORKSHARE:
11063 : 1 : return ST_OMP_PARALLEL_WORKSHARE;
11064 : 3 : case EXEC_OMP_DO:
11065 : 3 : return ST_OMP_DO;
11066 : 0 : case EXEC_OMP_LOOP:
11067 : 0 : return ST_OMP_LOOP;
11068 : 0 : case EXEC_OMP_ALLOCATE:
11069 : 0 : return ST_OMP_ALLOCATE_EXEC;
11070 : 0 : case EXEC_OMP_ALLOCATORS:
11071 : 0 : return ST_OMP_ALLOCATORS;
11072 : 0 : case EXEC_OMP_ASSUME:
11073 : 0 : return ST_OMP_ASSUME;
11074 : 1 : case EXEC_OMP_ATOMIC:
11075 : 1 : return ST_OMP_ATOMIC;
11076 : 1 : case EXEC_OMP_BARRIER:
11077 : 1 : return ST_OMP_BARRIER;
11078 : 1 : case EXEC_OMP_CANCEL:
11079 : 1 : return ST_OMP_CANCEL;
11080 : 1 : case EXEC_OMP_CANCELLATION_POINT:
11081 : 1 : return ST_OMP_CANCELLATION_POINT;
11082 : 0 : case EXEC_OMP_ERROR:
11083 : 0 : return ST_OMP_ERROR;
11084 : 1 : case EXEC_OMP_FLUSH:
11085 : 1 : return ST_OMP_FLUSH;
11086 : 1 : case EXEC_OMP_DISTRIBUTE:
11087 : 1 : return ST_OMP_DISTRIBUTE;
11088 : 1 : case EXEC_OMP_DISTRIBUTE_PARALLEL_DO:
11089 : 1 : return ST_OMP_DISTRIBUTE_PARALLEL_DO;
11090 : 1 : case EXEC_OMP_DISTRIBUTE_PARALLEL_DO_SIMD:
11091 : 1 : return ST_OMP_DISTRIBUTE_PARALLEL_DO_SIMD;
11092 : 1 : case EXEC_OMP_DISTRIBUTE_SIMD:
11093 : 1 : return ST_OMP_DISTRIBUTE_SIMD;
11094 : 1 : case EXEC_OMP_DO_SIMD:
11095 : 1 : return ST_OMP_DO_SIMD;
11096 : 0 : case EXEC_OMP_SCAN:
11097 : 0 : return ST_OMP_SCAN;
11098 : 0 : case EXEC_OMP_SCOPE:
11099 : 0 : return ST_OMP_SCOPE;
11100 : 1 : case EXEC_OMP_SIMD:
11101 : 1 : return ST_OMP_SIMD;
11102 : 1 : case EXEC_OMP_TARGET:
11103 : 1 : return ST_OMP_TARGET;
11104 : 1 : case EXEC_OMP_TARGET_DATA:
11105 : 1 : return ST_OMP_TARGET_DATA;
11106 : 1 : case EXEC_OMP_TARGET_ENTER_DATA:
11107 : 1 : return ST_OMP_TARGET_ENTER_DATA;
11108 : 1 : case EXEC_OMP_TARGET_EXIT_DATA:
11109 : 1 : return ST_OMP_TARGET_EXIT_DATA;
11110 : 1 : case EXEC_OMP_TARGET_PARALLEL:
11111 : 1 : return ST_OMP_TARGET_PARALLEL;
11112 : 1 : case EXEC_OMP_TARGET_PARALLEL_DO:
11113 : 1 : return ST_OMP_TARGET_PARALLEL_DO;
11114 : 1 : case EXEC_OMP_TARGET_PARALLEL_DO_SIMD:
11115 : 1 : return ST_OMP_TARGET_PARALLEL_DO_SIMD;
11116 : 0 : case EXEC_OMP_TARGET_PARALLEL_LOOP:
11117 : 0 : return ST_OMP_TARGET_PARALLEL_LOOP;
11118 : 1 : case EXEC_OMP_TARGET_SIMD:
11119 : 1 : return ST_OMP_TARGET_SIMD;
11120 : 1 : case EXEC_OMP_TARGET_TEAMS:
11121 : 1 : return ST_OMP_TARGET_TEAMS;
11122 : 1 : case EXEC_OMP_TARGET_TEAMS_DISTRIBUTE:
11123 : 1 : return ST_OMP_TARGET_TEAMS_DISTRIBUTE;
11124 : 1 : case EXEC_OMP_TARGET_TEAMS_DISTRIBUTE_PARALLEL_DO:
11125 : 1 : return ST_OMP_TARGET_TEAMS_DISTRIBUTE_PARALLEL_DO;
11126 : 1 : case EXEC_OMP_TARGET_TEAMS_DISTRIBUTE_PARALLEL_DO_SIMD:
11127 : 1 : return ST_OMP_TARGET_TEAMS_DISTRIBUTE_PARALLEL_DO_SIMD;
11128 : 1 : case EXEC_OMP_TARGET_TEAMS_DISTRIBUTE_SIMD:
11129 : 1 : return ST_OMP_TARGET_TEAMS_DISTRIBUTE_SIMD;
11130 : 0 : case EXEC_OMP_TARGET_TEAMS_LOOP:
11131 : 0 : return ST_OMP_TARGET_TEAMS_LOOP;
11132 : 1 : case EXEC_OMP_TARGET_UPDATE:
11133 : 1 : return ST_OMP_TARGET_UPDATE;
11134 : 1 : case EXEC_OMP_TASKGROUP:
11135 : 1 : return ST_OMP_TASKGROUP;
11136 : 1 : case EXEC_OMP_TASKLOOP:
11137 : 1 : return ST_OMP_TASKLOOP;
11138 : 1 : case EXEC_OMP_TASKLOOP_SIMD:
11139 : 1 : return ST_OMP_TASKLOOP_SIMD;
11140 : 1 : case EXEC_OMP_TASKWAIT:
11141 : 1 : return ST_OMP_TASKWAIT;
11142 : 1 : case EXEC_OMP_TASKYIELD:
11143 : 1 : return ST_OMP_TASKYIELD;
11144 : 1 : case EXEC_OMP_TEAMS:
11145 : 1 : return ST_OMP_TEAMS;
11146 : 1 : case EXEC_OMP_TEAMS_DISTRIBUTE:
11147 : 1 : return ST_OMP_TEAMS_DISTRIBUTE;
11148 : 1 : case EXEC_OMP_TEAMS_DISTRIBUTE_PARALLEL_DO:
11149 : 1 : return ST_OMP_TEAMS_DISTRIBUTE_PARALLEL_DO;
11150 : 1 : case EXEC_OMP_TEAMS_DISTRIBUTE_PARALLEL_DO_SIMD:
11151 : 1 : return ST_OMP_TEAMS_DISTRIBUTE_PARALLEL_DO_SIMD;
11152 : 1 : case EXEC_OMP_TEAMS_DISTRIBUTE_SIMD:
11153 : 1 : return ST_OMP_TEAMS_DISTRIBUTE_SIMD;
11154 : 0 : case EXEC_OMP_TEAMS_LOOP:
11155 : 0 : return ST_OMP_TEAMS_LOOP;
11156 : 6 : case EXEC_OMP_PARALLEL_DO:
11157 : 6 : return ST_OMP_PARALLEL_DO;
11158 : 1 : case EXEC_OMP_PARALLEL_DO_SIMD:
11159 : 1 : return ST_OMP_PARALLEL_DO_SIMD;
11160 : 0 : case EXEC_OMP_PARALLEL_LOOP:
11161 : 0 : return ST_OMP_PARALLEL_LOOP;
11162 : 1 : case EXEC_OMP_DEPOBJ:
11163 : 1 : return ST_OMP_DEPOBJ;
11164 : 0 : default:
11165 : 0 : gcc_unreachable ();
11166 : : }
11167 : : }
11168 : :
11169 : : static gfc_statement
11170 : 63 : oacc_code_to_statement (gfc_code *code)
11171 : : {
11172 : 63 : switch (code->op)
11173 : : {
11174 : : case EXEC_OACC_PARALLEL:
11175 : : return ST_OACC_PARALLEL;
11176 : : case EXEC_OACC_KERNELS:
11177 : : return ST_OACC_KERNELS;
11178 : : case EXEC_OACC_SERIAL:
11179 : : return ST_OACC_SERIAL;
11180 : : case EXEC_OACC_DATA:
11181 : : return ST_OACC_DATA;
11182 : : case EXEC_OACC_HOST_DATA:
11183 : : return ST_OACC_HOST_DATA;
11184 : : case EXEC_OACC_PARALLEL_LOOP:
11185 : : return ST_OACC_PARALLEL_LOOP;
11186 : : case EXEC_OACC_KERNELS_LOOP:
11187 : : return ST_OACC_KERNELS_LOOP;
11188 : : case EXEC_OACC_SERIAL_LOOP:
11189 : : return ST_OACC_SERIAL_LOOP;
11190 : : case EXEC_OACC_LOOP:
11191 : : return ST_OACC_LOOP;
11192 : : case EXEC_OACC_ATOMIC:
11193 : : return ST_OACC_ATOMIC;
11194 : : case EXEC_OACC_ROUTINE:
11195 : : return ST_OACC_ROUTINE;
11196 : : case EXEC_OACC_UPDATE:
11197 : : return ST_OACC_UPDATE;
11198 : : case EXEC_OACC_WAIT:
11199 : : return ST_OACC_WAIT;
11200 : : case EXEC_OACC_CACHE:
11201 : : return ST_OACC_CACHE;
11202 : : case EXEC_OACC_ENTER_DATA:
11203 : : return ST_OACC_ENTER_DATA;
11204 : : case EXEC_OACC_EXIT_DATA:
11205 : : return ST_OACC_EXIT_DATA;
11206 : : case EXEC_OACC_DECLARE:
11207 : : return ST_OACC_DECLARE;
11208 : 0 : default:
11209 : 0 : gcc_unreachable ();
11210 : : }
11211 : : }
11212 : :
11213 : : static void
11214 : 12253 : resolve_oacc_directive_inside_omp_region (gfc_code *code)
11215 : : {
11216 : 12253 : if (omp_current_ctx != NULL && omp_current_ctx->is_openmp)
11217 : : {
11218 : 11 : gfc_statement st = omp_code_to_statement (omp_current_ctx->code);
11219 : 11 : gfc_statement oacc_st = oacc_code_to_statement (code);
11220 : 11 : gfc_error ("The %s directive cannot be specified within "
11221 : : "a %s region at %L", gfc_ascii_statement (oacc_st),
11222 : : gfc_ascii_statement (st), &code->loc);
11223 : : }
11224 : 12253 : }
11225 : :
11226 : : static void
11227 : 18448 : resolve_omp_directive_inside_oacc_region (gfc_code *code)
11228 : : {
11229 : 18448 : if (omp_current_ctx != NULL && !omp_current_ctx->is_openmp)
11230 : : {
11231 : 52 : gfc_statement st = oacc_code_to_statement (omp_current_ctx->code);
11232 : 52 : gfc_statement omp_st = omp_code_to_statement (code);
11233 : 52 : gfc_error ("The %s directive cannot be specified within "
11234 : : "a %s region at %L", gfc_ascii_statement (omp_st),
11235 : : gfc_ascii_statement (st), &code->loc);
11236 : : }
11237 : 18448 : }
11238 : :
11239 : :
11240 : : static void
11241 : 4739 : resolve_oacc_nested_loops (gfc_code *code, gfc_code* do_code, int collapse,
11242 : : const char *clause)
11243 : : {
11244 : 4739 : gfc_symbol *dovar;
11245 : 4739 : gfc_code *c;
11246 : 4739 : int i;
11247 : :
11248 : 5244 : for (i = 1; i <= collapse; i++)
11249 : : {
11250 : 5244 : if (do_code->op == EXEC_DO_WHILE)
11251 : : {
11252 : 10 : gfc_error ("!$ACC LOOP cannot be a DO WHILE or DO without loop control "
11253 : : "at %L", &do_code->loc);
11254 : 10 : break;
11255 : : }
11256 : 5234 : if (do_code->op == EXEC_DO_CONCURRENT)
11257 : : {
11258 : 3 : gfc_error ("!$ACC LOOP cannot be a DO CONCURRENT loop at %L",
11259 : : &do_code->loc);
11260 : 3 : break;
11261 : : }
11262 : 5231 : gcc_assert (do_code->op == EXEC_DO);
11263 : 5231 : if (do_code->ext.iterator->var->ts.type != BT_INTEGER)
11264 : 6 : gfc_error ("!$ACC LOOP iteration variable must be of type integer at %L",
11265 : : &do_code->loc);
11266 : 5231 : dovar = do_code->ext.iterator->var->symtree->n.sym;
11267 : 5231 : if (i > 1)
11268 : : {
11269 : 503 : gfc_code *do_code2 = code->block->next;
11270 : 503 : int j;
11271 : :
11272 : 1190 : for (j = 1; j < i; j++)
11273 : : {
11274 : 695 : gfc_symbol *ivar = do_code2->ext.iterator->var->symtree->n.sym;
11275 : 695 : if (dovar == ivar
11276 : 695 : || gfc_find_sym_in_expr (ivar, do_code->ext.iterator->start)
11277 : 688 : || gfc_find_sym_in_expr (ivar, do_code->ext.iterator->end)
11278 : 1382 : || gfc_find_sym_in_expr (ivar, do_code->ext.iterator->step))
11279 : : {
11280 : 8 : gfc_error ("!$ACC LOOP %s loops don't form rectangular "
11281 : : "iteration space at %L", clause, &do_code->loc);
11282 : 8 : break;
11283 : : }
11284 : 687 : do_code2 = do_code2->block->next;
11285 : : }
11286 : : }
11287 : 5231 : if (i == collapse)
11288 : : break;
11289 : 560 : for (c = do_code->next; c; c = c->next)
11290 : 48 : if (c->op != EXEC_NOP && c->op != EXEC_CONTINUE)
11291 : : {
11292 : 0 : gfc_error ("%s !$ACC LOOP loops not perfectly nested at %L",
11293 : : clause, &c->loc);
11294 : 0 : break;
11295 : : }
11296 : 512 : if (c)
11297 : : break;
11298 : 512 : do_code = do_code->block;
11299 : 512 : if (do_code->op != EXEC_DO && do_code->op != EXEC_DO_WHILE
11300 : 0 : && do_code->op != EXEC_DO_CONCURRENT)
11301 : : {
11302 : 0 : gfc_error ("not enough DO loops for %s !$ACC LOOP at %L",
11303 : : clause, &code->loc);
11304 : 0 : break;
11305 : : }
11306 : 512 : do_code = do_code->next;
11307 : 512 : if (do_code == NULL
11308 : 507 : || (do_code->op != EXEC_DO && do_code->op != EXEC_DO_WHILE
11309 : 2 : && do_code->op != EXEC_DO_CONCURRENT))
11310 : : {
11311 : 7 : gfc_error ("not enough DO loops for %s !$ACC LOOP at %L",
11312 : : clause, &code->loc);
11313 : 7 : break;
11314 : : }
11315 : : }
11316 : 4739 : }
11317 : :
11318 : :
11319 : : static void
11320 : 9266 : resolve_oacc_loop_blocks (gfc_code *code)
11321 : : {
11322 : 9266 : if (!oacc_is_loop (code))
11323 : : return;
11324 : :
11325 : 4739 : if (code->ext.omp_clauses->tile_list && code->ext.omp_clauses->gang
11326 : 170 : && code->ext.omp_clauses->worker && code->ext.omp_clauses->vector)
11327 : 0 : gfc_error ("Tiled loop cannot be parallelized across gangs, workers and "
11328 : : "vectors at the same time at %L", &code->loc);
11329 : :
11330 : 4739 : if (code->ext.omp_clauses->tile_list)
11331 : : {
11332 : : gfc_expr_list *el;
11333 : 439 : for (el = code->ext.omp_clauses->tile_list; el; el = el->next)
11334 : : {
11335 : 269 : if (el->expr == NULL)
11336 : : {
11337 : : /* NULL expressions are used to represent '*' arguments.
11338 : : Convert those to a 0 expressions. */
11339 : 98 : el->expr = gfc_get_constant_expr (BT_INTEGER,
11340 : : gfc_default_integer_kind,
11341 : : &code->loc);
11342 : 98 : mpz_set_si (el->expr->value.integer, 0);
11343 : : }
11344 : : else
11345 : : {
11346 : 171 : resolve_positive_int_expr (el->expr, "TILE");
11347 : 171 : if (el->expr->expr_type != EXPR_CONSTANT)
11348 : 12 : gfc_error ("TILE requires constant expression at %L",
11349 : : &code->loc);
11350 : : }
11351 : : }
11352 : : }
11353 : : }
11354 : :
11355 : :
11356 : : void
11357 : 9266 : gfc_resolve_oacc_blocks (gfc_code *code, gfc_namespace *ns)
11358 : : {
11359 : 9266 : fortran_omp_context ctx;
11360 : 9266 : gfc_omp_clauses *omp_clauses = code->ext.omp_clauses;
11361 : 9266 : gfc_omp_namelist *n;
11362 : 9266 : int list;
11363 : :
11364 : 9266 : resolve_oacc_loop_blocks (code);
11365 : :
11366 : 9266 : ctx.code = code;
11367 : 9266 : ctx.sharing_clauses = new hash_set<gfc_symbol *>;
11368 : 9266 : ctx.private_iterators = new hash_set<gfc_symbol *>;
11369 : 9266 : ctx.previous = omp_current_ctx;
11370 : 9266 : ctx.is_openmp = false;
11371 : 9266 : omp_current_ctx = &ctx;
11372 : :
11373 : 315044 : for (list = 0; list < OMP_LIST_NUM; list++)
11374 : 305778 : switch (list)
11375 : : {
11376 : 9266 : case OMP_LIST_PRIVATE:
11377 : 9760 : for (n = omp_clauses->lists[list]; n; n = n->next)
11378 : 494 : ctx.sharing_clauses->add (n->sym);
11379 : : break;
11380 : : default:
11381 : : break;
11382 : : }
11383 : :
11384 : 9266 : gfc_resolve_blocks (code->block, ns);
11385 : :
11386 : 9266 : omp_current_ctx = ctx.previous;
11387 : 18532 : delete ctx.sharing_clauses;
11388 : 18532 : delete ctx.private_iterators;
11389 : 9266 : }
11390 : :
11391 : :
11392 : : static void
11393 : 4739 : resolve_oacc_loop (gfc_code *code)
11394 : : {
11395 : 4739 : gfc_code *do_code;
11396 : 4739 : int collapse;
11397 : :
11398 : 4739 : if (code->ext.omp_clauses)
11399 : 4739 : resolve_omp_clauses (code, code->ext.omp_clauses, NULL, true);
11400 : :
11401 : 4739 : do_code = code->block->next;
11402 : 4739 : collapse = code->ext.omp_clauses->collapse;
11403 : :
11404 : : /* Both collapsed and tiled loops are lowered the same way, but are not
11405 : : compatible. In gfc_trans_omp_do, the tile is prioritized. */
11406 : 4739 : if (code->ext.omp_clauses->tile_list)
11407 : : {
11408 : : int num = 0;
11409 : : gfc_expr_list *el;
11410 : 439 : for (el = code->ext.omp_clauses->tile_list; el; el = el->next)
11411 : 269 : ++num;
11412 : 170 : resolve_oacc_nested_loops (code, code->block->next, num, "tiled");
11413 : 170 : return;
11414 : : }
11415 : :
11416 : 4569 : if (collapse <= 0)
11417 : : collapse = 1;
11418 : 4569 : resolve_oacc_nested_loops (code, do_code, collapse, "collapsed");
11419 : : }
11420 : :
11421 : : void
11422 : 281927 : gfc_resolve_oacc_declare (gfc_namespace *ns)
11423 : : {
11424 : 281927 : int list;
11425 : 281927 : gfc_omp_namelist *n;
11426 : 281927 : gfc_oacc_declare *oc;
11427 : :
11428 : 281927 : if (ns->oacc_declare == NULL)
11429 : : return;
11430 : :
11431 : 278 : for (oc = ns->oacc_declare; oc; oc = oc->next)
11432 : : {
11433 : 5304 : for (list = 0; list < OMP_LIST_NUM; list++)
11434 : 5391 : for (n = oc->clauses->lists[list]; n; n = n->next)
11435 : : {
11436 : 243 : n->sym->mark = 0;
11437 : 243 : if (n->sym->attr.flavor != FL_VARIABLE
11438 : 11 : && (n->sym->attr.flavor != FL_PROCEDURE
11439 : 8 : || n->sym->result != n->sym))
11440 : : {
11441 : 9 : gfc_error ("Object %qs is not a variable at %L",
11442 : : n->sym->name, &oc->loc);
11443 : 9 : continue;
11444 : : }
11445 : :
11446 : 234 : if (n->expr && n->expr->ref->type == REF_ARRAY)
11447 : : {
11448 : 1 : gfc_error ("Array sections: %qs not allowed in"
11449 : : " !$ACC DECLARE at %L", n->sym->name, &oc->loc);
11450 : 1 : continue;
11451 : : }
11452 : : }
11453 : :
11454 : 244 : for (n = oc->clauses->lists[OMP_LIST_DEVICE_RESIDENT]; n; n = n->next)
11455 : 88 : check_array_not_assumed (n->sym, oc->loc, "DEVICE_RESIDENT");
11456 : : }
11457 : :
11458 : 278 : for (oc = ns->oacc_declare; oc; oc = oc->next)
11459 : : {
11460 : 5304 : for (list = 0; list < OMP_LIST_NUM; list++)
11461 : 5391 : for (n = oc->clauses->lists[list]; n; n = n->next)
11462 : : {
11463 : 243 : if (n->sym->mark)
11464 : : {
11465 : 8 : gfc_error ("Symbol %qs present on multiple clauses at %L",
11466 : : n->sym->name, &oc->loc);
11467 : 8 : continue;
11468 : : }
11469 : : else
11470 : 235 : n->sym->mark = 1;
11471 : : }
11472 : : }
11473 : :
11474 : 278 : for (oc = ns->oacc_declare; oc; oc = oc->next)
11475 : : {
11476 : 5304 : for (list = 0; list < OMP_LIST_NUM; list++)
11477 : 5391 : for (n = oc->clauses->lists[list]; n; n = n->next)
11478 : 243 : n->sym->mark = 0;
11479 : : }
11480 : : }
11481 : :
11482 : :
11483 : : void
11484 : 281927 : gfc_resolve_oacc_routines (gfc_namespace *ns)
11485 : : {
11486 : 281927 : for (gfc_oacc_routine_name *orn = ns->oacc_routine_names;
11487 : 282011 : orn;
11488 : 84 : orn = orn->next)
11489 : : {
11490 : 84 : gfc_symbol *sym = orn->sym;
11491 : 91 : if (!sym->attr.external
11492 : : && !sym->attr.function
11493 : 84 : && !sym->attr.subroutine)
11494 : : {
11495 : 7 : gfc_error ("NAME %qs does not refer to a subroutine or function"
11496 : : " in !$ACC ROUTINE ( NAME ) at %L", sym->name, &orn->loc);
11497 : 7 : continue;
11498 : : }
11499 : 77 : if (!gfc_add_omp_declare_target (&sym->attr, sym->name, &orn->loc))
11500 : : {
11501 : 20 : gfc_error ("NAME %qs invalid"
11502 : : " in !$ACC ROUTINE ( NAME ) at %L", sym->name, &orn->loc);
11503 : 20 : continue;
11504 : : }
11505 : : }
11506 : 281927 : }
11507 : :
11508 : :
11509 : : void
11510 : 12253 : gfc_resolve_oacc_directive (gfc_code *code, gfc_namespace *ns ATTRIBUTE_UNUSED)
11511 : : {
11512 : 12253 : resolve_oacc_directive_inside_omp_region (code);
11513 : :
11514 : 12253 : switch (code->op)
11515 : : {
11516 : 6971 : case EXEC_OACC_PARALLEL:
11517 : 6971 : case EXEC_OACC_KERNELS:
11518 : 6971 : case EXEC_OACC_SERIAL:
11519 : 6971 : case EXEC_OACC_DATA:
11520 : 6971 : case EXEC_OACC_HOST_DATA:
11521 : 6971 : case EXEC_OACC_UPDATE:
11522 : 6971 : case EXEC_OACC_ENTER_DATA:
11523 : 6971 : case EXEC_OACC_EXIT_DATA:
11524 : 6971 : case EXEC_OACC_WAIT:
11525 : 6971 : case EXEC_OACC_CACHE:
11526 : 6971 : resolve_omp_clauses (code, code->ext.omp_clauses, NULL, true);
11527 : 6971 : break;
11528 : 4739 : case EXEC_OACC_PARALLEL_LOOP:
11529 : 4739 : case EXEC_OACC_KERNELS_LOOP:
11530 : 4739 : case EXEC_OACC_SERIAL_LOOP:
11531 : 4739 : case EXEC_OACC_LOOP:
11532 : 4739 : resolve_oacc_loop (code);
11533 : 4739 : break;
11534 : 543 : case EXEC_OACC_ATOMIC:
11535 : 543 : resolve_omp_atomic (code);
11536 : 543 : break;
11537 : : default:
11538 : : break;
11539 : : }
11540 : 12253 : }
11541 : :
11542 : :
11543 : : static void
11544 : 1625 : resolve_omp_target (gfc_code *code)
11545 : : {
11546 : : #define GFC_IS_TEAMS_CONSTRUCT(op) \
11547 : : (op == EXEC_OMP_TEAMS \
11548 : : || op == EXEC_OMP_TEAMS_DISTRIBUTE \
11549 : : || op == EXEC_OMP_TEAMS_DISTRIBUTE_SIMD \
11550 : : || op == EXEC_OMP_TEAMS_DISTRIBUTE_PARALLEL_DO \
11551 : : || op == EXEC_OMP_TEAMS_DISTRIBUTE_PARALLEL_DO_SIMD \
11552 : : || op == EXEC_OMP_TEAMS_LOOP)
11553 : :
11554 : 1625 : if (!code->ext.omp_clauses->contains_teams_construct)
11555 : : return;
11556 : 184 : gfc_code *c = code->block->next;
11557 : 184 : if (c->op == EXEC_BLOCK)
11558 : 15 : c = c->ext.block.ns->code;
11559 : 184 : if (code->ext.omp_clauses->target_first_st_is_teams
11560 : 174 : && ((GFC_IS_TEAMS_CONSTRUCT (c->op) && c->next == NULL)
11561 : 10 : || (c->op == EXEC_BLOCK
11562 : 0 : && c->next
11563 : 0 : && GFC_IS_TEAMS_CONSTRUCT (c->next->op)
11564 : 0 : && c->next->next == NULL)))
11565 : : return;
11566 : 26 : while (c && !GFC_IS_TEAMS_CONSTRUCT (c->op))
11567 : 6 : c = c->next;
11568 : 20 : if (c)
11569 : 18 : gfc_error ("!$OMP TARGET region at %L with a nested TEAMS at %L may not "
11570 : : "contain any other statement, declaration or directive outside "
11571 : : "of the single TEAMS construct", &c->loc, &code->loc);
11572 : : else
11573 : 2 : gfc_error ("!$OMP TARGET region at %L with a nested TEAMS may not "
11574 : : "contain any other statement, declaration or directive outside "
11575 : : "of the single TEAMS construct", &code->loc);
11576 : : #undef GFC_IS_TEAMS_CONSTRUCT
11577 : : }
11578 : :
11579 : :
11580 : : /* Resolve OpenMP directive clauses and check various requirements
11581 : : of each directive. */
11582 : :
11583 : : void
11584 : 18448 : gfc_resolve_omp_directive (gfc_code *code, gfc_namespace *ns)
11585 : : {
11586 : 18448 : resolve_omp_directive_inside_oacc_region (code);
11587 : :
11588 : 18448 : if (code->op != EXEC_OMP_ATOMIC)
11589 : 16308 : gfc_maybe_initialize_eh ();
11590 : :
11591 : 18448 : switch (code->op)
11592 : : {
11593 : 4110 : case EXEC_OMP_DISTRIBUTE:
11594 : 4110 : case EXEC_OMP_DISTRIBUTE_PARALLEL_DO:
11595 : 4110 : case EXEC_OMP_DISTRIBUTE_PARALLEL_DO_SIMD:
11596 : 4110 : case EXEC_OMP_DISTRIBUTE_SIMD:
11597 : 4110 : case EXEC_OMP_DO:
11598 : 4110 : case EXEC_OMP_DO_SIMD:
11599 : 4110 : case EXEC_OMP_LOOP:
11600 : 4110 : case EXEC_OMP_PARALLEL_DO:
11601 : 4110 : case EXEC_OMP_PARALLEL_DO_SIMD:
11602 : 4110 : case EXEC_OMP_PARALLEL_LOOP:
11603 : 4110 : case EXEC_OMP_PARALLEL_MASKED_TASKLOOP:
11604 : 4110 : case EXEC_OMP_PARALLEL_MASKED_TASKLOOP_SIMD:
11605 : 4110 : case EXEC_OMP_PARALLEL_MASTER_TASKLOOP:
11606 : 4110 : case EXEC_OMP_PARALLEL_MASTER_TASKLOOP_SIMD:
11607 : 4110 : case EXEC_OMP_MASKED_TASKLOOP:
11608 : 4110 : case EXEC_OMP_MASKED_TASKLOOP_SIMD:
11609 : 4110 : case EXEC_OMP_MASTER_TASKLOOP:
11610 : 4110 : case EXEC_OMP_MASTER_TASKLOOP_SIMD:
11611 : 4110 : case EXEC_OMP_SIMD:
11612 : 4110 : case EXEC_OMP_TARGET_PARALLEL_DO:
11613 : 4110 : case EXEC_OMP_TARGET_PARALLEL_DO_SIMD:
11614 : 4110 : case EXEC_OMP_TARGET_PARALLEL_LOOP:
11615 : 4110 : case EXEC_OMP_TARGET_SIMD:
11616 : 4110 : case EXEC_OMP_TARGET_TEAMS_DISTRIBUTE:
11617 : 4110 : case EXEC_OMP_TARGET_TEAMS_DISTRIBUTE_PARALLEL_DO:
11618 : 4110 : case EXEC_OMP_TARGET_TEAMS_DISTRIBUTE_PARALLEL_DO_SIMD:
11619 : 4110 : case EXEC_OMP_TARGET_TEAMS_DISTRIBUTE_SIMD:
11620 : 4110 : case EXEC_OMP_TARGET_TEAMS_LOOP:
11621 : 4110 : case EXEC_OMP_TASKLOOP:
11622 : 4110 : case EXEC_OMP_TASKLOOP_SIMD:
11623 : 4110 : case EXEC_OMP_TEAMS_DISTRIBUTE:
11624 : 4110 : case EXEC_OMP_TEAMS_DISTRIBUTE_PARALLEL_DO:
11625 : 4110 : case EXEC_OMP_TEAMS_DISTRIBUTE_PARALLEL_DO_SIMD:
11626 : 4110 : case EXEC_OMP_TEAMS_DISTRIBUTE_SIMD:
11627 : 4110 : case EXEC_OMP_TEAMS_LOOP:
11628 : 4110 : resolve_omp_do (code);
11629 : 4110 : break;
11630 : 1625 : case EXEC_OMP_TARGET:
11631 : 1625 : resolve_omp_target (code);
11632 : 9129 : gcc_fallthrough ();
11633 : 9129 : case EXEC_OMP_ALLOCATE:
11634 : 9129 : case EXEC_OMP_ALLOCATORS:
11635 : 9129 : case EXEC_OMP_ASSUME:
11636 : 9129 : case EXEC_OMP_CANCEL:
11637 : 9129 : case EXEC_OMP_ERROR:
11638 : 9129 : case EXEC_OMP_MASKED:
11639 : 9129 : case EXEC_OMP_ORDERED:
11640 : 9129 : case EXEC_OMP_PARALLEL_WORKSHARE:
11641 : 9129 : case EXEC_OMP_PARALLEL:
11642 : 9129 : case EXEC_OMP_PARALLEL_MASKED:
11643 : 9129 : case EXEC_OMP_PARALLEL_MASTER:
11644 : 9129 : case EXEC_OMP_PARALLEL_SECTIONS:
11645 : 9129 : case EXEC_OMP_SCOPE:
11646 : 9129 : case EXEC_OMP_SECTIONS:
11647 : 9129 : case EXEC_OMP_SINGLE:
11648 : 9129 : case EXEC_OMP_TARGET_DATA:
11649 : 9129 : case EXEC_OMP_TARGET_ENTER_DATA:
11650 : 9129 : case EXEC_OMP_TARGET_EXIT_DATA:
11651 : 9129 : case EXEC_OMP_TARGET_PARALLEL:
11652 : 9129 : case EXEC_OMP_TARGET_TEAMS:
11653 : 9129 : case EXEC_OMP_TASK:
11654 : 9129 : case EXEC_OMP_TASKWAIT:
11655 : 9129 : case EXEC_OMP_TEAMS:
11656 : 9129 : case EXEC_OMP_WORKSHARE:
11657 : 9129 : case EXEC_OMP_DEPOBJ:
11658 : 9129 : if (code->ext.omp_clauses)
11659 : 8997 : resolve_omp_clauses (code, code->ext.omp_clauses, NULL);
11660 : : break;
11661 : 1708 : case EXEC_OMP_TARGET_UPDATE:
11662 : 1708 : if (code->ext.omp_clauses)
11663 : 1708 : resolve_omp_clauses (code, code->ext.omp_clauses, NULL);
11664 : 1708 : if (code->ext.omp_clauses == NULL
11665 : 1708 : || (code->ext.omp_clauses->lists[OMP_LIST_TO] == NULL
11666 : 992 : && code->ext.omp_clauses->lists[OMP_LIST_FROM] == NULL))
11667 : 0 : gfc_error ("OMP TARGET UPDATE at %L requires at least one TO or "
11668 : : "FROM clause", &code->loc);
11669 : : break;
11670 : 2140 : case EXEC_OMP_ATOMIC:
11671 : 2140 : resolve_omp_clauses (code, code->block->ext.omp_clauses, NULL);
11672 : 2140 : resolve_omp_atomic (code);
11673 : 2140 : break;
11674 : 159 : case EXEC_OMP_CRITICAL:
11675 : 159 : resolve_omp_clauses (code, code->ext.omp_clauses, NULL);
11676 : 159 : if (!code->ext.omp_clauses->critical_name
11677 : 112 : && code->ext.omp_clauses->hint
11678 : 3 : && code->ext.omp_clauses->hint->ts.type == BT_INTEGER
11679 : 3 : && code->ext.omp_clauses->hint->expr_type == EXPR_CONSTANT
11680 : 3 : && mpz_sgn (code->ext.omp_clauses->hint->value.integer) != 0)
11681 : 1 : gfc_error ("OMP CRITICAL at %L with HINT clause requires a NAME, "
11682 : : "except when omp_sync_hint_none is used", &code->loc);
11683 : : break;
11684 : 45 : case EXEC_OMP_SCAN:
11685 : : /* Flag is only used to checking, hence, it is unset afterwards. */
11686 : 45 : if (!code->ext.omp_clauses->if_present)
11687 : 6 : gfc_error ("Unexpected !$OMP SCAN at %L outside loop construct with "
11688 : : "%<inscan%> REDUCTION clause", &code->loc);
11689 : 45 : code->ext.omp_clauses->if_present = false;
11690 : 45 : resolve_omp_clauses (code, code->ext.omp_clauses, ns);
11691 : 45 : break;
11692 : : default:
11693 : : break;
11694 : : }
11695 : 18448 : }
11696 : :
11697 : : /* Resolve !$omp declare simd constructs in NS. */
11698 : :
11699 : : void
11700 : 291560 : gfc_resolve_omp_declare_simd (gfc_namespace *ns)
11701 : : {
11702 : 291560 : gfc_omp_declare_simd *ods;
11703 : :
11704 : 291821 : for (ods = ns->omp_declare_simd; ods; ods = ods->next)
11705 : : {
11706 : 261 : if (ods->proc_name != NULL
11707 : 221 : && ods->proc_name != ns->proc_name)
11708 : 6 : gfc_error ("!$OMP DECLARE SIMD should refer to containing procedure "
11709 : : "%qs at %L", ns->proc_name->name, &ods->where);
11710 : 261 : if (ods->clauses)
11711 : 243 : resolve_omp_clauses (NULL, ods->clauses, ns);
11712 : : }
11713 : 291560 : }
11714 : :
11715 : : struct omp_udr_callback_data
11716 : : {
11717 : : gfc_omp_udr *omp_udr;
11718 : : bool is_initializer;
11719 : : };
11720 : :
11721 : : static int
11722 : 3598 : omp_udr_callback (gfc_expr **e, int *walk_subtrees ATTRIBUTE_UNUSED,
11723 : : void *data)
11724 : : {
11725 : 3598 : struct omp_udr_callback_data *cd = (struct omp_udr_callback_data *) data;
11726 : 3598 : if ((*e)->expr_type == EXPR_VARIABLE)
11727 : : {
11728 : 2203 : if (cd->is_initializer)
11729 : : {
11730 : 535 : if ((*e)->symtree->n.sym != cd->omp_udr->omp_priv
11731 : 140 : && (*e)->symtree->n.sym != cd->omp_udr->omp_orig)
11732 : 4 : gfc_error ("Variable other than OMP_PRIV or OMP_ORIG used in "
11733 : : "INITIALIZER clause of !$OMP DECLARE REDUCTION at %L",
11734 : : &(*e)->where);
11735 : : }
11736 : : else
11737 : : {
11738 : 1668 : if ((*e)->symtree->n.sym != cd->omp_udr->omp_out
11739 : 597 : && (*e)->symtree->n.sym != cd->omp_udr->omp_in)
11740 : 6 : gfc_error ("Variable other than OMP_OUT or OMP_IN used in "
11741 : : "combiner of !$OMP DECLARE REDUCTION at %L",
11742 : : &(*e)->where);
11743 : : }
11744 : : }
11745 : 3598 : return 0;
11746 : : }
11747 : :
11748 : : /* Resolve !$omp declare reduction constructs. */
11749 : :
11750 : : static void
11751 : 600 : gfc_resolve_omp_udr (gfc_omp_udr *omp_udr)
11752 : : {
11753 : 600 : gfc_actual_arglist *a;
11754 : 600 : const char *predef_name = NULL;
11755 : :
11756 : 600 : switch (omp_udr->rop)
11757 : : {
11758 : 599 : case OMP_REDUCTION_PLUS:
11759 : 599 : case OMP_REDUCTION_TIMES:
11760 : 599 : case OMP_REDUCTION_MINUS:
11761 : 599 : case OMP_REDUCTION_AND:
11762 : 599 : case OMP_REDUCTION_OR:
11763 : 599 : case OMP_REDUCTION_EQV:
11764 : 599 : case OMP_REDUCTION_NEQV:
11765 : 599 : case OMP_REDUCTION_MAX:
11766 : 599 : case OMP_REDUCTION_USER:
11767 : 599 : break;
11768 : 1 : default:
11769 : 1 : gfc_error ("Invalid operator for !$OMP DECLARE REDUCTION %s at %L",
11770 : : omp_udr->name, &omp_udr->where);
11771 : 22 : return;
11772 : : }
11773 : :
11774 : 599 : if (gfc_omp_udr_predef (omp_udr->rop, omp_udr->name,
11775 : : &omp_udr->ts, &predef_name))
11776 : : {
11777 : 18 : if (predef_name)
11778 : 18 : gfc_error_now ("Redefinition of predefined %s "
11779 : : "!$OMP DECLARE REDUCTION at %L",
11780 : : predef_name, &omp_udr->where);
11781 : : else
11782 : 0 : gfc_error_now ("Redefinition of predefined "
11783 : : "!$OMP DECLARE REDUCTION at %L", &omp_udr->where);
11784 : 18 : return;
11785 : : }
11786 : :
11787 : 581 : if (omp_udr->ts.type == BT_CHARACTER
11788 : 62 : && omp_udr->ts.u.cl->length
11789 : 32 : && omp_udr->ts.u.cl->length->expr_type != EXPR_CONSTANT)
11790 : : {
11791 : 1 : gfc_error ("CHARACTER length in !$OMP DECLARE REDUCTION %s not "
11792 : : "constant at %L", omp_udr->name, &omp_udr->where);
11793 : 1 : return;
11794 : : }
11795 : :
11796 : 580 : struct omp_udr_callback_data cd;
11797 : 580 : cd.omp_udr = omp_udr;
11798 : 580 : cd.is_initializer = false;
11799 : 580 : gfc_code_walker (&omp_udr->combiner_ns->code, gfc_dummy_code_callback,
11800 : : omp_udr_callback, &cd);
11801 : 580 : if (omp_udr->combiner_ns->code->op == EXEC_CALL)
11802 : : {
11803 : 346 : for (a = omp_udr->combiner_ns->code->ext.actual; a; a = a->next)
11804 : 237 : if (a->expr == NULL)
11805 : : break;
11806 : 110 : if (a)
11807 : 1 : gfc_error ("Subroutine call with alternate returns in combiner "
11808 : : "of !$OMP DECLARE REDUCTION at %L",
11809 : : &omp_udr->combiner_ns->code->loc);
11810 : : }
11811 : 580 : if (omp_udr->initializer_ns)
11812 : : {
11813 : 373 : cd.is_initializer = true;
11814 : 373 : gfc_code_walker (&omp_udr->initializer_ns->code, gfc_dummy_code_callback,
11815 : : omp_udr_callback, &cd);
11816 : 373 : if (omp_udr->initializer_ns->code->op == EXEC_CALL)
11817 : : {
11818 : 377 : for (a = omp_udr->initializer_ns->code->ext.actual; a; a = a->next)
11819 : 243 : if (a->expr == NULL)
11820 : : break;
11821 : 135 : if (a)
11822 : 1 : gfc_error ("Subroutine call with alternate returns in "
11823 : : "INITIALIZER clause of !$OMP DECLARE REDUCTION "
11824 : : "at %L", &omp_udr->initializer_ns->code->loc);
11825 : 136 : for (a = omp_udr->initializer_ns->code->ext.actual; a; a = a->next)
11826 : 135 : if (a->expr
11827 : 135 : && a->expr->expr_type == EXPR_VARIABLE
11828 : 135 : && a->expr->symtree->n.sym == omp_udr->omp_priv
11829 : 134 : && a->expr->ref == NULL)
11830 : : break;
11831 : 135 : if (a == NULL)
11832 : 1 : gfc_error ("One of actual subroutine arguments in INITIALIZER "
11833 : : "clause of !$OMP DECLARE REDUCTION must be OMP_PRIV "
11834 : : "at %L", &omp_udr->initializer_ns->code->loc);
11835 : : }
11836 : : }
11837 : 207 : else if (omp_udr->ts.type == BT_DERIVED
11838 : 207 : && !gfc_has_default_initializer (omp_udr->ts.u.derived))
11839 : : {
11840 : 1 : gfc_error ("Missing INITIALIZER clause for !$OMP DECLARE REDUCTION "
11841 : : "of derived type without default initializer at %L",
11842 : : &omp_udr->where);
11843 : 1 : return;
11844 : : }
11845 : : }
11846 : :
11847 : : void
11848 : 292568 : gfc_resolve_omp_udrs (gfc_symtree *st)
11849 : : {
11850 : 292568 : gfc_omp_udr *omp_udr;
11851 : :
11852 : 292568 : if (st == NULL)
11853 : : return;
11854 : 504 : gfc_resolve_omp_udrs (st->left);
11855 : 504 : gfc_resolve_omp_udrs (st->right);
11856 : 1104 : for (omp_udr = st->n.omp_udr; omp_udr; omp_udr = omp_udr->next)
11857 : 600 : gfc_resolve_omp_udr (omp_udr);
11858 : : }
|
