Branch data Line data Source code
1 : : /* OpenMP directive matching and resolving.
2 : : Copyright (C) 2005-2023 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 "gfortran.h"
25 : : #include "arith.h"
26 : : #include "match.h"
27 : : #include "parse.h"
28 : : #include "constructor.h"
29 : : #include "diagnostic.h"
30 : : #include "gomp-constants.h"
31 : : #include "target-memory.h" /* For gfc_encode_character. */
32 : : #include "bitmap.h"
33 : : #include "omp-api.h" /* For omp_runtime_api_procname. */
34 : :
35 : :
36 : : static gfc_statement omp_code_to_statement (gfc_code *);
37 : :
38 : : enum gfc_omp_directive_kind {
39 : : GFC_OMP_DIR_DECLARATIVE,
40 : : GFC_OMP_DIR_EXECUTABLE,
41 : : GFC_OMP_DIR_INFORMATIONAL,
42 : : GFC_OMP_DIR_META,
43 : : GFC_OMP_DIR_SUBSIDIARY,
44 : : GFC_OMP_DIR_UTILITY
45 : : };
46 : :
47 : : struct gfc_omp_directive {
48 : : const char *name;
49 : : enum gfc_omp_directive_kind kind;
50 : : gfc_statement st;
51 : : };
52 : :
53 : : /* Alphabetically sorted OpenMP clauses, except that longer strings are before
54 : : substrings; excludes combined/composite directives. See note for "ordered"
55 : : and "nothing". */
56 : :
57 : : static const struct gfc_omp_directive gfc_omp_directives[] = {
58 : : {"allocate", GFC_OMP_DIR_DECLARATIVE, ST_OMP_ALLOCATE},
59 : : {"allocators", GFC_OMP_DIR_EXECUTABLE, ST_OMP_ALLOCATORS},
60 : : {"assumes", GFC_OMP_DIR_INFORMATIONAL, ST_OMP_ASSUMES},
61 : : {"assume", GFC_OMP_DIR_INFORMATIONAL, ST_OMP_ASSUME},
62 : : {"atomic", GFC_OMP_DIR_EXECUTABLE, ST_OMP_ATOMIC},
63 : : {"barrier", GFC_OMP_DIR_EXECUTABLE, ST_OMP_BARRIER},
64 : : {"cancellation point", GFC_OMP_DIR_EXECUTABLE, ST_OMP_CANCELLATION_POINT},
65 : : {"cancel", GFC_OMP_DIR_EXECUTABLE, ST_OMP_CANCEL},
66 : : {"critical", GFC_OMP_DIR_EXECUTABLE, ST_OMP_CRITICAL},
67 : : /* {"declare mapper", GFC_OMP_DIR_DECLARATIVE, ST_OMP_DECLARE_MAPPER}, */
68 : : {"declare reduction", GFC_OMP_DIR_DECLARATIVE, ST_OMP_DECLARE_REDUCTION},
69 : : {"declare simd", GFC_OMP_DIR_DECLARATIVE, ST_OMP_DECLARE_SIMD},
70 : : {"declare target", GFC_OMP_DIR_DECLARATIVE, ST_OMP_DECLARE_TARGET},
71 : : {"declare variant", GFC_OMP_DIR_DECLARATIVE, ST_OMP_DECLARE_VARIANT},
72 : : {"depobj", GFC_OMP_DIR_EXECUTABLE, ST_OMP_DEPOBJ},
73 : : /* {"dispatch", GFC_OMP_DIR_EXECUTABLE, ST_OMP_DISPATCH}, */
74 : : {"distribute", GFC_OMP_DIR_EXECUTABLE, ST_OMP_DISTRIBUTE},
75 : : {"do", GFC_OMP_DIR_EXECUTABLE, ST_OMP_DO},
76 : : /* "error" becomes GFC_OMP_DIR_EXECUTABLE with at(execution) */
77 : : {"error", GFC_OMP_DIR_UTILITY, ST_OMP_ERROR},
78 : : {"flush", GFC_OMP_DIR_EXECUTABLE, ST_OMP_FLUSH},
79 : : /* {"interop", GFC_OMP_DIR_EXECUTABLE, ST_OMP_INTEROP}, */
80 : : {"loop", GFC_OMP_DIR_EXECUTABLE, ST_OMP_LOOP},
81 : : {"masked", GFC_OMP_DIR_EXECUTABLE, ST_OMP_MASKED},
82 : : /* {"metadirective", GFC_OMP_DIR_META, ST_OMP_METADIRECTIVE}, */
83 : : /* Note: gfc_match_omp_nothing returns ST_NONE. */
84 : : {"nothing", GFC_OMP_DIR_UTILITY, ST_OMP_NOTHING},
85 : : /* Special case; for now map to the first one.
86 : : ordered-blockassoc = ST_OMP_ORDERED
87 : : ordered-standalone = ST_OMP_ORDERED_DEPEND + depend/doacross. */
88 : : {"ordered", GFC_OMP_DIR_EXECUTABLE, ST_OMP_ORDERED},
89 : : {"parallel", GFC_OMP_DIR_EXECUTABLE, ST_OMP_PARALLEL},
90 : : {"requires", GFC_OMP_DIR_INFORMATIONAL, ST_OMP_REQUIRES},
91 : : {"scan", GFC_OMP_DIR_SUBSIDIARY, ST_OMP_SCAN},
92 : : {"scope", GFC_OMP_DIR_EXECUTABLE, ST_OMP_SCOPE},
93 : : {"sections", GFC_OMP_DIR_EXECUTABLE, ST_OMP_SECTIONS},
94 : : {"section", GFC_OMP_DIR_SUBSIDIARY, ST_OMP_SECTION},
95 : : {"simd", GFC_OMP_DIR_EXECUTABLE, ST_OMP_SIMD},
96 : : {"single", GFC_OMP_DIR_EXECUTABLE, ST_OMP_SINGLE},
97 : : {"target data", GFC_OMP_DIR_EXECUTABLE, ST_OMP_TARGET_DATA},
98 : : {"target enter data", GFC_OMP_DIR_EXECUTABLE, ST_OMP_TARGET_ENTER_DATA},
99 : : {"target exit data", GFC_OMP_DIR_EXECUTABLE, ST_OMP_TARGET_EXIT_DATA},
100 : : {"target update", GFC_OMP_DIR_EXECUTABLE, ST_OMP_TARGET_UPDATE},
101 : : {"target", GFC_OMP_DIR_EXECUTABLE, ST_OMP_TARGET},
102 : : {"taskloop", GFC_OMP_DIR_EXECUTABLE, ST_OMP_TASKLOOP},
103 : : {"taskwait", GFC_OMP_DIR_EXECUTABLE, ST_OMP_TASKWAIT},
104 : : {"taskyield", GFC_OMP_DIR_EXECUTABLE, ST_OMP_TASKYIELD},
105 : : {"task", GFC_OMP_DIR_EXECUTABLE, ST_OMP_TASK},
106 : : {"teams", GFC_OMP_DIR_EXECUTABLE, ST_OMP_TEAMS},
107 : : {"threadprivate", GFC_OMP_DIR_DECLARATIVE, ST_OMP_THREADPRIVATE},
108 : : /* {"tile", GFC_OMP_DIR_EXECUTABLE, ST_OMP_TILE}, */
109 : : /* {"unroll", GFC_OMP_DIR_EXECUTABLE, ST_OMP_UNROLL}, */
110 : : {"workshare", GFC_OMP_DIR_EXECUTABLE, ST_OMP_WORKSHARE},
111 : : };
112 : :
113 : :
114 : : /* Match an end of OpenMP directive. End of OpenMP directive is optional
115 : : whitespace, followed by '\n' or comment '!'. */
116 : :
117 : : static match
118 : 48142 : gfc_match_omp_eos (void)
119 : : {
120 : 48142 : locus old_loc;
121 : 48142 : char c;
122 : :
123 : 48142 : old_loc = gfc_current_locus;
124 : 48142 : gfc_gobble_whitespace ();
125 : :
126 : 48142 : c = gfc_next_ascii_char ();
127 : 48142 : switch (c)
128 : : {
129 : 0 : case '!':
130 : 0 : do
131 : 0 : c = gfc_next_ascii_char ();
132 : 0 : while (c != '\n');
133 : : /* Fall through */
134 : :
135 : : case '\n':
136 : : return MATCH_YES;
137 : : }
138 : :
139 : 1293 : gfc_current_locus = old_loc;
140 : 1293 : return MATCH_NO;
141 : : }
142 : :
143 : : match
144 : 12153 : gfc_match_omp_eos_error (void)
145 : : {
146 : 12153 : if (gfc_match_omp_eos() == MATCH_YES)
147 : : return MATCH_YES;
148 : :
149 : 35 : gfc_error ("Unexpected junk at %C");
150 : 35 : return MATCH_ERROR;
151 : : }
152 : :
153 : :
154 : : /* Free an omp_clauses structure. */
155 : :
156 : : void
157 : 53935 : gfc_free_omp_clauses (gfc_omp_clauses *c)
158 : : {
159 : 53935 : int i;
160 : 53935 : if (c == NULL)
161 : : return;
162 : :
163 : 30299 : gfc_free_expr (c->if_expr);
164 : 30299 : gfc_free_expr (c->final_expr);
165 : 30299 : gfc_free_expr (c->num_threads);
166 : 30299 : gfc_free_expr (c->chunk_size);
167 : 30299 : gfc_free_expr (c->safelen_expr);
168 : 30299 : gfc_free_expr (c->simdlen_expr);
169 : 30299 : gfc_free_expr (c->num_teams_lower);
170 : 30299 : gfc_free_expr (c->num_teams_upper);
171 : 30299 : gfc_free_expr (c->device);
172 : 30299 : gfc_free_expr (c->thread_limit);
173 : 30299 : gfc_free_expr (c->dist_chunk_size);
174 : 30299 : gfc_free_expr (c->grainsize);
175 : 30299 : gfc_free_expr (c->hint);
176 : 30299 : gfc_free_expr (c->num_tasks);
177 : 30299 : gfc_free_expr (c->priority);
178 : 30299 : gfc_free_expr (c->detach);
179 : 363588 : for (i = 0; i < OMP_IF_LAST; i++)
180 : 302990 : gfc_free_expr (c->if_exprs[i]);
181 : 30299 : gfc_free_expr (c->async_expr);
182 : 30299 : gfc_free_expr (c->gang_num_expr);
183 : 30299 : gfc_free_expr (c->gang_static_expr);
184 : 30299 : gfc_free_expr (c->worker_expr);
185 : 30299 : gfc_free_expr (c->vector_expr);
186 : 30299 : gfc_free_expr (c->num_gangs_expr);
187 : 30299 : gfc_free_expr (c->num_workers_expr);
188 : 30299 : gfc_free_expr (c->vector_length_expr);
189 : 1060465 : for (i = 0; i < OMP_LIST_NUM; i++)
190 : 999867 : gfc_free_omp_namelist (c->lists[i],
191 : 999867 : i == OMP_LIST_AFFINITY || i == OMP_LIST_DEPEND,
192 : : i == OMP_LIST_ALLOCATE,
193 : : i == OMP_LIST_USES_ALLOCATORS);
194 : 30299 : gfc_free_expr_list (c->wait_list);
195 : 30299 : gfc_free_expr_list (c->tile_list);
196 : 30299 : free (CONST_CAST (char *, c->critical_name));
197 : 30299 : if (c->assume)
198 : : {
199 : 18 : free (c->assume->absent);
200 : 18 : free (c->assume->contains);
201 : 18 : gfc_free_expr_list (c->assume->holds);
202 : 18 : free (c->assume);
203 : : }
204 : 30299 : free (c);
205 : : }
206 : :
207 : : /* Free oacc_declare structures. */
208 : :
209 : : void
210 : 71 : gfc_free_oacc_declare_clauses (struct gfc_oacc_declare *oc)
211 : : {
212 : 71 : struct gfc_oacc_declare *decl = oc;
213 : :
214 : 71 : do
215 : : {
216 : 71 : struct gfc_oacc_declare *next;
217 : :
218 : 71 : next = decl->next;
219 : 71 : gfc_free_omp_clauses (decl->clauses);
220 : 71 : free (decl);
221 : 71 : decl = next;
222 : : }
223 : 71 : while (decl);
224 : 71 : }
225 : :
226 : : /* Free expression list. */
227 : : void
228 : 60656 : gfc_free_expr_list (gfc_expr_list *list)
229 : : {
230 : 60656 : gfc_expr_list *n;
231 : :
232 : 61301 : for (; list; list = n)
233 : : {
234 : 645 : n = list->next;
235 : 645 : free (list);
236 : : }
237 : 60656 : }
238 : :
239 : : /* Free an !$omp declare simd construct list. */
240 : :
241 : : void
242 : 219 : gfc_free_omp_declare_simd (gfc_omp_declare_simd *ods)
243 : : {
244 : 219 : if (ods)
245 : : {
246 : 219 : gfc_free_omp_clauses (ods->clauses);
247 : 219 : free (ods);
248 : : }
249 : 219 : }
250 : :
251 : : void
252 : 414316 : gfc_free_omp_declare_simd_list (gfc_omp_declare_simd *list)
253 : : {
254 : 414535 : while (list)
255 : : {
256 : 219 : gfc_omp_declare_simd *current = list;
257 : 219 : list = list->next;
258 : 219 : gfc_free_omp_declare_simd (current);
259 : : }
260 : 414316 : }
261 : :
262 : : static void
263 : 410 : gfc_free_omp_trait_property_list (gfc_omp_trait_property *list)
264 : : {
265 : 670 : while (list)
266 : : {
267 : 260 : gfc_omp_trait_property *current = list;
268 : 260 : list = list->next;
269 : 260 : switch (current->property_kind)
270 : : {
271 : 23 : case CTX_PROPERTY_ID:
272 : 23 : free (current->name);
273 : 23 : break;
274 : 185 : case CTX_PROPERTY_NAME_LIST:
275 : 185 : if (current->is_name)
276 : 138 : free (current->name);
277 : : break;
278 : 15 : case CTX_PROPERTY_SIMD:
279 : 15 : gfc_free_omp_clauses (current->clauses);
280 : 15 : break;
281 : : default:
282 : : break;
283 : : }
284 : 260 : free (current);
285 : : }
286 : 410 : }
287 : :
288 : : static void
289 : 320 : gfc_free_omp_selector_list (gfc_omp_selector *list)
290 : : {
291 : 730 : while (list)
292 : : {
293 : 410 : gfc_omp_selector *current = list;
294 : 410 : list = list->next;
295 : 410 : gfc_free_omp_trait_property_list (current->properties);
296 : 410 : free (current);
297 : : }
298 : 320 : }
299 : :
300 : : static void
301 : 288 : gfc_free_omp_set_selector_list (gfc_omp_set_selector *list)
302 : : {
303 : 608 : while (list)
304 : : {
305 : 320 : gfc_omp_set_selector *current = list;
306 : 320 : list = list->next;
307 : 320 : gfc_free_omp_selector_list (current->trait_selectors);
308 : 320 : free (current);
309 : : }
310 : 288 : }
311 : :
312 : : /* Free an !$omp declare variant construct list. */
313 : :
314 : : void
315 : 414316 : gfc_free_omp_declare_variant_list (gfc_omp_declare_variant *list)
316 : : {
317 : 414604 : while (list)
318 : : {
319 : 288 : gfc_omp_declare_variant *current = list;
320 : 288 : list = list->next;
321 : 288 : gfc_free_omp_set_selector_list (current->set_selectors);
322 : 288 : free (current);
323 : : }
324 : 414316 : }
325 : :
326 : : /* Free an !$omp declare reduction. */
327 : :
328 : : void
329 : 1118 : gfc_free_omp_udr (gfc_omp_udr *omp_udr)
330 : : {
331 : 1118 : if (omp_udr)
332 : : {
333 : 607 : gfc_free_omp_udr (omp_udr->next);
334 : 607 : gfc_free_namespace (omp_udr->combiner_ns);
335 : 607 : if (omp_udr->initializer_ns)
336 : 377 : gfc_free_namespace (omp_udr->initializer_ns);
337 : 607 : free (omp_udr);
338 : : }
339 : 1118 : }
340 : :
341 : :
342 : : static gfc_omp_udr *
343 : 4338 : gfc_find_omp_udr (gfc_namespace *ns, const char *name, gfc_typespec *ts)
344 : : {
345 : 4338 : gfc_symtree *st;
346 : :
347 : 4338 : if (ns == NULL)
348 : 467 : ns = gfc_current_ns;
349 : 5188 : do
350 : : {
351 : 5188 : gfc_omp_udr *omp_udr;
352 : :
353 : 5188 : st = gfc_find_symtree (ns->omp_udr_root, name);
354 : 5188 : if (st != NULL)
355 : : {
356 : 934 : for (omp_udr = st->n.omp_udr; omp_udr; omp_udr = omp_udr->next)
357 : 934 : if (ts == NULL)
358 : 367 : return omp_udr;
359 : 567 : else if (gfc_compare_types (&omp_udr->ts, ts))
360 : : {
361 : 479 : if (ts->type == BT_CHARACTER)
362 : : {
363 : 60 : if (omp_udr->ts.u.cl->length == NULL)
364 : 24 : return omp_udr;
365 : 36 : if (ts->u.cl->length == NULL)
366 : 0 : continue;
367 : 36 : if (gfc_compare_expr (omp_udr->ts.u.cl->length,
368 : : ts->u.cl->length,
369 : : INTRINSIC_EQ) != 0)
370 : 12 : continue;
371 : : }
372 : 443 : return omp_udr;
373 : : }
374 : : }
375 : :
376 : : /* Don't escape an interface block. */
377 : 4354 : if (ns && !ns->has_import_set
378 : 4354 : && ns->proc_name && ns->proc_name->attr.if_source == IFSRC_IFBODY)
379 : : break;
380 : :
381 : 4354 : ns = ns->parent;
382 : : }
383 : 4354 : while (ns != NULL);
384 : :
385 : : return NULL;
386 : : }
387 : :
388 : :
389 : : /* Match a variable/common block list and construct a namelist from it;
390 : : if has_all_memory != NULL, *has_all_memory is set and omp_all_memory
391 : : yields a list->sym NULL entry. */
392 : :
393 : : static match
394 : 27679 : gfc_match_omp_variable_list (const char *str, gfc_omp_namelist **list,
395 : : bool allow_common, bool *end_colon = NULL,
396 : : gfc_omp_namelist ***headp = NULL,
397 : : bool allow_sections = false,
398 : : bool allow_derived = false,
399 : : bool *has_all_memory = NULL,
400 : : bool reject_common_vars = false)
401 : : {
402 : 27679 : gfc_omp_namelist *head, *tail, *p;
403 : 27679 : locus old_loc, cur_loc;
404 : 27679 : char n[GFC_MAX_SYMBOL_LEN+1];
405 : 27679 : gfc_symbol *sym;
406 : 27679 : match m;
407 : 27679 : gfc_symtree *st;
408 : :
409 : 27679 : head = tail = NULL;
410 : :
411 : 27679 : old_loc = gfc_current_locus;
412 : 27679 : if (has_all_memory)
413 : 683 : *has_all_memory = false;
414 : 27679 : m = gfc_match (str);
415 : 27679 : if (m != MATCH_YES)
416 : : return m;
417 : :
418 : 33263 : for (;;)
419 : : {
420 : 33263 : cur_loc = gfc_current_locus;
421 : :
422 : 33263 : m = gfc_match_name (n);
423 : 33263 : if (m == MATCH_YES && strcmp (n, "omp_all_memory") == 0)
424 : : {
425 : 23 : if (!has_all_memory)
426 : : {
427 : 2 : gfc_error ("%<omp_all_memory%> at %C not permitted in this "
428 : : "clause");
429 : 2 : goto cleanup;
430 : : }
431 : 21 : *has_all_memory = true;
432 : 21 : p = gfc_get_omp_namelist ();
433 : 21 : if (head == NULL)
434 : : head = tail = p;
435 : : else
436 : : {
437 : 3 : tail->next = p;
438 : 3 : tail = tail->next;
439 : : }
440 : 21 : tail->where = cur_loc;
441 : 21 : goto next_item;
442 : : }
443 : 33059 : if (m == MATCH_YES)
444 : : {
445 : 33059 : gfc_symtree *st;
446 : 33059 : if ((m = gfc_get_ha_sym_tree (n, &st) ? MATCH_ERROR : MATCH_YES)
447 : : == MATCH_YES)
448 : 33059 : sym = st->n.sym;
449 : : }
450 : 33240 : switch (m)
451 : : {
452 : 33059 : case MATCH_YES:
453 : 33059 : gfc_expr *expr;
454 : 33059 : expr = NULL;
455 : 33059 : gfc_gobble_whitespace ();
456 : 19600 : if ((allow_sections && gfc_peek_ascii_char () == '(')
457 : 49476 : || (allow_derived && gfc_peek_ascii_char () == '%'))
458 : : {
459 : 4304 : gfc_current_locus = cur_loc;
460 : 4304 : m = gfc_match_variable (&expr, 0);
461 : 4304 : switch (m)
462 : : {
463 : 4 : case MATCH_ERROR:
464 : 11 : goto cleanup;
465 : 0 : case MATCH_NO:
466 : 0 : goto syntax;
467 : 4300 : default:
468 : 4300 : break;
469 : : }
470 : 4300 : if (gfc_is_coindexed (expr))
471 : : {
472 : 5 : gfc_error ("List item shall not be coindexed at %C");
473 : 5 : goto cleanup;
474 : : }
475 : : }
476 : 33050 : gfc_set_sym_referenced (sym);
477 : 33050 : p = gfc_get_omp_namelist ();
478 : 33050 : if (head == NULL)
479 : : head = tail = p;
480 : : else
481 : : {
482 : 8975 : tail->next = p;
483 : 8975 : tail = tail->next;
484 : : }
485 : 33050 : tail->sym = sym;
486 : 33050 : tail->expr = expr;
487 : 33050 : tail->where = cur_loc;
488 : 33050 : if (reject_common_vars && sym->attr.in_common)
489 : : {
490 : 2 : gcc_assert (allow_common);
491 : 2 : gfc_error ("%qs at %L is part of the common block %</%s/%> and "
492 : : "may only be specificed implicitly via the named "
493 : : "common block", sym->name, &cur_loc,
494 : 2 : sym->common_head->name);
495 : 2 : goto cleanup;
496 : : }
497 : 33048 : goto next_item;
498 : 181 : case MATCH_NO:
499 : 181 : break;
500 : 0 : case MATCH_ERROR:
501 : 0 : goto cleanup;
502 : : }
503 : :
504 : 181 : if (!allow_common)
505 : 8 : goto syntax;
506 : :
507 : 173 : m = gfc_match (" / %n /", n);
508 : 173 : if (m == MATCH_ERROR)
509 : 0 : goto cleanup;
510 : 173 : if (m == MATCH_NO)
511 : 13 : goto syntax;
512 : :
513 : 160 : st = gfc_find_symtree (gfc_current_ns->common_root, n);
514 : 160 : if (st == NULL)
515 : : {
516 : 2 : gfc_error ("COMMON block /%s/ not found at %C", n);
517 : 2 : goto cleanup;
518 : : }
519 : 569 : for (sym = st->n.common->head; sym; sym = sym->common_next)
520 : : {
521 : 411 : gfc_set_sym_referenced (sym);
522 : 411 : p = gfc_get_omp_namelist ();
523 : 411 : if (head == NULL)
524 : : head = tail = p;
525 : : else
526 : : {
527 : 294 : tail->next = p;
528 : 294 : tail = tail->next;
529 : : }
530 : 411 : tail->sym = sym;
531 : 411 : tail->where = cur_loc;
532 : : }
533 : :
534 : 158 : next_item:
535 : 33227 : if (end_colon && gfc_match_char (':') == MATCH_YES)
536 : : {
537 : 790 : *end_colon = true;
538 : 790 : break;
539 : : }
540 : 32437 : if (gfc_match_char (')') == MATCH_YES)
541 : : break;
542 : 9032 : if (gfc_match_char (',') != MATCH_YES)
543 : 13 : goto syntax;
544 : : }
545 : :
546 : 30184 : while (*list)
547 : 5989 : list = &(*list)->next;
548 : :
549 : 24195 : *list = head;
550 : 24195 : if (headp)
551 : 19013 : *headp = list;
552 : : return MATCH_YES;
553 : :
554 : 34 : syntax:
555 : 34 : gfc_error ("Syntax error in OpenMP variable list at %C");
556 : :
557 : 49 : cleanup:
558 : 49 : gfc_free_omp_namelist (head, false, false, false);
559 : 49 : gfc_current_locus = old_loc;
560 : 49 : return MATCH_ERROR;
561 : : }
562 : :
563 : : /* Match a variable/procedure/common block list and construct a namelist
564 : : from it. */
565 : :
566 : : static match
567 : 243 : gfc_match_omp_to_link (const char *str, gfc_omp_namelist **list)
568 : : {
569 : 243 : gfc_omp_namelist *head, *tail, *p;
570 : 243 : locus old_loc, cur_loc;
571 : 243 : char n[GFC_MAX_SYMBOL_LEN+1];
572 : 243 : gfc_symbol *sym;
573 : 243 : match m;
574 : 243 : gfc_symtree *st;
575 : :
576 : 243 : head = tail = NULL;
577 : :
578 : 243 : old_loc = gfc_current_locus;
579 : :
580 : 243 : m = gfc_match (str);
581 : 243 : if (m != MATCH_YES)
582 : : return m;
583 : :
584 : 427 : for (;;)
585 : : {
586 : 427 : cur_loc = gfc_current_locus;
587 : 427 : m = gfc_match_symbol (&sym, 1);
588 : 427 : switch (m)
589 : : {
590 : 402 : case MATCH_YES:
591 : 402 : p = gfc_get_omp_namelist ();
592 : 402 : if (head == NULL)
593 : : head = tail = p;
594 : : else
595 : : {
596 : 181 : tail->next = p;
597 : 181 : tail = tail->next;
598 : : }
599 : 402 : tail->sym = sym;
600 : 402 : tail->where = cur_loc;
601 : 402 : goto next_item;
602 : : case MATCH_NO:
603 : : break;
604 : 0 : case MATCH_ERROR:
605 : 0 : goto cleanup;
606 : : }
607 : :
608 : 25 : m = gfc_match (" / %n /", n);
609 : 25 : if (m == MATCH_ERROR)
610 : 0 : goto cleanup;
611 : 25 : if (m == MATCH_NO)
612 : 0 : goto syntax;
613 : :
614 : 25 : st = gfc_find_symtree (gfc_current_ns->common_root, n);
615 : 25 : if (st == NULL)
616 : : {
617 : 0 : gfc_error ("COMMON block /%s/ not found at %C", n);
618 : 0 : goto cleanup;
619 : : }
620 : 25 : p = gfc_get_omp_namelist ();
621 : 25 : if (head == NULL)
622 : : head = tail = p;
623 : : else
624 : : {
625 : 3 : tail->next = p;
626 : 3 : tail = tail->next;
627 : : }
628 : 25 : tail->u.common = st->n.common;
629 : 25 : tail->where = cur_loc;
630 : :
631 : 427 : next_item:
632 : 427 : if (gfc_match_char (')') == MATCH_YES)
633 : : break;
634 : 184 : if (gfc_match_char (',') != MATCH_YES)
635 : 0 : goto syntax;
636 : : }
637 : :
638 : 254 : while (*list)
639 : 11 : list = &(*list)->next;
640 : :
641 : 243 : *list = head;
642 : 243 : return MATCH_YES;
643 : :
644 : 0 : syntax:
645 : 0 : gfc_error ("Syntax error in OpenMP variable list at %C");
646 : :
647 : 0 : cleanup:
648 : 0 : gfc_free_omp_namelist (head, false, false, false);
649 : 0 : gfc_current_locus = old_loc;
650 : 0 : return MATCH_ERROR;
651 : : }
652 : :
653 : : /* Match detach(event-handle). */
654 : :
655 : : static match
656 : 126 : gfc_match_omp_detach (gfc_expr **expr)
657 : : {
658 : 126 : locus old_loc = gfc_current_locus;
659 : :
660 : 126 : if (gfc_match ("detach ( ") != MATCH_YES)
661 : 0 : goto syntax_error;
662 : :
663 : 126 : if (gfc_match_variable (expr, 0) != MATCH_YES)
664 : 0 : goto syntax_error;
665 : :
666 : 126 : if (gfc_match_char (')') != MATCH_YES)
667 : 0 : goto syntax_error;
668 : :
669 : : return MATCH_YES;
670 : :
671 : 0 : syntax_error:
672 : 0 : gfc_error ("Syntax error in OpenMP detach clause at %C");
673 : 0 : gfc_current_locus = old_loc;
674 : 0 : return MATCH_ERROR;
675 : :
676 : : }
677 : :
678 : : /* Match doacross(sink : ...) construct a namelist from it;
679 : : if depend is true, match legacy 'depend(sink : ...)'. */
680 : :
681 : : static match
682 : 240 : gfc_match_omp_doacross_sink (gfc_omp_namelist **list, bool depend)
683 : : {
684 : 240 : char n[GFC_MAX_SYMBOL_LEN+1];
685 : 240 : gfc_omp_namelist *head, *tail, *p;
686 : 240 : locus old_loc, cur_loc;
687 : 240 : gfc_symbol *sym;
688 : :
689 : 240 : head = tail = NULL;
690 : :
691 : 240 : old_loc = gfc_current_locus;
692 : :
693 : 1235 : for (;;)
694 : : {
695 : 1235 : cur_loc = gfc_current_locus;
696 : :
697 : 1235 : if (gfc_match_name (n) != MATCH_YES)
698 : 1 : goto syntax;
699 : 1234 : if (UNLIKELY (strcmp (n, "omp_all_memory") == 0))
700 : : {
701 : 1 : gfc_error ("%<omp_all_memory%> used with dependence-type "
702 : : "other than OUT or INOUT at %C");
703 : 1 : goto cleanup;
704 : : }
705 : 1233 : sym = NULL;
706 : 1233 : if (!(strcmp (n, "omp_cur_iteration") == 0))
707 : : {
708 : 1228 : gfc_symtree *st;
709 : 1228 : if (gfc_get_ha_sym_tree (n, &st))
710 : 0 : goto syntax;
711 : 1228 : sym = st->n.sym;
712 : 1228 : gfc_set_sym_referenced (sym);
713 : : }
714 : 1233 : p = gfc_get_omp_namelist ();
715 : 1233 : if (head == NULL)
716 : : {
717 : 238 : head = tail = p;
718 : 252 : head->u.depend_doacross_op = (depend ? OMP_DEPEND_SINK_FIRST
719 : : : OMP_DOACROSS_SINK_FIRST);
720 : : }
721 : : else
722 : : {
723 : 995 : tail->next = p;
724 : 995 : tail = tail->next;
725 : 995 : tail->u.depend_doacross_op = OMP_DOACROSS_SINK;
726 : : }
727 : 1233 : tail->sym = sym;
728 : 1233 : tail->expr = NULL;
729 : 1233 : tail->where = cur_loc;
730 : 1233 : if (gfc_match_char ('+') == MATCH_YES)
731 : : {
732 : 154 : if (gfc_match_literal_constant (&tail->expr, 0) != MATCH_YES)
733 : 0 : goto syntax;
734 : : }
735 : 1079 : else if (gfc_match_char ('-') == MATCH_YES)
736 : : {
737 : 418 : if (gfc_match_literal_constant (&tail->expr, 0) != MATCH_YES)
738 : 1 : goto syntax;
739 : 417 : tail->expr = gfc_uminus (tail->expr);
740 : : }
741 : 1232 : if (gfc_match_char (')') == MATCH_YES)
742 : : break;
743 : 995 : if (gfc_match_char (',') != MATCH_YES)
744 : 0 : goto syntax;
745 : : }
746 : :
747 : 1029 : while (*list)
748 : 792 : list = &(*list)->next;
749 : :
750 : 237 : *list = head;
751 : 237 : return MATCH_YES;
752 : :
753 : 2 : syntax:
754 : 2 : gfc_error ("Syntax error in OpenMP SINK dependence-type list at %C");
755 : :
756 : 3 : cleanup:
757 : 3 : gfc_free_omp_namelist (head, false, false, false);
758 : 3 : gfc_current_locus = old_loc;
759 : 3 : return MATCH_ERROR;
760 : : }
761 : :
762 : : static match
763 : 574 : match_oacc_expr_list (const char *str, gfc_expr_list **list,
764 : : bool allow_asterisk)
765 : : {
766 : 574 : gfc_expr_list *head, *tail, *p;
767 : 574 : locus old_loc;
768 : 574 : gfc_expr *expr;
769 : 574 : match m;
770 : :
771 : 574 : head = tail = NULL;
772 : :
773 : 574 : old_loc = gfc_current_locus;
774 : :
775 : 574 : m = gfc_match (str);
776 : 574 : if (m != MATCH_YES)
777 : : return m;
778 : :
779 : 595 : for (;;)
780 : : {
781 : 595 : m = gfc_match_expr (&expr);
782 : 595 : if (m == MATCH_YES || allow_asterisk)
783 : : {
784 : 589 : p = gfc_get_expr_list ();
785 : 589 : if (head == NULL)
786 : : head = tail = p;
787 : : else
788 : : {
789 : 144 : tail->next = p;
790 : 144 : tail = tail->next;
791 : : }
792 : 589 : if (m == MATCH_YES)
793 : 473 : tail->expr = expr;
794 : 116 : else if (gfc_match (" *") != MATCH_YES)
795 : 16 : goto syntax;
796 : 573 : goto next_item;
797 : : }
798 : 6 : if (m == MATCH_ERROR)
799 : 0 : goto cleanup;
800 : 6 : goto syntax;
801 : :
802 : 573 : next_item:
803 : 573 : if (gfc_match_char (')') == MATCH_YES)
804 : : break;
805 : 152 : if (gfc_match_char (',') != MATCH_YES)
806 : 5 : goto syntax;
807 : : }
808 : :
809 : 427 : while (*list)
810 : 6 : list = &(*list)->next;
811 : :
812 : 421 : *list = head;
813 : 421 : return MATCH_YES;
814 : :
815 : 27 : syntax:
816 : 27 : gfc_error ("Syntax error in OpenACC expression list at %C");
817 : :
818 : 27 : cleanup:
819 : 27 : gfc_free_expr_list (head);
820 : 27 : gfc_current_locus = old_loc;
821 : 27 : return MATCH_ERROR;
822 : : }
823 : :
824 : : static match
825 : 2877 : match_oacc_clause_gwv (gfc_omp_clauses *cp, unsigned gwv)
826 : : {
827 : 2877 : match ret = MATCH_YES;
828 : :
829 : 2877 : if (gfc_match (" ( ") != MATCH_YES)
830 : : return MATCH_NO;
831 : :
832 : 449 : if (gwv == GOMP_DIM_GANG)
833 : : {
834 : : /* The gang clause accepts two optional arguments, num and static.
835 : : The num argument may either be explicit (num: <val>) or
836 : : implicit without (<val> without num:). */
837 : :
838 : 431 : while (ret == MATCH_YES)
839 : : {
840 : 223 : if (gfc_match (" static :") == MATCH_YES)
841 : : {
842 : 105 : if (cp->gang_static)
843 : : return MATCH_ERROR;
844 : : else
845 : 104 : cp->gang_static = true;
846 : 104 : if (gfc_match_char ('*') == MATCH_YES)
847 : 15 : cp->gang_static_expr = NULL;
848 : 89 : else if (gfc_match (" %e ", &cp->gang_static_expr) != MATCH_YES)
849 : : return MATCH_ERROR;
850 : : }
851 : : else
852 : : {
853 : 118 : if (cp->gang_num_expr)
854 : : return MATCH_ERROR;
855 : :
856 : : /* The 'num' argument is optional. */
857 : 117 : gfc_match (" num :");
858 : :
859 : 117 : if (gfc_match (" %e ", &cp->gang_num_expr) != MATCH_YES)
860 : : return MATCH_ERROR;
861 : : }
862 : :
863 : 218 : ret = gfc_match (" , ");
864 : : }
865 : : }
866 : 236 : else if (gwv == GOMP_DIM_WORKER)
867 : : {
868 : : /* The 'num' argument is optional. */
869 : 103 : gfc_match (" num :");
870 : :
871 : 103 : if (gfc_match (" %e ", &cp->worker_expr) != MATCH_YES)
872 : : return MATCH_ERROR;
873 : : }
874 : 133 : else if (gwv == GOMP_DIM_VECTOR)
875 : : {
876 : : /* The 'length' argument is optional. */
877 : 133 : gfc_match (" length :");
878 : :
879 : 133 : if (gfc_match (" %e ", &cp->vector_expr) != MATCH_YES)
880 : : return MATCH_ERROR;
881 : : }
882 : : else
883 : 0 : gfc_fatal_error ("Unexpected OpenACC parallelism.");
884 : :
885 : 438 : return gfc_match (" )");
886 : : }
887 : :
888 : : static match
889 : 8 : gfc_match_oacc_clause_link (const char *str, gfc_omp_namelist **list)
890 : : {
891 : 8 : gfc_omp_namelist *head = NULL;
892 : 8 : gfc_omp_namelist *tail, *p;
893 : 8 : locus old_loc;
894 : 8 : char n[GFC_MAX_SYMBOL_LEN+1];
895 : 8 : gfc_symbol *sym;
896 : 8 : match m;
897 : 8 : gfc_symtree *st;
898 : :
899 : 8 : old_loc = gfc_current_locus;
900 : :
901 : 8 : m = gfc_match (str);
902 : 8 : if (m != MATCH_YES)
903 : : return m;
904 : :
905 : 8 : m = gfc_match (" (");
906 : :
907 : 14 : for (;;)
908 : : {
909 : 14 : m = gfc_match_symbol (&sym, 0);
910 : 14 : switch (m)
911 : : {
912 : 8 : case MATCH_YES:
913 : 8 : if (sym->attr.in_common)
914 : : {
915 : 2 : gfc_error_now ("Variable at %C is an element of a COMMON block");
916 : 2 : goto cleanup;
917 : : }
918 : 6 : gfc_set_sym_referenced (sym);
919 : 6 : p = gfc_get_omp_namelist ();
920 : 6 : if (head == NULL)
921 : : head = tail = p;
922 : : else
923 : : {
924 : 4 : tail->next = p;
925 : 4 : tail = tail->next;
926 : : }
927 : 6 : tail->sym = sym;
928 : 6 : tail->expr = NULL;
929 : 6 : tail->where = gfc_current_locus;
930 : 6 : goto next_item;
931 : : case MATCH_NO:
932 : : break;
933 : :
934 : 0 : case MATCH_ERROR:
935 : 0 : goto cleanup;
936 : : }
937 : :
938 : 6 : m = gfc_match (" / %n /", n);
939 : 6 : if (m == MATCH_ERROR)
940 : 0 : goto cleanup;
941 : 6 : if (m == MATCH_NO || n[0] == '\0')
942 : 0 : goto syntax;
943 : :
944 : 6 : st = gfc_find_symtree (gfc_current_ns->common_root, n);
945 : 6 : if (st == NULL)
946 : : {
947 : 1 : gfc_error ("COMMON block /%s/ not found at %C", n);
948 : 1 : goto cleanup;
949 : : }
950 : :
951 : 20 : for (sym = st->n.common->head; sym; sym = sym->common_next)
952 : : {
953 : 15 : gfc_set_sym_referenced (sym);
954 : 15 : p = gfc_get_omp_namelist ();
955 : 15 : if (head == NULL)
956 : : head = tail = p;
957 : : else
958 : : {
959 : 12 : tail->next = p;
960 : 12 : tail = tail->next;
961 : : }
962 : 15 : tail->sym = sym;
963 : 15 : tail->where = gfc_current_locus;
964 : : }
965 : :
966 : 5 : next_item:
967 : 11 : if (gfc_match_char (')') == MATCH_YES)
968 : : break;
969 : 6 : if (gfc_match_char (',') != MATCH_YES)
970 : 0 : goto syntax;
971 : : }
972 : :
973 : 5 : if (gfc_match_omp_eos () != MATCH_YES)
974 : : {
975 : 1 : gfc_error ("Unexpected junk after !$ACC DECLARE at %C");
976 : 1 : goto cleanup;
977 : : }
978 : :
979 : 4 : while (*list)
980 : 0 : list = &(*list)->next;
981 : 4 : *list = head;
982 : 4 : return MATCH_YES;
983 : :
984 : 0 : syntax:
985 : 0 : gfc_error ("Syntax error in !$ACC DECLARE list at %C");
986 : :
987 : 4 : cleanup:
988 : 4 : gfc_current_locus = old_loc;
989 : 4 : return MATCH_ERROR;
990 : : }
991 : :
992 : : /* OpenMP clauses. */
993 : : enum omp_mask1
994 : : {
995 : : OMP_CLAUSE_PRIVATE,
996 : : OMP_CLAUSE_FIRSTPRIVATE,
997 : : OMP_CLAUSE_LASTPRIVATE,
998 : : OMP_CLAUSE_COPYPRIVATE,
999 : : OMP_CLAUSE_SHARED,
1000 : : OMP_CLAUSE_COPYIN,
1001 : : OMP_CLAUSE_REDUCTION,
1002 : : OMP_CLAUSE_IN_REDUCTION,
1003 : : OMP_CLAUSE_TASK_REDUCTION,
1004 : : OMP_CLAUSE_IF,
1005 : : OMP_CLAUSE_NUM_THREADS,
1006 : : OMP_CLAUSE_SCHEDULE,
1007 : : OMP_CLAUSE_DEFAULT,
1008 : : OMP_CLAUSE_ORDER,
1009 : : OMP_CLAUSE_ORDERED,
1010 : : OMP_CLAUSE_COLLAPSE,
1011 : : OMP_CLAUSE_UNTIED,
1012 : : OMP_CLAUSE_FINAL,
1013 : : OMP_CLAUSE_MERGEABLE,
1014 : : OMP_CLAUSE_ALIGNED,
1015 : : OMP_CLAUSE_DEPEND,
1016 : : OMP_CLAUSE_INBRANCH,
1017 : : OMP_CLAUSE_LINEAR,
1018 : : OMP_CLAUSE_NOTINBRANCH,
1019 : : OMP_CLAUSE_PROC_BIND,
1020 : : OMP_CLAUSE_SAFELEN,
1021 : : OMP_CLAUSE_SIMDLEN,
1022 : : OMP_CLAUSE_UNIFORM,
1023 : : OMP_CLAUSE_DEVICE,
1024 : : OMP_CLAUSE_MAP,
1025 : : OMP_CLAUSE_TO,
1026 : : OMP_CLAUSE_FROM,
1027 : : OMP_CLAUSE_NUM_TEAMS,
1028 : : OMP_CLAUSE_THREAD_LIMIT,
1029 : : OMP_CLAUSE_DIST_SCHEDULE,
1030 : : OMP_CLAUSE_DEFAULTMAP,
1031 : : OMP_CLAUSE_GRAINSIZE,
1032 : : OMP_CLAUSE_HINT,
1033 : : OMP_CLAUSE_IS_DEVICE_PTR,
1034 : : OMP_CLAUSE_LINK,
1035 : : OMP_CLAUSE_NOGROUP,
1036 : : OMP_CLAUSE_NOTEMPORAL,
1037 : : OMP_CLAUSE_NUM_TASKS,
1038 : : OMP_CLAUSE_PRIORITY,
1039 : : OMP_CLAUSE_SIMD,
1040 : : OMP_CLAUSE_THREADS,
1041 : : OMP_CLAUSE_USE_DEVICE_PTR,
1042 : : OMP_CLAUSE_USE_DEVICE_ADDR, /* OpenMP 5.0. */
1043 : : OMP_CLAUSE_DEVICE_TYPE, /* OpenMP 5.0. */
1044 : : OMP_CLAUSE_ATOMIC, /* OpenMP 5.0. */
1045 : : OMP_CLAUSE_CAPTURE, /* OpenMP 5.0. */
1046 : : OMP_CLAUSE_MEMORDER, /* OpenMP 5.0. */
1047 : : OMP_CLAUSE_DETACH, /* OpenMP 5.0. */
1048 : : OMP_CLAUSE_AFFINITY, /* OpenMP 5.0. */
1049 : : OMP_CLAUSE_ALLOCATE, /* OpenMP 5.0. */
1050 : : OMP_CLAUSE_BIND, /* OpenMP 5.0. */
1051 : : OMP_CLAUSE_FILTER, /* OpenMP 5.1. */
1052 : : OMP_CLAUSE_AT, /* OpenMP 5.1. */
1053 : : OMP_CLAUSE_MESSAGE, /* OpenMP 5.1. */
1054 : : OMP_CLAUSE_SEVERITY, /* OpenMP 5.1. */
1055 : : OMP_CLAUSE_COMPARE, /* OpenMP 5.1. */
1056 : : OMP_CLAUSE_FAIL, /* OpenMP 5.1. */
1057 : : OMP_CLAUSE_WEAK, /* OpenMP 5.1. */
1058 : : OMP_CLAUSE_NOWAIT,
1059 : : /* This must come last. */
1060 : : OMP_MASK1_LAST
1061 : : };
1062 : :
1063 : : /* More OpenMP clauses and OpenACC 2.0+ specific clauses. */
1064 : : enum omp_mask2
1065 : : {
1066 : : OMP_CLAUSE_ASYNC,
1067 : : OMP_CLAUSE_NUM_GANGS,
1068 : : OMP_CLAUSE_NUM_WORKERS,
1069 : : OMP_CLAUSE_VECTOR_LENGTH,
1070 : : OMP_CLAUSE_COPY,
1071 : : OMP_CLAUSE_COPYOUT,
1072 : : OMP_CLAUSE_CREATE,
1073 : : OMP_CLAUSE_NO_CREATE,
1074 : : OMP_CLAUSE_PRESENT,
1075 : : OMP_CLAUSE_DEVICEPTR,
1076 : : OMP_CLAUSE_GANG,
1077 : : OMP_CLAUSE_WORKER,
1078 : : OMP_CLAUSE_VECTOR,
1079 : : OMP_CLAUSE_SEQ,
1080 : : OMP_CLAUSE_INDEPENDENT,
1081 : : OMP_CLAUSE_USE_DEVICE,
1082 : : OMP_CLAUSE_DEVICE_RESIDENT,
1083 : : OMP_CLAUSE_HOST_SELF,
1084 : : OMP_CLAUSE_WAIT,
1085 : : OMP_CLAUSE_DELETE,
1086 : : OMP_CLAUSE_AUTO,
1087 : : OMP_CLAUSE_TILE,
1088 : : OMP_CLAUSE_IF_PRESENT,
1089 : : OMP_CLAUSE_FINALIZE,
1090 : : OMP_CLAUSE_ATTACH,
1091 : : OMP_CLAUSE_NOHOST,
1092 : : OMP_CLAUSE_HAS_DEVICE_ADDR, /* OpenMP 5.1 */
1093 : : OMP_CLAUSE_ENTER, /* OpenMP 5.2 */
1094 : : OMP_CLAUSE_DOACROSS, /* OpenMP 5.2 */
1095 : : OMP_CLAUSE_ASSUMPTIONS, /* OpenMP 5.1. */
1096 : : OMP_CLAUSE_USES_ALLOCATORS, /* OpenMP 5.0 */
1097 : : /* This must come last. */
1098 : : OMP_MASK2_LAST
1099 : : };
1100 : :
1101 : : struct omp_inv_mask;
1102 : :
1103 : : /* Customized bitset for up to 128-bits.
1104 : : The two enums above provide bit numbers to use, and which of the
1105 : : two enums it is determines which of the two mask fields is used.
1106 : : Supported operations are defining a mask, like:
1107 : : #define XXX_CLAUSES \
1108 : : (omp_mask (OMP_CLAUSE_XXX) | OMP_CLAUSE_YYY | OMP_CLAUSE_ZZZ)
1109 : : oring such bitsets together or removing selected bits:
1110 : : (XXX_CLAUSES | YYY_CLAUSES) & ~(omp_mask (OMP_CLAUSE_VVV))
1111 : : and testing individual bits:
1112 : : if (mask & OMP_CLAUSE_UUU) */
1113 : :
1114 : : struct omp_mask {
1115 : : const uint64_t mask1;
1116 : : const uint64_t mask2;
1117 : : inline omp_mask ();
1118 : : inline omp_mask (omp_mask1);
1119 : : inline omp_mask (omp_mask2);
1120 : : inline omp_mask (uint64_t, uint64_t);
1121 : : inline omp_mask operator| (omp_mask1) const;
1122 : : inline omp_mask operator| (omp_mask2) const;
1123 : : inline omp_mask operator| (omp_mask) const;
1124 : : inline omp_mask operator& (const omp_inv_mask &) const;
1125 : : inline bool operator& (omp_mask1) const;
1126 : : inline bool operator& (omp_mask2) const;
1127 : : inline omp_inv_mask operator~ () const;
1128 : : };
1129 : :
1130 : : struct omp_inv_mask : public omp_mask {
1131 : : inline omp_inv_mask (const omp_mask &);
1132 : : };
1133 : :
1134 : : omp_mask::omp_mask () : mask1 (0), mask2 (0)
1135 : : {
1136 : : }
1137 : :
1138 : 28644 : omp_mask::omp_mask (omp_mask1 m) : mask1 (((uint64_t) 1) << m), mask2 (0)
1139 : : {
1140 : : }
1141 : :
1142 : 1448 : omp_mask::omp_mask (omp_mask2 m) : mask1 (0), mask2 (((uint64_t) 1) << m)
1143 : : {
1144 : : }
1145 : :
1146 : 28870 : omp_mask::omp_mask (uint64_t m1, uint64_t m2) : mask1 (m1), mask2 (m2)
1147 : : {
1148 : : }
1149 : :
1150 : : omp_mask
1151 : 28350 : omp_mask::operator| (omp_mask1 m) const
1152 : : {
1153 : 28350 : return omp_mask (mask1 | (((uint64_t) 1) << m), mask2);
1154 : : }
1155 : :
1156 : : omp_mask
1157 : 13590 : omp_mask::operator| (omp_mask2 m) const
1158 : : {
1159 : 13590 : return omp_mask (mask1, mask2 | (((uint64_t) 1) << m));
1160 : : }
1161 : :
1162 : : omp_mask
1163 : 3704 : omp_mask::operator| (omp_mask m) const
1164 : : {
1165 : 3704 : return omp_mask (mask1 | m.mask1, mask2 | m.mask2);
1166 : : }
1167 : :
1168 : : omp_mask
1169 : 1648 : omp_mask::operator& (const omp_inv_mask &m) const
1170 : : {
1171 : 1648 : return omp_mask (mask1 & ~m.mask1, mask2 & ~m.mask2);
1172 : : }
1173 : :
1174 : : bool
1175 : 111884 : omp_mask::operator& (omp_mask1 m) const
1176 : : {
1177 : 111884 : return (mask1 & (((uint64_t) 1) << m)) != 0;
1178 : : }
1179 : :
1180 : : bool
1181 : 71700 : omp_mask::operator& (omp_mask2 m) const
1182 : : {
1183 : 71700 : return (mask2 & (((uint64_t) 1) << m)) != 0;
1184 : : }
1185 : :
1186 : : omp_inv_mask
1187 : 1648 : omp_mask::operator~ () const
1188 : : {
1189 : 1648 : return omp_inv_mask (*this);
1190 : : }
1191 : :
1192 : 1648 : omp_inv_mask::omp_inv_mask (const omp_mask &m) : omp_mask (m)
1193 : : {
1194 : : }
1195 : :
1196 : : /* Helper function for OpenACC and OpenMP clauses involving memory
1197 : : mapping. */
1198 : :
1199 : : static bool
1200 : 6322 : gfc_match_omp_map_clause (gfc_omp_namelist **list, gfc_omp_map_op map_op,
1201 : : bool allow_common, bool allow_derived)
1202 : : {
1203 : 6322 : gfc_omp_namelist **head = NULL;
1204 : 6322 : if (gfc_match_omp_variable_list ("", list, allow_common, NULL, &head, true,
1205 : : allow_derived)
1206 : : == MATCH_YES)
1207 : : {
1208 : 6307 : gfc_omp_namelist *n;
1209 : 15135 : for (n = *head; n; n = n->next)
1210 : 8828 : n->u.map_op = map_op;
1211 : : return true;
1212 : : }
1213 : :
1214 : : return false;
1215 : : }
1216 : :
1217 : : static match
1218 : 1087 : gfc_match_iterator (gfc_namespace **ns, bool permit_var)
1219 : : {
1220 : 1087 : locus old_loc = gfc_current_locus;
1221 : :
1222 : 1087 : if (gfc_match ("iterator ( ") != MATCH_YES)
1223 : : return MATCH_NO;
1224 : :
1225 : 77 : gfc_typespec ts;
1226 : 77 : gfc_symbol *last = NULL;
1227 : 77 : gfc_expr *begin, *end, *step;
1228 : 77 : *ns = gfc_build_block_ns (gfc_current_ns);
1229 : 83 : char name[GFC_MAX_SYMBOL_LEN + 1];
1230 : 89 : while (true)
1231 : : {
1232 : 83 : locus prev_loc = gfc_current_locus;
1233 : 83 : if (gfc_match_type_spec (&ts) == MATCH_YES
1234 : 83 : && gfc_match (" :: ") == MATCH_YES)
1235 : : {
1236 : 5 : if (ts.type != BT_INTEGER)
1237 : : {
1238 : 2 : gfc_error ("Expected INTEGER type at %L", &prev_loc);
1239 : 5 : return MATCH_ERROR;
1240 : : }
1241 : : permit_var = false;
1242 : : }
1243 : : else
1244 : : {
1245 : 78 : ts.type = BT_INTEGER;
1246 : 78 : ts.kind = gfc_default_integer_kind;
1247 : 78 : gfc_current_locus = prev_loc;
1248 : : }
1249 : 81 : prev_loc = gfc_current_locus;
1250 : 81 : if (gfc_match_name (name) != MATCH_YES)
1251 : : {
1252 : 4 : gfc_error ("Expected identifier at %C");
1253 : 4 : goto failed;
1254 : : }
1255 : 77 : if (gfc_find_symtree ((*ns)->sym_root, name))
1256 : : {
1257 : 2 : gfc_error ("Same identifier %qs specified again at %C", name);
1258 : 2 : goto failed;
1259 : : }
1260 : :
1261 : 75 : gfc_symbol *sym = gfc_new_symbol (name, *ns);
1262 : 75 : if (last)
1263 : 4 : last->tlink = sym;
1264 : : else
1265 : 71 : (*ns)->omp_affinity_iterators = sym;
1266 : 75 : last = sym;
1267 : 75 : sym->declared_at = prev_loc;
1268 : 75 : sym->ts = ts;
1269 : 75 : sym->attr.flavor = FL_VARIABLE;
1270 : 75 : sym->attr.artificial = 1;
1271 : 75 : sym->attr.referenced = 1;
1272 : 75 : sym->refs++;
1273 : 75 : gfc_symtree *st = gfc_new_symtree (&(*ns)->sym_root, name);
1274 : 75 : st->n.sym = sym;
1275 : :
1276 : 75 : prev_loc = gfc_current_locus;
1277 : 75 : if (gfc_match (" = ") != MATCH_YES)
1278 : 3 : goto failed;
1279 : 72 : permit_var = false;
1280 : 72 : begin = end = step = NULL;
1281 : 72 : if (gfc_match ("%e : ", &begin) != MATCH_YES
1282 : 72 : || gfc_match ("%e ", &end) != MATCH_YES)
1283 : : {
1284 : 3 : gfc_error ("Expected range-specification at %C");
1285 : 3 : gfc_free_expr (begin);
1286 : 3 : gfc_free_expr (end);
1287 : 3 : return MATCH_ERROR;
1288 : : }
1289 : 69 : if (':' == gfc_peek_ascii_char ())
1290 : : {
1291 : 23 : if (gfc_match (": %e ", &step) != MATCH_YES)
1292 : : {
1293 : 5 : gfc_free_expr (begin);
1294 : 5 : gfc_free_expr (end);
1295 : 5 : gfc_free_expr (step);
1296 : 5 : goto failed;
1297 : : }
1298 : : }
1299 : :
1300 : 64 : gfc_expr *e = gfc_get_expr ();
1301 : 64 : e->where = prev_loc;
1302 : 64 : e->expr_type = EXPR_ARRAY;
1303 : 64 : e->ts = ts;
1304 : 64 : e->rank = 1;
1305 : 64 : e->shape = gfc_get_shape (1);
1306 : 110 : mpz_init_set_ui (e->shape[0], step ? 3 : 2);
1307 : 64 : gfc_constructor_append_expr (&e->value.constructor, begin, &begin->where);
1308 : 64 : gfc_constructor_append_expr (&e->value.constructor, end, &end->where);
1309 : 64 : if (step)
1310 : 18 : gfc_constructor_append_expr (&e->value.constructor, step, &step->where);
1311 : 64 : sym->value = e;
1312 : :
1313 : 64 : if (gfc_match (") ") == MATCH_YES)
1314 : : break;
1315 : 6 : if (gfc_match (", ") != MATCH_YES)
1316 : 0 : goto failed;
1317 : 6 : }
1318 : 58 : return MATCH_YES;
1319 : :
1320 : 14 : failed:
1321 : 14 : gfc_namespace *prev_ns = NULL;
1322 : 14 : for (gfc_namespace *it = gfc_current_ns->contained; it; it = it->sibling)
1323 : : {
1324 : 0 : if (it == *ns)
1325 : : {
1326 : 0 : if (prev_ns)
1327 : 0 : prev_ns->sibling = it->sibling;
1328 : : else
1329 : 0 : gfc_current_ns->contained = it->sibling;
1330 : 0 : gfc_free_namespace (it);
1331 : 0 : break;
1332 : : }
1333 : 0 : prev_ns = it;
1334 : : }
1335 : 14 : *ns = NULL;
1336 : 14 : if (!permit_var)
1337 : : return MATCH_ERROR;
1338 : 4 : gfc_current_locus = old_loc;
1339 : 4 : return MATCH_NO;
1340 : : }
1341 : :
1342 : : /* Match target update's to/from( [present:] var-list). */
1343 : :
1344 : : static match
1345 : 1718 : gfc_match_motion_var_list (const char *str, gfc_omp_namelist **list,
1346 : : gfc_omp_namelist ***headp)
1347 : : {
1348 : 1718 : match m = gfc_match (str);
1349 : 1718 : if (m != MATCH_YES)
1350 : : return m;
1351 : :
1352 : 1718 : match m_present = gfc_match (" present : ");
1353 : :
1354 : 1718 : m = gfc_match_omp_variable_list ("", list, false, NULL, headp, true, true);
1355 : 1718 : if (m != MATCH_YES)
1356 : : return m;
1357 : 1718 : if (m_present == MATCH_YES)
1358 : : {
1359 : 5 : gfc_omp_namelist *n;
1360 : 10 : for (n = **headp; n; n = n->next)
1361 : 5 : n->u.present_modifier = true;
1362 : : }
1363 : : return MATCH_YES;
1364 : : }
1365 : :
1366 : : /* reduction ( reduction-modifier, reduction-operator : variable-list )
1367 : : in_reduction ( reduction-operator : variable-list )
1368 : : task_reduction ( reduction-operator : variable-list ) */
1369 : :
1370 : : static match
1371 : 3972 : gfc_match_omp_clause_reduction (char pc, gfc_omp_clauses *c, bool openacc,
1372 : : bool allow_derived, bool openmp_target = false)
1373 : : {
1374 : 3972 : if (pc == 'r' && gfc_match ("reduction ( ") != MATCH_YES)
1375 : : return MATCH_NO;
1376 : 3972 : else if (pc == 'i' && gfc_match ("in_reduction ( ") != MATCH_YES)
1377 : : return MATCH_NO;
1378 : 3873 : else if (pc == 't' && gfc_match ("task_reduction ( ") != MATCH_YES)
1379 : : return MATCH_NO;
1380 : :
1381 : 3873 : locus old_loc = gfc_current_locus;
1382 : 3873 : int list_idx = 0;
1383 : :
1384 : 3873 : if (pc == 'r' && !openacc)
1385 : : {
1386 : 2033 : if (gfc_match ("inscan") == MATCH_YES)
1387 : : list_idx = OMP_LIST_REDUCTION_INSCAN;
1388 : 1967 : else if (gfc_match ("task") == MATCH_YES)
1389 : : list_idx = OMP_LIST_REDUCTION_TASK;
1390 : 1863 : else if (gfc_match ("default") == MATCH_YES)
1391 : : list_idx = OMP_LIST_REDUCTION;
1392 : 226 : if (list_idx != 0 && gfc_match (", ") != MATCH_YES)
1393 : : {
1394 : 1 : gfc_error ("Comma expected at %C");
1395 : 1 : gfc_current_locus = old_loc;
1396 : 1 : return MATCH_NO;
1397 : : }
1398 : 2032 : if (list_idx == 0)
1399 : 3464 : list_idx = OMP_LIST_REDUCTION;
1400 : : }
1401 : 1840 : else if (pc == 'i')
1402 : : list_idx = OMP_LIST_IN_REDUCTION;
1403 : 1722 : else if (pc == 't')
1404 : : list_idx = OMP_LIST_TASK_REDUCTION;
1405 : : else
1406 : 3464 : list_idx = OMP_LIST_REDUCTION;
1407 : :
1408 : 3872 : gfc_omp_reduction_op rop = OMP_REDUCTION_NONE;
1409 : 3872 : char buffer[GFC_MAX_SYMBOL_LEN + 3];
1410 : 3872 : if (gfc_match_char ('+') == MATCH_YES)
1411 : : rop = OMP_REDUCTION_PLUS;
1412 : 2089 : else if (gfc_match_char ('*') == MATCH_YES)
1413 : : rop = OMP_REDUCTION_TIMES;
1414 : 1875 : else if (gfc_match_char ('-') == MATCH_YES)
1415 : : rop = OMP_REDUCTION_MINUS;
1416 : 1758 : else if (gfc_match (".and.") == MATCH_YES)
1417 : : rop = OMP_REDUCTION_AND;
1418 : 1659 : else if (gfc_match (".or.") == MATCH_YES)
1419 : : rop = OMP_REDUCTION_OR;
1420 : 880 : else if (gfc_match (".eqv.") == MATCH_YES)
1421 : : rop = OMP_REDUCTION_EQV;
1422 : 788 : else if (gfc_match (".neqv.") == MATCH_YES)
1423 : : rop = OMP_REDUCTION_NEQV;
1424 : 698 : if (rop != OMP_REDUCTION_NONE)
1425 : 3174 : snprintf (buffer, sizeof buffer, "operator %s",
1426 : : gfc_op2string ((gfc_intrinsic_op) rop));
1427 : 698 : else if (gfc_match_defined_op_name (buffer + 1, 1) == MATCH_YES)
1428 : : {
1429 : 38 : buffer[0] = '.';
1430 : 38 : strcat (buffer, ".");
1431 : : }
1432 : 660 : else if (gfc_match_name (buffer) == MATCH_YES)
1433 : : {
1434 : 659 : gfc_symbol *sym;
1435 : 659 : const char *n = buffer;
1436 : :
1437 : 659 : gfc_find_symbol (buffer, NULL, 1, &sym);
1438 : 659 : if (sym != NULL)
1439 : : {
1440 : 213 : if (sym->attr.intrinsic)
1441 : 139 : n = sym->name;
1442 : 74 : else if ((sym->attr.flavor != FL_UNKNOWN
1443 : 72 : && sym->attr.flavor != FL_PROCEDURE)
1444 : : || sym->attr.external
1445 : 72 : || sym->attr.generic
1446 : 61 : || sym->attr.entry
1447 : : || sym->attr.result
1448 : : || sym->attr.dummy
1449 : : || sym->attr.subroutine
1450 : : || sym->attr.pointer
1451 : 61 : || sym->attr.target
1452 : : || sym->attr.cray_pointer
1453 : 60 : || sym->attr.cray_pointee
1454 : 60 : || (sym->attr.proc != PROC_UNKNOWN
1455 : 1 : && sym->attr.proc != PROC_INTRINSIC)
1456 : 59 : || sym->attr.if_source != IFSRC_UNKNOWN
1457 : 59 : || sym == sym->ns->proc_name)
1458 : : {
1459 : : sym = NULL;
1460 : : n = NULL;
1461 : : }
1462 : : else
1463 : 59 : n = sym->name;
1464 : : }
1465 : 198 : if (n == NULL)
1466 : : rop = OMP_REDUCTION_NONE;
1467 : 644 : else if (strcmp (n, "max") == 0)
1468 : : rop = OMP_REDUCTION_MAX;
1469 : 491 : else if (strcmp (n, "min") == 0)
1470 : : rop = OMP_REDUCTION_MIN;
1471 : 356 : else if (strcmp (n, "iand") == 0)
1472 : : rop = OMP_REDUCTION_IAND;
1473 : 308 : else if (strcmp (n, "ior") == 0)
1474 : : rop = OMP_REDUCTION_IOR;
1475 : 249 : else if (strcmp (n, "ieor") == 0)
1476 : : rop = OMP_REDUCTION_IEOR;
1477 : : if (rop != OMP_REDUCTION_NONE
1478 : 439 : && sym != NULL
1479 : : && ! sym->attr.intrinsic
1480 : 197 : && ! sym->attr.use_assoc
1481 : 58 : && ((sym->attr.flavor == FL_UNKNOWN
1482 : 2 : && !gfc_add_flavor (&sym->attr, FL_PROCEDURE,
1483 : : sym->name, NULL))
1484 : 58 : || !gfc_add_intrinsic (&sym->attr, NULL)))
1485 : : rop = OMP_REDUCTION_NONE;
1486 : : }
1487 : : else
1488 : 1 : buffer[0] = '\0';
1489 : 3872 : gfc_omp_udr *udr = (buffer[0] ? gfc_find_omp_udr (gfc_current_ns, buffer, NULL)
1490 : 3872 : : NULL);
1491 : 3872 : gfc_omp_namelist **head = NULL;
1492 : 3872 : if (rop == OMP_REDUCTION_NONE && udr)
1493 : 250 : rop = OMP_REDUCTION_USER;
1494 : :
1495 : 3872 : if (gfc_match_omp_variable_list (" :", &c->lists[list_idx], false, NULL,
1496 : : &head, openacc, allow_derived) != MATCH_YES)
1497 : : {
1498 : 7 : gfc_current_locus = old_loc;
1499 : 7 : return MATCH_NO;
1500 : : }
1501 : 3865 : gfc_omp_namelist *n;
1502 : 3865 : if (rop == OMP_REDUCTION_NONE)
1503 : : {
1504 : 6 : n = *head;
1505 : 6 : *head = NULL;
1506 : 6 : gfc_error_now ("!$OMP DECLARE REDUCTION %s not found at %L",
1507 : : buffer, &old_loc);
1508 : 6 : gfc_free_omp_namelist (n, false, false, false);
1509 : : }
1510 : : else
1511 : 8341 : for (n = *head; n; n = n->next)
1512 : : {
1513 : 4482 : n->u.reduction_op = rop;
1514 : 4482 : if (udr)
1515 : : {
1516 : 473 : n->u2.udr = gfc_get_omp_namelist_udr ();
1517 : 473 : n->u2.udr->udr = udr;
1518 : : }
1519 : 4482 : if (openmp_target && list_idx == OMP_LIST_IN_REDUCTION)
1520 : : {
1521 : 40 : gfc_omp_namelist *p = gfc_get_omp_namelist (), **tl;
1522 : 40 : p->sym = n->sym;
1523 : 40 : p->where = p->where;
1524 : 40 : p->u.map_op = OMP_MAP_ALWAYS_TOFROM;
1525 : :
1526 : 40 : tl = &c->lists[OMP_LIST_MAP];
1527 : 52 : while (*tl)
1528 : 12 : tl = &((*tl)->next);
1529 : 40 : *tl = p;
1530 : 40 : p->next = NULL;
1531 : : }
1532 : : }
1533 : : return MATCH_YES;
1534 : : }
1535 : :
1536 : : static match
1537 : 37 : gfc_omp_absent_contains_clause (gfc_omp_assumptions **assume, bool is_absent)
1538 : : {
1539 : 37 : if (*assume == NULL)
1540 : 12 : *assume = gfc_get_omp_assumptions ();
1541 : 59 : do
1542 : : {
1543 : 48 : gfc_statement st = ST_NONE;
1544 : 48 : gfc_gobble_whitespace ();
1545 : 48 : locus old_loc = gfc_current_locus;
1546 : 48 : char c = gfc_peek_ascii_char ();
1547 : 48 : enum gfc_omp_directive_kind kind
1548 : : = GFC_OMP_DIR_DECLARATIVE; /* Silence warning. */
1549 : 1329 : for (size_t i = 0; i < ARRAY_SIZE (gfc_omp_directives); i++)
1550 : : {
1551 : 1329 : if (gfc_omp_directives[i].name[0] > c)
1552 : : break;
1553 : 1281 : if (gfc_omp_directives[i].name[0] != c)
1554 : 963 : continue;
1555 : 318 : if (gfc_match (gfc_omp_directives[i].name) == MATCH_YES)
1556 : : {
1557 : 48 : st = gfc_omp_directives[i].st;
1558 : 48 : kind = gfc_omp_directives[i].kind;
1559 : : }
1560 : : }
1561 : 48 : gfc_gobble_whitespace ();
1562 : 48 : c = gfc_peek_ascii_char ();
1563 : 48 : if (st == ST_NONE || (c != ',' && c != ')'))
1564 : : {
1565 : 0 : if (st == ST_NONE)
1566 : 0 : gfc_error ("Unknown directive at %L", &old_loc);
1567 : : else
1568 : 0 : gfc_error ("Invalid combined or composite directive at %L",
1569 : : &old_loc);
1570 : 3 : return MATCH_ERROR;
1571 : : }
1572 : 48 : if (kind == GFC_OMP_DIR_DECLARATIVE
1573 : 48 : || kind == GFC_OMP_DIR_INFORMATIONAL
1574 : : || kind == GFC_OMP_DIR_META)
1575 : : {
1576 : 3 : gfc_error ("Invalid %qs directive at %L in %s clause: declarative, "
1577 : : "informational and meta directives not permitted",
1578 : : gfc_ascii_statement (st, true), &old_loc,
1579 : : is_absent ? "ABSENT" : "CONTAINS");
1580 : 3 : return MATCH_ERROR;
1581 : : }
1582 : 45 : if (is_absent)
1583 : : {
1584 : : /* Use exponential allocation; equivalent to pow2p(x). */
1585 : 33 : int i = (*assume)->n_absent;
1586 : 33 : int size = ((i == 0) ? 4
1587 : 10 : : pow2p_hwi (i) == 1 ? i*2 : 0);
1588 : 8 : if (size != 0)
1589 : 31 : (*assume)->absent = XRESIZEVEC (gfc_statement,
1590 : : (*assume)->absent, size);
1591 : 33 : (*assume)->absent[(*assume)->n_absent++] = st;
1592 : : }
1593 : : else
1594 : : {
1595 : 12 : int i = (*assume)->n_contains;
1596 : 12 : int size = ((i == 0) ? 4
1597 : 4 : : pow2p_hwi (i) == 1 ? i*2 : 0);
1598 : 4 : if (size != 0)
1599 : 12 : (*assume)->contains = XRESIZEVEC (gfc_statement,
1600 : : (*assume)->contains, size);
1601 : 12 : (*assume)->contains[(*assume)->n_contains++] = st;
1602 : : }
1603 : 45 : gfc_gobble_whitespace ();
1604 : 45 : if (gfc_match(",") == MATCH_YES)
1605 : 11 : continue;
1606 : 34 : if (gfc_match(")") == MATCH_YES)
1607 : : break;
1608 : 0 : gfc_error ("Expected %<,%> or %<)%> at %C");
1609 : 0 : return MATCH_ERROR;
1610 : : }
1611 : : while (true);
1612 : :
1613 : 34 : return MATCH_YES;
1614 : : }
1615 : :
1616 : : /* Check 'check' argument for duplicated statements in absent and/or contains
1617 : : clauses. If 'merge', merge them from check to 'merge'. */
1618 : :
1619 : : static match
1620 : 40 : omp_verify_merge_absent_contains (gfc_statement st, gfc_omp_assumptions *check,
1621 : : gfc_omp_assumptions *merge, locus *loc)
1622 : : {
1623 : 40 : if (check == NULL)
1624 : : return MATCH_YES;
1625 : 40 : bitmap_head absent_head, contains_head;
1626 : 40 : bitmap_obstack_initialize (NULL);
1627 : 40 : bitmap_initialize (&absent_head, &bitmap_default_obstack);
1628 : 40 : bitmap_initialize (&contains_head, &bitmap_default_obstack);
1629 : :
1630 : 40 : match m = MATCH_YES;
1631 : 73 : for (int i = 0; i < check->n_absent; i++)
1632 : 33 : if (!bitmap_set_bit (&absent_head, check->absent[i]))
1633 : : {
1634 : 2 : gfc_error ("%qs directive mentioned multiple times in %s clause in %s "
1635 : : "directive at %L",
1636 : 2 : gfc_ascii_statement (check->absent[i], true),
1637 : : "ABSENT", gfc_ascii_statement (st), loc);
1638 : 2 : m = MATCH_ERROR;
1639 : : }
1640 : 52 : for (int i = 0; i < check->n_contains; i++)
1641 : : {
1642 : 12 : if (!bitmap_set_bit (&contains_head, check->contains[i]))
1643 : : {
1644 : 2 : gfc_error ("%qs directive mentioned multiple times in %s clause in %s "
1645 : : "directive at %L",
1646 : 2 : gfc_ascii_statement (check->contains[i], true),
1647 : : "CONTAINS", gfc_ascii_statement (st), loc);
1648 : 2 : m = MATCH_ERROR;
1649 : : }
1650 : 12 : if (bitmap_bit_p (&absent_head, check->contains[i]))
1651 : : {
1652 : 2 : gfc_error ("%qs directive mentioned both times in ABSENT and CONTAINS "
1653 : : "clauses in %s directive at %L",
1654 : 2 : gfc_ascii_statement (check->absent[i], true),
1655 : : gfc_ascii_statement (st), loc);
1656 : 2 : m = MATCH_ERROR;
1657 : : }
1658 : : }
1659 : :
1660 : 40 : if (m == MATCH_ERROR)
1661 : : return MATCH_ERROR;
1662 : 34 : if (merge == NULL)
1663 : : return MATCH_YES;
1664 : 2 : if (merge->absent == NULL && check->absent)
1665 : : {
1666 : 1 : merge->n_absent = check->n_absent;
1667 : 1 : merge->absent = check->absent;
1668 : 1 : check->absent = NULL;
1669 : : }
1670 : 1 : else if (merge->absent && check->absent)
1671 : : {
1672 : 0 : check->absent = XRESIZEVEC (gfc_statement, check->absent,
1673 : : merge->n_absent + check->n_absent);
1674 : 0 : for (int i = 0; i < merge->n_absent; i++)
1675 : 0 : if (!bitmap_bit_p (&absent_head, merge->absent[i]))
1676 : 0 : check->absent[check->n_absent++] = merge->absent[i];
1677 : 0 : free (merge->absent);
1678 : 0 : merge->absent = check->absent;
1679 : 0 : merge->n_absent = check->n_absent;
1680 : 0 : check->absent = NULL;
1681 : : }
1682 : 2 : if (merge->contains == NULL && check->contains)
1683 : : {
1684 : 0 : merge->n_contains = check->n_contains;
1685 : 0 : merge->contains = check->contains;
1686 : 0 : check->contains = NULL;
1687 : : }
1688 : 2 : else if (merge->contains && check->contains)
1689 : : {
1690 : 0 : check->contains = XRESIZEVEC (gfc_statement, check->contains,
1691 : : merge->n_contains + check->n_contains);
1692 : 0 : for (int i = 0; i < merge->n_contains; i++)
1693 : 0 : if (!bitmap_bit_p (&contains_head, merge->contains[i]))
1694 : 0 : check->contains[check->n_contains++] = merge->contains[i];
1695 : 0 : free (merge->contains);
1696 : 0 : merge->contains = check->contains;
1697 : 0 : merge->n_contains = check->n_contains;
1698 : 0 : check->contains = NULL;
1699 : : }
1700 : : return MATCH_YES;
1701 : : }
1702 : :
1703 : : /* OpenMP 5.0
1704 : : uses_allocators ( allocator-list )
1705 : :
1706 : : allocator:
1707 : : predefined-allocator
1708 : : variable ( traits-array )
1709 : :
1710 : : OpenMP 5.2:
1711 : : uses_allocators ( [modifier-list :] allocator-list )
1712 : :
1713 : : allocator:
1714 : : variable or predefined-allocator
1715 : : modifier:
1716 : : traits ( traits-array )
1717 : : memspace ( mem-space-handle ) */
1718 : :
1719 : : static match
1720 : 47 : gfc_match_omp_clause_uses_allocators (gfc_omp_clauses *c)
1721 : : {
1722 : 47 : gfc_symbol *memspace_sym = NULL;
1723 : 47 : gfc_symbol *traits_sym = NULL;
1724 : 47 : gfc_omp_namelist *head = NULL;
1725 : 47 : gfc_omp_namelist *p, *tail, **list;
1726 : 47 : int ntraits, nmemspace;
1727 : 47 : bool has_modifiers;
1728 : 47 : locus old_loc, cur_loc;
1729 : :
1730 : 47 : gfc_gobble_whitespace ();
1731 : 47 : old_loc = gfc_current_locus;
1732 : 47 : ntraits = nmemspace = 0;
1733 : 77 : do
1734 : : {
1735 : 62 : cur_loc = gfc_current_locus;
1736 : 62 : if (gfc_match ("traits ( %S ) ", &traits_sym) == MATCH_YES)
1737 : 21 : ntraits++;
1738 : 41 : else if (gfc_match ("memspace ( %S ) ", &memspace_sym) == MATCH_YES)
1739 : 21 : nmemspace++;
1740 : 62 : if (ntraits > 1 || nmemspace > 1)
1741 : : {
1742 : 2 : gfc_error ("Duplicate %s modifier at %L in USES_ALLOCATORS clause",
1743 : : ntraits > 1 ? "TRAITS" : "MEMSPACE", &cur_loc);
1744 : 2 : return MATCH_ERROR;
1745 : : }
1746 : 60 : if (gfc_match (", ") == MATCH_YES)
1747 : 15 : continue;
1748 : 45 : if (gfc_match (": ") != MATCH_YES)
1749 : : {
1750 : : /* Assume no modifier. */
1751 : 22 : memspace_sym = traits_sym = NULL;
1752 : 22 : gfc_current_locus = old_loc;
1753 : 22 : break;
1754 : : }
1755 : : break;
1756 : : } while (true);
1757 : :
1758 : 68 : has_modifiers = traits_sym != NULL || memspace_sym != NULL;
1759 : 127 : do
1760 : : {
1761 : 86 : p = gfc_get_omp_namelist ();
1762 : 86 : p->where = gfc_current_locus;
1763 : 86 : if (head == NULL)
1764 : : head = tail = p;
1765 : : else
1766 : : {
1767 : 41 : tail->next = p;
1768 : 41 : tail = tail->next;
1769 : : }
1770 : 86 : if (gfc_match ("%S ", &p->sym) != MATCH_YES)
1771 : 0 : goto error;
1772 : 86 : if (!has_modifiers)
1773 : 58 : gfc_match ("( %S ) ", &p->u2.traits_sym);
1774 : 28 : else if (gfc_peek_ascii_char () == '(')
1775 : : {
1776 : 0 : gfc_error ("Unexpected %<(%> at %C");
1777 : 0 : goto error;
1778 : : }
1779 : : else
1780 : : {
1781 : 28 : p->u.memspace_sym = memspace_sym;
1782 : 28 : p->u2.traits_sym = traits_sym;
1783 : : }
1784 : 86 : if (gfc_match (", ") == MATCH_YES)
1785 : 41 : continue;
1786 : 45 : if (gfc_match (") ") == MATCH_YES)
1787 : : break;
1788 : 2 : goto error;
1789 : : } while (true);
1790 : :
1791 : 43 : list = &c->lists[OMP_LIST_USES_ALLOCATORS];
1792 : 48 : while (*list)
1793 : 5 : list = &(*list)->next;
1794 : 43 : *list = head;
1795 : :
1796 : 43 : return MATCH_YES;
1797 : :
1798 : 2 : error:
1799 : 2 : gfc_free_omp_namelist (head, false, false, true);
1800 : 2 : return MATCH_ERROR;
1801 : : }
1802 : :
1803 : :
1804 : : /* Match with duplicate check. Matches 'name'. If expr != NULL, it
1805 : : then matches '(expr)', otherwise, if open_parens is true,
1806 : : it matches a ' ( ' after 'name'.
1807 : : dupl_message requires '%qs %L' - and is used by
1808 : : gfc_match_dupl_memorder and gfc_match_dupl_atomic. */
1809 : :
1810 : : static match
1811 : 19852 : gfc_match_dupl_check (bool not_dupl, const char *name, bool open_parens = false,
1812 : : gfc_expr **expr = NULL, const char *dupl_msg = NULL)
1813 : : {
1814 : 19852 : match m;
1815 : 19852 : locus old_loc = gfc_current_locus;
1816 : 19852 : if ((m = gfc_match (name)) != MATCH_YES)
1817 : : return m;
1818 : 15315 : if (!not_dupl)
1819 : : {
1820 : 33 : if (dupl_msg)
1821 : 2 : gfc_error (dupl_msg, name, &old_loc);
1822 : : else
1823 : 31 : gfc_error ("Duplicated %qs clause at %L", name, &old_loc);
1824 : 33 : return MATCH_ERROR;
1825 : : }
1826 : 15282 : if (open_parens || expr)
1827 : : {
1828 : 8283 : if (gfc_match (" ( ") != MATCH_YES)
1829 : : {
1830 : 22 : gfc_error ("Expected %<(%> after %qs at %C", name);
1831 : 22 : return MATCH_ERROR;
1832 : : }
1833 : 8261 : if (expr)
1834 : : {
1835 : 4122 : if (gfc_match ("%e )", expr) != MATCH_YES)
1836 : : {
1837 : 7 : gfc_error ("Invalid expression after %<%s(%> at %C", name);
1838 : 7 : return MATCH_ERROR;
1839 : : }
1840 : : }
1841 : : }
1842 : : return MATCH_YES;
1843 : : }
1844 : :
1845 : : static match
1846 : 207 : gfc_match_dupl_memorder (bool not_dupl, const char *name)
1847 : : {
1848 : 0 : return gfc_match_dupl_check (not_dupl, name, false, NULL,
1849 : : "Duplicated memory-order clause: unexpected %s "
1850 : 0 : "clause at %L");
1851 : : }
1852 : :
1853 : : static match
1854 : 1157 : gfc_match_dupl_atomic (bool not_dupl, const char *name)
1855 : : {
1856 : 0 : return gfc_match_dupl_check (not_dupl, name, false, NULL,
1857 : : "Duplicated atomic clause: unexpected %s "
1858 : 0 : "clause at %L");
1859 : : }
1860 : :
1861 : : /* Match OpenMP and OpenACC directive clauses. MASK is a bitmask of
1862 : : clauses that are allowed for a particular directive. */
1863 : :
1864 : : static match
1865 : 30092 : gfc_match_omp_clauses (gfc_omp_clauses **cp, const omp_mask mask,
1866 : : bool first = true, bool needs_space = true,
1867 : : bool openacc = false, bool context_selector = false,
1868 : : bool openmp_target = false)
1869 : : {
1870 : 30092 : bool error = false;
1871 : 30092 : gfc_omp_clauses *c = gfc_get_omp_clauses ();
1872 : 30092 : locus old_loc;
1873 : : /* Determine whether we're dealing with an OpenACC directive that permits
1874 : : derived type member accesses. This in particular disallows
1875 : : "!$acc declare" from using such accesses, because it's not clear if/how
1876 : : that should work. */
1877 : 30092 : bool allow_derived = (openacc
1878 : 30092 : && ((mask & OMP_CLAUSE_ATTACH)
1879 : 5414 : || (mask & OMP_CLAUSE_DETACH)
1880 : 4908 : || (mask & OMP_CLAUSE_HOST_SELF)));
1881 : :
1882 : 30092 : gcc_checking_assert (OMP_MASK1_LAST <= 64 && OMP_MASK2_LAST <= 64);
1883 : 30092 : *cp = NULL;
1884 : 110918 : while (1)
1885 : : {
1886 : 70505 : match m = MATCH_NO;
1887 : 52713 : if ((first || (m = gfc_match_char (',')) != MATCH_YES)
1888 : 122903 : && (needs_space && gfc_match_space () != MATCH_YES))
1889 : : break;
1890 : 63039 : needs_space = false;
1891 : 63039 : first = false;
1892 : 63039 : gfc_gobble_whitespace ();
1893 : 63039 : bool end_colon;
1894 : 63039 : gfc_omp_namelist **head;
1895 : 63039 : old_loc = gfc_current_locus;
1896 : 63039 : char pc = gfc_peek_ascii_char ();
1897 : 63039 : if (pc == '\n' && m == MATCH_YES)
1898 : : {
1899 : 1 : gfc_error ("Clause expected at %C after trailing comma");
1900 : 1 : goto error;
1901 : : }
1902 : 63038 : switch (pc)
1903 : : {
1904 : 1185 : case 'a':
1905 : 1185 : end_colon = false;
1906 : 1185 : head = NULL;
1907 : 1209 : if ((mask & OMP_CLAUSE_ASSUMPTIONS)
1908 : 1185 : && gfc_match ("absent ( ") == MATCH_YES)
1909 : : {
1910 : 27 : if (gfc_omp_absent_contains_clause (&c->assume, true)
1911 : : != MATCH_YES)
1912 : 3 : goto error;
1913 : 24 : continue;
1914 : : }
1915 : 1158 : if ((mask & OMP_CLAUSE_ALIGNED)
1916 : 1158 : && gfc_match_omp_variable_list ("aligned (",
1917 : : &c->lists[OMP_LIST_ALIGNED],
1918 : : false, &end_colon,
1919 : : &head) == MATCH_YES)
1920 : : {
1921 : 112 : gfc_expr *alignment = NULL;
1922 : 112 : gfc_omp_namelist *n;
1923 : :
1924 : 112 : if (end_colon && gfc_match (" %e )", &alignment) != MATCH_YES)
1925 : : {
1926 : 0 : gfc_free_omp_namelist (*head, false, false, false);
1927 : 0 : gfc_current_locus = old_loc;
1928 : 0 : *head = NULL;
1929 : 0 : break;
1930 : : }
1931 : 268 : for (n = *head; n; n = n->next)
1932 : 156 : if (n->next && alignment)
1933 : 42 : n->expr = gfc_copy_expr (alignment);
1934 : : else
1935 : 114 : n->expr = alignment;
1936 : 112 : continue;
1937 : 112 : }
1938 : 1056 : if ((mask & OMP_CLAUSE_MEMORDER)
1939 : 1062 : && (m = gfc_match_dupl_memorder ((c->memorder
1940 : 16 : == OMP_MEMORDER_UNSET),
1941 : : "acq_rel")) != MATCH_NO)
1942 : : {
1943 : 10 : if (m == MATCH_ERROR)
1944 : 0 : goto error;
1945 : 10 : c->memorder = OMP_MEMORDER_ACQ_REL;
1946 : 10 : needs_space = true;
1947 : 10 : continue;
1948 : : }
1949 : 1042 : if ((mask & OMP_CLAUSE_MEMORDER)
1950 : 1042 : && (m = gfc_match_dupl_memorder ((c->memorder
1951 : 6 : == OMP_MEMORDER_UNSET),
1952 : : "acquire")) != MATCH_NO)
1953 : : {
1954 : 6 : if (m == MATCH_ERROR)
1955 : 0 : goto error;
1956 : 6 : c->memorder = OMP_MEMORDER_ACQUIRE;
1957 : 6 : needs_space = true;
1958 : 6 : continue;
1959 : : }
1960 : 1030 : if ((mask & OMP_CLAUSE_AFFINITY)
1961 : 1030 : && gfc_match ("affinity ( ") == MATCH_YES)
1962 : : {
1963 : 41 : gfc_namespace *ns_iter = NULL, *ns_curr = gfc_current_ns;
1964 : 41 : m = gfc_match_iterator (&ns_iter, true);
1965 : 41 : if (m == MATCH_ERROR)
1966 : : break;
1967 : 31 : if (m == MATCH_YES && gfc_match (" : ") != MATCH_YES)
1968 : : {
1969 : 1 : gfc_error ("Expected %<:%> at %C");
1970 : 1 : break;
1971 : : }
1972 : 30 : if (ns_iter)
1973 : 18 : gfc_current_ns = ns_iter;
1974 : 30 : head = NULL;
1975 : 30 : m = gfc_match_omp_variable_list ("", &c->lists[OMP_LIST_AFFINITY],
1976 : : false, NULL, &head, true);
1977 : 30 : gfc_current_ns = ns_curr;
1978 : 30 : if (m == MATCH_ERROR)
1979 : : break;
1980 : 27 : if (ns_iter)
1981 : : {
1982 : 45 : for (gfc_omp_namelist *n = *head; n; n = n->next)
1983 : : {
1984 : 27 : n->u2.ns = ns_iter;
1985 : 27 : ns_iter->refs++;
1986 : : }
1987 : : }
1988 : 27 : continue;
1989 : 27 : }
1990 : 989 : if ((mask & OMP_CLAUSE_ALLOCATE)
1991 : 989 : && gfc_match ("allocate ( ") == MATCH_YES)
1992 : : {
1993 : 215 : gfc_expr *allocator = NULL;
1994 : 215 : gfc_expr *align = NULL;
1995 : 215 : old_loc = gfc_current_locus;
1996 : 215 : if ((m = gfc_match ("allocator ( %e )", &allocator)) == MATCH_YES)
1997 : 5 : gfc_match (" , align ( %e )", &align);
1998 : 210 : else if ((m = gfc_match ("align ( %e )", &align)) == MATCH_YES)
1999 : 25 : gfc_match (" , allocator ( %e )", &allocator);
2000 : :
2001 : 215 : if (m == MATCH_YES)
2002 : : {
2003 : 30 : if (gfc_match (" : ") != MATCH_YES)
2004 : : {
2005 : 5 : gfc_error ("Expected %<:%> at %C");
2006 : 7 : goto error;
2007 : : }
2008 : : }
2009 : : else
2010 : : {
2011 : 185 : m = gfc_match_expr (&allocator);
2012 : 185 : if (m == MATCH_YES && gfc_match (" : ") != MATCH_YES)
2013 : : {
2014 : : /* If no ":" then there is no allocator, we backtrack
2015 : : and read the variable list. */
2016 : 93 : gfc_free_expr (allocator);
2017 : 93 : allocator = NULL;
2018 : 93 : gfc_current_locus = old_loc;
2019 : : }
2020 : : }
2021 : 210 : gfc_omp_namelist **head = NULL;
2022 : 210 : m = gfc_match_omp_variable_list ("", &c->lists[OMP_LIST_ALLOCATE],
2023 : : true, NULL, &head);
2024 : :
2025 : 210 : if (m != MATCH_YES)
2026 : : {
2027 : 2 : gfc_free_expr (allocator);
2028 : 2 : gfc_free_expr (align);
2029 : 2 : gfc_error ("Expected variable list at %C");
2030 : 2 : goto error;
2031 : : }
2032 : :
2033 : 587 : for (gfc_omp_namelist *n = *head; n; n = n->next)
2034 : : {
2035 : 758 : n->u2.allocator = ((allocator)
2036 : 379 : ? gfc_copy_expr (allocator) : NULL);
2037 : 379 : n->u.align = (align) ? gfc_copy_expr (align) : NULL;
2038 : : }
2039 : 208 : gfc_free_expr (allocator);
2040 : 208 : gfc_free_expr (align);
2041 : 208 : continue;
2042 : 208 : }
2043 : 821 : if ((mask & OMP_CLAUSE_AT)
2044 : 774 : && (m = gfc_match_dupl_check (c->at == OMP_AT_UNSET, "at", true))
2045 : : != MATCH_NO)
2046 : : {
2047 : 53 : if (m == MATCH_ERROR)
2048 : 2 : goto error;
2049 : 51 : if (gfc_match ("compilation )") == MATCH_YES)
2050 : 14 : c->at = OMP_AT_COMPILATION;
2051 : 37 : else if (gfc_match ("execution )") == MATCH_YES)
2052 : 33 : c->at = OMP_AT_EXECUTION;
2053 : : else
2054 : : {
2055 : 4 : gfc_error ("Expected COMPILATION or EXECUTION in AT clause "
2056 : : "at %C");
2057 : 4 : goto error;
2058 : : }
2059 : 47 : continue;
2060 : : }
2061 : 1334 : if ((mask & OMP_CLAUSE_ASYNC)
2062 : 721 : && (m = gfc_match_dupl_check (!c->async, "async")) != MATCH_NO)
2063 : : {
2064 : 613 : if (m == MATCH_ERROR)
2065 : 0 : goto error;
2066 : 613 : c->async = true;
2067 : 613 : m = gfc_match (" ( %e )", &c->async_expr);
2068 : 613 : if (m == MATCH_ERROR)
2069 : : {
2070 : 0 : gfc_current_locus = old_loc;
2071 : 0 : break;
2072 : : }
2073 : 613 : else if (m == MATCH_NO)
2074 : : {
2075 : 126 : c->async_expr
2076 : 126 : = gfc_get_constant_expr (BT_INTEGER,
2077 : : gfc_default_integer_kind,
2078 : : &gfc_current_locus);
2079 : 126 : mpz_set_si (c->async_expr->value.integer, GOMP_ASYNC_NOVAL);
2080 : 126 : needs_space = true;
2081 : : }
2082 : 613 : continue;
2083 : : }
2084 : 155 : if ((mask & OMP_CLAUSE_AUTO)
2085 : 108 : && (m = gfc_match_dupl_check (!c->par_auto, "auto"))
2086 : : != MATCH_NO)
2087 : : {
2088 : 47 : if (m == MATCH_ERROR)
2089 : 0 : goto error;
2090 : 47 : c->par_auto = true;
2091 : 47 : needs_space = true;
2092 : 47 : continue;
2093 : : }
2094 : 120 : if ((mask & OMP_CLAUSE_ATTACH)
2095 : 59 : && gfc_match ("attach ( ") == MATCH_YES
2096 : 120 : && gfc_match_omp_map_clause (&c->lists[OMP_LIST_MAP],
2097 : : OMP_MAP_ATTACH, false,
2098 : : allow_derived))
2099 : 59 : continue;
2100 : : break;
2101 : 36 : case 'b':
2102 : 70 : if ((mask & OMP_CLAUSE_BIND)
2103 : 36 : && (m = gfc_match_dupl_check (c->bind == OMP_BIND_UNSET, "bind",
2104 : : true)) != MATCH_NO)
2105 : : {
2106 : 36 : if (m == MATCH_ERROR)
2107 : 1 : goto error;
2108 : 35 : if (gfc_match ("teams )") == MATCH_YES)
2109 : 11 : c->bind = OMP_BIND_TEAMS;
2110 : 24 : else if (gfc_match ("parallel )") == MATCH_YES)
2111 : 15 : c->bind = OMP_BIND_PARALLEL;
2112 : 9 : else if (gfc_match ("thread )") == MATCH_YES)
2113 : 8 : c->bind = OMP_BIND_THREAD;
2114 : : else
2115 : : {
2116 : 1 : gfc_error ("Expected TEAMS, PARALLEL or THREAD as binding in "
2117 : : "BIND at %C");
2118 : 1 : break;
2119 : : }
2120 : 34 : continue;
2121 : : }
2122 : : break;
2123 : 6575 : case 'c':
2124 : 6864 : if ((mask & OMP_CLAUSE_CAPTURE)
2125 : 6575 : && (m = gfc_match_dupl_check (!c->capture, "capture"))
2126 : : != MATCH_NO)
2127 : : {
2128 : 290 : if (m == MATCH_ERROR)
2129 : 1 : goto error;
2130 : 289 : c->capture = true;
2131 : 289 : needs_space = true;
2132 : 289 : continue;
2133 : : }
2134 : 6285 : if (mask & OMP_CLAUSE_COLLAPSE)
2135 : : {
2136 : 1886 : gfc_expr *cexpr = NULL;
2137 : 1886 : if ((m = gfc_match_dupl_check (!c->collapse, "collapse", true,
2138 : : &cexpr)) != MATCH_NO)
2139 : : {
2140 : 1405 : int collapse;
2141 : 1405 : if (m == MATCH_ERROR)
2142 : 0 : goto error;
2143 : 1405 : if (gfc_extract_int (cexpr, &collapse, -1))
2144 : 4 : collapse = 1;
2145 : 1401 : else if (collapse <= 0)
2146 : : {
2147 : 8 : gfc_error_now ("COLLAPSE clause argument not constant "
2148 : : "positive integer at %C");
2149 : 8 : collapse = 1;
2150 : : }
2151 : 1405 : gfc_free_expr (cexpr);
2152 : 1405 : c->collapse = collapse;
2153 : 1405 : continue;
2154 : 1405 : }
2155 : : }
2156 : 5046 : if ((mask & OMP_CLAUSE_COMPARE)
2157 : 4880 : && (m = gfc_match_dupl_check (!c->compare, "compare"))
2158 : : != MATCH_NO)
2159 : : {
2160 : 167 : if (m == MATCH_ERROR)
2161 : 1 : goto error;
2162 : 166 : c->compare = true;
2163 : 166 : needs_space = true;
2164 : 166 : continue;
2165 : : }
2166 : 4723 : if ((mask & OMP_CLAUSE_ASSUMPTIONS)
2167 : 4713 : && gfc_match ("contains ( ") == MATCH_YES)
2168 : : {
2169 : 10 : if (gfc_omp_absent_contains_clause (&c->assume, false)
2170 : : != MATCH_YES)
2171 : 0 : goto error;
2172 : 10 : continue;
2173 : : }
2174 : 6791 : if ((mask & OMP_CLAUSE_COPY)
2175 : 3382 : && gfc_match ("copy ( ") == MATCH_YES
2176 : 6792 : && gfc_match_omp_map_clause (&c->lists[OMP_LIST_MAP],
2177 : : OMP_MAP_TOFROM, true,
2178 : : allow_derived))
2179 : 2088 : continue;
2180 : 2615 : if (mask & OMP_CLAUSE_COPYIN)
2181 : : {
2182 : 2217 : if (openacc)
2183 : : {
2184 : 2118 : if (gfc_match ("copyin ( ") == MATCH_YES
2185 : 2118 : && gfc_match_omp_map_clause (&c->lists[OMP_LIST_MAP],
2186 : : OMP_MAP_TO, true,
2187 : : allow_derived))
2188 : 1197 : continue;
2189 : : }
2190 : 99 : else if (gfc_match_omp_variable_list ("copyin (",
2191 : : &c->lists[OMP_LIST_COPYIN],
2192 : : true) == MATCH_YES)
2193 : 97 : continue;
2194 : : }
2195 : 2233 : if ((mask & OMP_CLAUSE_COPYOUT)
2196 : 1054 : && gfc_match ("copyout ( ") == MATCH_YES
2197 : 2233 : && gfc_match_omp_map_clause (&c->lists[OMP_LIST_MAP],
2198 : : OMP_MAP_FROM, true, allow_derived))
2199 : 912 : continue;
2200 : 493 : if ((mask & OMP_CLAUSE_COPYPRIVATE)
2201 : 409 : && gfc_match_omp_variable_list ("copyprivate (",
2202 : : &c->lists[OMP_LIST_COPYPRIVATE],
2203 : : true) == MATCH_YES)
2204 : 84 : continue;
2205 : 641 : if ((mask & OMP_CLAUSE_CREATE)
2206 : 323 : && gfc_match ("create ( ") == MATCH_YES
2207 : 641 : && gfc_match_omp_map_clause (&c->lists[OMP_LIST_MAP],
2208 : : OMP_MAP_ALLOC, true, allow_derived))
2209 : 316 : continue;
2210 : : break;
2211 : 3312 : case 'd':
2212 : 3312 : if ((mask & OMP_CLAUSE_DEFAULTMAP)
2213 : 3312 : && gfc_match ("defaultmap ( ") == MATCH_YES)
2214 : : {
2215 : 159 : enum gfc_omp_defaultmap behavior;
2216 : 159 : gfc_omp_defaultmap_category category
2217 : : = OMP_DEFAULTMAP_CAT_UNCATEGORIZED;
2218 : 159 : if (gfc_match ("alloc ") == MATCH_YES)
2219 : : behavior = OMP_DEFAULTMAP_ALLOC;
2220 : 153 : else if (gfc_match ("tofrom ") == MATCH_YES)
2221 : : behavior = OMP_DEFAULTMAP_TOFROM;
2222 : 122 : else if (gfc_match ("to ") == MATCH_YES)
2223 : : behavior = OMP_DEFAULTMAP_TO;
2224 : 117 : else if (gfc_match ("from ") == MATCH_YES)
2225 : : behavior = OMP_DEFAULTMAP_FROM;
2226 : 114 : else if (gfc_match ("firstprivate ") == MATCH_YES)
2227 : : behavior = OMP_DEFAULTMAP_FIRSTPRIVATE;
2228 : 83 : else if (gfc_match ("present ") == MATCH_YES)
2229 : : behavior = OMP_DEFAULTMAP_PRESENT;
2230 : 79 : else if (gfc_match ("none ") == MATCH_YES)
2231 : : behavior = OMP_DEFAULTMAP_NONE;
2232 : 10 : else if (gfc_match ("default ") == MATCH_YES)
2233 : : behavior = OMP_DEFAULTMAP_DEFAULT;
2234 : : else
2235 : : {
2236 : 1 : gfc_error ("Expected ALLOC, TO, FROM, TOFROM, FIRSTPRIVATE, "
2237 : : "PRESENT, NONE or DEFAULT at %C");
2238 : 1 : break;
2239 : : }
2240 : 158 : if (')' == gfc_peek_ascii_char ())
2241 : : ;
2242 : 88 : else if (gfc_match (": ") != MATCH_YES)
2243 : : break;
2244 : : else
2245 : : {
2246 : 88 : if (gfc_match ("scalar ") == MATCH_YES)
2247 : : category = OMP_DEFAULTMAP_CAT_SCALAR;
2248 : 56 : else if (gfc_match ("aggregate ") == MATCH_YES)
2249 : : category = OMP_DEFAULTMAP_CAT_AGGREGATE;
2250 : 35 : else if (gfc_match ("allocatable ") == MATCH_YES)
2251 : : category = OMP_DEFAULTMAP_CAT_ALLOCATABLE;
2252 : 23 : else if (gfc_match ("pointer ") == MATCH_YES)
2253 : : category = OMP_DEFAULTMAP_CAT_POINTER;
2254 : 9 : else if (gfc_match ("all ") == MATCH_YES)
2255 : : category = OMP_DEFAULTMAP_CAT_ALL;
2256 : : else
2257 : : {
2258 : 1 : gfc_error ("Expected SCALAR, AGGREGATE, ALLOCATABLE, "
2259 : : "POINTER or ALL at %C");
2260 : 1 : break;
2261 : : }
2262 : : }
2263 : 1046 : for (int i = 0; i < OMP_DEFAULTMAP_CAT_NUM; ++i)
2264 : : {
2265 : 902 : if (i != category
2266 : 902 : && category != OMP_DEFAULTMAP_CAT_UNCATEGORIZED
2267 : 416 : && category != OMP_DEFAULTMAP_CAT_ALL
2268 : 416 : && i != OMP_DEFAULTMAP_CAT_UNCATEGORIZED
2269 : 305 : && i != OMP_DEFAULTMAP_CAT_ALL)
2270 : 227 : continue;
2271 : 675 : if (c->defaultmap[i] != OMP_DEFAULTMAP_UNSET)
2272 : : {
2273 : 13 : const char *pcategory = NULL;
2274 : 13 : switch (i)
2275 : : {
2276 : : case OMP_DEFAULTMAP_CAT_UNCATEGORIZED: break;
2277 : : case OMP_DEFAULTMAP_CAT_ALL: pcategory = "ALL"; break;
2278 : 1 : case OMP_DEFAULTMAP_CAT_SCALAR: pcategory = "SCALAR"; break;
2279 : 2 : case OMP_DEFAULTMAP_CAT_AGGREGATE:
2280 : 2 : pcategory = "AGGREGATE";
2281 : 2 : break;
2282 : 1 : case OMP_DEFAULTMAP_CAT_ALLOCATABLE:
2283 : 1 : pcategory = "ALLOCATABLE";
2284 : 1 : break;
2285 : 2 : case OMP_DEFAULTMAP_CAT_POINTER:
2286 : 2 : pcategory = "POINTER";
2287 : 2 : break;
2288 : : default: gcc_unreachable ();
2289 : : }
2290 : 6 : if (i == OMP_DEFAULTMAP_CAT_UNCATEGORIZED)
2291 : 4 : gfc_error ("DEFAULTMAP at %C but prior DEFAULTMAP with "
2292 : : "unspecified category");
2293 : : else
2294 : 9 : gfc_error ("DEFAULTMAP at %C but prior DEFAULTMAP for "
2295 : : "category %s", pcategory);
2296 : 13 : goto error;
2297 : : }
2298 : : }
2299 : 144 : c->defaultmap[category] = behavior;
2300 : 144 : if (gfc_match (")") != MATCH_YES)
2301 : : break;
2302 : 144 : continue;
2303 : 144 : }
2304 : 4073 : if ((mask & OMP_CLAUSE_DEFAULT)
2305 : 3153 : && (m = gfc_match_dupl_check (c->default_sharing
2306 : : == OMP_DEFAULT_UNKNOWN, "default",
2307 : : true)) != MATCH_NO)
2308 : : {
2309 : 950 : if (m == MATCH_ERROR)
2310 : 4 : goto error;
2311 : 946 : if (gfc_match ("none") == MATCH_YES)
2312 : 552 : c->default_sharing = OMP_DEFAULT_NONE;
2313 : 394 : else if (openacc)
2314 : : {
2315 : 210 : if (gfc_match ("present") == MATCH_YES)
2316 : 190 : c->default_sharing = OMP_DEFAULT_PRESENT;
2317 : : }
2318 : : else
2319 : : {
2320 : 184 : if (gfc_match ("firstprivate") == MATCH_YES)
2321 : 7 : c->default_sharing = OMP_DEFAULT_FIRSTPRIVATE;
2322 : 177 : else if (gfc_match ("private") == MATCH_YES)
2323 : 24 : c->default_sharing = OMP_DEFAULT_PRIVATE;
2324 : 153 : else if (gfc_match ("shared") == MATCH_YES)
2325 : 153 : c->default_sharing = OMP_DEFAULT_SHARED;
2326 : : }
2327 : 946 : if (c->default_sharing == OMP_DEFAULT_UNKNOWN)
2328 : : {
2329 : 20 : if (openacc)
2330 : 20 : gfc_error ("Expected NONE or PRESENT in DEFAULT clause "
2331 : : "at %C");
2332 : : else
2333 : 0 : gfc_error ("Expected NONE, FIRSTPRIVATE, PRIVATE or SHARED "
2334 : : "in DEFAULT clause at %C");
2335 : 20 : goto error;
2336 : : }
2337 : 926 : if (gfc_match (" )") != MATCH_YES)
2338 : 6 : goto error;
2339 : 920 : continue;
2340 : : }
2341 : 2415 : if ((mask & OMP_CLAUSE_DELETE)
2342 : 247 : && gfc_match ("delete ( ") == MATCH_YES
2343 : 2415 : && gfc_match_omp_map_clause (&c->lists[OMP_LIST_MAP],
2344 : : OMP_MAP_RELEASE, true,
2345 : : allow_derived))
2346 : 212 : continue;
2347 : : /* DOACROSS: match 'doacross' and 'depend' with sink/source.
2348 : : DEPEND: match 'depend' but not sink/source. */
2349 : 1991 : m = MATCH_NO;
2350 : 1991 : if (((mask & OMP_CLAUSE_DOACROSS)
2351 : 381 : && gfc_match ("doacross ( ") == MATCH_YES)
2352 : 2345 : || (((mask & OMP_CLAUSE_DEPEND) || (mask & OMP_CLAUSE_DOACROSS))
2353 : 1437 : && (m = gfc_match ("depend ( ")) == MATCH_YES))
2354 : : {
2355 : 1073 : bool has_omp_all_memory;
2356 : 1073 : bool is_depend = m == MATCH_YES;
2357 : 1073 : gfc_namespace *ns_iter = NULL, *ns_curr = gfc_current_ns;
2358 : 1073 : match m_it = MATCH_NO;
2359 : 1073 : if (is_depend)
2360 : 1046 : m_it = gfc_match_iterator (&ns_iter, false);
2361 : 1046 : if (m_it == MATCH_ERROR)
2362 : : break;
2363 : 1068 : if (m_it == MATCH_YES && gfc_match (" , ") != MATCH_YES)
2364 : : break;
2365 : 1068 : m = MATCH_YES;
2366 : 1068 : gfc_omp_depend_doacross_op depend_op = OMP_DEPEND_OUT;
2367 : 1068 : if (gfc_match ("inoutset") == MATCH_YES)
2368 : : depend_op = OMP_DEPEND_INOUTSET;
2369 : 1056 : else if (gfc_match ("inout") == MATCH_YES)
2370 : : depend_op = OMP_DEPEND_INOUT;
2371 : 982 : else if (gfc_match ("in") == MATCH_YES)
2372 : : depend_op = OMP_DEPEND_IN;
2373 : 697 : else if (gfc_match ("out") == MATCH_YES)
2374 : : depend_op = OMP_DEPEND_OUT;
2375 : 437 : else if (gfc_match ("mutexinoutset") == MATCH_YES)
2376 : : depend_op = OMP_DEPEND_MUTEXINOUTSET;
2377 : 419 : else if (gfc_match ("depobj") == MATCH_YES)
2378 : : depend_op = OMP_DEPEND_DEPOBJ;
2379 : 385 : else if (gfc_match ("source") == MATCH_YES)
2380 : : {
2381 : 142 : if (m_it == MATCH_YES)
2382 : : {
2383 : 1 : gfc_error ("ITERATOR may not be combined with SOURCE "
2384 : : "at %C");
2385 : 17 : goto error;
2386 : : }
2387 : 141 : if (!(mask & OMP_CLAUSE_DOACROSS))
2388 : : {
2389 : 1 : gfc_error ("SOURCE at %C not permitted as dependence-type"
2390 : : " for this directive");
2391 : 1 : goto error;
2392 : : }
2393 : 140 : if (c->doacross_source)
2394 : : {
2395 : 0 : gfc_error ("Duplicated clause with SOURCE dependence-type"
2396 : : " at %C");
2397 : 0 : goto error;
2398 : : }
2399 : 140 : gfc_gobble_whitespace ();
2400 : 140 : m = gfc_match (": ");
2401 : 140 : if (m != MATCH_YES && !is_depend)
2402 : : {
2403 : 1 : gfc_error ("Expected %<:%> at %C");
2404 : 1 : goto error;
2405 : : }
2406 : 139 : if (gfc_match (")") != MATCH_YES
2407 : 145 : && !(m == MATCH_YES
2408 : 6 : && gfc_match ("omp_cur_iteration )") == MATCH_YES))
2409 : : {
2410 : 2 : gfc_error ("Expected %<)%> or %<omp_cur_iteration)%> "
2411 : : "at %C");
2412 : 2 : goto error;
2413 : : }
2414 : 137 : c->doacross_source = true;
2415 : 137 : c->depend_source = is_depend;
2416 : 1051 : continue;
2417 : : }
2418 : 243 : else if (gfc_match ("sink ") == MATCH_YES)
2419 : : {
2420 : 243 : if (!(mask & OMP_CLAUSE_DOACROSS))
2421 : : {
2422 : 2 : gfc_error ("SINK at %C not permitted as dependence-type "
2423 : : "for this directive");
2424 : 2 : goto error;
2425 : : }
2426 : 241 : if (gfc_match (": ") != MATCH_YES)
2427 : : {
2428 : 1 : gfc_error ("Expected %<:%> at %C");
2429 : 1 : goto error;
2430 : : }
2431 : 240 : if (m_it == MATCH_YES)
2432 : : {
2433 : 0 : gfc_error ("ITERATOR may not be combined with SINK "
2434 : : "at %C");
2435 : 0 : goto error;
2436 : : }
2437 : 240 : m = gfc_match_omp_doacross_sink (&c->lists[OMP_LIST_DEPEND],
2438 : : is_depend);
2439 : 240 : if (m == MATCH_YES)
2440 : 237 : continue;
2441 : 3 : goto error;
2442 : : }
2443 : : else
2444 : : m = MATCH_NO;
2445 : 683 : if (!(mask & OMP_CLAUSE_DEPEND))
2446 : : {
2447 : 0 : gfc_error ("Expected dependence-type SINK or SOURCE at %C");
2448 : 0 : goto error;
2449 : : }
2450 : 683 : head = NULL;
2451 : 683 : if (ns_iter)
2452 : 37 : gfc_current_ns = ns_iter;
2453 : 683 : if (m == MATCH_YES)
2454 : 683 : m = gfc_match_omp_variable_list (" : ",
2455 : : &c->lists[OMP_LIST_DEPEND],
2456 : : false, NULL, &head, true,
2457 : : false, &has_omp_all_memory);
2458 : 683 : if (m != MATCH_YES)
2459 : 2 : goto error;
2460 : 681 : gfc_current_ns = ns_curr;
2461 : 681 : if (has_omp_all_memory && depend_op != OMP_DEPEND_INOUT
2462 : 21 : && depend_op != OMP_DEPEND_OUT)
2463 : : {
2464 : 4 : gfc_error ("%<omp_all_memory%> used with DEPEND kind "
2465 : : "other than OUT or INOUT at %C");
2466 : 4 : goto error;
2467 : : }
2468 : 677 : gfc_omp_namelist *n;
2469 : 1382 : for (n = *head; n; n = n->next)
2470 : : {
2471 : 705 : n->u.depend_doacross_op = depend_op;
2472 : 705 : n->u2.ns = ns_iter;
2473 : 705 : if (ns_iter)
2474 : 36 : ns_iter->refs++;
2475 : : }
2476 : 677 : continue;
2477 : 677 : }
2478 : 1044 : if ((mask & OMP_CLAUSE_DETACH)
2479 : 162 : && !openacc
2480 : 127 : && !c->detach
2481 : 1044 : && gfc_match_omp_detach (&c->detach) == MATCH_YES)
2482 : 126 : continue;
2483 : 827 : if ((mask & OMP_CLAUSE_DETACH)
2484 : 36 : && openacc
2485 : 35 : && gfc_match ("detach ( ") == MATCH_YES
2486 : 827 : && gfc_match_omp_map_clause (&c->lists[OMP_LIST_MAP],
2487 : : OMP_MAP_DETACH, false,
2488 : : allow_derived))
2489 : 35 : continue;
2490 : 757 : if ((mask & OMP_CLAUSE_DEVICE)
2491 : 555 : && !openacc
2492 : 1034 : && ((m = gfc_match_dupl_check (!c->device, "device", true))
2493 : : != MATCH_NO))
2494 : : {
2495 : 251 : if (m == MATCH_ERROR)
2496 : 0 : goto error;
2497 : 251 : c->ancestor = false;
2498 : 251 : if (gfc_match ("device_num : ") == MATCH_YES)
2499 : : {
2500 : 16 : if (gfc_match ("%e )", &c->device) != MATCH_YES)
2501 : : {
2502 : 1 : gfc_error ("Expected integer expression at %C");
2503 : 1 : break;
2504 : : }
2505 : : }
2506 : 235 : else if (gfc_match ("ancestor : ") == MATCH_YES)
2507 : : {
2508 : 45 : bool has_requires = false;
2509 : 45 : c->ancestor = true;
2510 : 82 : for (gfc_namespace *ns = gfc_current_ns; ns; ns = ns->parent)
2511 : 80 : if (ns->omp_requires & OMP_REQ_REVERSE_OFFLOAD)
2512 : : {
2513 : : has_requires = true;
2514 : : break;
2515 : : }
2516 : 45 : if (!has_requires)
2517 : : {
2518 : 2 : gfc_error ("%<ancestor%> device modifier not "
2519 : : "preceded by %<requires%> directive "
2520 : : "with %<reverse_offload%> clause at %C");
2521 : 2 : break;
2522 : : }
2523 : 43 : locus old_loc2 = gfc_current_locus;
2524 : 43 : if (gfc_match ("%e )", &c->device) == MATCH_YES)
2525 : : {
2526 : 43 : int device = 0;
2527 : 43 : if (!gfc_extract_int (c->device, &device) && device != 1)
2528 : : {
2529 : 1 : gfc_current_locus = old_loc2;
2530 : 1 : gfc_error ("the %<device%> clause expression must "
2531 : : "evaluate to %<1%> at %C");
2532 : 1 : break;
2533 : : }
2534 : : }
2535 : : else
2536 : : {
2537 : 0 : gfc_error ("Expected integer expression at %C");
2538 : 0 : break;
2539 : : }
2540 : : }
2541 : 190 : else if (gfc_match ("%e )", &c->device) != MATCH_YES)
2542 : : {
2543 : 13 : gfc_error ("Expected integer expression or a single device-"
2544 : : "modifier %<device_num%> or %<ancestor%> at %C");
2545 : 13 : break;
2546 : : }
2547 : 234 : continue;
2548 : 234 : }
2549 : 782 : if ((mask & OMP_CLAUSE_DEVICE)
2550 : 304 : && openacc
2551 : 278 : && gfc_match ("device ( ") == MATCH_YES
2552 : 783 : && gfc_match_omp_map_clause (&c->lists[OMP_LIST_MAP],
2553 : : OMP_MAP_FORCE_TO, true,
2554 : : allow_derived))
2555 : 276 : continue;
2556 : 261 : if ((mask & OMP_CLAUSE_DEVICEPTR)
2557 : 80 : && gfc_match ("deviceptr ( ") == MATCH_YES
2558 : 263 : && gfc_match_omp_map_clause (&c->lists[OMP_LIST_MAP],
2559 : : OMP_MAP_FORCE_DEVICEPTR, false,
2560 : : allow_derived))
2561 : 31 : continue;
2562 : 247 : if ((mask & OMP_CLAUSE_DEVICE_TYPE)
2563 : 199 : && gfc_match ("device_type ( ") == MATCH_YES)
2564 : : {
2565 : 49 : if (gfc_match ("host") == MATCH_YES)
2566 : 16 : c->device_type = OMP_DEVICE_TYPE_HOST;
2567 : 33 : else if (gfc_match ("nohost") == MATCH_YES)
2568 : 16 : c->device_type = OMP_DEVICE_TYPE_NOHOST;
2569 : 17 : else if (gfc_match ("any") == MATCH_YES)
2570 : 16 : c->device_type = OMP_DEVICE_TYPE_ANY;
2571 : : else
2572 : : {
2573 : 1 : gfc_error ("Expected HOST, NOHOST or ANY at %C");
2574 : 1 : break;
2575 : : }
2576 : 48 : if (gfc_match (" )") != MATCH_YES)
2577 : : break;
2578 : 48 : continue;
2579 : : }
2580 : 196 : if ((mask & OMP_CLAUSE_DEVICE_RESIDENT)
2581 : 197 : && gfc_match_omp_variable_list
2582 : 47 : ("device_resident (",
2583 : : &c->lists[OMP_LIST_DEVICE_RESIDENT], true) == MATCH_YES)
2584 : 46 : continue;
2585 : 104 : if ((mask & OMP_CLAUSE_DIST_SCHEDULE)
2586 : 97 : && c->dist_sched_kind == OMP_SCHED_NONE
2587 : 201 : && gfc_match ("dist_schedule ( static") == MATCH_YES)
2588 : : {
2589 : 97 : m = MATCH_NO;
2590 : 97 : c->dist_sched_kind = OMP_SCHED_STATIC;
2591 : 97 : m = gfc_match (" , %e )", &c->dist_chunk_size);
2592 : 97 : if (m != MATCH_YES)
2593 : 14 : m = gfc_match_char (')');
2594 : 14 : if (m != MATCH_YES)
2595 : : {
2596 : 0 : c->dist_sched_kind = OMP_SCHED_NONE;
2597 : 0 : gfc_current_locus = old_loc;
2598 : : }
2599 : : else
2600 : 97 : continue;
2601 : : }
2602 : : break;
2603 : 57 : case 'e':
2604 : 57 : if ((mask & OMP_CLAUSE_ENTER))
2605 : : {
2606 : 57 : m = gfc_match_omp_to_link ("enter (", &c->lists[OMP_LIST_ENTER]);
2607 : 57 : if (m == MATCH_ERROR)
2608 : 0 : goto error;
2609 : 57 : if (m == MATCH_YES)
2610 : 57 : continue;
2611 : : }
2612 : : break;
2613 : 2131 : case 'f':
2614 : 2180 : if ((mask & OMP_CLAUSE_FAIL)
2615 : 2131 : && (m = gfc_match_dupl_check (c->fail == OMP_MEMORDER_UNSET,
2616 : : "fail", true)) != MATCH_NO)
2617 : : {
2618 : 58 : if (m == MATCH_ERROR)
2619 : 3 : goto error;
2620 : 55 : if (gfc_match ("seq_cst") == MATCH_YES)
2621 : 6 : c->fail = OMP_MEMORDER_SEQ_CST;
2622 : 49 : else if (gfc_match ("acquire") == MATCH_YES)
2623 : 14 : c->fail = OMP_MEMORDER_ACQUIRE;
2624 : 35 : else if (gfc_match ("relaxed") == MATCH_YES)
2625 : 30 : c->fail = OMP_MEMORDER_RELAXED;
2626 : : else
2627 : : {
2628 : 5 : gfc_error ("Expected SEQ_CST, ACQUIRE or RELAXED at %C");
2629 : 5 : break;
2630 : : }
2631 : 50 : if (gfc_match (" )") != MATCH_YES)
2632 : 1 : goto error;
2633 : 49 : continue;
2634 : : }
2635 : 2116 : if ((mask & OMP_CLAUSE_FILTER)
2636 : 2073 : && (m = gfc_match_dupl_check (!c->filter, "filter", true,
2637 : : &c->filter)) != MATCH_NO)
2638 : : {
2639 : 44 : if (m == MATCH_ERROR)
2640 : 1 : goto error;
2641 : 43 : continue;
2642 : : }
2643 : 2093 : if ((mask & OMP_CLAUSE_FINAL)
2644 : 2029 : && (m = gfc_match_dupl_check (!c->final_expr, "final", true,
2645 : : &c->final_expr)) != MATCH_NO)
2646 : : {
2647 : 64 : if (m == MATCH_ERROR)
2648 : 0 : goto error;
2649 : 64 : continue;
2650 : : }
2651 : 1981 : if ((mask & OMP_CLAUSE_FINALIZE)
2652 : 1965 : && (m = gfc_match_dupl_check (!c->finalize, "finalize"))
2653 : : != MATCH_NO)
2654 : : {
2655 : 16 : if (m == MATCH_ERROR)
2656 : 0 : goto error;
2657 : 16 : c->finalize = true;
2658 : 16 : needs_space = true;
2659 : 16 : continue;
2660 : : }
2661 : 2893 : if ((mask & OMP_CLAUSE_FIRSTPRIVATE)
2662 : 1949 : && gfc_match_omp_variable_list ("firstprivate (",
2663 : : &c->lists[OMP_LIST_FIRSTPRIVATE],
2664 : : true) == MATCH_YES)
2665 : 944 : continue;
2666 : 2003 : if ((mask & OMP_CLAUSE_FROM)
2667 : 1005 : && gfc_match_motion_var_list ("from (", &c->lists[OMP_LIST_FROM],
2668 : : &head) == MATCH_YES)
2669 : 998 : continue;
2670 : : break;
2671 : 1170 : case 'g':
2672 : 2292 : if ((mask & OMP_CLAUSE_GANG)
2673 : 1170 : && (m = gfc_match_dupl_check (!c->gang, "gang")) != MATCH_NO)
2674 : : {
2675 : 1127 : if (m == MATCH_ERROR)
2676 : 0 : goto error;
2677 : 1127 : c->gang = true;
2678 : 1127 : m = match_oacc_clause_gwv (c, GOMP_DIM_GANG);
2679 : 1127 : if (m == MATCH_ERROR)
2680 : : {
2681 : 5 : gfc_current_locus = old_loc;
2682 : 5 : break;
2683 : : }
2684 : 1122 : else if (m == MATCH_NO)
2685 : 916 : needs_space = true;
2686 : 1122 : continue;
2687 : : }
2688 : 86 : if ((mask & OMP_CLAUSE_GRAINSIZE)
2689 : 43 : && (m = gfc_match_dupl_check (!c->grainsize, "grainsize", true))
2690 : : != MATCH_NO)
2691 : : {
2692 : 43 : if (m == MATCH_ERROR)
2693 : 0 : goto error;
2694 : 43 : if (gfc_match ("strict : ") == MATCH_YES)
2695 : 6 : c->grainsize_strict = true;
2696 : 43 : if (gfc_match (" %e )", &c->grainsize) != MATCH_YES)
2697 : 0 : goto error;
2698 : 43 : continue;
2699 : : }
2700 : : break;
2701 : 415 : case 'h':
2702 : 450 : if ((mask & OMP_CLAUSE_HAS_DEVICE_ADDR)
2703 : 450 : && gfc_match_omp_variable_list
2704 : 35 : ("has_device_addr (", &c->lists[OMP_LIST_HAS_DEVICE_ADDR],
2705 : : false, NULL, NULL, true) == MATCH_YES)
2706 : 35 : continue;
2707 : 423 : if ((mask & OMP_CLAUSE_HINT)
2708 : 380 : && (m = gfc_match_dupl_check (!c->hint, "hint", true, &c->hint))
2709 : : != MATCH_NO)
2710 : : {
2711 : 43 : if (m == MATCH_ERROR)
2712 : 0 : goto error;
2713 : 43 : continue;
2714 : : }
2715 : 337 : if ((mask & OMP_CLAUSE_ASSUMPTIONS)
2716 : 337 : && gfc_match ("holds ( ") == MATCH_YES)
2717 : : {
2718 : 18 : gfc_expr *e;
2719 : 18 : if (gfc_match ("%e )", &e) != MATCH_YES)
2720 : 0 : goto error;
2721 : 18 : if (c->assume == NULL)
2722 : 11 : c->assume = gfc_get_omp_assumptions ();
2723 : 18 : gfc_expr_list *el = XCNEW (gfc_expr_list);
2724 : 18 : el->expr = e;
2725 : 18 : el->next = c->assume->holds;
2726 : 18 : c->assume->holds = el;
2727 : 18 : continue;
2728 : 18 : }
2729 : 637 : if ((mask & OMP_CLAUSE_HOST_SELF)
2730 : 319 : && gfc_match ("host ( ") == MATCH_YES
2731 : 638 : && gfc_match_omp_map_clause (&c->lists[OMP_LIST_MAP],
2732 : : OMP_MAP_FORCE_FROM, true,
2733 : : allow_derived))
2734 : 318 : continue;
2735 : : break;
2736 : 1503 : case 'i':
2737 : 1526 : if ((mask & OMP_CLAUSE_IF_PRESENT)
2738 : 1503 : && (m = gfc_match_dupl_check (!c->if_present, "if_present"))
2739 : : != MATCH_NO)
2740 : : {
2741 : 23 : if (m == MATCH_ERROR)
2742 : 0 : goto error;
2743 : 23 : c->if_present = true;
2744 : 23 : needs_space = true;
2745 : 23 : continue;
2746 : : }
2747 : 1480 : if ((mask & OMP_CLAUSE_IF)
2748 : 1480 : && (m = gfc_match_dupl_check (!c->if_expr, "if", true))
2749 : : != MATCH_NO)
2750 : : {
2751 : 1045 : if (m == MATCH_ERROR)
2752 : 15 : goto error;
2753 : 1030 : if (!openacc)
2754 : : {
2755 : : /* This should match the enum gfc_omp_if_kind order. */
2756 : : static const char *ifs[OMP_IF_LAST] = {
2757 : : "cancel : %e )",
2758 : : "parallel : %e )",
2759 : : "simd : %e )",
2760 : : "task : %e )",
2761 : : "taskloop : %e )",
2762 : : "target : %e )",
2763 : : "target data : %e )",
2764 : : "target update : %e )",
2765 : : "target enter data : %e )",
2766 : : "target exit data : %e )" };
2767 : : int i;
2768 : 4753 : for (i = 0; i < OMP_IF_LAST; i++)
2769 : 4363 : if (c->if_exprs[i] == NULL
2770 : 4363 : && gfc_match (ifs[i], &c->if_exprs[i]) == MATCH_YES)
2771 : : break;
2772 : 528 : if (i < OMP_IF_LAST)
2773 : 138 : continue;
2774 : : }
2775 : 892 : if (gfc_match (" %e )", &c->if_expr) == MATCH_YES)
2776 : 888 : continue;
2777 : 4 : goto error;
2778 : : }
2779 : 552 : if ((mask & OMP_CLAUSE_IN_REDUCTION)
2780 : 435 : && gfc_match_omp_clause_reduction (pc, c, openacc, allow_derived,
2781 : : openmp_target) == MATCH_YES)
2782 : 117 : continue;
2783 : 343 : if ((mask & OMP_CLAUSE_INBRANCH)
2784 : 318 : && (m = gfc_match_dupl_check (!c->inbranch && !c->notinbranch,
2785 : : "inbranch")) != MATCH_NO)
2786 : : {
2787 : 25 : if (m == MATCH_ERROR)
2788 : 0 : goto error;
2789 : 25 : c->inbranch = needs_space = true;
2790 : 25 : continue;
2791 : : }
2792 : 480 : if ((mask & OMP_CLAUSE_INDEPENDENT)
2793 : 293 : && (m = gfc_match_dupl_check (!c->independent, "independent"))
2794 : : != MATCH_NO)
2795 : : {
2796 : 187 : if (m == MATCH_ERROR)
2797 : 0 : goto error;
2798 : 187 : c->independent = true;
2799 : 187 : needs_space = true;
2800 : 187 : continue;
2801 : : }
2802 : 205 : if ((mask & OMP_CLAUSE_IS_DEVICE_PTR)
2803 : 205 : && gfc_match_omp_variable_list
2804 : 99 : ("is_device_ptr (",
2805 : : &c->lists[OMP_LIST_IS_DEVICE_PTR], false) == MATCH_YES)
2806 : 99 : continue;
2807 : : break;
2808 : 2274 : case 'l':
2809 : 2274 : if ((mask & OMP_CLAUSE_LASTPRIVATE)
2810 : 2274 : && gfc_match ("lastprivate ( ") == MATCH_YES)
2811 : : {
2812 : 1389 : bool conditional = gfc_match ("conditional : ") == MATCH_YES;
2813 : 1389 : head = NULL;
2814 : 1389 : if (gfc_match_omp_variable_list ("",
2815 : : &c->lists[OMP_LIST_LASTPRIVATE],
2816 : : false, NULL, &head) == MATCH_YES)
2817 : : {
2818 : 1389 : gfc_omp_namelist *n;
2819 : 3653 : for (n = *head; n; n = n->next)
2820 : 2264 : n->u.lastprivate_conditional = conditional;
2821 : 1389 : continue;
2822 : 1389 : }
2823 : 0 : gfc_current_locus = old_loc;
2824 : 0 : break;
2825 : : }
2826 : 885 : end_colon = false;
2827 : 885 : head = NULL;
2828 : 885 : if ((mask & OMP_CLAUSE_LINEAR)
2829 : 885 : && gfc_match ("linear (") == MATCH_YES)
2830 : : {
2831 : 840 : bool old_linear_modifier = false;
2832 : 840 : gfc_omp_linear_op linear_op = OMP_LINEAR_DEFAULT;
2833 : 840 : gfc_expr *step = NULL;
2834 : :
2835 : 840 : if (gfc_match_omp_variable_list (" ref (",
2836 : : &c->lists[OMP_LIST_LINEAR],
2837 : : false, NULL, &head)
2838 : : == MATCH_YES)
2839 : : {
2840 : : linear_op = OMP_LINEAR_REF;
2841 : : old_linear_modifier = true;
2842 : : }
2843 : 811 : else if (gfc_match_omp_variable_list (" val (",
2844 : : &c->lists[OMP_LIST_LINEAR],
2845 : : false, NULL, &head)
2846 : : == MATCH_YES)
2847 : : {
2848 : : linear_op = OMP_LINEAR_VAL;
2849 : : old_linear_modifier = true;
2850 : : }
2851 : 799 : else if (gfc_match_omp_variable_list (" uval (",
2852 : : &c->lists[OMP_LIST_LINEAR],
2853 : : false, NULL, &head)
2854 : : == MATCH_YES)
2855 : : {
2856 : : linear_op = OMP_LINEAR_UVAL;
2857 : : old_linear_modifier = true;
2858 : : }
2859 : 789 : else if (gfc_match_omp_variable_list ("",
2860 : : &c->lists[OMP_LIST_LINEAR],
2861 : : false, &end_colon, &head)
2862 : : == MATCH_YES)
2863 : : linear_op = OMP_LINEAR_DEFAULT;
2864 : : else
2865 : : {
2866 : 2 : gfc_current_locus = old_loc;
2867 : 2 : break;
2868 : : }
2869 : : if (linear_op != OMP_LINEAR_DEFAULT)
2870 : : {
2871 : 51 : if (gfc_match (" :") == MATCH_YES)
2872 : 31 : end_colon = true;
2873 : 20 : else if (gfc_match (" )") != MATCH_YES)
2874 : : {
2875 : 0 : gfc_free_omp_namelist (*head, false, false, false);
2876 : 0 : gfc_current_locus = old_loc;
2877 : 0 : *head = NULL;
2878 : 0 : break;
2879 : : }
2880 : : }
2881 : 838 : gfc_gobble_whitespace ();
2882 : 838 : if (old_linear_modifier && end_colon)
2883 : : {
2884 : 31 : if (gfc_match (" %e )", &step) != MATCH_YES)
2885 : : {
2886 : 1 : gfc_free_omp_namelist (*head, false, false, false);
2887 : 1 : gfc_current_locus = old_loc;
2888 : 1 : *head = NULL;
2889 : 5 : goto error;
2890 : : }
2891 : : }
2892 : 807 : else if (end_colon)
2893 : : {
2894 : 710 : bool has_error = false;
2895 : : bool has_modifiers = false;
2896 : : bool has_step = false;
2897 : 710 : bool duplicate_step = false;
2898 : 710 : bool duplicate_mod = false;
2899 : 710 : while (true)
2900 : : {
2901 : 710 : old_loc = gfc_current_locus;
2902 : 710 : bool close_paren = gfc_match ("val )") == MATCH_YES;
2903 : 710 : if (close_paren || gfc_match ("val , ") == MATCH_YES)
2904 : : {
2905 : 16 : if (linear_op != OMP_LINEAR_DEFAULT)
2906 : : {
2907 : : duplicate_mod = true;
2908 : : break;
2909 : : }
2910 : 15 : linear_op = OMP_LINEAR_VAL;
2911 : 15 : has_modifiers = true;
2912 : 15 : if (close_paren)
2913 : : break;
2914 : 10 : continue;
2915 : : }
2916 : 694 : close_paren = gfc_match ("uval )") == MATCH_YES;
2917 : 694 : if (close_paren || gfc_match ("uval , ") == MATCH_YES)
2918 : : {
2919 : 6 : if (linear_op != OMP_LINEAR_DEFAULT)
2920 : : {
2921 : : duplicate_mod = true;
2922 : : break;
2923 : : }
2924 : 6 : linear_op = OMP_LINEAR_UVAL;
2925 : 6 : has_modifiers = true;
2926 : 6 : if (close_paren)
2927 : : break;
2928 : 2 : continue;
2929 : : }
2930 : 688 : close_paren = gfc_match ("ref )") == MATCH_YES;
2931 : 688 : if (close_paren || gfc_match ("ref , ") == MATCH_YES)
2932 : : {
2933 : 15 : if (linear_op != OMP_LINEAR_DEFAULT)
2934 : : {
2935 : : duplicate_mod = true;
2936 : : break;
2937 : : }
2938 : 14 : linear_op = OMP_LINEAR_REF;
2939 : 14 : has_modifiers = true;
2940 : 14 : if (close_paren)
2941 : : break;
2942 : 7 : continue;
2943 : : }
2944 : 673 : close_paren = (gfc_match ("step ( %e ) )", &step)
2945 : : == MATCH_YES);
2946 : 684 : if (close_paren
2947 : 673 : || gfc_match ("step ( %e ) , ", &step) == MATCH_YES)
2948 : : {
2949 : 38 : if (has_step)
2950 : : {
2951 : : duplicate_step = true;
2952 : : break;
2953 : : }
2954 : 37 : has_modifiers = has_step = true;
2955 : 37 : if (close_paren)
2956 : : break;
2957 : 11 : continue;
2958 : : }
2959 : 635 : if (!has_modifiers
2960 : 635 : && gfc_match ("%e )", &step) == MATCH_YES)
2961 : : {
2962 : 635 : if ((step->expr_type == EXPR_FUNCTION
2963 : 634 : || step->expr_type == EXPR_VARIABLE)
2964 : 31 : && strcmp (step->symtree->name, "step") == 0)
2965 : : {
2966 : 1 : gfc_current_locus = old_loc;
2967 : 1 : gfc_match ("step (");
2968 : 1 : has_error = true;
2969 : : }
2970 : : break;
2971 : : }
2972 : : has_error = true;
2973 : : break;
2974 : : }
2975 : 680 : if (duplicate_mod || duplicate_step)
2976 : : {
2977 : 3 : gfc_error ("Multiple %qs modifiers specified at %C",
2978 : : duplicate_mod ? "linear" : "step");
2979 : 3 : has_error = true;
2980 : : }
2981 : 680 : if (has_error)
2982 : : {
2983 : 4 : gfc_free_omp_namelist (*head, false, false, false);
2984 : 4 : *head = NULL;
2985 : 4 : goto error;
2986 : : }
2987 : : }
2988 : 833 : if (step == NULL)
2989 : : {
2990 : 134 : step = gfc_get_constant_expr (BT_INTEGER,
2991 : : gfc_default_integer_kind,
2992 : : &old_loc);
2993 : 134 : mpz_set_si (step->value.integer, 1);
2994 : : }
2995 : 833 : (*head)->expr = step;
2996 : 833 : if (linear_op != OMP_LINEAR_DEFAULT || old_linear_modifier)
2997 : 176 : for (gfc_omp_namelist *n = *head; n; n = n->next)
2998 : : {
2999 : 94 : n->u.linear.op = linear_op;
3000 : 94 : n->u.linear.old_modifier = old_linear_modifier;
3001 : : }
3002 : 833 : continue;
3003 : 833 : }
3004 : 49 : if ((mask & OMP_CLAUSE_LINK)
3005 : 45 : && openacc
3006 : 53 : && (gfc_match_oacc_clause_link ("link (",
3007 : : &c->lists[OMP_LIST_LINK])
3008 : : == MATCH_YES))
3009 : 4 : continue;
3010 : 78 : else if ((mask & OMP_CLAUSE_LINK)
3011 : 41 : && !openacc
3012 : 78 : && (gfc_match_omp_to_link ("link (",
3013 : : &c->lists[OMP_LIST_LINK])
3014 : : == MATCH_YES))
3015 : 37 : continue;
3016 : : break;
3017 : 3965 : case 'm':
3018 : 3965 : if ((mask & OMP_CLAUSE_MAP)
3019 : 3965 : && gfc_match ("map ( ") == MATCH_YES)
3020 : : {
3021 : 3884 : locus old_loc2 = gfc_current_locus;
3022 : 3884 : int always_modifier = 0;
3023 : 3884 : int close_modifier = 0;
3024 : 3884 : int present_modifier = 0;
3025 : 3884 : locus second_always_locus = old_loc2;
3026 : 3884 : locus second_close_locus = old_loc2;
3027 : 3884 : locus second_present_locus = old_loc2;
3028 : :
3029 : 4366 : for (;;)
3030 : : {
3031 : 4125 : locus current_locus = gfc_current_locus;
3032 : 4125 : if (gfc_match ("always ") == MATCH_YES)
3033 : : {
3034 : 125 : if (always_modifier++ == 1)
3035 : 5 : second_always_locus = current_locus;
3036 : : }
3037 : 4000 : else if (gfc_match ("close ") == MATCH_YES)
3038 : : {
3039 : 65 : if (close_modifier++ == 1)
3040 : 5 : second_close_locus = current_locus;
3041 : : }
3042 : 3935 : else if (gfc_match ("present ") == MATCH_YES)
3043 : : {
3044 : 51 : if (present_modifier++ == 1)
3045 : 4 : second_present_locus = current_locus;
3046 : : }
3047 : : else
3048 : : break;
3049 : 241 : gfc_match (", ");
3050 : 241 : }
3051 : :
3052 : 3884 : gfc_omp_map_op map_op = OMP_MAP_TOFROM;
3053 : 3884 : int always_present_modifier
3054 : 3884 : = always_modifier && present_modifier;
3055 : :
3056 : 3884 : if (gfc_match ("alloc : ") == MATCH_YES)
3057 : 519 : map_op = (present_modifier ? OMP_MAP_PRESENT_ALLOC
3058 : : : OMP_MAP_ALLOC);
3059 : 3365 : else if (gfc_match ("tofrom : ") == MATCH_YES)
3060 : 483 : map_op = (always_present_modifier ? OMP_MAP_ALWAYS_PRESENT_TOFROM
3061 : 479 : : present_modifier ? OMP_MAP_PRESENT_TOFROM
3062 : 475 : : always_modifier ? OMP_MAP_ALWAYS_TOFROM
3063 : : : OMP_MAP_TOFROM);
3064 : 2882 : else if (gfc_match ("to : ") == MATCH_YES)
3065 : 1225 : map_op = (always_present_modifier ? OMP_MAP_ALWAYS_PRESENT_TO
3066 : 1221 : : present_modifier ? OMP_MAP_PRESENT_TO
3067 : 1210 : : always_modifier ? OMP_MAP_ALWAYS_TO
3068 : : : OMP_MAP_TO);
3069 : 1657 : else if (gfc_match ("from : ") == MATCH_YES)
3070 : 1317 : map_op = (always_present_modifier ? OMP_MAP_ALWAYS_PRESENT_FROM
3071 : 1313 : : present_modifier ? OMP_MAP_PRESENT_FROM
3072 : 1309 : : always_modifier ? OMP_MAP_ALWAYS_FROM
3073 : : : OMP_MAP_FROM);
3074 : 340 : else if (gfc_match ("release : ") == MATCH_YES)
3075 : : map_op = OMP_MAP_RELEASE;
3076 : 326 : else if (gfc_match ("delete : ") == MATCH_YES)
3077 : : map_op = OMP_MAP_DELETE;
3078 : : else
3079 : : {
3080 : 282 : gfc_current_locus = old_loc2;
3081 : 282 : always_modifier = 0;
3082 : 282 : close_modifier = 0;
3083 : : }
3084 : :
3085 : 3884 : if (always_modifier > 1)
3086 : : {
3087 : 5 : gfc_error ("too many %<always%> modifiers at %L",
3088 : : &second_always_locus);
3089 : 21 : break;
3090 : : }
3091 : 3879 : if (close_modifier > 1)
3092 : : {
3093 : 4 : gfc_error ("too many %<close%> modifiers at %L",
3094 : : &second_close_locus);
3095 : 4 : break;
3096 : : }
3097 : 3875 : if (present_modifier > 1)
3098 : : {
3099 : 4 : gfc_error ("too many %<present%> modifiers at %L",
3100 : : &second_present_locus);
3101 : 4 : break;
3102 : : }
3103 : :
3104 : 3871 : head = NULL;
3105 : 3871 : if (gfc_match_omp_variable_list ("", &c->lists[OMP_LIST_MAP],
3106 : : false, NULL, &head,
3107 : : true, true) == MATCH_YES)
3108 : : {
3109 : 3868 : gfc_omp_namelist *n;
3110 : 8809 : for (n = *head; n; n = n->next)
3111 : 4941 : n->u.map_op = map_op;
3112 : 3868 : continue;
3113 : 3868 : }
3114 : 3 : gfc_current_locus = old_loc;
3115 : 3 : break;
3116 : : }
3117 : 115 : if ((mask & OMP_CLAUSE_MERGEABLE)
3118 : 81 : && (m = gfc_match_dupl_check (!c->mergeable, "mergeable"))
3119 : : != MATCH_NO)
3120 : : {
3121 : 34 : if (m == MATCH_ERROR)
3122 : 0 : goto error;
3123 : 34 : c->mergeable = needs_space = true;
3124 : 34 : continue;
3125 : : }
3126 : 89 : if ((mask & OMP_CLAUSE_MESSAGE)
3127 : 47 : && (m = gfc_match_dupl_check (!c->message, "message", true,
3128 : : &c->message)) != MATCH_NO)
3129 : : {
3130 : 47 : if (m == MATCH_ERROR)
3131 : 5 : goto error;
3132 : 42 : continue;
3133 : : }
3134 : : break;
3135 : 2861 : case 'n':
3136 : 2911 : if ((mask & OMP_CLAUSE_NO_CREATE)
3137 : 1341 : && gfc_match ("no_create ( ") == MATCH_YES
3138 : 2911 : && gfc_match_omp_map_clause (&c->lists[OMP_LIST_MAP],
3139 : : OMP_MAP_IF_PRESENT, true,
3140 : : allow_derived))
3141 : 50 : continue;
3142 : 2823 : if ((mask & OMP_CLAUSE_ASSUMPTIONS)
3143 : 2831 : && (m = gfc_match_dupl_check (!c->assume
3144 : 20 : || !c->assume->no_openmp_routines,
3145 : : "no_openmp_routines")) == MATCH_YES)
3146 : : {
3147 : 12 : if (m == MATCH_ERROR)
3148 : : goto error;
3149 : 12 : if (c->assume == NULL)
3150 : 12 : c->assume = gfc_get_omp_assumptions ();
3151 : 12 : c->assume->no_openmp_routines = needs_space = true;
3152 : 12 : continue;
3153 : : }
3154 : 2801 : if ((mask & OMP_CLAUSE_ASSUMPTIONS)
3155 : 2807 : && (m = gfc_match_dupl_check (!c->assume || !c->assume->no_openmp,
3156 : : "no_openmp")) == MATCH_YES)
3157 : : {
3158 : 2 : if (m == MATCH_ERROR)
3159 : : goto error;
3160 : 2 : if (c->assume == NULL)
3161 : 2 : c->assume = gfc_get_omp_assumptions ();
3162 : 2 : c->assume->no_openmp = needs_space = true;
3163 : 2 : continue;
3164 : : }
3165 : 2803 : if ((mask & OMP_CLAUSE_ASSUMPTIONS)
3166 : 2803 : && (m = gfc_match_dupl_check (!c->assume
3167 : 6 : || !c->assume->no_parallelism,
3168 : : "no_parallelism")) == MATCH_YES)
3169 : : {
3170 : 6 : if (m == MATCH_ERROR)
3171 : : goto error;
3172 : 6 : if (c->assume == NULL)
3173 : 6 : c->assume = gfc_get_omp_assumptions ();
3174 : 6 : c->assume->no_parallelism = needs_space = true;
3175 : 6 : continue;
3176 : : }
3177 : 2804 : if ((mask & OMP_CLAUSE_NOGROUP)
3178 : 2791 : && (m = gfc_match_dupl_check (!c->nogroup, "nogroup"))
3179 : : != MATCH_NO)
3180 : : {
3181 : 13 : if (m == MATCH_ERROR)
3182 : 0 : goto error;
3183 : 13 : c->nogroup = needs_space = true;
3184 : 13 : continue;
3185 : : }
3186 : 2928 : if ((mask & OMP_CLAUSE_NOHOST)
3187 : 2778 : && (m = gfc_match_dupl_check (!c->nohost, "nohost")) != MATCH_NO)
3188 : : {
3189 : 151 : if (m == MATCH_ERROR)
3190 : 1 : goto error;
3191 : 150 : c->nohost = needs_space = true;
3192 : 150 : continue;
3193 : : }
3194 : 2669 : if ((mask & OMP_CLAUSE_NOTEMPORAL)
3195 : 2627 : && gfc_match_omp_variable_list ("nontemporal (",
3196 : : &c->lists[OMP_LIST_NONTEMPORAL],
3197 : : true) == MATCH_YES)
3198 : 42 : continue;
3199 : 2614 : if ((mask & OMP_CLAUSE_NOTINBRANCH)
3200 : 2585 : && (m = gfc_match_dupl_check (!c->notinbranch && !c->inbranch,
3201 : : "notinbranch")) != MATCH_NO)
3202 : : {
3203 : 30 : if (m == MATCH_ERROR)
3204 : 1 : goto error;
3205 : 29 : c->notinbranch = needs_space = true;
3206 : 29 : continue;
3207 : : }
3208 : 2671 : if ((mask & OMP_CLAUSE_NOWAIT)
3209 : 2555 : && (m = gfc_match_dupl_check (!c->nowait, "nowait")) != MATCH_NO)
3210 : : {
3211 : 118 : if (m == MATCH_ERROR)
3212 : 2 : goto error;
3213 : 116 : c->nowait = needs_space = true;
3214 : 116 : continue;
3215 : : }
3216 : 3119 : if ((mask & OMP_CLAUSE_NUM_GANGS)
3217 : 2437 : && (m = gfc_match_dupl_check (!c->num_gangs_expr, "num_gangs",
3218 : : true)) != MATCH_NO)
3219 : : {
3220 : 686 : if (m == MATCH_ERROR)
3221 : 2 : goto error;
3222 : 684 : if (gfc_match (" %e )", &c->num_gangs_expr) != MATCH_YES)
3223 : 2 : goto error;
3224 : 682 : continue;
3225 : : }
3226 : 1786 : if ((mask & OMP_CLAUSE_NUM_TASKS)
3227 : 1751 : && (m = gfc_match_dupl_check (!c->num_tasks, "num_tasks", true))
3228 : : != MATCH_NO)
3229 : : {
3230 : 35 : if (m == MATCH_ERROR)
3231 : 0 : goto error;
3232 : 35 : if (gfc_match ("strict : ") == MATCH_YES)
3233 : 6 : c->num_tasks_strict = true;
3234 : 35 : if (gfc_match (" %e )", &c->num_tasks) != MATCH_YES)
3235 : 0 : goto error;
3236 : 35 : continue;
3237 : : }
3238 : 1843 : if ((mask & OMP_CLAUSE_NUM_TEAMS)
3239 : 1716 : && (m = gfc_match_dupl_check (!c->num_teams_upper, "num_teams",
3240 : : true)) != MATCH_NO)
3241 : : {
3242 : 127 : if (m == MATCH_ERROR)
3243 : 0 : goto error;
3244 : 127 : if (gfc_match ("%e ", &c->num_teams_upper) != MATCH_YES)
3245 : 0 : goto error;
3246 : 127 : if (gfc_peek_ascii_char () == ':')
3247 : : {
3248 : 21 : c->num_teams_lower = c->num_teams_upper;
3249 : 21 : c->num_teams_upper = NULL;
3250 : 21 : if (gfc_match (": %e ", &c->num_teams_upper) != MATCH_YES)
3251 : 0 : goto error;
3252 : : }
3253 : 127 : if (gfc_match (") ") != MATCH_YES)
3254 : 0 : goto error;
3255 : 127 : continue;
3256 : : }
3257 : 2538 : if ((mask & OMP_CLAUSE_NUM_THREADS)
3258 : 1589 : && (m = gfc_match_dupl_check (!c->num_threads, "num_threads", true,
3259 : : &c->num_threads)) != MATCH_NO)
3260 : : {
3261 : 949 : if (m == MATCH_ERROR)
3262 : 0 : goto error;
3263 : 949 : continue;
3264 : : }
3265 : 1239 : if ((mask & OMP_CLAUSE_NUM_WORKERS)
3266 : 640 : && (m = gfc_match_dupl_check (!c->num_workers_expr, "num_workers",
3267 : : true, &c->num_workers_expr))
3268 : : != MATCH_NO)
3269 : : {
3270 : 603 : if (m == MATCH_ERROR)
3271 : 4 : goto error;
3272 : 599 : continue;
3273 : : }
3274 : : break;
3275 : 587 : case 'o':
3276 : 821 : if ((mask & OMP_CLAUSE_ORDER)
3277 : 587 : && (m = gfc_match_dupl_check (!c->order_concurrent, "order ("))
3278 : : != MATCH_NO)
3279 : : {
3280 : 245 : if (m == MATCH_ERROR)
3281 : 8 : goto error;
3282 : 237 : if (gfc_match (" reproducible : concurrent )") == MATCH_YES)
3283 : 55 : c->order_reproducible = true;
3284 : 182 : else if (gfc_match (" concurrent )") == MATCH_YES)
3285 : : ;
3286 : 50 : else if (gfc_match (" unconstrained : concurrent )") == MATCH_YES)
3287 : 47 : c->order_unconstrained = true;
3288 : : else
3289 : : {
3290 : 3 : gfc_error ("Expected ORDER(CONCURRENT) at %C "
3291 : : "with optional %<reproducible%> or "
3292 : : "%<unconstrained%> modifier");
3293 : 3 : goto error;
3294 : : }
3295 : 234 : c->order_concurrent = true;
3296 : 234 : continue;
3297 : : }
3298 : 342 : if ((mask & OMP_CLAUSE_ORDERED)
3299 : 342 : && (m = gfc_match_dupl_check (!c->ordered, "ordered"))
3300 : : != MATCH_NO)
3301 : : {
3302 : 339 : if (m == MATCH_ERROR)
3303 : 0 : goto error;
3304 : 339 : gfc_expr *cexpr = NULL;
3305 : 339 : m = gfc_match (" ( %e )", &cexpr);
3306 : :
3307 : 339 : c->ordered = true;
3308 : 339 : if (m == MATCH_YES)
3309 : : {
3310 : 140 : int ordered = 0;
3311 : 140 : if (gfc_extract_int (cexpr, &ordered, -1))
3312 : 0 : ordered = 0;
3313 : 140 : else if (ordered <= 0)
3314 : : {
3315 : 0 : gfc_error_now ("ORDERED clause argument not"
3316 : : " constant positive integer at %C");
3317 : 0 : ordered = 0;
3318 : : }
3319 : 140 : c->orderedc = ordered;
3320 : 140 : gfc_free_expr (cexpr);
3321 : 140 : continue;
3322 : 140 : }
3323 : :
3324 : 199 : needs_space = true;
3325 : 199 : continue;
3326 : 199 : }
3327 : : break;
3328 : 2405 : case 'p':
3329 : 2470 : if ((mask & OMP_CLAUSE_COPY)
3330 : 778 : && gfc_match ("pcopy ( ") == MATCH_YES
3331 : 2471 : && gfc_match_omp_map_clause (&c->lists[OMP_LIST_MAP],
3332 : : OMP_MAP_TOFROM, true, allow_derived))
3333 : 65 : continue;
3334 : 2412 : if ((mask & OMP_CLAUSE_COPYIN)
3335 : 1592 : && gfc_match ("pcopyin ( ") == MATCH_YES
3336 : 2412 : && gfc_match_omp_map_clause (&c->lists[OMP_LIST_MAP],
3337 : : OMP_MAP_TO, true, allow_derived))
3338 : 72 : continue;
3339 : 2338 : if ((mask & OMP_CLAUSE_COPYOUT)
3340 : 642 : && gfc_match ("pcopyout ( ") == MATCH_YES
3341 : 2338 : && gfc_match_omp_map_clause (&c->lists[OMP_LIST_MAP],
3342 : : OMP_MAP_FROM, true, allow_derived))
3343 : 70 : continue;
3344 : 2211 : if ((mask & OMP_CLAUSE_CREATE)
3345 : 582 : && gfc_match ("pcreate ( ") == MATCH_YES
3346 : 2211 : && gfc_match_omp_map_clause (&c->lists[OMP_LIST_MAP],
3347 : : OMP_MAP_ALLOC, true, allow_derived))
3348 : 13 : continue;
3349 : 2562 : if ((mask & OMP_CLAUSE_PRESENT)
3350 : 559 : && gfc_match ("present ( ") == MATCH_YES
3351 : 2564 : && gfc_match_omp_map_clause (&c->lists[OMP_LIST_MAP],
3352 : : OMP_MAP_FORCE_PRESENT, false,
3353 : : allow_derived))
3354 : 377 : continue;
3355 : 1830 : if ((mask & OMP_CLAUSE_COPY)
3356 : 182 : && gfc_match ("present_or_copy ( ") == MATCH_YES
3357 : 1830 : && gfc_match_omp_map_clause (&c->lists[OMP_LIST_MAP],
3358 : : OMP_MAP_TOFROM, true,
3359 : : allow_derived))
3360 : 22 : continue;
3361 : 1825 : if ((mask & OMP_CLAUSE_COPYIN)
3362 : 1038 : && gfc_match ("present_or_copyin ( ") == MATCH_YES
3363 : 1825 : && gfc_match_omp_map_clause (&c->lists[OMP_LIST_MAP],
3364 : : OMP_MAP_TO, true, allow_derived))
3365 : 39 : continue;
3366 : 1781 : if ((mask & OMP_CLAUSE_COPYOUT)
3367 : 126 : && gfc_match ("present_or_copyout ( ") == MATCH_YES
3368 : 1781 : && gfc_match_omp_map_clause (&c->lists[OMP_LIST_MAP],
3369 : : OMP_MAP_FROM, true, allow_derived))
3370 : 34 : continue;
3371 : 1740 : if ((mask & OMP_CLAUSE_CREATE)
3372 : 97 : && gfc_match ("present_or_create ( ") == MATCH_YES
3373 : 1740 : && gfc_match_omp_map_clause (&c->lists[OMP_LIST_MAP],
3374 : : OMP_MAP_ALLOC, true, allow_derived))
3375 : 27 : continue;
3376 : 1720 : if ((mask & OMP_CLAUSE_PRIORITY)
3377 : 1686 : && (m = gfc_match_dupl_check (!c->priority, "priority", true,
3378 : : &c->priority)) != MATCH_NO)
3379 : : {
3380 : 34 : if (m == MATCH_ERROR)
3381 : 0 : goto error;
3382 : 34 : continue;
3383 : : }
3384 : 3231 : if ((mask & OMP_CLAUSE_PRIVATE)
3385 : 1652 : && gfc_match_omp_variable_list ("private (",
3386 : : &c->lists[OMP_LIST_PRIVATE],
3387 : : true) == MATCH_YES)
3388 : 1579 : continue;
3389 : 137 : if ((mask & OMP_CLAUSE_PROC_BIND)
3390 : 137 : && (m = gfc_match_dupl_check ((c->proc_bind
3391 : 64 : == OMP_PROC_BIND_UNKNOWN),
3392 : : "proc_bind", true)) != MATCH_NO)
3393 : : {
3394 : 64 : if (m == MATCH_ERROR)
3395 : 0 : goto error;
3396 : 64 : if (gfc_match ("primary )") == MATCH_YES)
3397 : 1 : c->proc_bind = OMP_PROC_BIND_PRIMARY;
3398 : 63 : else if (gfc_match ("master )") == MATCH_YES)
3399 : 9 : c->proc_bind = OMP_PROC_BIND_MASTER;
3400 : 54 : else if (gfc_match ("spread )") == MATCH_YES)
3401 : 53 : c->proc_bind = OMP_PROC_BIND_SPREAD;
3402 : 1 : else if (gfc_match ("close )") == MATCH_YES)
3403 : 1 : c->proc_bind = OMP_PROC_BIND_CLOSE;
3404 : : else
3405 : 0 : goto error;
3406 : 64 : continue;
3407 : : }
3408 : : break;
3409 : 4203 : case 'r':
3410 : 4689 : if ((mask & OMP_CLAUSE_ATOMIC)
3411 : 4203 : && (m = gfc_match_dupl_atomic ((c->atomic_op
3412 : : == GFC_OMP_ATOMIC_UNSET),
3413 : : "read")) != MATCH_NO)
3414 : : {
3415 : 486 : if (m == MATCH_ERROR)
3416 : 0 : goto error;
3417 : 486 : c->atomic_op = GFC_OMP_ATOMIC_READ;
3418 : 486 : needs_space = true;
3419 : 486 : continue;
3420 : : }
3421 : 7400 : if ((mask & OMP_CLAUSE_REDUCTION)
3422 : 3717 : && gfc_match_omp_clause_reduction (pc, c, openacc,
3423 : : allow_derived) == MATCH_YES)
3424 : 3683 : continue;
3425 : 44 : if ((mask & OMP_CLAUSE_MEMORDER)
3426 : 61 : && (m = gfc_match_dupl_memorder ((c->memorder
3427 : 27 : == OMP_MEMORDER_UNSET),
3428 : : "relaxed")) != MATCH_NO)
3429 : : {
3430 : 10 : if (m == MATCH_ERROR)
3431 : 0 : goto error;
3432 : 10 : c->memorder = OMP_MEMORDER_RELAXED;
3433 : 10 : needs_space = true;
3434 : 10 : continue;
3435 : : }
3436 : 40 : if ((mask & OMP_CLAUSE_MEMORDER)
3437 : 41 : && (m = gfc_match_dupl_memorder ((c->memorder
3438 : 17 : == OMP_MEMORDER_UNSET),
3439 : : "release")) != MATCH_NO)
3440 : : {
3441 : 17 : if (m == MATCH_ERROR)
3442 : 1 : goto error;
3443 : 16 : c->memorder = OMP_MEMORDER_RELEASE;
3444 : 16 : needs_space = true;
3445 : 16 : continue;
3446 : : }
3447 : : break;
3448 : 2555 : case 's':
3449 : 2648 : if ((mask & OMP_CLAUSE_SAFELEN)
3450 : 2555 : && (m = gfc_match_dupl_check (!c->safelen_expr, "safelen",
3451 : : true, &c->safelen_expr))
3452 : : != MATCH_NO)
3453 : : {
3454 : 93 : if (m == MATCH_ERROR)
3455 : 0 : goto error;
3456 : 93 : continue;
3457 : : }
3458 : 2462 : if ((mask & OMP_CLAUSE_SCHEDULE)
3459 : 2462 : && (m = gfc_match_dupl_check (c->sched_kind == OMP_SCHED_NONE,
3460 : : "schedule", true)) != MATCH_NO)
3461 : : {
3462 : 775 : if (m == MATCH_ERROR)
3463 : 0 : goto error;
3464 : 775 : int nmodifiers = 0;
3465 : 775 : locus old_loc2 = gfc_current_locus;
3466 : 793 : do
3467 : : {
3468 : 784 : if (gfc_match ("simd") == MATCH_YES)
3469 : : {
3470 : 18 : c->sched_simd = true;
3471 : 18 : nmodifiers++;
3472 : : }
3473 : 766 : else if (gfc_match ("monotonic") == MATCH_YES)
3474 : : {
3475 : 30 : c->sched_monotonic = true;
3476 : 30 : nmodifiers++;
3477 : : }
3478 : 736 : else if (gfc_match ("nonmonotonic") == MATCH_YES)
3479 : : {
3480 : 35 : c->sched_nonmonotonic = true;
3481 : 35 : nmodifiers++;
3482 : : }
3483 : : else
3484 : : {
3485 : 701 : if (nmodifiers)
3486 : 0 : gfc_current_locus = old_loc2;
3487 : : break;
3488 : : }
3489 : 92 : if (nmodifiers == 1
3490 : 83 : && gfc_match (" , ") == MATCH_YES)
3491 : 9 : continue;
3492 : 74 : else if (gfc_match (" : ") == MATCH_YES)
3493 : : break;
3494 : 0 : gfc_current_locus = old_loc2;
3495 : 0 : break;
3496 : : }
3497 : : while (1);
3498 : 775 : if (gfc_match ("static") == MATCH_YES)
3499 : 405 : c->sched_kind = OMP_SCHED_STATIC;
3500 : 370 : else if (gfc_match ("dynamic") == MATCH_YES)
3501 : 164 : c->sched_kind = OMP_SCHED_DYNAMIC;
3502 : 206 : else if (gfc_match ("guided") == MATCH_YES)
3503 : 113 : c->sched_kind = OMP_SCHED_GUIDED;
3504 : 93 : else if (gfc_match ("runtime") == MATCH_YES)
3505 : 85 : c->sched_kind = OMP_SCHED_RUNTIME;
3506 : 8 : else if (gfc_match ("auto") == MATCH_YES)
3507 : 8 : c->sched_kind = OMP_SCHED_AUTO;
3508 : 775 : if (c->sched_kind != OMP_SCHED_NONE)
3509 : : {
3510 : 775 : m = MATCH_NO;
3511 : 775 : if (c->sched_kind != OMP_SCHED_RUNTIME
3512 : 690 : && c->sched_kind != OMP_SCHED_AUTO)
3513 : 682 : m = gfc_match (" , %e )", &c->chunk_size);
3514 : 682 : if (m != MATCH_YES)
3515 : 271 : m = gfc_match_char (')');
3516 : 271 : if (m != MATCH_YES)
3517 : 0 : c->sched_kind = OMP_SCHED_NONE;
3518 : : }
3519 : 775 : if (c->sched_kind != OMP_SCHED_NONE)
3520 : 775 : continue;
3521 : : else
3522 : 0 : gfc_current_locus = old_loc;
3523 : : }
3524 : 1781 : if ((mask & OMP_CLAUSE_HOST_SELF)
3525 : 95 : && gfc_match ("self ( ") == MATCH_YES
3526 : 1782 : && gfc_match_omp_map_clause (&c->lists[OMP_LIST_MAP],
3527 : : OMP_MAP_FORCE_FROM, true,
3528 : : allow_derived))
3529 : 94 : continue;
3530 : 1910 : if ((mask & OMP_CLAUSE_SEQ)
3531 : 1593 : && (m = gfc_match_dupl_check (!c->seq, "seq")) != MATCH_NO)
3532 : : {
3533 : 317 : if (m == MATCH_ERROR)
3534 : 0 : goto error;
3535 : 317 : c->seq = true;
3536 : 317 : needs_space = true;
3537 : 317 : continue;
3538 : : }
3539 : 1417 : if ((mask & OMP_CLAUSE_MEMORDER)
3540 : 1417 : && (m = gfc_match_dupl_memorder ((c->memorder
3541 : 141 : == OMP_MEMORDER_UNSET),
3542 : : "seq_cst")) != MATCH_NO)
3543 : : {
3544 : 141 : if (m == MATCH_ERROR)
3545 : 0 : goto error;
3546 : 141 : c->memorder = OMP_MEMORDER_SEQ_CST;
3547 : 141 : needs_space = true;
3548 : 141 : continue;
3549 : : }
3550 : 2084 : if ((mask & OMP_CLAUSE_SHARED)
3551 : 1135 : && gfc_match_omp_variable_list ("shared (",
3552 : : &c->lists[OMP_LIST_SHARED],
3553 : : true) == MATCH_YES)
3554 : 949 : continue;
3555 : 304 : if ((mask & OMP_CLAUSE_SIMDLEN)
3556 : 186 : && (m = gfc_match_dupl_check (!c->simdlen_expr, "simdlen", true,
3557 : : &c->simdlen_expr)) != MATCH_NO)
3558 : : {
3559 : 118 : if (m == MATCH_ERROR)
3560 : 0 : goto error;
3561 : 118 : continue;
3562 : : }
3563 : 90 : if ((mask & OMP_CLAUSE_SIMD)
3564 : 68 : && (m = gfc_match_dupl_check (!c->simd, "simd")) != MATCH_NO)
3565 : : {
3566 : 22 : if (m == MATCH_ERROR)
3567 : 0 : goto error;
3568 : 22 : c->simd = needs_space = true;
3569 : 22 : continue;
3570 : : }
3571 : 85 : if ((mask & OMP_CLAUSE_SEVERITY)
3572 : 46 : && (m = gfc_match_dupl_check (!c->severity, "severity", true))
3573 : : != MATCH_NO)
3574 : : {
3575 : 45 : if (m == MATCH_ERROR)
3576 : 2 : goto error;
3577 : 43 : if (gfc_match ("fatal )") == MATCH_YES)
3578 : 10 : c->severity = OMP_SEVERITY_FATAL;
3579 : 33 : else if (gfc_match ("warning )") == MATCH_YES)
3580 : 29 : c->severity = OMP_SEVERITY_WARNING;
3581 : : else
3582 : : {
3583 : 4 : gfc_error ("Expected FATAL or WARNING in SEVERITY clause "
3584 : : "at %C");
3585 : 4 : goto error;
3586 : : }
3587 : 39 : continue;
3588 : : }
3589 : : break;
3590 : 1124 : case 't':
3591 : 1189 : if ((mask & OMP_CLAUSE_TASK_REDUCTION)
3592 : 1124 : && gfc_match_omp_clause_reduction (pc, c, openacc,
3593 : : allow_derived) == MATCH_YES)
3594 : 65 : continue;
3595 : 1131 : if ((mask & OMP_CLAUSE_THREAD_LIMIT)
3596 : 1059 : && (m = gfc_match_dupl_check (!c->thread_limit, "thread_limit",
3597 : : true, &c->thread_limit))
3598 : : != MATCH_NO)
3599 : : {
3600 : 72 : if (m == MATCH_ERROR)
3601 : 0 : goto error;
3602 : 72 : continue;
3603 : : }
3604 : 1000 : if ((mask & OMP_CLAUSE_THREADS)
3605 : 987 : && (m = gfc_match_dupl_check (!c->threads, "threads"))
3606 : : != MATCH_NO)
3607 : : {
3608 : 13 : if (m == MATCH_ERROR)
3609 : 0 : goto error;
3610 : 13 : c->threads = needs_space = true;
3611 : 13 : continue;
3612 : : }
3613 : 1144 : if ((mask & OMP_CLAUSE_TILE)
3614 : 190 : && !c->tile_list
3615 : 1164 : && match_oacc_expr_list ("tile (", &c->tile_list,
3616 : : true) == MATCH_YES)
3617 : 170 : continue;
3618 : 804 : if ((mask & OMP_CLAUSE_TO) && (mask & OMP_CLAUSE_LINK))
3619 : : {
3620 : : /* Declare target: 'to' is an alias for 'enter';
3621 : : 'to' is deprecated since 5.2. */
3622 : 64 : m = gfc_match_omp_to_link ("to (", &c->lists[OMP_LIST_TO]);
3623 : 64 : if (m == MATCH_ERROR)
3624 : 0 : goto error;
3625 : 64 : if (m == MATCH_YES)
3626 : 64 : continue;
3627 : : }
3628 : 1460 : else if ((mask & OMP_CLAUSE_TO)
3629 : 740 : && gfc_match_motion_var_list ("to (", &c->lists[OMP_LIST_TO],
3630 : : &head) == MATCH_YES)
3631 : 720 : continue;
3632 : : break;
3633 : 1480 : case 'u':
3634 : 1543 : if ((mask & OMP_CLAUSE_UNIFORM)
3635 : 1480 : && gfc_match_omp_variable_list ("uniform (",
3636 : : &c->lists[OMP_LIST_UNIFORM],
3637 : : false) == MATCH_YES)
3638 : 63 : continue;
3639 : 1558 : if ((mask & OMP_CLAUSE_UNTIED)
3640 : 1417 : && (m = gfc_match_dupl_check (!c->untied, "untied")) != MATCH_NO)
3641 : : {
3642 : 141 : if (m == MATCH_ERROR)
3643 : 0 : goto error;
3644 : 141 : c->untied = needs_space = true;
3645 : 141 : continue;
3646 : : }
3647 : 1513 : if ((mask & OMP_CLAUSE_ATOMIC)
3648 : 1276 : && (m = gfc_match_dupl_atomic ((c->atomic_op
3649 : : == GFC_OMP_ATOMIC_UNSET),
3650 : : "update")) != MATCH_NO)
3651 : : {
3652 : 238 : if (m == MATCH_ERROR)
3653 : 1 : goto error;
3654 : 237 : c->atomic_op = GFC_OMP_ATOMIC_UPDATE;
3655 : 237 : needs_space = true;
3656 : 237 : continue;
3657 : : }
3658 : 1098 : if ((mask & OMP_CLAUSE_USE_DEVICE)
3659 : 1038 : && gfc_match_omp_variable_list ("use_device (",
3660 : : &c->lists[OMP_LIST_USE_DEVICE],
3661 : : true) == MATCH_YES)
3662 : 60 : continue;
3663 : 1139 : if ((mask & OMP_CLAUSE_USE_DEVICE_PTR)
3664 : 1904 : && gfc_match_omp_variable_list
3665 : 926 : ("use_device_ptr (",
3666 : : &c->lists[OMP_LIST_USE_DEVICE_PTR], false) == MATCH_YES)
3667 : 161 : continue;
3668 : 1582 : if ((mask & OMP_CLAUSE_USE_DEVICE_ADDR)
3669 : 1582 : && gfc_match_omp_variable_list
3670 : 765 : ("use_device_addr (", &c->lists[OMP_LIST_USE_DEVICE_ADDR],
3671 : : false, NULL, NULL, true) == MATCH_YES)
3672 : 765 : continue;
3673 : 95 : if ((mask & OMP_CLAUSE_USES_ALLOCATORS)
3674 : 52 : && (gfc_match ("uses_allocators ( ") == MATCH_YES))
3675 : : {
3676 : 47 : if (gfc_match_omp_clause_uses_allocators (c) != MATCH_YES)
3677 : 4 : goto error;
3678 : 43 : continue;
3679 : : }
3680 : : break;
3681 : 1516 : case 'v':
3682 : : /* VECTOR_LENGTH must be matched before VECTOR, because the latter
3683 : : doesn't unconditionally match '('. */
3684 : 2085 : if ((mask & OMP_CLAUSE_VECTOR_LENGTH)
3685 : 1516 : && (m = gfc_match_dupl_check (!c->vector_length_expr,
3686 : : "vector_length", true,
3687 : : &c->vector_length_expr))
3688 : : != MATCH_NO)
3689 : : {
3690 : 573 : if (m == MATCH_ERROR)
3691 : 4 : goto error;
3692 : 569 : continue;
3693 : : }
3694 : 1881 : if ((mask & OMP_CLAUSE_VECTOR)
3695 : 943 : && (m = gfc_match_dupl_check (!c->vector, "vector")) != MATCH_NO)
3696 : : {
3697 : 941 : if (m == MATCH_ERROR)
3698 : 0 : goto error;
3699 : 941 : c->vector = true;
3700 : 941 : m = match_oacc_clause_gwv (c, GOMP_DIM_VECTOR);
3701 : 941 : if (m == MATCH_ERROR)
3702 : 3 : goto error;
3703 : 938 : if (m == MATCH_NO)
3704 : 810 : needs_space = true;
3705 : 938 : continue;
3706 : : }
3707 : : break;
3708 : 1416 : case 'w':
3709 : 1416 : if ((mask & OMP_CLAUSE_WAIT)
3710 : 1416 : && gfc_match ("wait") == MATCH_YES)
3711 : : {
3712 : 187 : m = match_oacc_expr_list (" (", &c->wait_list, false);
3713 : 187 : if (m == MATCH_ERROR)
3714 : 9 : goto error;
3715 : 178 : else if (m == MATCH_NO)
3716 : : {
3717 : 47 : gfc_expr *expr
3718 : 47 : = gfc_get_constant_expr (BT_INTEGER,
3719 : : gfc_default_integer_kind,
3720 : : &gfc_current_locus);
3721 : 47 : mpz_set_si (expr->value.integer, GOMP_ASYNC_NOVAL);
3722 : 47 : gfc_expr_list **expr_list = &c->wait_list;
3723 : 103 : while (*expr_list)
3724 : 9 : expr_list = &(*expr_list)->next;
3725 : 47 : *expr_list = gfc_get_expr_list ();
3726 : 47 : (*expr_list)->expr = expr;
3727 : 47 : needs_space = true;
3728 : : }
3729 : 178 : continue;
3730 : 178 : }
3731 : 1242 : if ((mask & OMP_CLAUSE_WEAK)
3732 : 1229 : && (m = gfc_match_dupl_check (!c->weak, "weak"))
3733 : : != MATCH_NO)
3734 : : {
3735 : 14 : if (m == MATCH_ERROR)
3736 : 1 : goto error;
3737 : 13 : c->weak = true;
3738 : 13 : needs_space = true;
3739 : 13 : continue;
3740 : : }
3741 : 2021 : if ((mask & OMP_CLAUSE_WORKER)
3742 : 1215 : && (m = gfc_match_dupl_check (!c->worker, "worker")) != MATCH_NO)
3743 : : {
3744 : 809 : if (m == MATCH_ERROR)
3745 : 0 : goto error;
3746 : 809 : c->worker = true;
3747 : 809 : m = match_oacc_clause_gwv (c, GOMP_DIM_WORKER);
3748 : 809 : if (m == MATCH_ERROR)
3749 : 3 : goto error;
3750 : 806 : else if (m == MATCH_NO)
3751 : 709 : needs_space = true;
3752 : 806 : continue;
3753 : : }
3754 : 812 : if ((mask & OMP_CLAUSE_ATOMIC)
3755 : 406 : && (m = gfc_match_dupl_atomic ((c->atomic_op
3756 : : == GFC_OMP_ATOMIC_UNSET),
3757 : : "write")) != MATCH_NO)
3758 : : {
3759 : 406 : if (m == MATCH_ERROR)
3760 : 0 : goto error;
3761 : 406 : c->atomic_op = GFC_OMP_ATOMIC_WRITE;
3762 : 406 : needs_space = true;
3763 : 406 : continue;
3764 : : }
3765 : : break;
3766 : : }
3767 : : break;
3768 : 40413 : }
3769 : :
3770 : 30092 : end:
3771 : 30092 : if (error
3772 : 29923 : || (context_selector && gfc_peek_ascii_char () != ')')
3773 : 29908 : || (!context_selector && gfc_match_omp_eos () != MATCH_YES))
3774 : : {
3775 : 405 : if (!gfc_error_flag_test ())
3776 : 121 : gfc_error ("Failed to match clause at %C");
3777 : 405 : gfc_free_omp_clauses (c);
3778 : 405 : return MATCH_ERROR;
3779 : : }
3780 : :
3781 : 29687 : *cp = c;
3782 : 29687 : return MATCH_YES;
3783 : :
3784 : 169 : error:
3785 : 169 : error = true;
3786 : 169 : goto end;
3787 : : }
3788 : :
3789 : :
3790 : : #define OACC_PARALLEL_CLAUSES \
3791 : : (omp_mask (OMP_CLAUSE_IF) | OMP_CLAUSE_ASYNC | OMP_CLAUSE_NUM_GANGS \
3792 : : | OMP_CLAUSE_NUM_WORKERS | OMP_CLAUSE_VECTOR_LENGTH | OMP_CLAUSE_REDUCTION \
3793 : : | OMP_CLAUSE_COPY | OMP_CLAUSE_COPYIN | OMP_CLAUSE_COPYOUT \
3794 : : | OMP_CLAUSE_CREATE | OMP_CLAUSE_NO_CREATE | OMP_CLAUSE_PRESENT \
3795 : : | OMP_CLAUSE_DEVICEPTR | OMP_CLAUSE_PRIVATE | OMP_CLAUSE_FIRSTPRIVATE \
3796 : : | OMP_CLAUSE_DEFAULT | OMP_CLAUSE_WAIT | OMP_CLAUSE_ATTACH)
3797 : : #define OACC_KERNELS_CLAUSES \
3798 : : (omp_mask (OMP_CLAUSE_IF) | OMP_CLAUSE_ASYNC | OMP_CLAUSE_NUM_GANGS \
3799 : : | OMP_CLAUSE_NUM_WORKERS | OMP_CLAUSE_VECTOR_LENGTH | OMP_CLAUSE_DEVICEPTR \
3800 : : | OMP_CLAUSE_COPY | OMP_CLAUSE_COPYIN | OMP_CLAUSE_COPYOUT \
3801 : : | OMP_CLAUSE_CREATE | OMP_CLAUSE_NO_CREATE | OMP_CLAUSE_PRESENT \
3802 : : | OMP_CLAUSE_DEFAULT | OMP_CLAUSE_WAIT | OMP_CLAUSE_ATTACH)
3803 : : #define OACC_SERIAL_CLAUSES \
3804 : : (omp_mask (OMP_CLAUSE_IF) | OMP_CLAUSE_ASYNC | OMP_CLAUSE_REDUCTION \
3805 : : | OMP_CLAUSE_COPY | OMP_CLAUSE_COPYIN | OMP_CLAUSE_COPYOUT \
3806 : : | OMP_CLAUSE_CREATE | OMP_CLAUSE_NO_CREATE | OMP_CLAUSE_PRESENT \
3807 : : | OMP_CLAUSE_DEVICEPTR | OMP_CLAUSE_PRIVATE | OMP_CLAUSE_FIRSTPRIVATE \
3808 : : | OMP_CLAUSE_DEFAULT | OMP_CLAUSE_WAIT | OMP_CLAUSE_ATTACH)
3809 : : #define OACC_DATA_CLAUSES \
3810 : : (omp_mask (OMP_CLAUSE_IF) | OMP_CLAUSE_DEVICEPTR | OMP_CLAUSE_COPY \
3811 : : | OMP_CLAUSE_COPYIN | OMP_CLAUSE_COPYOUT | OMP_CLAUSE_CREATE \
3812 : : | OMP_CLAUSE_NO_CREATE | OMP_CLAUSE_PRESENT | OMP_CLAUSE_ATTACH \
3813 : : | OMP_CLAUSE_DEFAULT)
3814 : : #define OACC_LOOP_CLAUSES \
3815 : : (omp_mask (OMP_CLAUSE_COLLAPSE) | OMP_CLAUSE_GANG | OMP_CLAUSE_WORKER \
3816 : : | OMP_CLAUSE_VECTOR | OMP_CLAUSE_SEQ | OMP_CLAUSE_INDEPENDENT \
3817 : : | OMP_CLAUSE_PRIVATE | OMP_CLAUSE_REDUCTION | OMP_CLAUSE_AUTO \
3818 : : | OMP_CLAUSE_TILE)
3819 : : #define OACC_PARALLEL_LOOP_CLAUSES \
3820 : : (OACC_LOOP_CLAUSES | OACC_PARALLEL_CLAUSES)
3821 : : #define OACC_KERNELS_LOOP_CLAUSES \
3822 : : (OACC_LOOP_CLAUSES | OACC_KERNELS_CLAUSES)
3823 : : #define OACC_SERIAL_LOOP_CLAUSES \
3824 : : (OACC_LOOP_CLAUSES | OACC_SERIAL_CLAUSES)
3825 : : #define OACC_HOST_DATA_CLAUSES \
3826 : : (omp_mask (OMP_CLAUSE_USE_DEVICE) \
3827 : : | OMP_CLAUSE_IF \
3828 : : | OMP_CLAUSE_IF_PRESENT)
3829 : : #define OACC_DECLARE_CLAUSES \
3830 : : (omp_mask (OMP_CLAUSE_COPY) | OMP_CLAUSE_COPYIN | OMP_CLAUSE_COPYOUT \
3831 : : | OMP_CLAUSE_CREATE | OMP_CLAUSE_DEVICEPTR | OMP_CLAUSE_DEVICE_RESIDENT \
3832 : : | OMP_CLAUSE_PRESENT \
3833 : : | OMP_CLAUSE_LINK)
3834 : : #define OACC_UPDATE_CLAUSES \
3835 : : (omp_mask (OMP_CLAUSE_IF) | OMP_CLAUSE_ASYNC | OMP_CLAUSE_HOST_SELF \
3836 : : | OMP_CLAUSE_DEVICE | OMP_CLAUSE_WAIT | OMP_CLAUSE_IF_PRESENT)
3837 : : #define OACC_ENTER_DATA_CLAUSES \
3838 : : (omp_mask (OMP_CLAUSE_IF) | OMP_CLAUSE_ASYNC | OMP_CLAUSE_WAIT \
3839 : : | OMP_CLAUSE_COPYIN | OMP_CLAUSE_CREATE | OMP_CLAUSE_ATTACH)
3840 : : #define OACC_EXIT_DATA_CLAUSES \
3841 : : (omp_mask (OMP_CLAUSE_IF) | OMP_CLAUSE_ASYNC | OMP_CLAUSE_WAIT \
3842 : : | OMP_CLAUSE_COPYOUT | OMP_CLAUSE_DELETE | OMP_CLAUSE_FINALIZE \
3843 : : | OMP_CLAUSE_DETACH)
3844 : : #define OACC_WAIT_CLAUSES \
3845 : : omp_mask (OMP_CLAUSE_ASYNC)
3846 : : #define OACC_ROUTINE_CLAUSES \
3847 : : (omp_mask (OMP_CLAUSE_GANG) | OMP_CLAUSE_WORKER | OMP_CLAUSE_VECTOR \
3848 : : | OMP_CLAUSE_SEQ \
3849 : : | OMP_CLAUSE_NOHOST)
3850 : :
3851 : :
3852 : : static match
3853 : 10436 : match_acc (gfc_exec_op op, const omp_mask mask)
3854 : : {
3855 : 10436 : gfc_omp_clauses *c;
3856 : 10436 : if (gfc_match_omp_clauses (&c, mask, false, false, true) != MATCH_YES)
3857 : : return MATCH_ERROR;
3858 : 10276 : new_st.op = op;
3859 : 10276 : new_st.ext.omp_clauses = c;
3860 : 10276 : return MATCH_YES;
3861 : : }
3862 : :
3863 : : match
3864 : 1377 : gfc_match_oacc_parallel_loop (void)
3865 : : {
3866 : 1377 : return match_acc (EXEC_OACC_PARALLEL_LOOP, OACC_PARALLEL_LOOP_CLAUSES);
3867 : : }
3868 : :
3869 : :
3870 : : match
3871 : 2851 : gfc_match_oacc_parallel (void)
3872 : : {
3873 : 2851 : return match_acc (EXEC_OACC_PARALLEL, OACC_PARALLEL_CLAUSES);
3874 : : }
3875 : :
3876 : :
3877 : : match
3878 : 128 : gfc_match_oacc_kernels_loop (void)
3879 : : {
3880 : 128 : return match_acc (EXEC_OACC_KERNELS_LOOP, OACC_KERNELS_LOOP_CLAUSES);
3881 : : }
3882 : :
3883 : :
3884 : : match
3885 : 796 : gfc_match_oacc_kernels (void)
3886 : : {
3887 : 796 : return match_acc (EXEC_OACC_KERNELS, OACC_KERNELS_CLAUSES);
3888 : : }
3889 : :
3890 : :
3891 : : match
3892 : 4 : gfc_match_oacc_serial_loop (void)
3893 : : {
3894 : 4 : return match_acc (EXEC_OACC_SERIAL_LOOP, OACC_SERIAL_LOOP_CLAUSES);
3895 : : }
3896 : :
3897 : :
3898 : : match
3899 : 60 : gfc_match_oacc_serial (void)
3900 : : {
3901 : 60 : return match_acc (EXEC_OACC_SERIAL, OACC_SERIAL_CLAUSES);
3902 : : }
3903 : :
3904 : :
3905 : : match
3906 : 596 : gfc_match_oacc_data (void)
3907 : : {
3908 : 596 : return match_acc (EXEC_OACC_DATA, OACC_DATA_CLAUSES);
3909 : : }
3910 : :
3911 : :
3912 : : match
3913 : 65 : gfc_match_oacc_host_data (void)
3914 : : {
3915 : 65 : return match_acc (EXEC_OACC_HOST_DATA, OACC_HOST_DATA_CLAUSES);
3916 : : }
3917 : :
3918 : :
3919 : : match
3920 : 3274 : gfc_match_oacc_loop (void)
3921 : : {
3922 : 3274 : return match_acc (EXEC_OACC_LOOP, OACC_LOOP_CLAUSES);
3923 : : }
3924 : :
3925 : :
3926 : : match
3927 : 170 : gfc_match_oacc_declare (void)
3928 : : {
3929 : 170 : gfc_omp_clauses *c;
3930 : 170 : gfc_omp_namelist *n;
3931 : 170 : gfc_namespace *ns = gfc_current_ns;
3932 : 170 : gfc_oacc_declare *new_oc;
3933 : 170 : bool module_var = false;
3934 : 170 : locus where = gfc_current_locus;
3935 : :
3936 : 170 : if (gfc_match_omp_clauses (&c, OACC_DECLARE_CLAUSES, false, false, true)
3937 : : != MATCH_YES)
3938 : : return MATCH_ERROR;
3939 : :
3940 : 252 : for (n = c->lists[OMP_LIST_DEVICE_RESIDENT]; n != NULL; n = n->next)
3941 : 88 : n->sym->attr.oacc_declare_device_resident = 1;
3942 : :
3943 : 184 : for (n = c->lists[OMP_LIST_LINK]; n != NULL; n = n->next)
3944 : 20 : n->sym->attr.oacc_declare_link = 1;
3945 : :
3946 : 295 : for (n = c->lists[OMP_LIST_MAP]; n != NULL; n = n->next)
3947 : : {
3948 : 141 : gfc_symbol *s = n->sym;
3949 : :
3950 : 141 : if (gfc_current_ns->proc_name
3951 : 141 : && gfc_current_ns->proc_name->attr.flavor == FL_MODULE)
3952 : : {
3953 : 48 : if (n->u.map_op != OMP_MAP_ALLOC && n->u.map_op != OMP_MAP_TO)
3954 : : {
3955 : 6 : gfc_error ("Invalid clause in module with !$ACC DECLARE at %L",
3956 : : &where);
3957 : 6 : return MATCH_ERROR;
3958 : : }
3959 : :
3960 : : module_var = true;
3961 : : }
3962 : :
3963 : 135 : if (s->attr.use_assoc)
3964 : : {
3965 : 0 : gfc_error ("Variable is USE-associated with !$ACC DECLARE at %L",
3966 : : &where);
3967 : 0 : return MATCH_ERROR;
3968 : : }
3969 : :
3970 : 135 : if ((s->result == s && s->ns->contained != gfc_current_ns)
3971 : 135 : || ((s->attr.flavor == FL_UNKNOWN || s->attr.flavor == FL_VARIABLE)
3972 : 125 : && s->ns != gfc_current_ns))
3973 : : {
3974 : 2 : gfc_error ("Variable %qs shall be declared in the same scoping unit "
3975 : : "as !$ACC DECLARE at %L", s->name, &where);
3976 : 2 : return MATCH_ERROR;
3977 : : }
3978 : :
3979 : 133 : if ((s->attr.dimension || s->attr.codimension)
3980 : 69 : && s->attr.dummy && s->as->type != AS_EXPLICIT)
3981 : : {
3982 : 2 : gfc_error ("Assumed-size dummy array with !$ACC DECLARE at %L",
3983 : : &where);
3984 : 2 : return MATCH_ERROR;
3985 : : }
3986 : :
3987 : 131 : switch (n->u.map_op)
3988 : : {
3989 : 49 : case OMP_MAP_FORCE_ALLOC:
3990 : 49 : case OMP_MAP_ALLOC:
3991 : 49 : s->attr.oacc_declare_create = 1;
3992 : 49 : break;
3993 : :
3994 : 48 : case OMP_MAP_FORCE_TO:
3995 : 48 : case OMP_MAP_TO:
3996 : 48 : s->attr.oacc_declare_copyin = 1;
3997 : 48 : break;
3998 : :
3999 : 1 : case OMP_MAP_FORCE_DEVICEPTR:
4000 : 1 : s->attr.oacc_declare_deviceptr = 1;
4001 : 1 : break;
4002 : :
4003 : : default:
4004 : : break;
4005 : : }
4006 : : }
4007 : :
4008 : 154 : new_oc = gfc_get_oacc_declare ();
4009 : 154 : new_oc->next = ns->oacc_declare;
4010 : 154 : new_oc->module_var = module_var;
4011 : 154 : new_oc->clauses = c;
4012 : 154 : new_oc->loc = gfc_current_locus;
4013 : 154 : ns->oacc_declare = new_oc;
4014 : :
4015 : 154 : return MATCH_YES;
4016 : : }
4017 : :
4018 : :
4019 : : match
4020 : 688 : gfc_match_oacc_update (void)
4021 : : {
4022 : 688 : gfc_omp_clauses *c;
4023 : 688 : locus here = gfc_current_locus;
4024 : :
4025 : 688 : if (gfc_match_omp_clauses (&c, OACC_UPDATE_CLAUSES, false, false, true)
4026 : : != MATCH_YES)
4027 : : return MATCH_ERROR;
4028 : :
4029 : 684 : if (!c->lists[OMP_LIST_MAP])
4030 : : {
4031 : 1 : gfc_error ("%<acc update%> must contain at least one "
4032 : : "%<device%> or %<host%> or %<self%> clause at %L", &here);
4033 : 1 : return MATCH_ERROR;
4034 : : }
4035 : :
4036 : 683 : new_st.op = EXEC_OACC_UPDATE;
4037 : 683 : new_st.ext.omp_clauses = c;
4038 : 683 : return MATCH_YES;
4039 : : }
4040 : :
4041 : :
4042 : : match
4043 : 779 : gfc_match_oacc_enter_data (void)
4044 : : {
4045 : 779 : return match_acc (EXEC_OACC_ENTER_DATA, OACC_ENTER_DATA_CLAUSES);
4046 : : }
4047 : :
4048 : :
4049 : : match
4050 : 506 : gfc_match_oacc_exit_data (void)
4051 : : {
4052 : 506 : return match_acc (EXEC_OACC_EXIT_DATA, OACC_EXIT_DATA_CLAUSES);
4053 : : }
4054 : :
4055 : :
4056 : : match
4057 : 197 : gfc_match_oacc_wait (void)
4058 : : {
4059 : 197 : gfc_omp_clauses *c = gfc_get_omp_clauses ();
4060 : 197 : gfc_expr_list *wait_list = NULL, *el;
4061 : 197 : bool space = true;
4062 : 197 : match m;
4063 : :
4064 : 197 : m = match_oacc_expr_list (" (", &wait_list, true);
4065 : 197 : if (m == MATCH_ERROR)
4066 : : return m;
4067 : 191 : else if (m == MATCH_YES)
4068 : 120 : space = false;
4069 : :
4070 : 191 : if (gfc_match_omp_clauses (&c, OACC_WAIT_CLAUSES, space, space, true)
4071 : : == MATCH_ERROR)
4072 : : return MATCH_ERROR;
4073 : :
4074 : 178 : if (wait_list)
4075 : 249 : for (el = wait_list; el; el = el->next)
4076 : : {
4077 : 134 : if (el->expr == NULL)
4078 : : {
4079 : 2 : gfc_error ("Invalid argument to !$ACC WAIT at %C");
4080 : 2 : return MATCH_ERROR;
4081 : : }
4082 : :
4083 : 132 : if (!gfc_resolve_expr (el->expr)
4084 : 132 : || el->expr->ts.type != BT_INTEGER || el->expr->rank != 0)
4085 : : {
4086 : 3 : gfc_error ("WAIT clause at %L requires a scalar INTEGER expression",
4087 : 3 : &el->expr->where);
4088 : :
4089 : 3 : return MATCH_ERROR;
4090 : : }
4091 : : }
4092 : 173 : c->wait_list = wait_list;
4093 : 173 : new_st.op = EXEC_OACC_WAIT;
4094 : 173 : new_st.ext.omp_clauses = c;
4095 : 173 : return MATCH_YES;
4096 : : }
4097 : :
4098 : :
4099 : : match
4100 : 74 : gfc_match_oacc_cache (void)
4101 : : {
4102 : 74 : gfc_omp_clauses *c = gfc_get_omp_clauses ();
4103 : : /* The OpenACC cache directive explicitly only allows "array elements or
4104 : : subarrays", which we're currently not checking here. Either check this
4105 : : after the call of gfc_match_omp_variable_list, or add something like a
4106 : : only_sections variant next to its allow_sections parameter. */
4107 : 74 : match m = gfc_match_omp_variable_list (" (",
4108 : : &c->lists[OMP_LIST_CACHE], true,
4109 : : NULL, NULL, true);
4110 : 74 : if (m != MATCH_YES)
4111 : : {
4112 : 1 : gfc_free_omp_clauses(c);
4113 : 1 : return m;
4114 : : }
4115 : :
4116 : 73 : if (gfc_current_state() != COMP_DO
4117 : 56 : && gfc_current_state() != COMP_DO_CONCURRENT)
4118 : : {
4119 : 2 : gfc_error ("ACC CACHE directive must be inside of loop %C");
4120 : 2 : gfc_free_omp_clauses(c);
4121 : 2 : return MATCH_ERROR;
4122 : : }
4123 : :
4124 : 71 : new_st.op = EXEC_OACC_CACHE;
4125 : 71 : new_st.ext.omp_clauses = c;
4126 : 71 : return MATCH_YES;
4127 : : }
4128 : :
4129 : : /* Determine the OpenACC 'routine' directive's level of parallelism. */
4130 : :
4131 : : static oacc_routine_lop
4132 : 716 : gfc_oacc_routine_lop (gfc_omp_clauses *clauses)
4133 : : {
4134 : 716 : oacc_routine_lop ret = OACC_ROUTINE_LOP_SEQ;
4135 : :
4136 : 716 : if (clauses)
4137 : : {
4138 : 568 : unsigned n_lop_clauses = 0;
4139 : :
4140 : 568 : if (clauses->gang)
4141 : : {
4142 : 160 : ++n_lop_clauses;
4143 : 160 : ret = OACC_ROUTINE_LOP_GANG;
4144 : : }
4145 : 568 : if (clauses->worker)
4146 : : {
4147 : 110 : ++n_lop_clauses;
4148 : 110 : ret = OACC_ROUTINE_LOP_WORKER;
4149 : : }
4150 : 568 : if (clauses->vector)
4151 : : {
4152 : 112 : ++n_lop_clauses;
4153 : 112 : ret = OACC_ROUTINE_LOP_VECTOR;
4154 : : }
4155 : 568 : if (clauses->seq)
4156 : : {
4157 : 202 : ++n_lop_clauses;
4158 : 202 : ret = OACC_ROUTINE_LOP_SEQ;
4159 : : }
4160 : :
4161 : 568 : if (n_lop_clauses > 1)
4162 : 47 : ret = OACC_ROUTINE_LOP_ERROR;
4163 : : }
4164 : :
4165 : 716 : return ret;
4166 : : }
4167 : :
4168 : : match
4169 : 680 : gfc_match_oacc_routine (void)
4170 : : {
4171 : 680 : locus old_loc;
4172 : 680 : match m;
4173 : 680 : gfc_intrinsic_sym *isym = NULL;
4174 : 680 : gfc_symbol *sym = NULL;
4175 : 680 : gfc_omp_clauses *c = NULL;
4176 : 680 : gfc_oacc_routine_name *n = NULL;
4177 : 680 : oacc_routine_lop lop = OACC_ROUTINE_LOP_NONE;
4178 : 680 : bool nohost;
4179 : :
4180 : 680 : old_loc = gfc_current_locus;
4181 : :
4182 : 680 : m = gfc_match (" (");
4183 : :
4184 : 680 : if (gfc_current_ns->proc_name
4185 : 678 : && gfc_current_ns->proc_name->attr.if_source == IFSRC_IFBODY
4186 : 90 : && m == MATCH_YES)
4187 : : {
4188 : 3 : gfc_error ("Only the !$ACC ROUTINE form without "
4189 : : "list is allowed in interface block at %C");
4190 : 3 : goto cleanup;
4191 : : }
4192 : :
4193 : 590 : if (m == MATCH_YES)
4194 : : {
4195 : 279 : char buffer[GFC_MAX_SYMBOL_LEN + 1];
4196 : :
4197 : 279 : m = gfc_match_name (buffer);
4198 : 279 : if (m == MATCH_YES)
4199 : : {
4200 : 278 : gfc_symtree *st = NULL;
4201 : :
4202 : : /* First look for an intrinsic symbol. */
4203 : 278 : isym = gfc_find_function (buffer);
4204 : 278 : if (!isym)
4205 : 278 : isym = gfc_find_subroutine (buffer);
4206 : : /* If no intrinsic symbol found, search the current namespace. */
4207 : 278 : if (!isym)
4208 : 260 : st = gfc_find_symtree (gfc_current_ns->sym_root, buffer);
4209 : 260 : if (st)
4210 : : {
4211 : 254 : sym = st->n.sym;
4212 : : /* If the name in a 'routine' directive refers to the containing
4213 : : subroutine or function, then make sure that we'll later handle
4214 : : this accordingly. */
4215 : 254 : if (gfc_current_ns->proc_name != NULL
4216 : 254 : && strcmp (sym->name, gfc_current_ns->proc_name->name) == 0)
4217 : 278 : sym = NULL;
4218 : : }
4219 : :
4220 : 278 : if (isym == NULL && st == NULL)
4221 : : {
4222 : 6 : gfc_error ("Invalid NAME %qs in !$ACC ROUTINE ( NAME ) at %C",
4223 : : buffer);
4224 : 6 : gfc_current_locus = old_loc;
4225 : 9 : return MATCH_ERROR;
4226 : : }
4227 : : }
4228 : : else
4229 : : {
4230 : 1 : gfc_error ("Syntax error in !$ACC ROUTINE ( NAME ) at %C");
4231 : 1 : gfc_current_locus = old_loc;
4232 : 1 : return MATCH_ERROR;
4233 : : }
4234 : :
4235 : 272 : if (gfc_match_char (')') != MATCH_YES)
4236 : : {
4237 : 2 : gfc_error ("Syntax error in !$ACC ROUTINE ( NAME ) at %C, expecting"
4238 : : " %<)%> after NAME");
4239 : 2 : gfc_current_locus = old_loc;
4240 : 2 : return MATCH_ERROR;
4241 : : }
4242 : : }
4243 : :
4244 : 668 : if (gfc_match_omp_eos () != MATCH_YES
4245 : 668 : && (gfc_match_omp_clauses (&c, OACC_ROUTINE_CLAUSES, false, false, true)
4246 : : != MATCH_YES))
4247 : : return MATCH_ERROR;
4248 : :
4249 : 665 : lop = gfc_oacc_routine_lop (c);
4250 : 665 : if (lop == OACC_ROUTINE_LOP_ERROR)
4251 : : {
4252 : 47 : gfc_error ("Multiple loop axes specified for routine at %C");
4253 : 47 : goto cleanup;
4254 : : }
4255 : 618 : nohost = c ? c->nohost : false;
4256 : :
4257 : 618 : if (isym != NULL)
4258 : : {
4259 : : /* Diagnose any OpenACC 'routine' directive that doesn't match the
4260 : : (implicit) one with a 'seq' clause. */
4261 : 16 : if (c && (c->gang || c->worker || c->vector))
4262 : : {
4263 : 10 : gfc_error ("Intrinsic symbol specified in !$ACC ROUTINE ( NAME )"
4264 : : " at %C marked with incompatible GANG, WORKER, or VECTOR"
4265 : : " clause");
4266 : 10 : goto cleanup;
4267 : : }
4268 : : /* ..., and no 'nohost' clause. */
4269 : 6 : if (nohost)
4270 : : {
4271 : 2 : gfc_error ("Intrinsic symbol specified in !$ACC ROUTINE ( NAME )"
4272 : : " at %C marked with incompatible NOHOST clause");
4273 : 2 : goto cleanup;
4274 : : }
4275 : : }
4276 : 602 : else if (sym != NULL)
4277 : : {
4278 : 135 : bool add = true;
4279 : :
4280 : : /* For a repeated OpenACC 'routine' directive, diagnose if it doesn't
4281 : : match the first one. */
4282 : 135 : for (gfc_oacc_routine_name *n_p = gfc_current_ns->oacc_routine_names;
4283 : 306 : n_p;
4284 : 171 : n_p = n_p->next)
4285 : 211 : if (n_p->sym == sym)
4286 : : {
4287 : 51 : add = false;
4288 : 51 : bool nohost_p = n_p->clauses ? n_p->clauses->nohost : false;
4289 : 51 : if (lop != gfc_oacc_routine_lop (n_p->clauses)
4290 : 51 : || nohost != nohost_p)
4291 : : {
4292 : 40 : gfc_error ("!$ACC ROUTINE already applied at %C");
4293 : 40 : goto cleanup;
4294 : : }
4295 : : }
4296 : :
4297 : 95 : if (add)
4298 : : {
4299 : 84 : sym->attr.oacc_routine_lop = lop;
4300 : 84 : sym->attr.oacc_routine_nohost = nohost;
4301 : :
4302 : 84 : n = gfc_get_oacc_routine_name ();
4303 : 84 : n->sym = sym;
4304 : 84 : n->clauses = c;
4305 : 84 : n->next = gfc_current_ns->oacc_routine_names;
4306 : 84 : n->loc = old_loc;
4307 : 84 : gfc_current_ns->oacc_routine_names = n;
4308 : : }
4309 : : }
4310 : 467 : else if (gfc_current_ns->proc_name)
4311 : : {
4312 : : /* For a repeated OpenACC 'routine' directive, diagnose if it doesn't
4313 : : match the first one. */
4314 : 466 : oacc_routine_lop lop_p = gfc_current_ns->proc_name->attr.oacc_routine_lop;
4315 : 466 : bool nohost_p = gfc_current_ns->proc_name->attr.oacc_routine_nohost;
4316 : 466 : if (lop_p != OACC_ROUTINE_LOP_NONE
4317 : 86 : && (lop != lop_p
4318 : 86 : || nohost != nohost_p))
4319 : : {
4320 : 56 : gfc_error ("!$ACC ROUTINE already applied at %C");
4321 : 56 : goto cleanup;
4322 : : }
4323 : :
4324 : 410 : if (!gfc_add_omp_declare_target (&gfc_current_ns->proc_name->attr,
4325 : : gfc_current_ns->proc_name->name,
4326 : : &old_loc))
4327 : 1 : goto cleanup;
4328 : 409 : gfc_current_ns->proc_name->attr.oacc_routine_lop = lop;
4329 : 409 : gfc_current_ns->proc_name->attr.oacc_routine_nohost = nohost;
4330 : : }
4331 : : else
4332 : : /* Something has gone wrong, possibly a syntax error. */
4333 : 1 : goto cleanup;
4334 : :
4335 : 508 : if (gfc_pure (NULL) && c && (c->gang || c->worker || c->vector))
4336 : : {
4337 : 6 : gfc_error ("!$ACC ROUTINE with GANG, WORKER, or VECTOR clause is not "
4338 : : "permitted in PURE procedure at %C");
4339 : 6 : goto cleanup;
4340 : : }
4341 : :
4342 : :
4343 : 502 : if (n)
4344 : 84 : n->clauses = c;
4345 : 418 : else if (gfc_current_ns->oacc_routine)
4346 : 0 : gfc_current_ns->oacc_routine_clauses = c;
4347 : :
4348 : 502 : new_st.op = EXEC_OACC_ROUTINE;
4349 : 502 : new_st.ext.omp_clauses = c;
4350 : 502 : return MATCH_YES;
4351 : :
4352 : 166 : cleanup:
4353 : 166 : gfc_current_locus = old_loc;
4354 : 166 : return MATCH_ERROR;
4355 : : }
4356 : :
4357 : :
4358 : : #define OMP_PARALLEL_CLAUSES \
4359 : : (omp_mask (OMP_CLAUSE_PRIVATE) | OMP_CLAUSE_FIRSTPRIVATE \
4360 : : | OMP_CLAUSE_SHARED | OMP_CLAUSE_COPYIN | OMP_CLAUSE_REDUCTION \
4361 : : | OMP_CLAUSE_IF | OMP_CLAUSE_NUM_THREADS | OMP_CLAUSE_DEFAULT \
4362 : : | OMP_CLAUSE_PROC_BIND | OMP_CLAUSE_ALLOCATE)
4363 : : #define OMP_DECLARE_SIMD_CLAUSES \
4364 : : (omp_mask (OMP_CLAUSE_SIMDLEN) | OMP_CLAUSE_LINEAR \
4365 : : | OMP_CLAUSE_UNIFORM | OMP_CLAUSE_ALIGNED | OMP_CLAUSE_INBRANCH \
4366 : : | OMP_CLAUSE_NOTINBRANCH)
4367 : : #define OMP_DO_CLAUSES \
4368 : : (omp_mask (OMP_CLAUSE_PRIVATE) | OMP_CLAUSE_FIRSTPRIVATE \
4369 : : | OMP_CLAUSE_LASTPRIVATE | OMP_CLAUSE_REDUCTION \
4370 : : | OMP_CLAUSE_SCHEDULE | OMP_CLAUSE_ORDERED | OMP_CLAUSE_COLLAPSE \
4371 : : | OMP_CLAUSE_LINEAR | OMP_CLAUSE_ORDER | OMP_CLAUSE_ALLOCATE \
4372 : : | OMP_CLAUSE_NOWAIT)
4373 : : #define OMP_LOOP_CLAUSES \
4374 : : (omp_mask (OMP_CLAUSE_BIND) | OMP_CLAUSE_COLLAPSE | OMP_CLAUSE_ORDER \
4375 : : | OMP_CLAUSE_PRIVATE | OMP_CLAUSE_LASTPRIVATE | OMP_CLAUSE_REDUCTION)
4376 : :
4377 : : #define OMP_SCOPE_CLAUSES \
4378 : : (omp_mask (OMP_CLAUSE_PRIVATE) |OMP_CLAUSE_FIRSTPRIVATE \
4379 : : | OMP_CLAUSE_REDUCTION | OMP_CLAUSE_ALLOCATE | OMP_CLAUSE_NOWAIT)
4380 : : #define OMP_SECTIONS_CLAUSES \
4381 : : (omp_mask (OMP_CLAUSE_PRIVATE) | OMP_CLAUSE_FIRSTPRIVATE \
4382 : : | OMP_CLAUSE_LASTPRIVATE | OMP_CLAUSE_REDUCTION \
4383 : : | OMP_CLAUSE_ALLOCATE | OMP_CLAUSE_NOWAIT)
4384 : : #define OMP_SIMD_CLAUSES \
4385 : : (omp_mask (OMP_CLAUSE_PRIVATE) | OMP_CLAUSE_LASTPRIVATE \
4386 : : | OMP_CLAUSE_REDUCTION | OMP_CLAUSE_COLLAPSE | OMP_CLAUSE_SAFELEN \
4387 : : | OMP_CLAUSE_LINEAR | OMP_CLAUSE_ALIGNED | OMP_CLAUSE_SIMDLEN \
4388 : : | OMP_CLAUSE_IF | OMP_CLAUSE_ORDER | OMP_CLAUSE_NOTEMPORAL)
4389 : : #define OMP_TASK_CLAUSES \
4390 : : (omp_mask (OMP_CLAUSE_PRIVATE) | OMP_CLAUSE_FIRSTPRIVATE \
4391 : : | OMP_CLAUSE_SHARED | OMP_CLAUSE_IF | OMP_CLAUSE_DEFAULT \
4392 : : | OMP_CLAUSE_UNTIED | OMP_CLAUSE_FINAL | OMP_CLAUSE_MERGEABLE \
4393 : : | OMP_CLAUSE_DEPEND | OMP_CLAUSE_PRIORITY | OMP_CLAUSE_IN_REDUCTION \
4394 : : | OMP_CLAUSE_DETACH | OMP_CLAUSE_AFFINITY | OMP_CLAUSE_ALLOCATE)
4395 : : #define OMP_TASKLOOP_CLAUSES \
4396 : : (omp_mask (OMP_CLAUSE_PRIVATE) | OMP_CLAUSE_FIRSTPRIVATE \
4397 : : | OMP_CLAUSE_LASTPRIVATE | OMP_CLAUSE_SHARED | OMP_CLAUSE_IF \
4398 : : | OMP_CLAUSE_DEFAULT | OMP_CLAUSE_UNTIED | OMP_CLAUSE_FINAL \
4399 : : | OMP_CLAUSE_MERGEABLE | OMP_CLAUSE_PRIORITY | OMP_CLAUSE_GRAINSIZE \
4400 : : | OMP_CLAUSE_NUM_TASKS | OMP_CLAUSE_COLLAPSE | OMP_CLAUSE_NOGROUP \
4401 : : | OMP_CLAUSE_REDUCTION | OMP_CLAUSE_IN_REDUCTION | OMP_CLAUSE_ALLOCATE)
4402 : : #define OMP_TASKGROUP_CLAUSES \
4403 : : (omp_mask (OMP_CLAUSE_TASK_REDUCTION) | OMP_CLAUSE_ALLOCATE)
4404 : : #define OMP_TARGET_CLAUSES \
4405 : : (omp_mask (OMP_CLAUSE_DEVICE) | OMP_CLAUSE_MAP | OMP_CLAUSE_IF \
4406 : : | OMP_CLAUSE_DEPEND | OMP_CLAUSE_NOWAIT | OMP_CLAUSE_PRIVATE \
4407 : : | OMP_CLAUSE_FIRSTPRIVATE | OMP_CLAUSE_DEFAULTMAP \
4408 : : | OMP_CLAUSE_IS_DEVICE_PTR | OMP_CLAUSE_IN_REDUCTION \
4409 : : | OMP_CLAUSE_THREAD_LIMIT | OMP_CLAUSE_ALLOCATE \
4410 : : | OMP_CLAUSE_HAS_DEVICE_ADDR | OMP_CLAUSE_USES_ALLOCATORS)
4411 : : #define OMP_TARGET_DATA_CLAUSES \
4412 : : (omp_mask (OMP_CLAUSE_DEVICE) | OMP_CLAUSE_MAP | OMP_CLAUSE_IF \
4413 : : | OMP_CLAUSE_USE_DEVICE_PTR | OMP_CLAUSE_USE_DEVICE_ADDR)
4414 : : #define OMP_TARGET_ENTER_DATA_CLAUSES \
4415 : : (omp_mask (OMP_CLAUSE_DEVICE) | OMP_CLAUSE_MAP | OMP_CLAUSE_IF \
4416 : : | OMP_CLAUSE_DEPEND | OMP_CLAUSE_NOWAIT)
4417 : : #define OMP_TARGET_EXIT_DATA_CLAUSES \
4418 : : (omp_mask (OMP_CLAUSE_DEVICE) | OMP_CLAUSE_MAP | OMP_CLAUSE_IF \
4419 : : | OMP_CLAUSE_DEPEND | OMP_CLAUSE_NOWAIT)
4420 : : #define OMP_TARGET_UPDATE_CLAUSES \
4421 : : (omp_mask (OMP_CLAUSE_DEVICE) | OMP_CLAUSE_IF | OMP_CLAUSE_TO \
4422 : : | OMP_CLAUSE_FROM | OMP_CLAUSE_DEPEND | OMP_CLAUSE_NOWAIT)
4423 : : #define OMP_TEAMS_CLAUSES \
4424 : : (omp_mask (OMP_CLAUSE_NUM_TEAMS) | OMP_CLAUSE_THREAD_LIMIT \
4425 : : | OMP_CLAUSE_DEFAULT | OMP_CLAUSE_PRIVATE | OMP_CLAUSE_FIRSTPRIVATE \
4426 : : | OMP_CLAUSE_SHARED | OMP_CLAUSE_REDUCTION | OMP_CLAUSE_ALLOCATE)
4427 : : #define OMP_DISTRIBUTE_CLAUSES \
4428 : : (omp_mask (OMP_CLAUSE_PRIVATE) | OMP_CLAUSE_FIRSTPRIVATE \
4429 : : | OMP_CLAUSE_LASTPRIVATE | OMP_CLAUSE_COLLAPSE | OMP_CLAUSE_DIST_SCHEDULE \
4430 : : | OMP_CLAUSE_ORDER | OMP_CLAUSE_ALLOCATE)
4431 : : #define OMP_SINGLE_CLAUSES \
4432 : : (omp_mask (OMP_CLAUSE_PRIVATE) | OMP_CLAUSE_FIRSTPRIVATE \
4433 : : | OMP_CLAUSE_ALLOCATE | OMP_CLAUSE_NOWAIT | OMP_CLAUSE_COPYPRIVATE)
4434 : : #define OMP_ORDERED_CLAUSES \
4435 : : (omp_mask (OMP_CLAUSE_THREADS) | OMP_CLAUSE_SIMD)
4436 : : #define OMP_DECLARE_TARGET_CLAUSES \
4437 : : (omp_mask (OMP_CLAUSE_ENTER) | OMP_CLAUSE_LINK | OMP_CLAUSE_DEVICE_TYPE \
4438 : : | OMP_CLAUSE_TO)
4439 : : #define OMP_ATOMIC_CLAUSES \
4440 : : (omp_mask (OMP_CLAUSE_ATOMIC) | OMP_CLAUSE_CAPTURE | OMP_CLAUSE_HINT \
4441 : : | OMP_CLAUSE_MEMORDER | OMP_CLAUSE_COMPARE | OMP_CLAUSE_FAIL \
4442 : : | OMP_CLAUSE_WEAK)
4443 : : #define OMP_MASKED_CLAUSES \
4444 : : (omp_mask (OMP_CLAUSE_FILTER))
4445 : : #define OMP_ERROR_CLAUSES \
4446 : : (omp_mask (OMP_CLAUSE_AT) | OMP_CLAUSE_MESSAGE | OMP_CLAUSE_SEVERITY)
4447 : : #define OMP_WORKSHARE_CLAUSES \
4448 : : omp_mask (OMP_CLAUSE_NOWAIT)
4449 : : #define OMP_ALLOCATORS_CLAUSES \
4450 : : omp_mask (OMP_CLAUSE_ALLOCATE)
4451 : :
4452 : :
4453 : : static match
4454 : 14400 : match_omp (gfc_exec_op op, const omp_mask mask)
4455 : : {
4456 : 14400 : gfc_omp_clauses *c;
4457 : 14400 : if (gfc_match_omp_clauses (&c, mask, true, true, false, false,
4458 : : op == EXEC_OMP_TARGET) != MATCH_YES)
4459 : : return MATCH_ERROR;
4460 : 14216 : new_st.op = op;
4461 : 14216 : new_st.ext.omp_clauses = c;
4462 : 14216 : return MATCH_YES;
4463 : : }
4464 : :
4465 : : /* Handles both declarative and (deprecated) executable ALLOCATE directive;
4466 : : accepts optional list (for executable) and common blocks.
4467 : : If no variables have been provided, the single omp namelist has sym == NULL.
4468 : :
4469 : : Note that the executable ALLOCATE directive permits structure elements only
4470 : : in OpenMP 5.0 and 5.1 but not longer in 5.2. See also the comment on the
4471 : : 'omp allocators' directive below. The accidental change was reverted for
4472 : : OpenMP TR12, permitting them again. See also gfc_match_omp_allocators.
4473 : :
4474 : : Hence, structure elements are rejected for now, also to make resolving
4475 : : OMP_LIST_ALLOCATE simpler (check for duplicates, same symbol in
4476 : : Fortran allocate stmt). TODO: Permit structure elements. */
4477 : :
4478 : : match
4479 : 92 : gfc_match_omp_allocate (void)
4480 : : {
4481 : 92 : match m;
4482 : 92 : bool first = true;
4483 : 92 : gfc_omp_namelist *vars = NULL;
4484 : 92 : gfc_expr *align = NULL;
4485 : 92 : gfc_expr *allocator = NULL;
4486 : 92 : locus loc = gfc_current_locus;
4487 : :
4488 : 92 : m = gfc_match_omp_variable_list (" (", &vars, true, NULL, NULL, true, true,
4489 : : NULL, true);
4490 : :
4491 : 92 : if (m == MATCH_ERROR)
4492 : : return m;
4493 : :
4494 : 174 : while (true)
4495 : : {
4496 : 174 : gfc_gobble_whitespace ();
4497 : 174 : if (gfc_match_omp_eos () == MATCH_YES)
4498 : : break;
4499 : 87 : if (!first)
4500 : 12 : gfc_match (", ");
4501 : 87 : first = false;
4502 : 87 : if ((m = gfc_match_dupl_check (!align, "align", true, &align))
4503 : : != MATCH_NO)
4504 : : {
4505 : 32 : if (m == MATCH_ERROR)
4506 : 1 : goto error;
4507 : 31 : continue;
4508 : : }
4509 : 55 : if ((m = gfc_match_dupl_check (!allocator, "allocator",
4510 : : true, &allocator)) != MATCH_NO)
4511 : : {
4512 : 54 : if (m == MATCH_ERROR)
4513 : 1 : goto error;
4514 : 53 : continue;
4515 : : }
4516 : 1 : gfc_error ("Expected ALIGN or ALLOCATOR clause at %C");
4517 : 1 : return MATCH_ERROR;
4518 : : }
4519 : 181 : for (gfc_omp_namelist *n = vars; n; n = n->next)
4520 : 97 : if (n->expr)
4521 : : {
4522 : 3 : if ((n->expr->ref && n->expr->ref->type == REF_COMPONENT)
4523 : 3 : || (n->expr->ref->next && n->expr->ref->type == REF_COMPONENT))
4524 : 1 : gfc_error ("Sorry, structure-element list item at %L in ALLOCATE "
4525 : : "directive is not yet supported", &n->expr->where);
4526 : : else
4527 : 2 : gfc_error ("Unexpected expression as list item at %L in ALLOCATE "
4528 : : "directive", &n->expr->where);
4529 : :
4530 : 3 : gfc_free_omp_namelist (vars, false, true, false);
4531 : 3 : goto error;
4532 : : }
4533 : :
4534 : 84 : new_st.op = EXEC_OMP_ALLOCATE;
4535 : 84 : new_st.ext.omp_clauses = gfc_get_omp_clauses ();
4536 : 84 : if (vars == NULL)
4537 : : {
4538 : 6 : vars = gfc_get_omp_namelist ();
4539 : 6 : vars->where = loc;
4540 : 6 : vars->u.align = align;
4541 : 6 : vars->u2.allocator = allocator;
4542 : 6 : new_st.ext.omp_clauses->lists[OMP_LIST_ALLOCATE] = vars;
4543 : : }
4544 : : else
4545 : : {
4546 : 78 : new_st.ext.omp_clauses->lists[OMP_LIST_ALLOCATE] = vars;
4547 : 172 : for (; vars; vars = vars->next)
4548 : : {
4549 : 94 : vars->u.align = (align) ? gfc_copy_expr (align) : NULL;
4550 : 94 : vars->u2.allocator = ((allocator) ? gfc_copy_expr (allocator) : NULL);
4551 : : }
4552 : 78 : gfc_free_expr (allocator);
4553 : 78 : gfc_free_expr (align);
4554 : : }
4555 : : return MATCH_YES;
4556 : :
4557 : 5 : error:
4558 : 5 : gfc_free_expr (align);
4559 : 5 : gfc_free_expr (allocator);
4560 : 5 : return MATCH_ERROR;
4561 : : }
4562 : :
4563 : : /* In line with OpenMP 5.2 derived-type components are rejected.
4564 : : See also comment before gfc_match_omp_allocate. */
4565 : :
4566 : : match
4567 : 11 : gfc_match_omp_allocators (void)
4568 : : {
4569 : 11 : return match_omp (EXEC_OMP_ALLOCATORS, OMP_ALLOCATORS_CLAUSES);
4570 : : }
4571 : :
4572 : :
4573 : : match
4574 : 17 : gfc_match_omp_assume (void)
4575 : : {
4576 : 17 : gfc_omp_clauses *c;
4577 : 17 : locus loc = gfc_current_locus;
4578 : 17 : if ((gfc_match_omp_clauses (&c, omp_mask (OMP_CLAUSE_ASSUMPTIONS))
4579 : : != MATCH_YES)
4580 : 17 : || (omp_verify_merge_absent_contains (ST_OMP_ASSUME, c->assume, NULL,
4581 : : &loc) != MATCH_YES))
4582 : 4 : return MATCH_ERROR;
4583 : 13 : new_st.op = EXEC_OMP_ASSUME;
4584 : 13 : new_st.ext.omp_clauses = c;
4585 : 13 : return MATCH_YES;
4586 : : }
4587 : :
4588 : :
4589 : : match
4590 : 28 : gfc_match_omp_assumes (void)
4591 : : {
4592 : 28 : gfc_omp_clauses *c;
4593 : 28 : locus loc = gfc_current_locus;
4594 : 28 : if (!gfc_current_ns->proc_name
4595 : 27 : || (gfc_current_ns->proc_name->attr.flavor != FL_MODULE
4596 : : && !gfc_current_ns->proc_name->attr.subroutine
4597 : 23 : && !gfc_current_ns->proc_name->attr.function))
4598 : : {
4599 : 2 : gfc_error ("!$OMP ASSUMES at %C must be in the specification part of a "
4600 : : "subprogram or module");
4601 : 2 : return MATCH_ERROR;
4602 : : }
4603 : 26 : if ((gfc_match_omp_clauses (&c, omp_mask (OMP_CLAUSE_ASSUMPTIONS))
4604 : : != MATCH_YES)
4605 : 26 : || (omp_verify_merge_absent_contains (ST_OMP_ASSUMES, c->assume,
4606 : : gfc_current_ns->omp_assumes, &loc)
4607 : : != MATCH_YES))
4608 : 5 : return MATCH_ERROR;
4609 : 21 : if (gfc_current_ns->omp_assumes == NULL)
4610 : : {
4611 : 19 : gfc_current_ns->omp_assumes = c->assume;
4612 : 19 : c->assume = NULL;
4613 : : }
4614 : 2 : else if (gfc_current_ns->omp_assumes && c->assume)
4615 : : {
4616 : 2 : gfc_current_ns->omp_assumes->no_openmp |= c->assume->no_openmp;
4617 : 2 : gfc_current_ns->omp_assumes->no_openmp_routines
4618 : 2 : |= c->assume->no_openmp_routines;
4619 : 2 : gfc_current_ns->omp_assumes->no_parallelism |= c->assume->no_parallelism;
4620 : 2 : if (gfc_current_ns->omp_assumes->holds && c->assume->holds)
4621 : : {
4622 : : gfc_expr_list *el = gfc_current_ns->omp_assumes->holds;
4623 : 1 : for ( ; el->next ; el = el->next)
4624 : : ;
4625 : 1 : el->next = c->assume->holds;
4626 : 1 : }
4627 : 1 : else if (c->assume->holds)
4628 : 0 : gfc_current_ns->omp_assumes->holds = c->assume->holds;
4629 : 2 : c->assume->holds = NULL;
4630 : : }
4631 : 21 : gfc_free_omp_clauses (c);
4632 : 21 : return MATCH_YES;
4633 : : }
4634 : :
4635 : :
4636 : : match
4637 : 162 : gfc_match_omp_critical (void)
4638 : : {
4639 : 162 : char n[GFC_MAX_SYMBOL_LEN+1];
4640 : 162 : gfc_omp_clauses *c = NULL;
4641 : :
4642 : 162 : if (gfc_match (" ( %n )", n) != MATCH_YES)
4643 : 115 : n[0] = '\0';
4644 : :
4645 : 162 : if (gfc_match_omp_clauses (&c, omp_mask (OMP_CLAUSE_HINT),
4646 : 162 : /* first = */ n[0] == '\0') != MATCH_YES)
4647 : : return MATCH_ERROR;
4648 : :
4649 : 160 : new_st.op = EXEC_OMP_CRITICAL;
4650 : 160 : new_st.ext.omp_clauses = c;
4651 : 160 : if (n[0])
4652 : 47 : c->critical_name = xstrdup (n);
4653 : : return MATCH_YES;
4654 : : }
4655 : :
4656 : :
4657 : : match
4658 : 160 : gfc_match_omp_end_critical (void)
4659 : : {
4660 : 160 : char n[GFC_MAX_SYMBOL_LEN+1];
4661 : :
4662 : 160 : if (gfc_match (" ( %n )", n) != MATCH_YES)
4663 : 113 : n[0] = '\0';
4664 : 160 : if (gfc_match_omp_eos () != MATCH_YES)
4665 : : {
4666 : 1 : gfc_error ("Unexpected junk after $OMP CRITICAL statement at %C");
4667 : 1 : return MATCH_ERROR;
4668 : : }
4669 : :
4670 : 159 : new_st.op = EXEC_OMP_END_CRITICAL;
4671 : 159 : new_st.ext.omp_name = n[0] ? xstrdup (n) : NULL;
4672 : 159 : return MATCH_YES;
4673 : : }
4674 : :
4675 : : /* depobj(depobj) depend(dep-type:loc)|destroy|update(dep-type)
4676 : : dep-type = in/out/inout/mutexinoutset/depobj/source/sink
4677 : : depend: !source, !sink
4678 : : update: !source, !sink, !depobj
4679 : : locator = exactly one list item .*/
4680 : : match
4681 : 119 : gfc_match_omp_depobj (void)
4682 : : {
4683 : 119 : gfc_omp_clauses *c = NULL;
4684 : 119 : gfc_expr *depobj;
4685 : :
4686 : 119 : if (gfc_match (" ( %v ) ", &depobj) != MATCH_YES)
4687 : : {
4688 : 2 : gfc_error ("Expected %<( depobj )%> at %C");
4689 : 2 : return MATCH_ERROR;
4690 : : }
4691 : 117 : if (gfc_match ("update ( ") == MATCH_YES)
4692 : : {
4693 : 12 : c = gfc_get_omp_clauses ();
4694 : 12 : if (gfc_match ("inoutset )") == MATCH_YES)
4695 : 2 : c->depobj_update = OMP_DEPEND_INOUTSET;
4696 : 10 : else if (gfc_match ("inout )") == MATCH_YES)
4697 : 1 : c->depobj_update = OMP_DEPEND_INOUT;
4698 : 9 : else if (gfc_match ("in )") == MATCH_YES)
4699 : 2 : c->depobj_update = OMP_DEPEND_IN;
4700 : 7 : else if (gfc_match ("out )") == MATCH_YES)
4701 : 2 : c->depobj_update = OMP_DEPEND_OUT;
4702 : 5 : else if (gfc_match ("mutexinoutset )") == MATCH_YES)
4703 : 2 : c->depobj_update = OMP_DEPEND_MUTEXINOUTSET;
4704 : : else
4705 : : {
4706 : 3 : gfc_error ("Expected IN, OUT, INOUT, INOUTSET or MUTEXINOUTSET "
4707 : : "followed by %<)%> at %C");
4708 : 3 : goto error;
4709 : : }
4710 : : }
4711 : 105 : else if (gfc_match ("destroy") == MATCH_YES)
4712 : : {
4713 : 11 : c = gfc_get_omp_clauses ();
4714 : 11 : c->destroy = true;
4715 : : }
4716 : 94 : else if (gfc_match_omp_clauses (&c, omp_mask (OMP_CLAUSE_DEPEND), true, false)
4717 : : != MATCH_YES)
4718 : 2 : goto error;
4719 : :
4720 : 112 : if (c->depobj_update == OMP_DEPEND_UNSET && !c->destroy)
4721 : : {
4722 : 92 : if (!c->doacross_source && !c->lists[OMP_LIST_DEPEND])
4723 : : {
4724 : 1 : gfc_error ("Expected DEPEND, UPDATE, or DESTROY clause at %C");
4725 : 1 : goto error;
4726 : : }
4727 : 91 : if (c->lists[OMP_LIST_DEPEND]->u.depend_doacross_op == OMP_DEPEND_DEPOBJ)
4728 : : {
4729 : 1 : gfc_error ("DEPEND clause at %L of OMP DEPOBJ construct shall not "
4730 : : "have dependence-type DEPOBJ",
4731 : : c->lists[OMP_LIST_DEPEND]
4732 : : ? &c->lists[OMP_LIST_DEPEND]->where : &gfc_current_locus);
4733 : 1 : goto error;
4734 : : }
4735 : 90 : if (c->lists[OMP_LIST_DEPEND]->next)
4736 : : {
4737 : 1 : gfc_error ("DEPEND clause at %L of OMP DEPOBJ construct shall have "
4738 : : "only a single locator",
4739 : : &c->lists[OMP_LIST_DEPEND]->next->where);
4740 : 1 : goto error;
4741 : : }
4742 : : }
4743 : :
4744 : 109 : c->depobj = depobj;
4745 : 109 : new_st.op = EXEC_OMP_DEPOBJ;
4746 : 109 : new_st.ext.omp_clauses = c;
4747 : 109 : return MATCH_YES;
4748 : :
4749 : 8 : error:
4750 : 8 : gfc_free_expr (depobj);
4751 : 8 : gfc_free_omp_clauses (c);
4752 : 8 : return MATCH_ERROR;
4753 : : }
4754 : :
4755 : : match
4756 : 57 : gfc_match_omp_distribute (void)
4757 : : {
4758 : 57 : return match_omp (EXEC_OMP_DISTRIBUTE, OMP_DISTRIBUTE_CLAUSES);
4759 : : }
4760 : :
4761 : :
4762 : : match
4763 : 36 : gfc_match_omp_distribute_parallel_do (void)
4764 : : {
4765 : 36 : return match_omp (EXEC_OMP_DISTRIBUTE_PARALLEL_DO,
4766 : 36 : (OMP_DISTRIBUTE_CLAUSES | OMP_PARALLEL_CLAUSES
4767 : 36 : | OMP_DO_CLAUSES)
4768 : 36 : & ~(omp_mask (OMP_CLAUSE_ORDERED)
4769 : 36 : | OMP_CLAUSE_LINEAR | OMP_CLAUSE_NOWAIT));
4770 : : }
4771 : :
4772 : :
4773 : : match
4774 : 34 : gfc_match_omp_distribute_parallel_do_simd (void)
4775 : : {
4776 : 34 : return match_omp (EXEC_OMP_DISTRIBUTE_PARALLEL_DO_SIMD,
4777 : 34 : (OMP_DISTRIBUTE_CLAUSES | OMP_PARALLEL_CLAUSES
4778 : 34 : | OMP_DO_CLAUSES | OMP_SIMD_CLAUSES)
4779 : 34 : & ~(omp_mask (OMP_CLAUSE_ORDERED) | OMP_CLAUSE_NOWAIT));
4780 : : }
4781 : :
4782 : :
4783 : : match
4784 : 52 : gfc_match_omp_distribute_simd (void)
4785 : : {
4786 : 52 : return match_omp (EXEC_OMP_DISTRIBUTE_SIMD,
4787 : 52 : OMP_DISTRIBUTE_CLAUSES | OMP_SIMD_CLAUSES);
4788 : : }
4789 : :
4790 : :
4791 : : match
4792 : 1155 : gfc_match_omp_do (void)
4793 : : {
4794 : 1155 : return match_omp (EXEC_OMP_DO, OMP_DO_CLAUSES);
4795 : : }
4796 : :
4797 : :
4798 : : match
4799 : 137 : gfc_match_omp_do_simd (void)
4800 : : {
4801 : 137 : return match_omp (EXEC_OMP_DO_SIMD, OMP_DO_CLAUSES | OMP_SIMD_CLAUSES);
4802 : : }
4803 : :
4804 : :
4805 : : match
4806 : 69 : gfc_match_omp_loop (void)
4807 : : {
4808 : 69 : return match_omp (EXEC_OMP_LOOP, OMP_LOOP_CLAUSES);
4809 : : }
4810 : :
4811 : :
4812 : : match
4813 : 12 : gfc_match_omp_teams_loop (void)
4814 : : {
4815 : 12 : return match_omp (EXEC_OMP_TEAMS_LOOP, OMP_TEAMS_CLAUSES | OMP_LOOP_CLAUSES);
4816 : : }
4817 : :
4818 : :
4819 : : match
4820 : 15 : gfc_match_omp_target_teams_loop (void)
4821 : : {
4822 : 15 : return match_omp (EXEC_OMP_TARGET_TEAMS_LOOP,
4823 : 15 : OMP_TARGET_CLAUSES | OMP_TEAMS_CLAUSES | OMP_LOOP_CLAUSES);
4824 : : }
4825 : :
4826 : :
4827 : : match
4828 : 12 : gfc_match_omp_parallel_loop (void)
4829 : : {
4830 : 12 : return match_omp (EXEC_OMP_PARALLEL_LOOP,
4831 : 12 : OMP_PARALLEL_CLAUSES | OMP_LOOP_CLAUSES);
4832 : : }
4833 : :
4834 : :
4835 : : match
4836 : 16 : gfc_match_omp_target_parallel_loop (void)
4837 : : {
4838 : 16 : return match_omp (EXEC_OMP_TARGET_PARALLEL_LOOP,
4839 : 16 : (OMP_TARGET_CLAUSES | OMP_PARALLEL_CLAUSES
4840 : 16 : | OMP_LOOP_CLAUSES));
4841 : : }
4842 : :
4843 : :
4844 : : match
4845 : 88 : gfc_match_omp_error (void)
4846 : : {
4847 : 88 : locus loc = gfc_current_locus;
4848 : 88 : match m = match_omp (EXEC_OMP_ERROR, OMP_ERROR_CLAUSES);
4849 : 88 : if (m != MATCH_YES)
4850 : : return m;
4851 : :
4852 : 69 : gfc_omp_clauses *c = new_st.ext.omp_clauses;
4853 : 69 : if (c->severity == OMP_SEVERITY_UNSET)
4854 : 32 : c->severity = OMP_SEVERITY_FATAL;
4855 : 69 : if (new_st.ext.omp_clauses->at == OMP_AT_EXECUTION)
4856 : : return MATCH_YES;
4857 : 36 : if (c->message
4858 : 36 : && (!gfc_resolve_expr (c->message)
4859 : 16 : || c->message->ts.type != BT_CHARACTER
4860 : 14 : || c->message->ts.kind != gfc_default_character_kind
4861 : 13 : || c->message->rank != 0))
4862 : : {
4863 : 4 : gfc_error ("MESSAGE clause at %L requires a scalar default-kind "
4864 : : "CHARACTER expression",
4865 : 4 : &new_st.ext.omp_clauses->message->where);
4866 : 4 : return MATCH_ERROR;
4867 : : }
4868 : 32 : if (c->message && !gfc_is_constant_expr (c->message))
4869 : : {
4870 : 2 : gfc_error ("Constant character expression required in MESSAGE clause "
4871 : 2 : "at %L", &new_st.ext.omp_clauses->message->where);
4872 : 2 : return MATCH_ERROR;
4873 : : }
4874 : 30 : if (c->message)
4875 : : {
4876 : 10 : const char *msg = G_("$OMP ERROR encountered at %L: %s");
4877 : 10 : gcc_assert (c->message->expr_type == EXPR_CONSTANT);
4878 : 10 : gfc_charlen_t slen = c->message->value.character.length;
4879 : 10 : int i = gfc_validate_kind (BT_CHARACTER, gfc_default_character_kind,
4880 : : false);
4881 : 10 : size_t size = slen * gfc_character_kinds[i].bit_size / 8;
4882 : 10 : unsigned char *s = XCNEWVAR (unsigned char, size + 1);
4883 : 10 : gfc_encode_character (gfc_default_character_kind, slen,
4884 : 10 : c->message->value.character.string,
4885 : : (unsigned char *) s, size);
4886 : 10 : s[size] = '\0';
4887 : 10 : if (c->severity == OMP_SEVERITY_WARNING)
4888 : 6 : gfc_warning_now (0, msg, &loc, s);
4889 : : else
4890 : 4 : gfc_error_now (msg, &loc, s);
4891 : 10 : free (s);
4892 : : }
4893 : : else
4894 : : {
4895 : 20 : const char *msg = G_("$OMP ERROR encountered at %L");
4896 : 20 : if (c->severity == OMP_SEVERITY_WARNING)
4897 : 7 : gfc_warning_now (0, msg, &loc);
4898 : : else
4899 : 13 : gfc_error_now (msg, &loc);
4900 : : }
4901 : : return MATCH_YES;
4902 : : }
4903 : :
4904 : : match
4905 : 82 : gfc_match_omp_flush (void)
4906 : : {
4907 : 82 : gfc_omp_namelist *list = NULL;
4908 : 82 : gfc_omp_clauses *c = NULL;
4909 : 82 : gfc_gobble_whitespace ();
4910 : 82 : enum gfc_omp_memorder mo = OMP_MEMORDER_UNSET;
4911 : 82 : if (gfc_match_omp_eos () == MATCH_NO && gfc_peek_ascii_char () != '(')
4912 : : {
4913 : 14 : if (gfc_match ("seq_cst") == MATCH_YES)
4914 : : mo = OMP_MEMORDER_SEQ_CST;
4915 : 11 : else if (gfc_match ("acq_rel") == MATCH_YES)
4916 : : mo = OMP_MEMORDER_ACQ_REL;
4917 : 8 : else if (gfc_match ("release") == MATCH_YES)
4918 : : mo = OMP_MEMORDER_RELEASE;
4919 : 5 : else if (gfc_match ("acquire") == MATCH_YES)
4920 : : mo = OMP_MEMORDER_ACQUIRE;
4921 : : else
4922 : : {
4923 : 2 : gfc_error ("Expected SEQ_CST, AQC_REL, RELEASE, or ACQUIRE at %C");
4924 : 2 : return MATCH_ERROR;
4925 : : }
4926 : 12 : c = gfc_get_omp_clauses ();
4927 : 12 : c->memorder = mo;
4928 : : }
4929 : 80 : gfc_match_omp_variable_list (" (", &list, true);
4930 : 80 : if (list && mo != OMP_MEMORDER_UNSET)
4931 : : {
4932 : 4 : gfc_error ("List specified together with memory order clause in FLUSH "
4933 : : "directive at %C");
4934 : 4 : gfc_free_omp_namelist (list, false, false, false);
4935 : 4 : gfc_free_omp_clauses (c);
4936 : 4 : return MATCH_ERROR;
4937 : : }
4938 : 76 : if (gfc_match_omp_eos () != MATCH_YES)
4939 : : {
4940 : 0 : gfc_error ("Unexpected junk after $OMP FLUSH statement at %C");
4941 : 0 : gfc_free_omp_namelist (list, false, false, false);
4942 : 0 : gfc_free_omp_clauses (c);
4943 : 0 : return MATCH_ERROR;
4944 : : }
4945 : 76 : new_st.op = EXEC_OMP_FLUSH;
4946 : 76 : new_st.ext.omp_namelist = list;
4947 : 76 : new_st.ext.omp_clauses = c;
4948 : 76 : return MATCH_YES;
4949 : : }
4950 : :
4951 : :
4952 : : match
4953 : 193 : gfc_match_omp_declare_simd (void)
4954 : : {
4955 : 193 : locus where = gfc_current_locus;
4956 : 193 : gfc_symbol *proc_name;
4957 : 193 : gfc_omp_clauses *c;
4958 : 193 : gfc_omp_declare_simd *ods;
4959 : 193 : bool needs_space = false;
4960 : :
4961 : 193 : switch (gfc_match (" ( "))
4962 : : {
4963 : 149 : case MATCH_YES:
4964 : 149 : if (gfc_match_symbol (&proc_name, /* host assoc = */ true) != MATCH_YES
4965 : 149 : || gfc_match (" ) ") != MATCH_YES)
4966 : 0 : return MATCH_ERROR;
4967 : : break;
4968 : 44 : case MATCH_NO: proc_name = NULL; needs_space = true; break;
4969 : : case MATCH_ERROR: return MATCH_ERROR;
4970 : : }
4971 : :
4972 : 193 : if (gfc_match_omp_clauses (&c, OMP_DECLARE_SIMD_CLAUSES, true,
4973 : : needs_space) != MATCH_YES)
4974 : : return MATCH_ERROR;
4975 : :
4976 : 188 : if (gfc_current_ns->is_block_data)
4977 : : {
4978 : 1 : gfc_free_omp_clauses (c);
4979 : 1 : return MATCH_YES;
4980 : : }
4981 : :
4982 : 187 : ods = gfc_get_omp_declare_simd ();
4983 : 187 : ods->where = where;
4984 : 187 : ods->proc_name = proc_name;
4985 : 187 : ods->clauses = c;
4986 : 187 : ods->next = gfc_current_ns->omp_declare_simd;
4987 : 187 : gfc_current_ns->omp_declare_simd = ods;
4988 : 187 : return MATCH_YES;
4989 : : }
4990 : :
4991 : :
4992 : : static bool
4993 : 877 : match_udr_expr (gfc_symtree *omp_sym1, gfc_symtree *omp_sym2)
4994 : : {
4995 : 877 : match m;
4996 : 877 : locus old_loc = gfc_current_locus;
4997 : 877 : char sname[GFC_MAX_SYMBOL_LEN + 1];
4998 : 877 : gfc_symbol *sym;
4999 : 877 : gfc_namespace *ns = gfc_current_ns;
5000 : 877 : gfc_expr *lvalue = NULL, *rvalue = NULL;
5001 : 877 : gfc_symtree *st;
5002 : 877 : gfc_actual_arglist *arglist;
5003 : :
5004 : 877 : m = gfc_match (" %v =", &lvalue);
5005 : 877 : if (m != MATCH_YES)
5006 : 200 : gfc_current_locus = old_loc;
5007 : : else
5008 : : {
5009 : 677 : m = gfc_match (" %e )", &rvalue);
5010 : 677 : if (m == MATCH_YES)
5011 : : {
5012 : 675 : ns->code = gfc_get_code (EXEC_ASSIGN);
5013 : 675 : ns->code->expr1 = lvalue;
5014 : 675 : ns->code->expr2 = rvalue;
5015 : 675 : ns->code->loc = old_loc;
5016 : 675 : return true;
5017 : : }
5018 : :
5019 : 2 : gfc_current_locus = old_loc;
5020 : 2 : gfc_free_expr (lvalue);
5021 : : }
5022 : :
5023 : 202 : m = gfc_match (" %n", sname);
5024 : 202 : if (m != MATCH_YES)
5025 : : return false;
5026 : :
5027 : 202 : if (strcmp (sname, omp_sym1->name) == 0
5028 : 200 : || strcmp (sname, omp_sym2->name) == 0)
5029 : : return false;
5030 : :
5031 : 200 : gfc_current_ns = ns->parent;
5032 : 200 : if (gfc_get_ha_sym_tree (sname, &st))
5033 : : return false;
5034 : :
5035 : 200 : sym = st->n.sym;
5036 : 200 : if (sym->attr.flavor != FL_PROCEDURE
5037 : 72 : && sym->attr.flavor != FL_UNKNOWN)
5038 : : return false;
5039 : :
5040 : 199 : if (!sym->attr.generic
5041 : : && !sym->attr.subroutine
5042 : 199 : && !sym->attr.function)
5043 : : {
5044 : 71 : if (!(sym->attr.external && !sym->attr.referenced))
5045 : : {
5046 : : /* ...create a symbol in this scope... */
5047 : 71 : if (sym->ns != gfc_current_ns
5048 : 71 : && gfc_get_sym_tree (sname, NULL, &st, false) == 1)
5049 : : return false;
5050 : :
5051 : 71 : if (sym != st->n.sym)
5052 : 71 : sym = st->n.sym;
5053 : : }
5054 : :
5055 : : /* ...and then to try to make the symbol into a subroutine. */
5056 : 71 : if (!gfc_add_subroutine (&sym->attr, sym->name, NULL))
5057 : : return false;
5058 : : }
5059 : :
5060 : 199 : gfc_set_sym_referenced (sym);
5061 : 199 : gfc_gobble_whitespace ();
5062 : 199 : if (gfc_peek_ascii_char () != '(')
5063 : : return false;
5064 : :
5065 : 195 : gfc_current_ns = ns;
5066 : 195 : m = gfc_match_actual_arglist (1, &arglist);
5067 : 195 : if (m != MATCH_YES)
5068 : : return false;
5069 : :
5070 : 195 : if (gfc_match_char (')') != MATCH_YES)
5071 : : return false;
5072 : :
5073 : 195 : ns->code = gfc_get_code (EXEC_CALL);
5074 : 195 : ns->code->symtree = st;
5075 : 195 : ns->code->ext.actual = arglist;
5076 : 195 : ns->code->loc = old_loc;
5077 : 195 : return true;
5078 : : }
5079 : :
5080 : : static bool
5081 : 1156 : gfc_omp_udr_predef (gfc_omp_reduction_op rop, const char *name,
5082 : : gfc_typespec *ts, const char **n)
5083 : : {
5084 : 1156 : if (!gfc_numeric_ts (ts) && ts->type != BT_LOGICAL)
5085 : : return false;
5086 : :
5087 : 648 : switch (rop)
5088 : : {
5089 : 21 : case OMP_REDUCTION_PLUS:
5090 : 21 : case OMP_REDUCTION_MINUS:
5091 : 21 : case OMP_REDUCTION_TIMES:
5092 : 21 : return ts->type != BT_LOGICAL;
5093 : 8 : case OMP_REDUCTION_AND:
5094 : 8 : case OMP_REDUCTION_OR:
5095 : 8 : case OMP_REDUCTION_EQV:
5096 : 8 : case OMP_REDUCTION_NEQV:
5097 : 8 : return ts->type == BT_LOGICAL;
5098 : 618 : case OMP_REDUCTION_USER:
5099 : 618 : if (name[0] != '.' && (ts->type == BT_INTEGER || ts->type == BT_REAL))
5100 : : {
5101 : 546 : gfc_symbol *sym;
5102 : :
5103 : 546 : gfc_find_symbol (name, NULL, 1, &sym);
5104 : 546 : if (sym != NULL)
5105 : : {
5106 : 93 : if (sym->attr.intrinsic)
5107 : 0 : *n = sym->name;
5108 : 93 : else if ((sym->attr.flavor != FL_UNKNOWN
5109 : 81 : && sym->attr.flavor != FL_PROCEDURE)
5110 : : || sym->attr.external
5111 : 69 : || sym->attr.generic
5112 : 54 : || sym->attr.entry
5113 : : || sym->attr.result
5114 : : || sym->attr.dummy
5115 : : || sym->attr.subroutine
5116 : : || sym->attr.pointer
5117 : 54 : || sym->attr.target
5118 : : || sym->attr.cray_pointer
5119 : 50 : || sym->attr.cray_pointee
5120 : 50 : || (sym->attr.proc != PROC_UNKNOWN
5121 : 0 : && sym->attr.proc != PROC_INTRINSIC)
5122 : 50 : || sym->attr.if_source != IFSRC_UNKNOWN
5123 : 50 : || sym == sym->ns->proc_name)
5124 : 43 : *n = NULL;
5125 : : else
5126 : 50 : *n = sym->name;
5127 : : }
5128 : : else
5129 : 453 : *n = name;
5130 : 546 : if (*n
5131 : 503 : && (strcmp (*n, "max") == 0 || strcmp (*n, "min") == 0))
5132 : 54 : return true;
5133 : 510 : else if (*n
5134 : 467 : && ts->type == BT_INTEGER
5135 : 383 : && (strcmp (*n, "iand") == 0
5136 : 377 : || strcmp (*n, "ior") == 0
5137 : 371 : || strcmp (*n, "ieor") == 0))
5138 : : return true;
5139 : : }
5140 : : break;
5141 : : default:
5142 : : break;
5143 : : }
5144 : : return false;
5145 : : }
5146 : :
5147 : : gfc_omp_udr *
5148 : 639 : gfc_omp_udr_find (gfc_symtree *st, gfc_typespec *ts)
5149 : : {
5150 : 639 : gfc_omp_udr *omp_udr;
5151 : :
5152 : 639 : if (st == NULL)
5153 : : return NULL;
5154 : :
5155 : 250 : for (omp_udr = st->n.omp_udr; omp_udr; omp_udr = omp_udr->next)
5156 : 154 : if (omp_udr->ts.type == ts->type
5157 : 89 : || ((omp_udr->ts.type == BT_DERIVED || omp_udr->ts.type == BT_CLASS)
5158 : 0 : && (ts->type == BT_DERIVED || ts->type == BT_CLASS)))
5159 : : {
5160 : 65 : if (omp_udr->ts.type == BT_DERIVED || omp_udr->ts.type == BT_CLASS)
5161 : : {
5162 : 12 : if (strcmp (omp_udr->ts.u.derived->name, ts->u.derived->name) == 0)
5163 : 6 : return omp_udr;
5164 : : }
5165 : 53 : else if (omp_udr->ts.kind == ts->kind)
5166 : : {
5167 : 19 : if (omp_udr->ts.type == BT_CHARACTER)
5168 : : {
5169 : 17 : if (omp_udr->ts.u.cl->length == NULL
5170 : 15 : || ts->u.cl->length == NULL)
5171 : 2 : return omp_udr;
5172 : 15 : if (omp_udr->ts.u.cl->length->expr_type != EXPR_CONSTANT)
5173 : 0 : return omp_udr;
5174 : 15 : if (ts->u.cl->length->expr_type != EXPR_CONSTANT)
5175 : 0 : return omp_udr;
5176 : 15 : if (omp_udr->ts.u.cl->length->ts.type != BT_INTEGER)
5177 : 0 : return omp_udr;
5178 : 15 : if (ts->u.cl->length->ts.type != BT_INTEGER)
5179 : 0 : return omp_udr;
5180 : 15 : if (gfc_compare_expr (omp_udr->ts.u.cl->length,
5181 : : ts->u.cl->length, INTRINSIC_EQ) != 0)
5182 : 15 : continue;
5183 : : }
5184 : 2 : return omp_udr;
5185 : : }
5186 : : }
5187 : : return NULL;
5188 : : }
5189 : :
5190 : : match
5191 : 532 : gfc_match_omp_declare_reduction (void)
5192 : : {
5193 : 532 : match m;
5194 : 532 : gfc_intrinsic_op op;
5195 : 532 : char name[GFC_MAX_SYMBOL_LEN + 3];
5196 : 532 : auto_vec<gfc_typespec, 5> tss;
5197 : 532 : gfc_typespec ts;
5198 : 532 : unsigned int i;
5199 : 532 : gfc_symtree *st;
5200 : 532 : locus where = gfc_current_locus;
5201 : 532 : locus end_loc = gfc_current_locus;
5202 : 532 : bool end_loc_set = false;
5203 : 532 : gfc_omp_reduction_op rop = OMP_REDUCTION_NONE;
5204 : :
5205 : 532 : if (gfc_match_char ('(') != MATCH_YES)
5206 : : return MATCH_ERROR;
5207 : :
5208 : 530 : m = gfc_match (" %o : ", &op);
5209 : 530 : if (m == MATCH_ERROR)
5210 : : return MATCH_ERROR;
5211 : 530 : if (m == MATCH_YES)
5212 : : {
5213 : 117 : snprintf (name, sizeof name, "operator %s", gfc_op2string (op));
5214 : 117 : rop = (gfc_omp_reduction_op) op;
5215 : : }
5216 : : else
5217 : : {
5218 : 413 : m = gfc_match_defined_op_name (name + 1, 1);
5219 : 413 : if (m == MATCH_ERROR)
5220 : : return MATCH_ERROR;
5221 : 413 : if (m == MATCH_YES)
5222 : : {
5223 : 41 : name[0] = '.';
5224 : 41 : strcat (name, ".");
5225 : 41 : if (gfc_match (" : ") != MATCH_YES)
5226 : : return MATCH_ERROR;
5227 : : }
5228 : : else
5229 : : {
5230 : 372 : if (gfc_match (" %n : ", name) != MATCH_YES)
5231 : : return MATCH_ERROR;
5232 : : }
5233 : : rop = OMP_REDUCTION_USER;
5234 : : }
5235 : :
5236 : 529 : m = gfc_match_type_spec (&ts);
5237 : 529 : if (m != MATCH_YES)
5238 : : return MATCH_ERROR;
5239 : : /* Treat len=: the same as len=*. */
5240 : 528 : if (ts.type == BT_CHARACTER)
5241 : 61 : ts.deferred = false;
5242 : 528 : tss.safe_push (ts);
5243 : :
5244 : 1093 : while (gfc_match_char (',') == MATCH_YES)
5245 : : {
5246 : 37 : m = gfc_match_type_spec (&ts);
5247 : 37 : if (m != MATCH_YES)
5248 : : return MATCH_ERROR;
5249 : 37 : tss.safe_push (ts);
5250 : : }
5251 : 528 : if (gfc_match_char (':') != MATCH_YES)
5252 : : return MATCH_ERROR;
5253 : :
5254 : 527 : st = gfc_find_symtree (gfc_current_ns->omp_udr_root, name);
5255 : 2168 : for (i = 0; i < tss.length (); i++)
5256 : : {
5257 : 564 : gfc_symtree *omp_out, *omp_in;
5258 : 564 : gfc_symtree *omp_priv = NULL, *omp_orig = NULL;
5259 : 564 : gfc_namespace *combiner_ns, *initializer_ns = NULL;
5260 : 564 : gfc_omp_udr *prev_udr, *omp_udr;
5261 : 564 : const char *predef_name = NULL;
5262 : :
5263 : 564 : omp_udr = gfc_get_omp_udr ();
5264 : 564 : omp_udr->name = gfc_get_string ("%s", name);
5265 : 564 : omp_udr->rop = rop;
5266 : 564 : omp_udr->ts = tss[i];
5267 : 564 : omp_udr->where = where;
5268 : :
5269 : 564 : gfc_current_ns = combiner_ns = gfc_get_namespace (gfc_current_ns, 1);
5270 : 564 : combiner_ns->proc_name = combiner_ns->parent->proc_name;
5271 : :
5272 : 564 : gfc_get_sym_tree ("omp_out", combiner_ns, &omp_out, false);
5273 : 564 : gfc_get_sym_tree ("omp_in", combiner_ns, &omp_in, false);
5274 : 564 : combiner_ns->omp_udr_ns = 1;
5275 : 564 : omp_out->n.sym->ts = tss[i];
5276 : 564 : omp_in->n.sym->ts = tss[i];
5277 : 564 : omp_out->n.sym->attr.omp_udr_artificial_var = 1;
5278 : 564 : omp_in->n.sym->attr.omp_udr_artificial_var = 1;
5279 : 564 : omp_out->n.sym->attr.flavor = FL_VARIABLE;
5280 : 564 : omp_in->n.sym->attr.flavor = FL_VARIABLE;
5281 : 564 : gfc_commit_symbols ();
5282 : 564 : omp_udr->combiner_ns = combiner_ns;
5283 : 564 : omp_udr->omp_out = omp_out->n.sym;
5284 : 564 : omp_udr->omp_in = omp_in->n.sym;
5285 : :
5286 : 564 : locus old_loc = gfc_current_locus;
5287 : :
5288 : 564 : if (!match_udr_expr (omp_out, omp_in))
5289 : : {
5290 : 4 : syntax:
5291 : 7 : gfc_current_locus = old_loc;
5292 : 7 : gfc_current_ns = combiner_ns->parent;
5293 : 7 : gfc_undo_symbols ();
5294 : 7 : gfc_free_omp_udr (omp_udr);
5295 : 7 : return MATCH_ERROR;
5296 : : }
5297 : :
5298 : 560 : if (gfc_match (" initializer ( ") == MATCH_YES)
5299 : : {
5300 : 313 : gfc_current_ns = combiner_ns->parent;
5301 : 313 : initializer_ns = gfc_get_namespace (gfc_current_ns, 1);
5302 : 313 : gfc_current_ns = initializer_ns;
5303 : 313 : initializer_ns->proc_name = initializer_ns->parent->proc_name;
5304 : :
5305 : 313 : gfc_get_sym_tree ("omp_priv", initializer_ns, &omp_priv, false);
5306 : 313 : gfc_get_sym_tree ("omp_orig", initializer_ns, &omp_orig, false);
5307 : 313 : initializer_ns->omp_udr_ns = 1;
5308 : 313 : omp_priv->n.sym->ts = tss[i];
5309 : 313 : omp_orig->n.sym->ts = tss[i];
5310 : 313 : omp_priv->n.sym->attr.omp_udr_artificial_var = 1;
5311 : 313 : omp_orig->n.sym->attr.omp_udr_artificial_var = 1;
5312 : 313 : omp_priv->n.sym->attr.flavor = FL_VARIABLE;
5313 : 313 : omp_orig->n.sym->attr.flavor = FL_VARIABLE;
5314 : 313 : gfc_commit_symbols ();
5315 : 313 : omp_udr->initializer_ns = initializer_ns;
5316 : 313 : omp_udr->omp_priv = omp_priv->n.sym;
5317 : 313 : omp_udr->omp_orig = omp_orig->n.sym;
5318 : :
5319 : 313 : if (!match_udr_expr (omp_priv, omp_orig))
5320 : 3 : goto syntax;
5321 : : }
5322 : :
5323 : 557 : gfc_current_ns = combiner_ns->parent;
5324 : 557 : if (!end_loc_set)
5325 : : {
5326 : 520 : end_loc_set = true;
5327 : 520 : end_loc = gfc_current_locus;
5328 : : }
5329 : 557 : gfc_current_locus = old_loc;
5330 : :
5331 : 557 : prev_udr = gfc_omp_udr_find (st, &tss[i]);
5332 : 557 : if (gfc_omp_udr_predef (rop, name, &tss[i], &predef_name)
5333 : : /* Don't error on !$omp declare reduction (min : integer : ...)
5334 : : just yet, there could be integer :: min afterwards,
5335 : : making it valid. When the UDR is resolved, we'll get
5336 : : to it again. */
5337 : 557 : && (rop != OMP_REDUCTION_USER || name[0] == '.'))
5338 : : {
5339 : 29 : if (predef_name)
5340 : 0 : gfc_error_now ("Redefinition of predefined %s "
5341 : : "!$OMP DECLARE REDUCTION at %L",
5342 : : predef_name, &where);
5343 : : else
5344 : 29 : gfc_error_now ("Redefinition of predefined "
5345 : : "!$OMP DECLARE REDUCTION at %L", &where);
5346 : : }
5347 : 528 : else if (prev_udr)
5348 : : {
5349 : 6 : gfc_error_now ("Redefinition of !$OMP DECLARE REDUCTION at %L",
5350 : : &where);
5351 : 6 : gfc_error_now ("Previous !$OMP DECLARE REDUCTION at %L",
5352 : : &prev_udr->where);
5353 : : }
5354 : 522 : else if (st)
5355 : : {
5356 : 96 : omp_udr->next = st->n.omp_udr;
5357 : 96 : st->n.omp_udr = omp_udr;
5358 : : }
5359 : : else
5360 : : {
5361 : 426 : st = gfc_new_symtree (&gfc_current_ns->omp_udr_root, name);
5362 : 426 : st->n.omp_udr = omp_udr;
5363 : : }
5364 : : }
5365 : :
5366 : 520 : if (end_loc_set)
5367 : : {
5368 : 520 : gfc_current_locus = end_loc;
5369 : 520 : if (gfc_match_omp_eos () != MATCH_YES)
5370 : : {
5371 : 1 : gfc_error ("Unexpected junk after !$OMP DECLARE REDUCTION at %C");
5372 : 1 : gfc_current_locus = where;
5373 : 1 : return MATCH_ERROR;
5374 : : }
5375 : :
5376 : : return MATCH_YES;
5377 : : }
5378 : 0 : gfc_clear_error ();
5379 : 0 : return MATCH_ERROR;
5380 : 532 : }
5381 : :
5382 : :
5383 : : match
5384 : 358 : gfc_match_omp_declare_target (void)
5385 : : {
5386 : 358 : locus old_loc;
5387 : 358 : match m;
5388 : 358 : gfc_omp_clauses *c = NULL;
5389 : 358 : int list;
5390 : 358 : gfc_omp_namelist *n;
5391 : 358 : gfc_symbol *s;
5392 : :
5393 : 358 : old_loc = gfc_current_locus;
5394 : :
5395 : 358 : if (gfc_current_ns->proc_name
5396 : 358 : && gfc_match_omp_eos () == MATCH_YES)
5397 : : {
5398 : 127 : if (!gfc_add_omp_declare_target (&gfc_current_ns->proc_name->attr,
5399 : 127 : gfc_current_ns->proc_name->name,
5400 : : &old_loc))
5401 : 0 : goto cleanup;
5402 : : return MATCH_YES;
5403 : : }
5404 : :
5405 : 231 : if (gfc_current_ns->proc_name
5406 : 231 : && gfc_current_ns->proc_name->attr.if_source == IFSRC_IFBODY)
5407 : : {
5408 : 2 : gfc_error ("Only the !$OMP DECLARE TARGET form without "
5409 : : "clauses is allowed in interface block at %C");
5410 : 2 : goto cleanup;
5411 : : }
5412 : :
5413 : 229 : m = gfc_match (" (");
5414 : 229 : if (m == MATCH_YES)
5415 : : {
5416 : 85 : c = gfc_get_omp_clauses ();
5417 : 85 : gfc_current_locus = old_loc;
5418 : 85 : m = gfc_match_omp_to_link (" (", &c->lists[OMP_LIST_ENTER]);
5419 : 85 : if (m != MATCH_YES)
5420 : 0 : goto syntax;
5421 : 85 : if (gfc_match_omp_eos () != MATCH_YES)
5422 : : {
5423 : 0 : gfc_error ("Unexpected junk after !$OMP DECLARE TARGET at %C");
5424 : 0 : goto cleanup;
5425 : : }
5426 : : }
5427 : 144 : else if (gfc_match_omp_clauses (&c, OMP_DECLARE_TARGET_CLAUSES) != MATCH_YES)
5428 : : return MATCH_ERROR;
5429 : :
5430 : 228 : gfc_buffer_error (false);
5431 : :
5432 : 228 : static const int to_enter_link_lists[]
5433 : : = { OMP_LIST_TO, OMP_LIST_ENTER, OMP_LIST_LINK };
5434 : 912 : for (size_t listn = 0; listn < ARRAY_SIZE (to_enter_link_lists)
5435 : 912 : && (list = to_enter_link_lists[listn], true); ++listn)
5436 : 1110 : for (n = c->lists[list]; n; n = n->next)
5437 : 426 : if (n->sym)
5438 : 401 : n->sym->mark = 0;
5439 : 25 : else if (n->u.common->head)
5440 : 25 : n->u.common->head->mark = 0;
5441 : :
5442 : 684 : for (size_t listn = 0; listn < ARRAY_SIZE (to_enter_link_lists)
5443 : 912 : && (list = to_enter_link_lists[listn], true); ++listn)
5444 : 1110 : for (n = c->lists[list]; n; n = n->next)
5445 : 426 : if (n->sym)
5446 : : {
5447 : 401 : if (n->sym->attr.in_common)
5448 : 1 : gfc_error_now ("OMP DECLARE TARGET variable at %L is an "
5449 : : "element of a COMMON block", &n->where);
5450 : 400 : else if (n->sym->mark)
5451 : 9 : gfc_error_now ("Variable at %L mentioned multiple times in "
5452 : : "clauses of the same OMP DECLARE TARGET directive",
5453 : : &n->where);
5454 : 391 : else if (n->sym->attr.omp_declare_target
5455 : 391 : && n->sym->attr.omp_declare_target_link
5456 : 9 : && list != OMP_LIST_LINK)
5457 : 1 : gfc_error_now ("OMP DECLARE TARGET variable at %L previously "
5458 : : "mentioned in LINK clause and later in %s clause",
5459 : : &n->where, list == OMP_LIST_TO ? "TO" : "ENTER");
5460 : 390 : else if (n->sym->attr.omp_declare_target
5461 : : && !n->sym->attr.omp_declare_target_link
5462 : 14 : && list == OMP_LIST_LINK)
5463 : 1 : gfc_error_now ("OMP DECLARE TARGET variable at %L previously "
5464 : : "mentioned in TO or ENTER clause and later in "
5465 : : "LINK clause", &n->where);
5466 : 389 : else if (gfc_add_omp_declare_target (&n->sym->attr, n->sym->name,
5467 : : &n->sym->declared_at))
5468 : : {
5469 : 383 : if (list == OMP_LIST_LINK)
5470 : 20 : gfc_add_omp_declare_target_link (&n->sym->attr, n->sym->name,
5471 : 20 : &n->sym->declared_at);
5472 : : }
5473 : 401 : if (c->device_type != OMP_DEVICE_TYPE_UNSET)
5474 : : {
5475 : 41 : if (n->sym->attr.omp_device_type != OMP_DEVICE_TYPE_UNSET
5476 : 17 : && n->sym->attr.omp_device_type != c->device_type)
5477 : 13 : gfc_error_now ("List item %qs at %L set in previous OMP DECLARE "
5478 : : "TARGET directive to a different DEVICE_TYPE",
5479 : : n->sym->name, &n->where);
5480 : 41 : n->sym->attr.omp_device_type = c->device_type;
5481 : : }
5482 : 401 : n->sym->mark = 1;
5483 : : }
5484 : 25 : else if (n->u.common->omp_declare_target
5485 : 25 : && n->u.common->omp_declare_target_link
5486 : 6 : && list != OMP_LIST_LINK)
5487 : 2 : gfc_error_now ("OMP DECLARE TARGET COMMON at %L previously "
5488 : : "mentioned in LINK clause and later in %s clause",
5489 : : &n->where, list == OMP_LIST_TO ? "TO" : "ENTER");
5490 : 24 : else if (n->u.common->omp_declare_target
5491 : : && !n->u.common->omp_declare_target_link
5492 : 6 : && list == OMP_LIST_LINK)
5493 : 1 : gfc_error_now ("OMP DECLARE TARGET COMMON at %L previously "
5494 : : "mentioned in TO or ENTER clause and later in "
5495 : : "LINK clause", &n->where);
5496 : 23 : else if (n->u.common->head && n->u.common->head->mark)
5497 : 4 : gfc_error_now ("COMMON at %L mentioned multiple times in "
5498 : : "clauses of the same OMP DECLARE TARGET directive",
5499 : : &n->where);
5500 : : else
5501 : : {
5502 : 19 : n->u.common->omp_declare_target = 1;
5503 : 19 : n->u.common->omp_declare_target_link = (list == OMP_LIST_LINK);
5504 : 19 : if (n->u.common->omp_device_type != OMP_DEVICE_TYPE_UNSET
5505 : 0 : && n->u.common->omp_device_type != c->device_type)
5506 : 0 : gfc_error_now ("COMMON at %L set in previous OMP DECLARE "
5507 : : "TARGET directive to a different DEVICE_TYPE",
5508 : : &n->where);
5509 : 19 : n->u.common->omp_device_type = c->device_type;
5510 : :
5511 : 59 : for (s = n->u.common->head; s; s = s->common_next)
5512 : : {
5513 : 40 : s->mark = 1;
5514 : 40 : if (gfc_add_omp_declare_target (&s->attr, s->name,
5515 : : &s->declared_at))
5516 : : {
5517 : 40 : if (list == OMP_LIST_LINK)
5518 : 21 : gfc_add_omp_declare_target_link (&s->attr, s->name,
5519 : : &s->declared_at);
5520 : : }
5521 : 40 : if (s->attr.omp_device_type != OMP_DEVICE_TYPE_UNSET
5522 : 0 : && s->attr.omp_device_type != c->device_type)
5523 : 0 : gfc_error_now ("List item %qs at %L set in previous OMP DECLARE"
5524 : : " TARGET directive to a different DEVICE_TYPE",
5525 : : s->name, &n->where);
5526 : 40 : s->attr.omp_device_type = c->device_type;
5527 : : }
5528 : : }
5529 : 228 : if (c->device_type
5530 : 48 : && !c->lists[OMP_LIST_ENTER]
5531 : 47 : && !c->lists[OMP_LIST_TO]
5532 : 18 : && !c->lists[OMP_LIST_LINK])
5533 : 1 : gfc_warning_now (0, "OMP DECLARE TARGET directive at %L with only "
5534 : : "DEVICE_TYPE clause is ignored", &old_loc);
5535 : :
5536 : 228 : gfc_buffer_error (true);
5537 : :
5538 : 228 : if (c)
5539 : 228 : gfc_free_omp_clauses (c);
5540 : 228 : return MATCH_YES;
5541 : :
5542 : 0 : syntax:
5543 : 0 : gfc_error ("Syntax error in !$OMP DECLARE TARGET list at %C");
5544 : :
5545 : 2 : cleanup:
5546 : 2 : gfc_current_locus = old_loc;
5547 : 2 : if (c)
5548 : 0 : gfc_free_omp_clauses (c);
5549 : : return MATCH_ERROR;
5550 : : }
5551 : :
5552 : :
5553 : : static const char *const omp_construct_selectors[] = {
5554 : : "simd", "target", "teams", "parallel", "do", NULL };
5555 : : static const char *const omp_device_selectors[] = {
5556 : : "kind", "isa", "arch", NULL };
5557 : : static const char *const omp_implementation_selectors[] = {
5558 : : "vendor", "extension", "atomic_default_mem_order", "unified_address",
5559 : : "unified_shared_memory", "dynamic_allocators", "reverse_offload", NULL };
5560 : : static const char *const omp_user_selectors[] = {
5561 : : "condition", NULL };
5562 : :
5563 : :
5564 : : /* OpenMP 5.0:
5565 : :
5566 : : trait-selector:
5567 : : trait-selector-name[([trait-score:]trait-property[,trait-property[,...]])]
5568 : :
5569 : : trait-score:
5570 : : score(score-expression) */
5571 : :
5572 : : match
5573 : 330 : gfc_match_omp_context_selector (gfc_omp_set_selector *oss)
5574 : : {
5575 : 524 : do
5576 : : {
5577 : 427 : char selector[GFC_MAX_SYMBOL_LEN + 1];
5578 : :
5579 : 427 : if (gfc_match_name (selector) != MATCH_YES)
5580 : : {
5581 : 2 : gfc_error ("expected trait selector name at %C");
5582 : 45 : return MATCH_ERROR;
5583 : : }
5584 : :
5585 : 425 : gfc_omp_selector *os = gfc_get_omp_selector ();
5586 : 425 : os->trait_selector_name = XNEWVEC (char, strlen (selector) + 1);
5587 : 425 : strcpy (os->trait_selector_name, selector);
5588 : 425 : os->next = oss->trait_selectors;
5589 : 425 : oss->trait_selectors = os;
5590 : :
5591 : 425 : const char *const *selectors = NULL;
5592 : 425 : bool allow_score = true;
5593 : 425 : bool allow_user = false;
5594 : 425 : int property_limit = 0;
5595 : 425 : enum gfc_omp_trait_property_kind property_kind = CTX_PROPERTY_NONE;
5596 : 425 : switch (oss->trait_set_selector_name[0])
5597 : : {
5598 : : case 'c': /* construct */
5599 : : selectors = omp_construct_selectors;
5600 : : allow_score = false;
5601 : : property_limit = 1;
5602 : : property_kind = CTX_PROPERTY_SIMD;
5603 : : break;
5604 : 98 : case 'd': /* device */
5605 : 98 : selectors = omp_device_selectors;
5606 : 98 : allow_score = false;
5607 : 98 : allow_user = true;
5608 : 98 : property_limit = 3;
5609 : 98 : property_kind = CTX_PROPERTY_NAME_LIST;
5610 : 98 : break;
5611 : 100 : case 'i': /* implementation */
5612 : 100 : selectors = omp_implementation_selectors;
5613 : 100 : allow_user = true;
5614 : 100 : property_limit = 3;
5615 : 100 : property_kind = CTX_PROPERTY_NAME_LIST;
5616 : 100 : break;
5617 : 41 : case 'u': /* user */
5618 : 41 : selectors = omp_user_selectors;
5619 : 41 : property_limit = 1;
5620 : 41 : property_kind = CTX_PROPERTY_EXPR;
5621 : 41 : break;
5622 : 0 : default:
5623 : 0 : gcc_unreachable ();
5624 : : }
5625 : 1166 : for (int i = 0; ; i++)
5626 : : {
5627 : 1166 : if (selectors[i] == NULL)
5628 : : {
5629 : 18 : if (allow_user)
5630 : : {
5631 : : property_kind = CTX_PROPERTY_USER;
5632 : : break;
5633 : : }
5634 : : else
5635 : : {
5636 : 15 : gfc_error ("selector %qs not allowed for context selector "
5637 : : "set %qs at %C",
5638 : : selector, oss->trait_set_selector_name);
5639 : 15 : return MATCH_ERROR;
5640 : : }
5641 : : }
5642 : 1148 : if (i == property_limit)
5643 : 187 : property_kind = CTX_PROPERTY_NONE;
5644 : 1148 : if (strcmp (selectors[i], selector) == 0)
5645 : : break;
5646 : : }
5647 : 407 : if (property_kind == CTX_PROPERTY_NAME_LIST
5648 : 180 : && oss->trait_set_selector_name[0] == 'i'
5649 : 83 : && strcmp (selector, "atomic_default_mem_order") == 0)
5650 : 410 : property_kind = CTX_PROPERTY_ID;
5651 : :
5652 : 410 : if (gfc_match (" (") == MATCH_YES)
5653 : : {
5654 : 236 : if (property_kind == CTX_PROPERTY_NONE)
5655 : : {
5656 : 6 : gfc_error ("selector %qs does not accept any properties at %C",
5657 : : selector);
5658 : 6 : return MATCH_ERROR;
5659 : : }
5660 : :
5661 : 230 : if (allow_score && gfc_match (" score") == MATCH_YES)
5662 : : {
5663 : 52 : if (gfc_match (" (") != MATCH_YES)
5664 : : {
5665 : 0 : gfc_error ("expected %<(%> at %C");
5666 : 0 : return MATCH_ERROR;
5667 : : }
5668 : 52 : if (gfc_match_expr (&os->score) != MATCH_YES
5669 : 51 : || !gfc_resolve_expr (os->score)
5670 : 51 : || os->score->ts.type != BT_INTEGER
5671 : 103 : || os->score->rank != 0)
5672 : : {
5673 : 1 : gfc_error ("score argument must be constant integer "
5674 : : "expression at %C");
5675 : 1 : return MATCH_ERROR;
5676 : : }
5677 : :
5678 : 51 : if (os->score->expr_type == EXPR_CONSTANT
5679 : 51 : && mpz_sgn (os->score->value.integer) < 0)
5680 : : {
5681 : 1 : gfc_error ("score argument must be non-negative at %C");
5682 : 1 : return MATCH_ERROR;
5683 : : }
5684 : :
5685 : 50 : if (gfc_match (" )") != MATCH_YES)
5686 : : {
5687 : 0 : gfc_error ("expected %<)%> at %C");
5688 : 0 : return MATCH_ERROR;
5689 : : }
5690 : :
5691 : 50 : if (gfc_match (" :") != MATCH_YES)
5692 : : {
5693 : 0 : gfc_error ("expected : at %C");
5694 : 0 : return MATCH_ERROR;
5695 : : }
5696 : : }
5697 : :
5698 : 228 : gfc_omp_trait_property *otp = gfc_get_omp_trait_property ();
5699 : 228 : otp->property_kind = property_kind;
5700 : 228 : otp->next = os->properties;
5701 : 228 : os->properties = otp;
5702 : :
5703 : 228 : switch (property_kind)
5704 : : {
5705 : 5 : case CTX_PROPERTY_USER:
5706 : 5 : do
5707 : : {
5708 : 5 : if (gfc_match_expr (&otp->expr) != MATCH_YES)
5709 : : {
5710 : 0 : gfc_error ("property must be constant integer "
5711 : : "expression or string literal at %C");
5712 : 0 : return MATCH_ERROR;
5713 : : }
5714 : :
5715 : 5 : if (gfc_match (" ,") != MATCH_YES)
5716 : : break;
5717 : : }
5718 : : while (1);
5719 : : break;
5720 : 25 : case CTX_PROPERTY_ID:
5721 : 25 : {
5722 : 25 : char buf[GFC_MAX_SYMBOL_LEN + 1];
5723 : 25 : if (gfc_match_name (buf) == MATCH_YES)
5724 : : {
5725 : 24 : otp->name = XNEWVEC (char, strlen (buf) + 1);
5726 : 24 : strcpy (otp->name, buf);
5727 : : }
5728 : : else
5729 : : {
5730 : 1 : gfc_error ("expected identifier at %C");
5731 : 1 : return MATCH_ERROR;
5732 : : }
5733 : : }
5734 : 24 : break;
5735 : 194 : case CTX_PROPERTY_NAME_LIST:
5736 : 240 : do
5737 : : {
5738 : 194 : char buf[GFC_MAX_SYMBOL_LEN + 1];
5739 : 194 : if (gfc_match_name (buf) == MATCH_YES)
5740 : : {
5741 : 147 : otp->name = XNEWVEC (char, strlen (buf) + 1);
5742 : 147 : strcpy (otp->name, buf);
5743 : 147 : otp->is_name = true;
5744 : : }
5745 : 47 : else if (gfc_match_literal_constant (&otp->expr, 0)
5746 : : != MATCH_YES
5747 : 47 : || otp->expr->ts.type != BT_CHARACTER)
5748 : : {
5749 : 5 : gfc_error ("expected identifier or string literal "
5750 : : "at %C");
5751 : 5 : return MATCH_ERROR;
5752 : : }
5753 : :
5754 : 189 : if (gfc_match (" ,") == MATCH_YES)
5755 : : {
5756 : 46 : otp = gfc_get_omp_trait_property ();
5757 : 46 : otp->property_kind = property_kind;
5758 : 46 : otp->next = os->properties;
5759 : 46 : os->properties = otp;
5760 : : }
5761 : : else
5762 : : break;
5763 : 46 : }
5764 : : while (1);
5765 : 143 : break;
5766 : 37 : case CTX_PROPERTY_EXPR:
5767 : 37 : if (gfc_match_expr (&otp->expr) != MATCH_YES)
5768 : : {
5769 : 3 : gfc_error ("expected expression at %C");
5770 : 3 : return MATCH_ERROR;
5771 : : }
5772 : 34 : if (!gfc_resolve_expr (otp->expr)
5773 : 34 : || (otp->expr->ts.type != BT_LOGICAL
5774 : 34 : && otp->expr->ts.type != BT_INTEGER)
5775 : 68 : || otp->expr->rank != 0)
5776 : : {
5777 : 0 : gfc_error ("property must be constant integer or logical "
5778 : : "expression at %C");
5779 : 0 : return MATCH_ERROR;
5780 : : }
5781 : : break;
5782 : 15 : case CTX_PROPERTY_SIMD:
5783 : 15 : {
5784 : 15 : if (gfc_match_omp_clauses (&otp->clauses,
5785 : 15 : OMP_DECLARE_SIMD_CLAUSES,
5786 : : true, false, false, true)
5787 : : != MATCH_YES)
5788 : : {
5789 : 1 : gfc_error ("expected simd clause at %C");
5790 : 1 : return MATCH_ERROR;
5791 : : }
5792 : : break;
5793 : : }
5794 : 0 : default:
5795 : 0 : gcc_unreachable ();
5796 : : }
5797 : :
5798 : 218 : if (gfc_match (" )") != MATCH_YES)
5799 : : {
5800 : 2 : gfc_error ("expected %<)%> at %C");
5801 : 2 : return MATCH_ERROR;
5802 : : }
5803 : : }
5804 : 174 : else if (property_kind == CTX_PROPERTY_NAME_LIST
5805 : : || property_kind == CTX_PROPERTY_ID
5806 : 174 : || property_kind == CTX_PROPERTY_EXPR)
5807 : : {
5808 : 8 : if (gfc_match (" (") != MATCH_YES)
5809 : : {
5810 : 8 : gfc_error ("expected %<(%> at %C");
5811 : 8 : return MATCH_ERROR;
5812 : : }
5813 : : }
5814 : :
5815 : 382 : if (gfc_match (" ,") != MATCH_YES)
5816 : : break;
5817 : 97 : }
5818 : : while (1);
5819 : :
5820 : 285 : return MATCH_YES;
5821 : : }
5822 : :
5823 : : /* OpenMP 5.0:
5824 : :
5825 : : trait-set-selector[,trait-set-selector[,...]]
5826 : :
5827 : : trait-set-selector:
5828 : : trait-set-selector-name = { trait-selector[, trait-selector[, ...]] }
5829 : :
5830 : : trait-set-selector-name:
5831 : : constructor
5832 : : device
5833 : : implementation
5834 : : user */
5835 : :
5836 : : match
5837 : 289 : gfc_match_omp_context_selector_specification (gfc_omp_declare_variant *odv)
5838 : : {
5839 : 387 : do
5840 : : {
5841 : 338 : match m;
5842 : 338 : const char *selector_sets[] = { "construct", "device",
5843 : : "implementation", "user" };
5844 : 338 : const int selector_set_count = ARRAY_SIZE (selector_sets);
5845 : 338 : int i;
5846 : 338 : char buf[GFC_MAX_SYMBOL_LEN + 1];
5847 : :
5848 : 338 : m = gfc_match_name (buf);
5849 : 338 : if (m == MATCH_YES)
5850 : 748 : for (i = 0; i < selector_set_count; i++)
5851 : 745 : if (strcmp (buf, selector_sets[i]) == 0)
5852 : : break;
5853 : :
5854 : 338 : if (m != MATCH_YES || i == selector_set_count)
5855 : : {
5856 : 5 : gfc_error ("expected %<construct%>, %<device%>, %<implementation%> "
5857 : : "or %<user%> at %C");
5858 : 53 : return MATCH_ERROR;
5859 : : }
5860 : :
5861 : 333 : m = gfc_match (" =");
5862 : 333 : if (m != MATCH_YES)
5863 : : {
5864 : 1 : gfc_error ("expected %<=%> at %C");
5865 : 1 : return MATCH_ERROR;
5866 : : }
5867 : :
5868 : 332 : m = gfc_match (" {");
5869 : 332 : if (m != MATCH_YES)
5870 : : {
5871 : 2 : gfc_error ("expected %<{%> at %C");
5872 : 2 : return MATCH_ERROR;
5873 : : }
5874 : :
5875 : 330 : gfc_omp_set_selector *oss = gfc_get_omp_set_selector ();
5876 : 330 : oss->next = odv->set_selectors;
5877 : 330 : oss->trait_set_selector_name = selector_sets[i];
5878 : 330 : odv->set_selectors = oss;
5879 : :
5880 : 330 : if (gfc_match_omp_context_selector (oss) != MATCH_YES)
5881 : : return MATCH_ERROR;
5882 : :
5883 : 285 : m = gfc_match (" }");
5884 : 285 : if (m != MATCH_YES)
5885 : : {
5886 : 0 : gfc_error ("expected %<}%> at %C");
5887 : 0 : return MATCH_ERROR;
5888 : : }
5889 : :
5890 : 285 : m = gfc_match (" ,");
5891 : 285 : if (m != MATCH_YES)
5892 : : break;
5893 : 49 : }
5894 : : while (1);
5895 : :
5896 : 236 : return MATCH_YES;
5897 : : }
5898 : :
5899 : :
5900 : : match
5901 : 297 : gfc_match_omp_declare_variant (void)
5902 : : {
5903 : 297 : bool first_p = true;
5904 : 297 : char buf[GFC_MAX_SYMBOL_LEN + 1];
5905 : :
5906 : 297 : if (gfc_match (" (") != MATCH_YES)
5907 : : {
5908 : 2 : gfc_error ("expected %<(%> at %C");
5909 : 2 : return MATCH_ERROR;
5910 : : }
5911 : :
5912 : 295 : gfc_symtree *base_proc_st, *variant_proc_st;
5913 : 295 : if (gfc_match_name (buf) != MATCH_YES)
5914 : : {
5915 : 2 : gfc_error ("expected name at %C");
5916 : 2 : return MATCH_ERROR;
5917 : : }
5918 : :
5919 : 293 : if (gfc_get_ha_sym_tree (buf, &base_proc_st))
5920 : : return MATCH_ERROR;
5921 : :
5922 : 293 : if (gfc_match (" :") == MATCH_YES)
5923 : : {
5924 : 10 : if (gfc_match_name (buf) != MATCH_YES)
5925 : : {
5926 : 0 : gfc_error ("expected variant name at %C");
5927 : 0 : return MATCH_ERROR;
5928 : : }
5929 : :
5930 : 10 : if (gfc_get_ha_sym_tree (buf, &variant_proc_st))
5931 : : return MATCH_ERROR;
5932 : : }
5933 : : else
5934 : : {
5935 : : /* Base procedure not specified. */
5936 : 283 : variant_proc_st = base_proc_st;
5937 : 283 : base_proc_st = NULL;
5938 : : }
5939 : :
5940 : 293 : gfc_omp_declare_variant *odv;
5941 : 293 : odv = gfc_get_omp_declare_variant ();
5942 : 293 : odv->where = gfc_current_locus;
5943 : 293 : odv->variant_proc_symtree = variant_proc_st;
5944 : 293 : odv->base_proc_symtree = base_proc_st;
5945 : 293 : odv->next = NULL;
5946 : 293 : odv->error_p = false;
5947 : :
5948 : : /* Add the new declare variant to the end of the list. */
5949 : 293 : gfc_omp_declare_variant **prev_next = &gfc_current_ns->omp_declare_variant;
5950 : 372 : while (*prev_next)
5951 : 79 : prev_next = &((*prev_next)->next);
5952 : 293 : *prev_next = odv;
5953 : :
5954 : 293 : if (gfc_match (" )") != MATCH_YES)
5955 : : {
5956 : 0 : gfc_error ("expected %<)%> at %C");
5957 : 0 : return MATCH_ERROR;
5958 : : }
5959 : :
5960 : 529 : for (;;)
5961 : : {
5962 : 529 : if (gfc_match (" match") != MATCH_YES)
5963 : : {
5964 : 239 : if (first_p)
5965 : : {
5966 : 3 : gfc_error ("expected %<match%> at %C");
5967 : 3 : return MATCH_ERROR;
5968 : : }
5969 : : else
5970 : : break;
5971 : : }
5972 : :
5973 : 290 : if (gfc_match (" (") != MATCH_YES)
5974 : : {
5975 : 1 : gfc_error ("expected %<(%> at %C");
5976 : 1 : return MATCH_ERROR;
5977 : : }
5978 : :
5979 : 289 : if (gfc_match_omp_context_selector_specification (odv) != MATCH_YES)
5980 : : return MATCH_ERROR;
5981 : :
5982 : 236 : if (gfc_match (" )") != MATCH_YES)
5983 : : {
5984 : 0 : gfc_error ("expected %<)%> at %C");
5985 : 0 : return MATCH_ERROR;
5986 : : }
5987 : :
5988 : : first_p = false;
5989 : : }
5990 : :
5991 : : return MATCH_YES;
5992 : : }
5993 : :
5994 : :
5995 : : match
5996 : 203 : gfc_match_omp_threadprivate (void)
5997 : : {
5998 : 203 : locus old_loc;
5999 : 203 : char n[GFC_MAX_SYMBOL_LEN+1];
6000 : 203 : gfc_symbol *sym;
6001 : 203 : match m;
6002 : 203 : gfc_symtree *st;
6003 : :
6004 : 203 : old_loc = gfc_current_locus;
6005 : :
6006 : 203 : m = gfc_match (" (");
6007 : 203 : if (m != MATCH_YES)
6008 : : return m;
6009 : :
6010 : 245 : for (;;)
6011 : : {
6012 : 245 : m = gfc_match_symbol (&sym, 0);
6013 : 245 : switch (m)
6014 : : {
6015 : 174 : case MATCH_YES:
6016 : 174 : if (sym->attr.in_common)
6017 : 0 : gfc_error_now ("Threadprivate variable at %C is an element of "
6018 : : "a COMMON block");
6019 : 174 : else if (!gfc_add_threadprivate (&sym->attr, sym->name, &sym->declared_at))
6020 : 1 : goto cleanup;
6021 : 173 : goto next_item;
6022 : : case MATCH_NO:
6023 : : break;
6024 : 0 : case MATCH_ERROR:
6025 : 0 : goto cleanup;
6026 : : }
6027 : :
6028 : 71 : m = gfc_match (" / %n /", n);
6029 : 71 : if (m == MATCH_ERROR)
6030 : 0 : goto cleanup;
6031 : 71 : if (m == MATCH_NO || n[0] == '\0')
6032 : 0 : goto syntax;
6033 : :
6034 : 71 : st = gfc_find_symtree (gfc_current_ns->common_root, n);
6035 : 71 : if (st == NULL)
6036 : : {
6037 : 2 : gfc_error ("COMMON block /%s/ not found at %C", n);
6038 : 2 : goto cleanup;
6039 : : }
6040 : 69 : st->n.common->threadprivate = 1;
6041 : 176 : for (sym = st->n.common->head; sym; sym = sym->common_next)
6042 : 107 : if (!gfc_add_threadprivate (&sym->attr, sym->name, &sym->declared_at))
6043 : 0 : goto cleanup;
6044 : :
6045 : 69 : next_item:
6046 : 242 : if (gfc_match_char (')') == MATCH_YES)
6047 : : break;
6048 : 42 : if (gfc_match_char (',') != MATCH_YES)
6049 : 0 : goto syntax;
6050 : : }
6051 : :
6052 : 200 : if (gfc_match_omp_eos () != MATCH_YES)
6053 : : {
6054 : 0 : gfc_error ("Unexpected junk after OMP THREADPRIVATE at %C");
6055 : 0 : goto cleanup;
6056 : : }
6057 : :
6058 : : return MATCH_YES;
6059 : :
6060 : 0 : syntax:
6061 : 0 : gfc_error ("Syntax error in !$OMP THREADPRIVATE list at %C");
6062 : :
6063 : 3 : cleanup:
6064 : 3 : gfc_current_locus = old_loc;
6065 : 3 : return MATCH_ERROR;
6066 : : }
6067 : :
6068 : :
6069 : : match
6070 : 2049 : gfc_match_omp_parallel (void)
6071 : : {
6072 : 2049 : return match_omp (EXEC_OMP_PARALLEL, OMP_PARALLEL_CLAUSES);
6073 : : }
6074 : :
6075 : :
6076 : : match
6077 : 903 : gfc_match_omp_parallel_do (void)
6078 : : {
6079 : 903 : return match_omp (EXEC_OMP_PARALLEL_DO,
6080 : 903 : (OMP_PARALLEL_CLAUSES | OMP_DO_CLAUSES)
6081 : 903 : & ~(omp_mask (OMP_CLAUSE_NOWAIT)));
6082 : : }
6083 : :
6084 : :
6085 : : match
6086 : 290 : gfc_match_omp_parallel_do_simd (void)
6087 : : {
6088 : 290 : return match_omp (EXEC_OMP_PARALLEL_DO_SIMD,
6089 : 290 : (OMP_PARALLEL_CLAUSES | OMP_DO_CLAUSES | OMP_SIMD_CLAUSES)
6090 : 290 : & ~(omp_mask (OMP_CLAUSE_NOWAIT)));
6091 : : }
6092 : :
6093 : :
6094 : : match
6095 : 14 : gfc_match_omp_parallel_masked (void)
6096 : : {
6097 : 14 : return match_omp (EXEC_OMP_PARALLEL_MASKED,
6098 : 14 : OMP_PARALLEL_CLAUSES | OMP_MASKED_CLAUSES);
6099 : : }
6100 : :
6101 : : match
6102 : 10 : gfc_match_omp_parallel_masked_taskloop (void)
6103 : : {
6104 : 10 : return match_omp (EXEC_OMP_PARALLEL_MASKED_TASKLOOP,
6105 : 10 : (OMP_PARALLEL_CLAUSES | OMP_MASKED_CLAUSES
6106 : 10 : | OMP_TASKLOOP_CLAUSES)
6107 : 10 : & ~(omp_mask (OMP_CLAUSE_IN_REDUCTION)));
6108 : : }
6109 : :
6110 : : match
6111 : 13 : gfc_match_omp_parallel_masked_taskloop_simd (void)
6112 : : {
6113 : 13 : return match_omp (EXEC_OMP_PARALLEL_MASKED_TASKLOOP_SIMD,
6114 : 13 : (OMP_PARALLEL_CLAUSES | OMP_MASKED_CLAUSES
6115 : 13 : | OMP_TASKLOOP_CLAUSES | OMP_SIMD_CLAUSES)
6116 : 13 : & ~(omp_mask (OMP_CLAUSE_IN_REDUCTION)));
6117 : : }
6118 : :
6119 : : match
6120 : 14 : gfc_match_omp_parallel_master (void)
6121 : : {
6122 : 14 : return match_omp (EXEC_OMP_PARALLEL_MASTER, OMP_PARALLEL_CLAUSES);
6123 : : }
6124 : :
6125 : : match
6126 : 15 : gfc_match_omp_parallel_master_taskloop (void)
6127 : : {
6128 : 15 : return match_omp (EXEC_OMP_PARALLEL_MASTER_TASKLOOP,
6129 : 15 : (OMP_PARALLEL_CLAUSES | OMP_TASKLOOP_CLAUSES)
6130 : 15 : & ~(omp_mask (OMP_CLAUSE_IN_REDUCTION)));
6131 : : }
6132 : :
6133 : : match
6134 : 20 : gfc_match_omp_parallel_master_taskloop_simd (void)
6135 : : {
6136 : 20 : return match_omp (EXEC_OMP_PARALLEL_MASTER_TASKLOOP_SIMD,
6137 : 20 : (OMP_PARALLEL_CLAUSES | OMP_TASKLOOP_CLAUSES
6138 : 20 : | OMP_SIMD_CLAUSES)
6139 : 20 : & ~(omp_mask (OMP_CLAUSE_IN_REDUCTION)));
6140 : : }
6141 : :
6142 : : match
6143 : 59 : gfc_match_omp_parallel_sections (void)
6144 : : {
6145 : 59 : return match_omp (EXEC_OMP_PARALLEL_SECTIONS,
6146 : 59 : (OMP_PARALLEL_CLAUSES | OMP_SECTIONS_CLAUSES)
6147 : 59 : & ~(omp_mask (OMP_CLAUSE_NOWAIT)));
6148 : : }
6149 : :
6150 : :
6151 : : match
6152 : 56 : gfc_match_omp_parallel_workshare (void)
6153 : : {
6154 : 56 : return match_omp (EXEC_OMP_PARALLEL_WORKSHARE, OMP_PARALLEL_CLAUSES);
6155 : : }
6156 : :
6157 : : void
6158 : 45070 : gfc_check_omp_requires (gfc_namespace *ns, int ref_omp_requires)
6159 : : {
6160 : 45070 : if (ns->omp_target_seen
6161 : 843 : && (ns->omp_requires & OMP_REQ_TARGET_MASK)
6162 : 843 : != (ref_omp_requires & OMP_REQ_TARGET_MASK))
6163 : : {
6164 : 3 : gcc_assert (ns->proc_name);
6165 : 3 : if ((ref_omp_requires & OMP_REQ_REVERSE_OFFLOAD)
6166 : 3 : && !(ns->omp_requires & OMP_REQ_REVERSE_OFFLOAD))
6167 : 2 : gfc_error ("Program unit at %L has OpenMP device constructs/routines "
6168 : : "but does not set !$OMP REQUIRES REVERSE_OFFLOAD but other "
6169 : : "program units do", &ns->proc_name->declared_at);
6170 : 3 : if ((ref_omp_requires & OMP_REQ_UNIFIED_ADDRESS)
6171 : 1 : && !(ns->omp_requires & OMP_REQ_UNIFIED_ADDRESS))
6172 : 1 : gfc_error ("Program unit at %L has OpenMP device constructs/routines "
6173 : : "but does not set !$OMP REQUIRES UNIFIED_ADDRESS but other "
6174 : 1 : "program units do", &ns->proc_name->declared_at);
6175 : 3 : if ((ref_omp_requires & OMP_REQ_UNIFIED_SHARED_MEMORY)
6176 : 3 : && !(ns->omp_requires & OMP_REQ_UNIFIED_SHARED_MEMORY))
6177 : 2 : gfc_error ("Program unit at %L has OpenMP device constructs/routines "
6178 : : "but does not set !$OMP REQUIRES UNIFIED_SHARED_MEMORY but "
6179 : 2 : "other program units do", &ns->proc_name->declared_at);
6180 : : }
6181 : 45070 : }
6182 : :
6183 : : bool
6184 : 109 : gfc_omp_requires_add_clause (gfc_omp_requires_kind clause,
6185 : : const char *clause_name, locus *loc,
6186 : : const char *module_name)
6187 : : {
6188 : 109 : gfc_namespace *prog_unit = gfc_current_ns;
6189 : 133 : while (prog_unit->parent)
6190 : : {
6191 : 25 : if (gfc_state_stack->previous
6192 : 25 : && gfc_state_stack->previous->state == COMP_INTERFACE)
6193 : : break;
6194 : : prog_unit = prog_unit->parent;
6195 : : }
6196 : :
6197 : : /* Requires added after use. */
6198 : 109 : if (prog_unit->omp_target_seen
6199 : 24 : && (clause & OMP_REQ_TARGET_MASK)
6200 : 24 : && !(prog_unit->omp_requires & clause))
6201 : : {
6202 : 0 : if (module_name)
6203 : 0 : gfc_error ("!$OMP REQUIRES clause %qs specified via module %qs use "
6204 : : "at %L comes after using a device construct/routine",
6205 : : clause_name, module_name, loc);
6206 : : else
6207 : 0 : gfc_error ("!$OMP REQUIRES clause %qs specified at %L comes after "
6208 : : "using a device construct/routine", clause_name, loc);
6209 : 0 : return false;
6210 : : }
6211 : :
6212 : : /* Overriding atomic_default_mem_order clause value. */
6213 : 109 : if ((clause & OMP_REQ_ATOMIC_MEM_ORDER_MASK)
6214 : 28 : && (prog_unit->omp_requires & OMP_REQ_ATOMIC_MEM_ORDER_MASK)
6215 : 5 : && (prog_unit->omp_requires & OMP_REQ_ATOMIC_MEM_ORDER_MASK)
6216 : 5 : != (int) clause)
6217 : : {
6218 : 2 : const char *other;
6219 : 2 : if (prog_unit->omp_requires & OMP_REQ_ATOMIC_MEM_ORDER_SEQ_CST)
6220 : : other = "seq_cst";
6221 : 0 : else if (prog_unit->omp_requires & OMP_REQ_ATOMIC_MEM_ORDER_ACQ_REL)
6222 : : other = "acq_rel";
6223 : 0 : else if (prog_unit->omp_requires & OMP_REQ_ATOMIC_MEM_ORDER_RELAXED)
6224 : : other = "relaxed";
6225 : : else
6226 : : gcc_unreachable ();
6227 : :
6228 : 2 : if (module_name)
6229 : 0 : gfc_error ("!$OMP REQUIRES clause %<atomic_default_mem_order(%s)%> "
6230 : : "specified via module %qs use at %L overrides a previous "
6231 : : "%<atomic_default_mem_order(%s)%> (which might be through "
6232 : : "using a module)", clause_name, module_name, loc, other);
6233 : : else
6234 : 2 : gfc_error ("!$OMP REQUIRES clause %<atomic_default_mem_order(%s)%> "
6235 : : "specified at %L overrides a previous "
6236 : : "%<atomic_default_mem_order(%s)%> (which might be through "
6237 : : "using a module)", clause_name, loc, other);
6238 : 2 : return false;
6239 : : }
6240 : :
6241 : : /* Requires via module not at program-unit level and not repeating clause. */
6242 : 107 : if (prog_unit != gfc_current_ns && !(prog_unit->omp_requires & clause))
6243 : : {
6244 : 0 : if (clause & OMP_REQ_ATOMIC_MEM_ORDER_MASK)
6245 : 0 : gfc_error ("!$OMP REQUIRES clause %<atomic_default_mem_order(%s)%> "
6246 : : "specified via module %qs use at %L but same clause is "
6247 : : "not specified for the program unit", clause_name,
6248 : : module_name, loc);
6249 : : else
6250 : 0 : gfc_error ("!$OMP REQUIRES clause %qs specified via module %qs use at "
6251 : : "%L but same clause is not specified for the program unit",
6252 : : clause_name, module_name, loc);
6253 : 0 : return false;
6254 : : }
6255 : :
6256 : 107 : if (!gfc_state_stack->previous
6257 : 100 : || gfc_state_stack->previous->state != COMP_INTERFACE)
6258 : 106 : prog_unit->omp_requires |= clause;
6259 : : return true;
6260 : : }
6261 : :
6262 : : match
6263 : 84 : gfc_match_omp_requires (void)
6264 : : {
6265 : 84 : static const char *clauses[] = {"reverse_offload",
6266 : : "unified_address",
6267 : : "unified_shared_memory",
6268 : : "dynamic_allocators",
6269 : : "atomic_default"};
6270 : 84 : const char *clause = NULL;
6271 : 84 : int requires_clauses = 0;
6272 : 84 : bool first = true;
6273 : 84 : locus old_loc;
6274 : :
6275 : 84 : if (gfc_current_ns->parent
6276 : 7 : && (!gfc_state_stack->previous
6277 : 7 : || gfc_state_stack->previous->state != COMP_INTERFACE))
6278 : : {
6279 : 6 : gfc_error ("!$OMP REQUIRES at %C must appear in the specification part "
6280 : : "of a program unit");
6281 : 6 : return MATCH_ERROR;
6282 : : }
6283 : :
6284 : 232 : while (true)
6285 : : {
6286 : 155 : old_loc = gfc_current_locus;
6287 : 155 : gfc_omp_requires_kind requires_clause;
6288 : 77 : if ((first || gfc_match_char (',') != MATCH_YES)
6289 : 155 : && (first && gfc_match_space () != MATCH_YES))
6290 : 0 : goto error;
6291 : 155 : first = false;
6292 : 155 : gfc_gobble_whitespace ();
6293 : 155 : old_loc = gfc_current_locus;
6294 : :
6295 : 155 : if (gfc_match_omp_eos () != MATCH_NO)
6296 : : break;
6297 : 89 : if (gfc_match (clauses[0]) == MATCH_YES)
6298 : : {
6299 : 33 : clause = clauses[0];
6300 : 33 : requires_clause = OMP_REQ_REVERSE_OFFLOAD;
6301 : 33 : if (requires_clauses & OMP_REQ_REVERSE_OFFLOAD)
6302 : 1 : goto duplicate_clause;
6303 : : }
6304 : 56 : else if (gfc_match (clauses[1]) == MATCH_YES)
6305 : : {
6306 : 9 : clause = clauses[1];
6307 : 9 : requires_clause = OMP_REQ_UNIFIED_ADDRESS;
6308 : 9 : if (requires_clauses & OMP_REQ_UNIFIED_ADDRESS)
6309 : 1 : goto duplicate_clause;
6310 : : }
6311 : 47 : else if (gfc_match (clauses[2]) == MATCH_YES)
6312 : : {
6313 : 14 : clause = clauses[2];
6314 : 14 : requires_clause = OMP_REQ_UNIFIED_SHARED_MEMORY;
6315 : 14 : if (requires_clauses & OMP_REQ_UNIFIED_SHARED_MEMORY)
6316 : 1 : goto duplicate_clause;
6317 : : }
6318 : 33 : else if (gfc_match (clauses[3]) == MATCH_YES)
6319 : : {
6320 : 5 : clause = clauses[3];
6321 : 5 : requires_clause = OMP_REQ_DYNAMIC_ALLOCATORS;
6322 : 5 : if (requires_clauses & OMP_REQ_DYNAMIC_ALLOCATORS)
6323 : 1 : goto duplicate_clause;
6324 : : }
6325 : 28 : else if (gfc_match ("atomic_default_mem_order (") == MATCH_YES)
6326 : : {
6327 : 27 : clause = clauses[4];
6328 : 27 : if (requires_clauses & OMP_REQ_ATOMIC_MEM_ORDER_MASK)
6329 : 1 : goto duplicate_clause;
6330 : 26 : if (gfc_match (" seq_cst )") == MATCH_YES)
6331 : : {
6332 : : clause = "seq_cst";
6333 : : requires_clause = OMP_REQ_ATOMIC_MEM_ORDER_SEQ_CST;
6334 : : }
6335 : 14 : else if (gfc_match (" acq_rel )") == MATCH_YES)
6336 : : {
6337 : : clause = "acq_rel";
6338 : : requires_clause = OMP_REQ_ATOMIC_MEM_ORDER_ACQ_REL;
6339 : : }
6340 : 8 : else if (gfc_match (" relaxed )") == MATCH_YES)
6341 : : {
6342 : : clause = "relaxed";
6343 : : requires_clause = OMP_REQ_ATOMIC_MEM_ORDER_RELAXED;
6344 : : }
6345 : : else
6346 : : {
6347 : 4 : gfc_error ("Expected SEQ_CST, ACQ_REL or RELAXED for "
6348 : : "ATOMIC_DEFAULT_MEM_ORDER clause at %C");
6349 : 4 : goto error;
6350 : : }
6351 : : }
6352 : : else
6353 : 1 : goto error;
6354 : :
6355 : 79 : if (!gfc_omp_requires_add_clause (requires_clause, clause, &old_loc, NULL))
6356 : 2 : goto error;
6357 : 77 : requires_clauses |= requires_clause;
6358 : 77 : }
6359 : :
6360 : 66 : if (requires_clauses == 0)
6361 : : {
6362 : 1 : if (!gfc_error_flag_test ())
6363 : 1 : gfc_error ("Clause expected at %C");
6364 : 1 : goto error;
6365 : : }
6366 : : return MATCH_YES;
6367 : :
6368 : 5 : duplicate_clause:
6369 : 5 : gfc_error ("%qs clause at %L specified more than once", clause, &old_loc);
6370 : 13 : error:
6371 : 13 : if (!gfc_error_flag_test ())
6372 : 1 : gfc_error ("Expected UNIFIED_ADDRESS, UNIFIED_SHARED_MEMORY, "
6373 : : "DYNAMIC_ALLOCATORS, REVERSE_OFFLOAD, or "
6374 : : "ATOMIC_DEFAULT_MEM_ORDER clause at %L", &old_loc);
6375 : : return MATCH_ERROR;
6376 : : }
6377 : :
6378 : :
6379 : : match
6380 : 47 : gfc_match_omp_scan (void)
6381 : : {
6382 : 47 : bool incl;
6383 : 47 : gfc_omp_clauses *c = gfc_get_omp_clauses ();
6384 : 47 : gfc_gobble_whitespace ();
6385 : 47 : if ((incl = (gfc_match ("inclusive") == MATCH_YES))
6386 : 47 : || gfc_match ("exclusive") == MATCH_YES)
6387 : : {
6388 : 64 : if (gfc_match_omp_variable_list (" (", &c->lists[incl ? OMP_LIST_SCAN_IN
6389 : : : OMP_LIST_SCAN_EX],
6390 : : false) != MATCH_YES)
6391 : : {
6392 : 0 : gfc_free_omp_clauses (c);
6393 : 0 : return MATCH_ERROR;
6394 : : }
6395 : : }
6396 : : else
6397 : : {
6398 : 1 : gfc_error ("Expected INCLUSIVE or EXCLUSIVE clause at %C");
6399 : 1 : gfc_free_omp_clauses (c);
6400 : 1 : return MATCH_ERROR;
6401 : : }
6402 : 46 : if (gfc_match_omp_eos () != MATCH_YES)
6403 : : {
6404 : 1 : gfc_error ("Unexpected junk after !$OMP SCAN at %C");
6405 : 1 : gfc_free_omp_clauses (c);
6406 : 1 : return MATCH_ERROR;
6407 : : }
6408 : :
6409 : 45 : new_st.op = EXEC_OMP_SCAN;
6410 : 45 : new_st.ext.omp_clauses = c;
6411 : 45 : return MATCH_YES;
6412 : : }
6413 : :
6414 : :
6415 : : match
6416 : 57 : gfc_match_omp_scope (void)
6417 : : {
6418 : 57 : return match_omp (EXEC_OMP_SCOPE, OMP_SCOPE_CLAUSES);
6419 : : }
6420 : :
6421 : :
6422 : : match
6423 : 82 : gfc_match_omp_sections (void)
6424 : : {
6425 : 82 : return match_omp (EXEC_OMP_SECTIONS, OMP_SECTIONS_CLAUSES);
6426 : : }
6427 : :
6428 : :
6429 : : match
6430 : 754 : gfc_match_omp_simd (void)
6431 : : {
6432 : 754 : return match_omp (EXEC_OMP_SIMD, OMP_SIMD_CLAUSES);
6433 : : }
6434 : :
6435 : :
6436 : : match
6437 : 575 : gfc_match_omp_single (void)
6438 : : {
6439 : 575 : return match_omp (EXEC_OMP_SINGLE, OMP_SINGLE_CLAUSES);
6440 : : }
6441 : :
6442 : :
6443 : : match
6444 : 1441 : gfc_match_omp_target (void)
6445 : : {
6446 : 1441 : return match_omp (EXEC_OMP_TARGET, OMP_TARGET_CLAUSES);
6447 : : }
6448 : :
6449 : :
6450 : : match
6451 : 1387 : gfc_match_omp_target_data (void)
6452 : : {
6453 : 1387 : return match_omp (EXEC_OMP_TARGET_DATA, OMP_TARGET_DATA_CLAUSES);
6454 : : }
6455 : :
6456 : :
6457 : : match
6458 : 257 : gfc_match_omp_target_enter_data (void)
6459 : : {
6460 : 257 : return match_omp (EXEC_OMP_TARGET_ENTER_DATA, OMP_TARGET_ENTER_DATA_CLAUSES);
6461 : : }
6462 : :
6463 : :
6464 : : match
6465 : 179 : gfc_match_omp_target_exit_data (void)
6466 : : {
6467 : 179 : return match_omp (EXEC_OMP_TARGET_EXIT_DATA, OMP_TARGET_EXIT_DATA_CLAUSES);
6468 : : }
6469 : :
6470 : :
6471 : : match
6472 : 23 : gfc_match_omp_target_parallel (void)
6473 : : {
6474 : 23 : return match_omp (EXEC_OMP_TARGET_PARALLEL,
6475 : 23 : (OMP_TARGET_CLAUSES | OMP_PARALLEL_CLAUSES)
6476 : 23 : & ~(omp_mask (OMP_CLAUSE_COPYIN)));
6477 : : }
6478 : :
6479 : :
6480 : : match
6481 : 45 : gfc_match_omp_target_parallel_do (void)
6482 : : {
6483 : 45 : return match_omp (EXEC_OMP_TARGET_PARALLEL_DO,
6484 : 45 : (OMP_TARGET_CLAUSES | OMP_PARALLEL_CLAUSES
6485 : 45 : | OMP_DO_CLAUSES) & ~(omp_mask (OMP_CLAUSE_COPYIN)));
6486 : : }
6487 : :
6488 : :
6489 : : match
6490 : 19 : gfc_match_omp_target_parallel_do_simd (void)
6491 : : {
6492 : 19 : return match_omp (EXEC_OMP_TARGET_PARALLEL_DO_SIMD,
6493 : 19 : (OMP_TARGET_CLAUSES | OMP_PARALLEL_CLAUSES | OMP_DO_CLAUSES
6494 : 19 : | OMP_SIMD_CLAUSES) & ~(omp_mask (OMP_CLAUSE_COPYIN)));
6495 : : }
6496 : :
6497 : :
6498 : : match
6499 : 34 : gfc_match_omp_target_simd (void)
6500 : : {
6501 : 34 : return match_omp (EXEC_OMP_TARGET_SIMD,
6502 : 34 : OMP_TARGET_CLAUSES | OMP_SIMD_CLAUSES);
6503 : : }
6504 : :
6505 : :
6506 : : match
6507 : 66 : gfc_match_omp_target_teams (void)
6508 : : {
6509 : 66 : return match_omp (EXEC_OMP_TARGET_TEAMS,
6510 : 66 : OMP_TARGET_CLAUSES | OMP_TEAMS_CLAUSES);
6511 : : }
6512 : :
6513 : :
6514 : : match
6515 : 16 : gfc_match_omp_target_teams_distribute (void)
6516 : : {
6517 : 16 : return match_omp (EXEC_OMP_TARGET_TEAMS_DISTRIBUTE,
6518 : 16 : OMP_TARGET_CLAUSES | OMP_TEAMS_CLAUSES
6519 : 16 : | OMP_DISTRIBUTE_CLAUSES);
6520 : : }
6521 : :
6522 : :
6523 : : match
6524 : 47 : gfc_match_omp_target_teams_distribute_parallel_do (void)
6525 : : {
6526 : 47 : return match_omp (EXEC_OMP_TARGET_TEAMS_DISTRIBUTE_PARALLEL_DO,
6527 : 47 : (OMP_TARGET_CLAUSES | OMP_TEAMS_CLAUSES
6528 : 47 : | OMP_DISTRIBUTE_CLAUSES | OMP_PARALLEL_CLAUSES
6529 : 47 : | OMP_DO_CLAUSES)
6530 : 47 : & ~(omp_mask (OMP_CLAUSE_ORDERED))
6531 : 47 : & ~(omp_mask (OMP_CLAUSE_LINEAR)));
6532 : : }
6533 : :
6534 : :
6535 : : match
6536 : 33 : gfc_match_omp_target_teams_distribute_parallel_do_simd (void)
6537 : : {
6538 : 33 : return match_omp (EXEC_OMP_TARGET_TEAMS_DISTRIBUTE_PARALLEL_DO_SIMD,
6539 : 33 : (OMP_TARGET_CLAUSES | OMP_TEAMS_CLAUSES
6540 : 33 : | OMP_DISTRIBUTE_CLAUSES | OMP_PARALLEL_CLAUSES
6541 : 33 : | OMP_DO_CLAUSES | OMP_SIMD_CLAUSES)
6542 : 33 : & ~(omp_mask (OMP_CLAUSE_ORDERED)));
6543 : : }
6544 : :
6545 : :
6546 : : match
6547 : 21 : gfc_match_omp_target_teams_distribute_simd (void)
6548 : : {
6549 : 21 : return match_omp (EXEC_OMP_TARGET_TEAMS_DISTRIBUTE_SIMD,
6550 : 21 : OMP_TARGET_CLAUSES | OMP_TEAMS_CLAUSES
6551 : 21 : | OMP_DISTRIBUTE_CLAUSES | OMP_SIMD_CLAUSES);
6552 : : }
6553 : :
6554 : :
6555 : : match
6556 : 1708 : gfc_match_omp_target_update (void)
6557 : : {
6558 : 1708 : return match_omp (EXEC_OMP_TARGET_UPDATE, OMP_TARGET_UPDATE_CLAUSES);
6559 : : }
6560 : :
6561 : :
6562 : : match
6563 : 1179 : gfc_match_omp_task (void)
6564 : : {
6565 : 1179 : return match_omp (EXEC_OMP_TASK, OMP_TASK_CLAUSES);
6566 : : }
6567 : :
6568 : :
6569 : : match
6570 : 87 : gfc_match_omp_taskloop (void)
6571 : : {
6572 : 87 : return match_omp (EXEC_OMP_TASKLOOP, OMP_TASKLOOP_CLAUSES);
6573 : : }
6574 : :
6575 : :
6576 : : match
6577 : 39 : gfc_match_omp_taskloop_simd (void)
6578 : : {
6579 : 39 : return match_omp (EXEC_OMP_TASKLOOP_SIMD,
6580 : 39 : OMP_TASKLOOP_CLAUSES | OMP_SIMD_CLAUSES);
6581 : : }
6582 : :
6583 : :
6584 : : match
6585 : 144 : gfc_match_omp_taskwait (void)
6586 : : {
6587 : 144 : if (gfc_match_omp_eos () == MATCH_YES)
6588 : : {
6589 : 132 : new_st.op = EXEC_OMP_TASKWAIT;
6590 : 132 : new_st.ext.omp_clauses = NULL;
6591 : 132 : return MATCH_YES;
6592 : : }
6593 : 12 : return match_omp (EXEC_OMP_TASKWAIT,
6594 : 12 : omp_mask (OMP_CLAUSE_DEPEND) | OMP_CLAUSE_NOWAIT);
6595 : : }
6596 : :
6597 : :
6598 : : match
6599 : 10 : gfc_match_omp_taskyield (void)
6600 : : {
6601 : 10 : if (gfc_match_omp_eos () != MATCH_YES)
6602 : : {
6603 : 0 : gfc_error ("Unexpected junk after TASKYIELD clause at %C");
6604 : 0 : return MATCH_ERROR;
6605 : : }
6606 : 10 : new_st.op = EXEC_OMP_TASKYIELD;
6607 : 10 : new_st.ext.omp_clauses = NULL;
6608 : 10 : return MATCH_YES;
6609 : : }
6610 : :
6611 : :
6612 : : match
6613 : 147 : gfc_match_omp_teams (void)
6614 : : {
6615 : 147 : return match_omp (EXEC_OMP_TEAMS, OMP_TEAMS_CLAUSES);
6616 : : }
6617 : :
6618 : :
6619 : : match
6620 : 22 : gfc_match_omp_teams_distribute (void)
6621 : : {
6622 : 22 : return match_omp (EXEC_OMP_TEAMS_DISTRIBUTE,
6623 : 22 : OMP_TEAMS_CLAUSES | OMP_DISTRIBUTE_CLAUSES);
6624 : : }
6625 : :
6626 : :
6627 : : match
6628 : 39 : gfc_match_omp_teams_distribute_parallel_do (void)
6629 : : {
6630 : 39 : return match_omp (EXEC_OMP_TEAMS_DISTRIBUTE_PARALLEL_DO,
6631 : 39 : (OMP_TEAMS_CLAUSES | OMP_DISTRIBUTE_CLAUSES
6632 : 39 : | OMP_PARALLEL_CLAUSES | OMP_DO_CLAUSES)
6633 : 39 : & ~(omp_mask (OMP_CLAUSE_ORDERED)
6634 : 39 : | OMP_CLAUSE_LINEAR | OMP_CLAUSE_NOWAIT));
6635 : : }
6636 : :
6637 : :
6638 : : match
6639 : 62 : gfc_match_omp_teams_distribute_parallel_do_simd (void)
6640 : : {
6641 : 62 : return match_omp (EXEC_OMP_TEAMS_DISTRIBUTE_PARALLEL_DO_SIMD,
6642 : 62 : (OMP_TEAMS_CLAUSES | OMP_DISTRIBUTE_CLAUSES
6643 : 62 : | OMP_PARALLEL_CLAUSES | OMP_DO_CLAUSES
6644 : 62 : | OMP_SIMD_CLAUSES)
6645 : 62 : & ~(omp_mask (OMP_CLAUSE_ORDERED) | OMP_CLAUSE_NOWAIT));
6646 : : }
6647 : :
6648 : :
6649 : : match
6650 : 44 : gfc_match_omp_teams_distribute_simd (void)
6651 : : {
6652 : 44 : return match_omp (EXEC_OMP_TEAMS_DISTRIBUTE_SIMD,
6653 : 44 : OMP_TEAMS_CLAUSES | OMP_DISTRIBUTE_CLAUSES
6654 : 44 : | OMP_SIMD_CLAUSES);
6655 : : }
6656 : :
6657 : :
6658 : : match
6659 : 39 : gfc_match_omp_workshare (void)
6660 : : {
6661 : 39 : return match_omp (EXEC_OMP_WORKSHARE, OMP_WORKSHARE_CLAUSES);
6662 : : }
6663 : :
6664 : :
6665 : : match
6666 : 48 : gfc_match_omp_masked (void)
6667 : : {
6668 : 48 : return match_omp (EXEC_OMP_MASKED, OMP_MASKED_CLAUSES);
6669 : : }
6670 : :
6671 : : match
6672 : 10 : gfc_match_omp_masked_taskloop (void)
6673 : : {
6674 : 10 : return match_omp (EXEC_OMP_MASKED_TASKLOOP,
6675 : 10 : OMP_MASKED_CLAUSES | OMP_TASKLOOP_CLAUSES);
6676 : : }
6677 : :
6678 : : match
6679 : 15 : gfc_match_omp_masked_taskloop_simd (void)
6680 : : {
6681 : 15 : return match_omp (EXEC_OMP_MASKED_TASKLOOP_SIMD,
6682 : 15 : (OMP_MASKED_CLAUSES | OMP_TASKLOOP_CLAUSES
6683 : 15 : | OMP_SIMD_CLAUSES));
6684 : : }
6685 : :
6686 : : match
6687 : 110 : gfc_match_omp_master (void)
6688 : : {
6689 : 110 : if (gfc_match_omp_eos () != MATCH_YES)
6690 : : {
6691 : 1 : gfc_error ("Unexpected junk after $OMP MASTER statement at %C");
6692 : 1 : return MATCH_ERROR;
6693 : : }
6694 : 109 : new_st.op = EXEC_OMP_MASTER;
6695 : 109 : new_st.ext.omp_clauses = NULL;
6696 : 109 : return MATCH_YES;
6697 : : }
6698 : :
6699 : : match
6700 : 16 : gfc_match_omp_master_taskloop (void)
6701 : : {
6702 : 16 : return match_omp (EXEC_OMP_MASTER_TASKLOOP, OMP_TASKLOOP_CLAUSES);
6703 : : }
6704 : :
6705 : : match
6706 : 22 : gfc_match_omp_master_taskloop_simd (void)
6707 : : {
6708 : 22 : return match_omp (EXEC_OMP_MASTER_TASKLOOP_SIMD,
6709 : 22 : OMP_TASKLOOP_CLAUSES | OMP_SIMD_CLAUSES);
6710 : : }
6711 : :
6712 : : match
6713 : 235 : gfc_match_omp_ordered (void)
6714 : : {
6715 : 235 : return match_omp (EXEC_OMP_ORDERED, OMP_ORDERED_CLAUSES);
6716 : : }
6717 : :
6718 : : match
6719 : 8 : gfc_match_omp_nothing (void)
6720 : : {
6721 : 8 : if (gfc_match_omp_eos () != MATCH_YES)
6722 : : {
6723 : 1 : gfc_error ("Unexpected junk after $OMP NOTHING statement at %C");
6724 : 1 : return MATCH_ERROR;
6725 : : }
6726 : : /* Will use ST_NONE; therefore, no EXEC_OMP_ is needed. */
6727 : : return MATCH_YES;
6728 : : }
6729 : :
6730 : : match
6731 : 315 : gfc_match_omp_ordered_depend (void)
6732 : : {
6733 : 315 : return match_omp (EXEC_OMP_ORDERED, omp_mask (OMP_CLAUSE_DOACROSS));
6734 : : }
6735 : :
6736 : :
6737 : : /* omp atomic [clause-list]
6738 : : - atomic-clause: read | write | update
6739 : : - capture
6740 : : - memory-order-clause: seq_cst | acq_rel | release | acquire | relaxed
6741 : : - hint(hint-expr)
6742 : : - OpenMP 5.1: compare | fail (seq_cst | acquire | relaxed ) | weak
6743 : : */
6744 : :
6745 : : match
6746 : 2146 : gfc_match_omp_atomic (void)
6747 : : {
6748 : 2146 : gfc_omp_clauses *c;
6749 : 2146 : locus loc = gfc_current_locus;
6750 : :
6751 : 2146 : if (gfc_match_omp_clauses (&c, OMP_ATOMIC_CLAUSES, true, true) != MATCH_YES)
6752 : : return MATCH_ERROR;
6753 : :
6754 : 2128 : if (c->atomic_op == GFC_OMP_ATOMIC_UNSET)
6755 : 1003 : c->atomic_op = GFC_OMP_ATOMIC_UPDATE;
6756 : :
6757 : 2128 : if (c->capture && c->atomic_op != GFC_OMP_ATOMIC_UPDATE)
6758 : 3 : gfc_error ("!$OMP ATOMIC at %L with %s clause is incompatible with "
6759 : : "READ or WRITE", &loc, "CAPTURE");
6760 : 2128 : if (c->compare && c->atomic_op != GFC_OMP_ATOMIC_UPDATE)
6761 : 3 : gfc_error ("!$OMP ATOMIC at %L with %s clause is incompatible with "
6762 : : "READ or WRITE", &loc, "COMPARE");
6763 : 2128 : if (c->fail != OMP_MEMORDER_UNSET && c->atomic_op != GFC_OMP_ATOMIC_UPDATE)
6764 : 2 : gfc_error ("!$OMP ATOMIC at %L with %s clause is incompatible with "
6765 : : "READ or WRITE", &loc, "FAIL");
6766 : 2128 : if (c->weak && !c->compare)
6767 : : {
6768 : 5 : gfc_error ("!$OMP ATOMIC at %L with %s clause requires %s clause", &loc,
6769 : : "WEAK", "COMPARE");
6770 : 5 : c->weak = false;
6771 : : }
6772 : :
6773 : 2128 : if (c->memorder == OMP_MEMORDER_UNSET)
6774 : : {
6775 : 1946 : gfc_namespace *prog_unit = gfc_current_ns;
6776 : 2496 : while (prog_unit->parent)
6777 : : prog_unit = prog_unit->parent;
6778 : 1946 : switch (prog_unit->omp_requires & OMP_REQ_ATOMIC_MEM_ORDER_MASK)
6779 : : {
6780 : 1923 : case 0:
6781 : 1923 : case OMP_REQ_ATOMIC_MEM_ORDER_RELAXED:
6782 : 1923 : c->memorder = OMP_MEMORDER_RELAXED;
6783 : 1923 : break;
6784 : 7 : case OMP_REQ_ATOMIC_MEM_ORDER_SEQ_CST:
6785 : 7 : c->memorder = OMP_MEMORDER_SEQ_CST;
6786 : 7 : break;
6787 : 16 : case OMP_REQ_ATOMIC_MEM_ORDER_ACQ_REL:
6788 : 16 : if (c->capture)
6789 : 5 : c->memorder = OMP_MEMORDER_ACQ_REL;
6790 : 11 : else if (c->atomic_op == GFC_OMP_ATOMIC_READ)
6791 : 3 : c->memorder = OMP_MEMORDER_ACQUIRE;
6792 : : else
6793 : 8 : c->memorder = OMP_MEMORDER_RELEASE;
6794 : : break;
6795 : : default:
6796 : : gcc_unreachable ();
6797 : : }
6798 : : }
6799 : : else
6800 : 182 : switch (c->atomic_op)
6801 : : {
6802 : 28 : case GFC_OMP_ATOMIC_READ:
6803 : 28 : if (c->memorder == OMP_MEMORDER_RELEASE)
6804 : : {
6805 : 1 : gfc_error ("!$OMP ATOMIC READ at %L incompatible with "
6806 : : "RELEASE clause", &loc);
6807 : 1 : c->memorder = OMP_MEMORDER_SEQ_CST;
6808 : : }
6809 : 27 : else if (c->memorder == OMP_MEMORDER_ACQ_REL)
6810 : 1 : c->memorder = OMP_MEMORDER_ACQUIRE;
6811 : : break;
6812 : 34 : case GFC_OMP_ATOMIC_WRITE:
6813 : 34 : if (c->memorder == OMP_MEMORDER_ACQUIRE)
6814 : : {
6815 : 1 : gfc_error ("!$OMP ATOMIC WRITE at %L incompatible with "
6816 : : "ACQUIRE clause", &loc);
6817 : 1 : c->memorder = OMP_MEMORDER_SEQ_CST;
6818 : : }
6819 : 33 : else if (c->memorder == OMP_MEMORDER_ACQ_REL)
6820 : 1 : c->memorder = OMP_MEMORDER_RELEASE;
6821 : : break;
6822 : : default:
6823 : : break;
6824 : : }
6825 : 2128 : gfc_error_check ();
6826 : 2128 : new_st.ext.omp_clauses = c;
6827 : 2128 : new_st.op = EXEC_OMP_ATOMIC;
6828 : 2128 : return MATCH_YES;
6829 : : }
6830 : :
6831 : :
6832 : : /* acc atomic [ read | write | update | capture] */
6833 : :
6834 : : match
6835 : 552 : gfc_match_oacc_atomic (void)
6836 : : {
6837 : 552 : gfc_omp_clauses *c = gfc_get_omp_clauses ();
6838 : 552 : c->atomic_op = GFC_OMP_ATOMIC_UPDATE;
6839 : 552 : c->memorder = OMP_MEMORDER_RELAXED;
6840 : 552 : gfc_gobble_whitespace ();
6841 : 552 : if (gfc_match ("update") == MATCH_YES)
6842 : : ;
6843 : 373 : else if (gfc_match ("read") == MATCH_YES)
6844 : 17 : c->atomic_op = GFC_OMP_ATOMIC_READ;
6845 : 356 : else if (gfc_match ("write") == MATCH_YES)
6846 : 13 : c->atomic_op = GFC_OMP_ATOMIC_WRITE;
6847 : 343 : else if (gfc_match ("capture") == MATCH_YES)
6848 : 319 : c->capture = true;
6849 : 552 : gfc_gobble_whitespace ();
6850 : 552 : if (gfc_match_omp_eos () != MATCH_YES)
6851 : : {
6852 : 9 : gfc_error ("Unexpected junk after !$ACC ATOMIC statement at %C");
6853 : 9 : gfc_free_omp_clauses (c);
6854 : 9 : return MATCH_ERROR;
6855 : : }
6856 : 543 : new_st.ext.omp_clauses = c;
6857 : 543 : new_st.op = EXEC_OACC_ATOMIC;
6858 : 543 : return MATCH_YES;
6859 : : }
6860 : :
6861 : :
6862 : : match
6863 : 605 : gfc_match_omp_barrier (void)
6864 : : {
6865 : 605 : if (gfc_match_omp_eos () != MATCH_YES)
6866 : : {
6867 : 0 : gfc_error ("Unexpected junk after $OMP BARRIER statement at %C");
6868 : 0 : return MATCH_ERROR;
6869 : : }
6870 : 605 : new_st.op = EXEC_OMP_BARRIER;
6871 : 605 : new_st.ext.omp_clauses = NULL;
6872 : 605 : return MATCH_YES;
6873 : : }
6874 : :
6875 : :
6876 : : match
6877 : 188 : gfc_match_omp_taskgroup (void)
6878 : : {
6879 : 188 : return match_omp (EXEC_OMP_TASKGROUP, OMP_TASKGROUP_CLAUSES);
6880 : : }
6881 : :
6882 : :
6883 : : static enum gfc_omp_cancel_kind
6884 : 494 : gfc_match_omp_cancel_kind (void)
6885 : : {
6886 : 494 : if (gfc_match_space () != MATCH_YES)
6887 : : return OMP_CANCEL_UNKNOWN;
6888 : 492 : if (gfc_match ("parallel") == MATCH_YES)
6889 : : return OMP_CANCEL_PARALLEL;
6890 : 352 : if (gfc_match ("sections") == MATCH_YES)
6891 : : return OMP_CANCEL_SECTIONS;
6892 : 253 : if (gfc_match ("do") == MATCH_YES)
6893 : : return OMP_CANCEL_DO;
6894 : 123 : if (gfc_match ("taskgroup") == MATCH_YES)
6895 : : return OMP_CANCEL_TASKGROUP;
6896 : : return OMP_CANCEL_UNKNOWN;
6897 : : }
6898 : :
6899 : :
6900 : : match
6901 : 321 : gfc_match_omp_cancel (void)
6902 : : {
6903 : 321 : gfc_omp_clauses *c;
6904 : 321 : enum gfc_omp_cancel_kind kind = gfc_match_omp_cancel_kind ();
6905 : 321 : if (kind == OMP_CANCEL_UNKNOWN)
6906 : : return MATCH_ERROR;
6907 : 319 : if (gfc_match_omp_clauses (&c, omp_mask (OMP_CLAUSE_IF), false) != MATCH_YES)
6908 : : return MATCH_ERROR;
6909 : 316 : c->cancel = kind;
6910 : 316 : new_st.op = EXEC_OMP_CANCEL;
6911 : 316 : new_st.ext.omp_clauses = c;
6912 : 316 : return MATCH_YES;
6913 : : }
6914 : :
6915 : :
6916 : : match
6917 : 173 : gfc_match_omp_cancellation_point (void)
6918 : : {
6919 : 173 : gfc_omp_clauses *c;
6920 : 173 : enum gfc_omp_cancel_kind kind = gfc_match_omp_cancel_kind ();
6921 : 173 : if (kind == OMP_CANCEL_UNKNOWN)
6922 : : {
6923 : 2 : gfc_error ("Expected construct-type PARALLEL, SECTIONS, DO or TASKGROUP "
6924 : : "in $OMP CANCELLATION POINT statement at %C");
6925 : 2 : return MATCH_ERROR;
6926 : : }
6927 : 171 : if (gfc_match_omp_eos () != MATCH_YES)
6928 : : {
6929 : 0 : gfc_error ("Unexpected junk after $OMP CANCELLATION POINT statement "
6930 : : "at %C");
6931 : 0 : return MATCH_ERROR;
6932 : : }
6933 : 171 : c = gfc_get_omp_clauses ();
6934 : 171 : c->cancel = kind;
6935 : 171 : new_st.op = EXEC_OMP_CANCELLATION_POINT;
6936 : 171 : new_st.ext.omp_clauses = c;
6937 : 171 : return MATCH_YES;
6938 : : }
6939 : :
6940 : :
6941 : : match
6942 : 1952 : gfc_match_omp_end_nowait (void)
6943 : : {
6944 : 1952 : bool nowait = false;
6945 : 1952 : if (gfc_match ("% nowait") == MATCH_YES)
6946 : 255 : nowait = true;
6947 : 1952 : if (gfc_match_omp_eos () != MATCH_YES)
6948 : : {
6949 : 4 : if (nowait)
6950 : 3 : gfc_error ("Unexpected junk after NOWAIT clause at %C");
6951 : : else
6952 : 1 : gfc_error ("Unexpected junk at %C");
6953 : 4 : return MATCH_ERROR;
6954 : : }
6955 : 1948 : new_st.op = EXEC_OMP_END_NOWAIT;
6956 : 1948 : new_st.ext.omp_bool = nowait;
6957 : 1948 : return MATCH_YES;
6958 : : }
6959 : :
6960 : :
6961 : : match
6962 : 571 : gfc_match_omp_end_single (void)
6963 : : {
6964 : 571 : gfc_omp_clauses *c;
6965 : 571 : if (gfc_match_omp_clauses (&c, omp_mask (OMP_CLAUSE_COPYPRIVATE)
6966 : : | OMP_CLAUSE_NOWAIT) != MATCH_YES)
6967 : : return MATCH_ERROR;
6968 : 571 : new_st.op = EXEC_OMP_END_SINGLE;
6969 : 571 : new_st.ext.omp_clauses = c;
6970 : 571 : return MATCH_YES;
6971 : : }
6972 : :
6973 : :
6974 : : static bool
6975 : 32924 : oacc_is_loop (gfc_code *code)
6976 : : {
6977 : 32924 : return code->op == EXEC_OACC_PARALLEL_LOOP
6978 : : || code->op == EXEC_OACC_KERNELS_LOOP
6979 : 17814 : || code->op == EXEC_OACC_SERIAL_LOOP
6980 : 11983 : || code->op == EXEC_OACC_LOOP;
6981 : : }
6982 : :
6983 : : static void
6984 : 5170 : resolve_scalar_int_expr (gfc_expr *expr, const char *clause)
6985 : : {
6986 : 5170 : if (!gfc_resolve_expr (expr)
6987 : 5170 : || expr->ts.type != BT_INTEGER
6988 : 10276 : || expr->rank != 0)
6989 : 78 : gfc_error ("%s clause at %L requires a scalar INTEGER expression",
6990 : : clause, &expr->where);
6991 : 5170 : }
6992 : :
6993 : : static void
6994 : 3907 : resolve_positive_int_expr (gfc_expr *expr, const char *clause)
6995 : : {
6996 : 3907 : resolve_scalar_int_expr (expr, clause);
6997 : 3907 : if (expr->expr_type == EXPR_CONSTANT
6998 : 3469 : && expr->ts.type == BT_INTEGER
6999 : 3436 : && mpz_sgn (expr->value.integer) <= 0)
7000 : 41 : gfc_warning (0, "INTEGER expression of %s clause at %L must be positive",
7001 : : clause, &expr->where);
7002 : 3907 : }
7003 : :
7004 : : static void
7005 : 76 : resolve_nonnegative_int_expr (gfc_expr *expr, const char *clause)
7006 : : {
7007 : 76 : resolve_scalar_int_expr (expr, clause);
7008 : 76 : if (expr->expr_type == EXPR_CONSTANT
7009 : 8 : && expr->ts.type == BT_INTEGER
7010 : 7 : && mpz_sgn (expr->value.integer) < 0)
7011 : 1 : gfc_warning (0, "INTEGER expression of %s clause at %L must be "
7012 : : "non-negative", clause, &expr->where);
7013 : 76 : }
7014 : :
7015 : : /* Emits error when symbol is pointer, cray pointer or cray pointee
7016 : : of derived of polymorphic type. */
7017 : :
7018 : : static void
7019 : 98 : check_symbol_not_pointer (gfc_symbol *sym, locus loc, const char *name)
7020 : : {
7021 : 98 : if (sym->ts.type == BT_DERIVED && sym->attr.cray_pointer)
7022 : 0 : gfc_error ("Cray pointer object %qs of derived type in %s clause at %L",
7023 : : sym->name, name, &loc);
7024 : 98 : if (sym->ts.type == BT_DERIVED && sym->attr.cray_pointee)
7025 : 0 : gfc_error ("Cray pointee object %qs of derived type in %s clause at %L",
7026 : : sym->name, name, &loc);
7027 : :
7028 : 98 : if ((sym->ts.type == BT_ASSUMED && sym->attr.pointer)
7029 : 98 : || (sym->ts.type == BT_CLASS && CLASS_DATA (sym)
7030 : 0 : && CLASS_DATA (sym)->attr.pointer))
7031 : 0 : gfc_error ("POINTER object %qs of polymorphic type in %s clause at %L",
7032 : : sym->name, name, &loc);
7033 : 98 : if ((sym->ts.type == BT_ASSUMED && sym->attr.cray_pointer)
7034 : 98 : || (sym->ts.type == BT_CLASS && CLASS_DATA (sym)
7035 : 0 : && CLASS_DATA (sym)->attr.cray_pointer))
7036 : 0 : gfc_error ("Cray pointer object %qs of polymorphic type in %s clause at %L",
7037 : : sym->name, name, &loc);
7038 : 98 : if ((sym->ts.type == BT_ASSUMED && sym->attr.cray_pointee)
7039 : 98 : || (sym->ts.type == BT_CLASS && CLASS_DATA (sym)
7040 : 0 : && CLASS_DATA (sym)->attr.cray_pointee))
7041 : 0 : gfc_error ("Cray pointee object %qs of polymorphic type in %s clause at %L",
7042 : : sym->name, name, &loc);
7043 : 98 : }
7044 : :
7045 : : /* Emits error when symbol represents assumed size/rank array. */
7046 : :
7047 : : static void
7048 : 13555 : check_array_not_assumed (gfc_symbol *sym, locus loc, const char *name)
7049 : : {
7050 : 13555 : if (sym->as && sym->as->type == AS_ASSUMED_SIZE)
7051 : 10 : gfc_error ("Assumed size array %qs in %s clause at %L",
7052 : : sym->name, name, &loc);
7053 : 13555 : if (sym->as && sym->as->type == AS_ASSUMED_RANK)
7054 : 9 : gfc_error ("Assumed rank array %qs in %s clause at %L",
7055 : : sym->name, name, &loc);
7056 : 13555 : }
7057 : :
7058 : : static void
7059 : 5588 : resolve_oacc_data_clauses (gfc_symbol *sym, locus loc, const char *name)
7060 : : {
7061 : 0 : check_array_not_assumed (sym, loc, name);
7062 : 0 : }
7063 : :
7064 : : static void
7065 : 50 : resolve_oacc_deviceptr_clause (gfc_symbol *sym, locus loc, const char *name)
7066 : : {
7067 : 50 : if (sym->attr.pointer
7068 : 49 : || (sym->ts.type == BT_CLASS && CLASS_DATA (sym)
7069 : 0 : && CLASS_DATA (sym)->attr.class_pointer))
7070 : 1 : gfc_error ("POINTER object %qs in %s clause at %L",
7071 : : sym->name, name, &loc);
7072 : 50 : if (sym->attr.cray_pointer
7073 : 48 : || (sym->ts.type == BT_CLASS && CLASS_DATA (sym)
7074 : 0 : && CLASS_DATA (sym)->attr.cray_pointer))
7075 : 2 : gfc_error ("Cray pointer object %qs in %s clause at %L",
7076 : : sym->name, name, &loc);
7077 : 50 : if (sym->attr.cray_pointee
7078 : 48 : || (sym->ts.type == BT_CLASS && CLASS_DATA (sym)
7079 : 0 : && CLASS_DATA (sym)->attr.cray_pointee))
7080 : 2 : gfc_error ("Cray pointee object %qs in %s clause at %L",
7081 : : sym->name, name, &loc);
7082 : 50 : if (sym->attr.allocatable
7083 : 49 : || (sym->ts.type == BT_CLASS && CLASS_DATA (sym)
7084 : 0 : && CLASS_DATA (sym)->attr.allocatable))
7085 : 1 : gfc_error ("ALLOCATABLE object %qs in %s clause at %L",
7086 : : sym->name, name, &loc);
7087 : 50 : if (sym->attr.value)
7088 : 1 : gfc_error ("VALUE object %qs in %s clause at %L",
7089 : : sym->name, name, &loc);
7090 : 50 : check_array_not_assumed (sym, loc, name);
7091 : 50 : }
7092 : :
7093 : :
7094 : : struct resolve_omp_udr_callback_data
7095 : : {
7096 : : gfc_symbol *sym1, *sym2;
7097 : : };
7098 : :
7099 : :
7100 : : static int
7101 : 1413 : resolve_omp_udr_callback (gfc_expr **e, int *, void *data)
7102 : : {
7103 : 1413 : struct resolve_omp_udr_callback_data *rcd
7104 : : = (struct resolve_omp_udr_callback_data *) data;
7105 : 1413 : if ((*e)->expr_type == EXPR_VARIABLE
7106 : 801 : && ((*e)->symtree->n.sym == rcd->sym1
7107 : 255 : || (*e)->symtree->n.sym == rcd->sym2))
7108 : : {
7109 : 801 : gfc_ref *ref = gfc_get_ref ();
7110 : 801 : ref->type = REF_ARRAY;
7111 : 801 : ref->u.ar.where = (*e)->where;
7112 : 801 : ref->u.ar.as = (*e)->symtree->n.sym->as;
7113 : 801 : ref->u.ar.type = AR_FULL;
7114 : 801 : ref->u.ar.dimen = 0;
7115 : 801 : ref->next = (*e)->ref;
7116 : 801 : (*e)->ref = ref;
7117 : : }
7118 : 1413 : return 0;
7119 : : }
7120 : :
7121 : :
7122 : : static int
7123 : 2990 : resolve_omp_udr_callback2 (gfc_expr **e, int *, void *)
7124 : : {
7125 : 2990 : if ((*e)->expr_type == EXPR_FUNCTION
7126 : 360 : && (*e)->value.function.isym == NULL)
7127 : : {
7128 : 174 : gfc_symbol *sym = (*e)->symtree->n.sym;
7129 : 174 : if (!sym->attr.intrinsic
7130 : 174 : && sym->attr.if_source == IFSRC_UNKNOWN)
7131 : 4 : gfc_error ("Implicitly declared function %s used in "
7132 : : "!$OMP DECLARE REDUCTION at %L", sym->name, &(*e)->where);
7133 : : }
7134 : 2990 : return 0;
7135 : : }
7136 : :
7137 : :
7138 : : static gfc_code *
7139 : 797 : resolve_omp_udr_clause (gfc_omp_namelist *n, gfc_namespace *ns,
7140 : : gfc_symbol *sym1, gfc_symbol *sym2)
7141 : : {
7142 : 797 : gfc_code *copy;
7143 : 797 : gfc_symbol sym1_copy, sym2_copy;
7144 : :
7145 : 797 : if (ns->code->op == EXEC_ASSIGN)
7146 : : {
7147 : 625 : copy = gfc_get_code (EXEC_ASSIGN);
7148 : 625 : copy->expr1 = gfc_copy_expr (ns->code->expr1);
7149 : 625 : copy->expr2 = gfc_copy_expr (ns->code->expr2);
7150 : : }
7151 : : else
7152 : : {
7153 : 172 : copy = gfc_get_code (EXEC_CALL);
7154 : 172 : copy->symtree = ns->code->symtree;
7155 : 172 : copy->ext.actual = gfc_copy_actual_arglist (ns->code->ext.actual);
7156 : : }
7157 : 797 : copy->loc = ns->code->loc;
7158 : 797 : sym1_copy = *sym1;
7159 : 797 : sym2_copy = *sym2;
7160 : 797 : *sym1 = *n->sym;
7161 : 797 : *sym2 = *n->sym;
7162 : 797 : sym1->name = sym1_copy.name;
7163 : 797 : sym2->name = sym2_copy.name;
7164 : 797 : ns->proc_name = ns->parent->proc_name;
7165 : 797 : if (n->sym->attr.dimension)
7166 : : {
7167 : 348 : struct resolve_omp_udr_callback_data rcd;
7168 : 348 : rcd.sym1 = sym1;
7169 : 348 : rcd.sym2 = sym2;
7170 : 348 : gfc_code_walker (©, gfc_dummy_code_callback,
7171 : : resolve_omp_udr_callback, &rcd);
7172 : : }
7173 : 797 : gfc_resolve_code (copy, gfc_current_ns);
7174 : 797 : if (copy->op == EXEC_CALL && copy->resolved_isym == NULL)
7175 : : {
7176 : 172 : gfc_symbol *sym = copy->resolved_sym;
7177 : 172 : if (sym
7178 : 170 : && !sym->attr.intrinsic
7179 : 170 : && sym->attr.if_source == IFSRC_UNKNOWN)
7180 : 4 : gfc_error ("Implicitly declared subroutine %s used in "
7181 : : "!$OMP DECLARE REDUCTION at %L", sym->name,
7182 : : ©->loc);
7183 : : }
7184 : 797 : gfc_code_walker (©, gfc_dummy_code_callback,
7185 : : resolve_omp_udr_callback2, NULL);
7186 : 797 : *sym1 = sym1_copy;
7187 : 797 : *sym2 = sym2_copy;
7188 : 797 : return copy;
7189 : : }
7190 : :
7191 : : /* Assume that a constant expression in the range 1 (omp_default_mem_alloc)
7192 : : to 8 (omp_thread_mem_alloc) range is fine. The original symbol name is
7193 : : already lost during matching via gfc_match_expr. */
7194 : : bool
7195 : 27 : is_predefined_allocator (gfc_expr *expr)
7196 : : {
7197 : 27 : return (gfc_resolve_expr (expr)
7198 : 27 : && expr->rank == 0
7199 : 22 : && expr->ts.type == BT_INTEGER
7200 : 17 : && expr->ts.kind == gfc_c_intptr_kind
7201 : 12 : && expr->expr_type == EXPR_CONSTANT
7202 : 7 : && mpz_sgn (expr->value.integer) > 0
7203 : 34 : && mpz_cmp_si (expr->value.integer, 8) <= 0);
7204 : : }
7205 : :
7206 : : /* Resolve declarative ALLOCATE statement. Note: Common block vars only appear
7207 : : as /block/ not individual, which is ensured during parsing. */
7208 : :
7209 : : void
7210 : 11 : gfc_resolve_omp_allocate (gfc_namespace *ns, gfc_omp_namelist *list)
7211 : : {
7212 : 71 : for (gfc_omp_namelist *n = list; n; n = n->next)
7213 : 60 : n->sym->mark = 0;
7214 : 67 : for (gfc_omp_namelist *n = list; n; n = n->next)
7215 : : {
7216 : 56 : if (n->sym->attr.flavor != FL_VARIABLE)
7217 : : {
7218 : 1 : gfc_error ("Argument %qs at %L to declarative !$OMP ALLOCATE "
7219 : : "directive must be a variable", n->sym->name,
7220 : : &n->where);
7221 : 13 : continue;
7222 : : }
7223 : 55 : if (ns != n->sym->ns || n->sym->attr.use_assoc
7224 : 54 : || n->sym->attr.host_assoc || n->sym->attr.imported)
7225 : : {
7226 : 2 : gfc_error ("Argument %qs at %L to declarative !$OMP ALLOCATE shall be"
7227 : : " in the same scope as the variable declaration",
7228 : : n->sym->name, &n->where);
7229 : 2 : continue;
7230 : : }
7231 : 53 : if (n->sym->attr.dummy)
7232 : : {
7233 : 1 : gfc_error ("Unexpected dummy argument %qs as argument at %L to "
7234 : : "declarative !$OMP ALLOCATE", n->sym->name, &n->where);
7235 : 1 : continue;
7236 : : }
7237 : 52 : if (n->sym->mark)
7238 : : {
7239 : 3 : if (n->sym->attr.in_common)
7240 : : {
7241 : 1 : gfc_error ("Duplicated common block %</%s/%> in !$OMP ALLOCATE "
7242 : 1 : "at %L", n->sym->common_head->name, &n->where);
7243 : 3 : while (n->next && n->next->sym
7244 : 4 : && n->sym->common_head == n->next->sym->common_head)
7245 : : n = n->next;
7246 : : }
7247 : : else
7248 : 2 : gfc_error ("Duplicated variable %qs in !$OMP ALLOCATE at %L",
7249 : : n->sym->name, &n->where);
7250 : 3 : continue;
7251 : : }
7252 : 49 : n->sym->mark = 1;
7253 : 49 : if ((n->sym->ts.type == BT_CLASS && n->sym->attr.class_ok
7254 : 0 : && CLASS_DATA (n->sym)->attr.allocatable)
7255 : 49 : || (n->sym->ts.type != BT_CLASS && n->sym->attr.allocatable))
7256 : 1 : gfc_error ("Unexpected allocatable variable %qs at %L in declarative "
7257 : : "!$OMP ALLOCATE directive", n->sym->name, &n->where);
7258 : 48 : else if ((n->sym->ts.type == BT_CLASS && n->sym->attr.class_ok
7259 : 0 : && CLASS_DATA (n->sym)->attr.class_pointer)
7260 : 48 : || (n->sym->ts.type != BT_CLASS && n->sym->attr.pointer))
7261 : 1 : gfc_error ("Unexpected pointer variable %qs at %L in declarative "
7262 |
