1 /* OpenMP directive matching and resolving.
2 Copyright (C) 2005-2013 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 "flags.h"
25 #include "gfortran.h"
26 #include "match.h"
27 #include "parse.h"
28 #include "pointer-set.h"
29
30 /* Match an end of OpenMP directive. End of OpenMP directive is optional
31 whitespace, followed by '\n' or comment '!'. */
32
33 match
gfc_match_omp_eos(void)34 gfc_match_omp_eos (void)
35 {
36 locus old_loc;
37 char c;
38
39 old_loc = gfc_current_locus;
40 gfc_gobble_whitespace ();
41
42 c = gfc_next_ascii_char ();
43 switch (c)
44 {
45 case '!':
46 do
47 c = gfc_next_ascii_char ();
48 while (c != '\n');
49 /* Fall through */
50
51 case '\n':
52 return MATCH_YES;
53 }
54
55 gfc_current_locus = old_loc;
56 return MATCH_NO;
57 }
58
59 /* Free an omp_clauses structure. */
60
61 void
gfc_free_omp_clauses(gfc_omp_clauses * c)62 gfc_free_omp_clauses (gfc_omp_clauses *c)
63 {
64 int i;
65 if (c == NULL)
66 return;
67
68 gfc_free_expr (c->if_expr);
69 gfc_free_expr (c->final_expr);
70 gfc_free_expr (c->num_threads);
71 gfc_free_expr (c->chunk_size);
72 for (i = 0; i < OMP_LIST_NUM; i++)
73 gfc_free_namelist (c->lists[i]);
74 free (c);
75 }
76
77 /* Match a variable/common block list and construct a namelist from it. */
78
79 static match
gfc_match_omp_variable_list(const char * str,gfc_namelist ** list,bool allow_common)80 gfc_match_omp_variable_list (const char *str, gfc_namelist **list,
81 bool allow_common)
82 {
83 gfc_namelist *head, *tail, *p;
84 locus old_loc;
85 char n[GFC_MAX_SYMBOL_LEN+1];
86 gfc_symbol *sym;
87 match m;
88 gfc_symtree *st;
89
90 head = tail = NULL;
91
92 old_loc = gfc_current_locus;
93
94 m = gfc_match (str);
95 if (m != MATCH_YES)
96 return m;
97
98 for (;;)
99 {
100 m = gfc_match_symbol (&sym, 1);
101 switch (m)
102 {
103 case MATCH_YES:
104 gfc_set_sym_referenced (sym);
105 p = gfc_get_namelist ();
106 if (head == NULL)
107 head = tail = p;
108 else
109 {
110 tail->next = p;
111 tail = tail->next;
112 }
113 tail->sym = sym;
114 goto next_item;
115 case MATCH_NO:
116 break;
117 case MATCH_ERROR:
118 goto cleanup;
119 }
120
121 if (!allow_common)
122 goto syntax;
123
124 m = gfc_match (" / %n /", n);
125 if (m == MATCH_ERROR)
126 goto cleanup;
127 if (m == MATCH_NO)
128 goto syntax;
129
130 st = gfc_find_symtree (gfc_current_ns->common_root, n);
131 if (st == NULL)
132 {
133 gfc_error ("COMMON block /%s/ not found at %C", n);
134 goto cleanup;
135 }
136 for (sym = st->n.common->head; sym; sym = sym->common_next)
137 {
138 gfc_set_sym_referenced (sym);
139 p = gfc_get_namelist ();
140 if (head == NULL)
141 head = tail = p;
142 else
143 {
144 tail->next = p;
145 tail = tail->next;
146 }
147 tail->sym = sym;
148 }
149
150 next_item:
151 if (gfc_match_char (')') == MATCH_YES)
152 break;
153 if (gfc_match_char (',') != MATCH_YES)
154 goto syntax;
155 }
156
157 while (*list)
158 list = &(*list)->next;
159
160 *list = head;
161 return MATCH_YES;
162
163 syntax:
164 gfc_error ("Syntax error in OpenMP variable list at %C");
165
166 cleanup:
167 gfc_free_namelist (head);
168 gfc_current_locus = old_loc;
169 return MATCH_ERROR;
170 }
171
172 #define OMP_CLAUSE_PRIVATE (1 << 0)
173 #define OMP_CLAUSE_FIRSTPRIVATE (1 << 1)
174 #define OMP_CLAUSE_LASTPRIVATE (1 << 2)
175 #define OMP_CLAUSE_COPYPRIVATE (1 << 3)
176 #define OMP_CLAUSE_SHARED (1 << 4)
177 #define OMP_CLAUSE_COPYIN (1 << 5)
178 #define OMP_CLAUSE_REDUCTION (1 << 6)
179 #define OMP_CLAUSE_IF (1 << 7)
180 #define OMP_CLAUSE_NUM_THREADS (1 << 8)
181 #define OMP_CLAUSE_SCHEDULE (1 << 9)
182 #define OMP_CLAUSE_DEFAULT (1 << 10)
183 #define OMP_CLAUSE_ORDERED (1 << 11)
184 #define OMP_CLAUSE_COLLAPSE (1 << 12)
185 #define OMP_CLAUSE_UNTIED (1 << 13)
186 #define OMP_CLAUSE_FINAL (1 << 14)
187 #define OMP_CLAUSE_MERGEABLE (1 << 15)
188
189 /* Match OpenMP directive clauses. MASK is a bitmask of
190 clauses that are allowed for a particular directive. */
191
192 static match
gfc_match_omp_clauses(gfc_omp_clauses ** cp,int mask)193 gfc_match_omp_clauses (gfc_omp_clauses **cp, int mask)
194 {
195 gfc_omp_clauses *c = gfc_get_omp_clauses ();
196 locus old_loc;
197 bool needs_space = true, first = true;
198
199 *cp = NULL;
200 while (1)
201 {
202 if ((first || gfc_match_char (',') != MATCH_YES)
203 && (needs_space && gfc_match_space () != MATCH_YES))
204 break;
205 needs_space = false;
206 first = false;
207 gfc_gobble_whitespace ();
208 if ((mask & OMP_CLAUSE_IF) && c->if_expr == NULL
209 && gfc_match ("if ( %e )", &c->if_expr) == MATCH_YES)
210 continue;
211 if ((mask & OMP_CLAUSE_FINAL) && c->final_expr == NULL
212 && gfc_match ("final ( %e )", &c->final_expr) == MATCH_YES)
213 continue;
214 if ((mask & OMP_CLAUSE_NUM_THREADS) && c->num_threads == NULL
215 && gfc_match ("num_threads ( %e )", &c->num_threads) == MATCH_YES)
216 continue;
217 if ((mask & OMP_CLAUSE_PRIVATE)
218 && gfc_match_omp_variable_list ("private (",
219 &c->lists[OMP_LIST_PRIVATE], true)
220 == MATCH_YES)
221 continue;
222 if ((mask & OMP_CLAUSE_FIRSTPRIVATE)
223 && gfc_match_omp_variable_list ("firstprivate (",
224 &c->lists[OMP_LIST_FIRSTPRIVATE],
225 true)
226 == MATCH_YES)
227 continue;
228 if ((mask & OMP_CLAUSE_LASTPRIVATE)
229 && gfc_match_omp_variable_list ("lastprivate (",
230 &c->lists[OMP_LIST_LASTPRIVATE],
231 true)
232 == MATCH_YES)
233 continue;
234 if ((mask & OMP_CLAUSE_COPYPRIVATE)
235 && gfc_match_omp_variable_list ("copyprivate (",
236 &c->lists[OMP_LIST_COPYPRIVATE],
237 true)
238 == MATCH_YES)
239 continue;
240 if ((mask & OMP_CLAUSE_SHARED)
241 && gfc_match_omp_variable_list ("shared (",
242 &c->lists[OMP_LIST_SHARED], true)
243 == MATCH_YES)
244 continue;
245 if ((mask & OMP_CLAUSE_COPYIN)
246 && gfc_match_omp_variable_list ("copyin (",
247 &c->lists[OMP_LIST_COPYIN], true)
248 == MATCH_YES)
249 continue;
250 old_loc = gfc_current_locus;
251 if ((mask & OMP_CLAUSE_REDUCTION)
252 && gfc_match ("reduction ( ") == MATCH_YES)
253 {
254 int reduction = OMP_LIST_NUM;
255 char buffer[GFC_MAX_SYMBOL_LEN + 1];
256 if (gfc_match_char ('+') == MATCH_YES)
257 reduction = OMP_LIST_PLUS;
258 else if (gfc_match_char ('*') == MATCH_YES)
259 reduction = OMP_LIST_MULT;
260 else if (gfc_match_char ('-') == MATCH_YES)
261 reduction = OMP_LIST_SUB;
262 else if (gfc_match (".and.") == MATCH_YES)
263 reduction = OMP_LIST_AND;
264 else if (gfc_match (".or.") == MATCH_YES)
265 reduction = OMP_LIST_OR;
266 else if (gfc_match (".eqv.") == MATCH_YES)
267 reduction = OMP_LIST_EQV;
268 else if (gfc_match (".neqv.") == MATCH_YES)
269 reduction = OMP_LIST_NEQV;
270 else if (gfc_match_name (buffer) == MATCH_YES)
271 {
272 gfc_symbol *sym;
273 const char *n = buffer;
274
275 gfc_find_symbol (buffer, NULL, 1, &sym);
276 if (sym != NULL)
277 {
278 if (sym->attr.intrinsic)
279 n = sym->name;
280 else if ((sym->attr.flavor != FL_UNKNOWN
281 && sym->attr.flavor != FL_PROCEDURE)
282 || sym->attr.external
283 || sym->attr.generic
284 || sym->attr.entry
285 || sym->attr.result
286 || sym->attr.dummy
287 || sym->attr.subroutine
288 || sym->attr.pointer
289 || sym->attr.target
290 || sym->attr.cray_pointer
291 || sym->attr.cray_pointee
292 || (sym->attr.proc != PROC_UNKNOWN
293 && sym->attr.proc != PROC_INTRINSIC)
294 || sym->attr.if_source != IFSRC_UNKNOWN
295 || sym == sym->ns->proc_name)
296 {
297 gfc_error_now ("%s is not INTRINSIC procedure name "
298 "at %C", buffer);
299 sym = NULL;
300 }
301 else
302 n = sym->name;
303 }
304 if (strcmp (n, "max") == 0)
305 reduction = OMP_LIST_MAX;
306 else if (strcmp (n, "min") == 0)
307 reduction = OMP_LIST_MIN;
308 else if (strcmp (n, "iand") == 0)
309 reduction = OMP_LIST_IAND;
310 else if (strcmp (n, "ior") == 0)
311 reduction = OMP_LIST_IOR;
312 else if (strcmp (n, "ieor") == 0)
313 reduction = OMP_LIST_IEOR;
314 if (reduction != OMP_LIST_NUM
315 && sym != NULL
316 && ! sym->attr.intrinsic
317 && ! sym->attr.use_assoc
318 && ((sym->attr.flavor == FL_UNKNOWN
319 && gfc_add_flavor (&sym->attr, FL_PROCEDURE,
320 sym->name, NULL) == FAILURE)
321 || gfc_add_intrinsic (&sym->attr, NULL) == FAILURE))
322 {
323 gfc_free_omp_clauses (c);
324 return MATCH_ERROR;
325 }
326 }
327 if (reduction != OMP_LIST_NUM
328 && gfc_match_omp_variable_list (" :", &c->lists[reduction],
329 false)
330 == MATCH_YES)
331 continue;
332 else
333 gfc_current_locus = old_loc;
334 }
335 if ((mask & OMP_CLAUSE_DEFAULT)
336 && c->default_sharing == OMP_DEFAULT_UNKNOWN)
337 {
338 if (gfc_match ("default ( shared )") == MATCH_YES)
339 c->default_sharing = OMP_DEFAULT_SHARED;
340 else if (gfc_match ("default ( private )") == MATCH_YES)
341 c->default_sharing = OMP_DEFAULT_PRIVATE;
342 else if (gfc_match ("default ( none )") == MATCH_YES)
343 c->default_sharing = OMP_DEFAULT_NONE;
344 else if (gfc_match ("default ( firstprivate )") == MATCH_YES)
345 c->default_sharing = OMP_DEFAULT_FIRSTPRIVATE;
346 if (c->default_sharing != OMP_DEFAULT_UNKNOWN)
347 continue;
348 }
349 old_loc = gfc_current_locus;
350 if ((mask & OMP_CLAUSE_SCHEDULE)
351 && c->sched_kind == OMP_SCHED_NONE
352 && gfc_match ("schedule ( ") == MATCH_YES)
353 {
354 if (gfc_match ("static") == MATCH_YES)
355 c->sched_kind = OMP_SCHED_STATIC;
356 else if (gfc_match ("dynamic") == MATCH_YES)
357 c->sched_kind = OMP_SCHED_DYNAMIC;
358 else if (gfc_match ("guided") == MATCH_YES)
359 c->sched_kind = OMP_SCHED_GUIDED;
360 else if (gfc_match ("runtime") == MATCH_YES)
361 c->sched_kind = OMP_SCHED_RUNTIME;
362 else if (gfc_match ("auto") == MATCH_YES)
363 c->sched_kind = OMP_SCHED_AUTO;
364 if (c->sched_kind != OMP_SCHED_NONE)
365 {
366 match m = MATCH_NO;
367 if (c->sched_kind != OMP_SCHED_RUNTIME
368 && c->sched_kind != OMP_SCHED_AUTO)
369 m = gfc_match (" , %e )", &c->chunk_size);
370 if (m != MATCH_YES)
371 m = gfc_match_char (')');
372 if (m != MATCH_YES)
373 c->sched_kind = OMP_SCHED_NONE;
374 }
375 if (c->sched_kind != OMP_SCHED_NONE)
376 continue;
377 else
378 gfc_current_locus = old_loc;
379 }
380 if ((mask & OMP_CLAUSE_ORDERED) && !c->ordered
381 && gfc_match ("ordered") == MATCH_YES)
382 {
383 c->ordered = needs_space = true;
384 continue;
385 }
386 if ((mask & OMP_CLAUSE_UNTIED) && !c->untied
387 && gfc_match ("untied") == MATCH_YES)
388 {
389 c->untied = needs_space = true;
390 continue;
391 }
392 if ((mask & OMP_CLAUSE_MERGEABLE) && !c->mergeable
393 && gfc_match ("mergeable") == MATCH_YES)
394 {
395 c->mergeable = needs_space = true;
396 continue;
397 }
398 if ((mask & OMP_CLAUSE_COLLAPSE) && !c->collapse)
399 {
400 gfc_expr *cexpr = NULL;
401 match m = gfc_match ("collapse ( %e )", &cexpr);
402
403 if (m == MATCH_YES)
404 {
405 int collapse;
406 const char *p = gfc_extract_int (cexpr, &collapse);
407 if (p)
408 {
409 gfc_error_now (p);
410 collapse = 1;
411 }
412 else if (collapse <= 0)
413 {
414 gfc_error_now ("COLLAPSE clause argument not"
415 " constant positive integer at %C");
416 collapse = 1;
417 }
418 c->collapse = collapse;
419 gfc_free_expr (cexpr);
420 continue;
421 }
422 }
423
424 break;
425 }
426
427 if (gfc_match_omp_eos () != MATCH_YES)
428 {
429 gfc_free_omp_clauses (c);
430 return MATCH_ERROR;
431 }
432
433 *cp = c;
434 return MATCH_YES;
435 }
436
437 #define OMP_PARALLEL_CLAUSES \
438 (OMP_CLAUSE_PRIVATE | OMP_CLAUSE_FIRSTPRIVATE | OMP_CLAUSE_SHARED \
439 | OMP_CLAUSE_COPYIN | OMP_CLAUSE_REDUCTION | OMP_CLAUSE_IF \
440 | OMP_CLAUSE_NUM_THREADS | OMP_CLAUSE_DEFAULT)
441 #define OMP_DO_CLAUSES \
442 (OMP_CLAUSE_PRIVATE | OMP_CLAUSE_FIRSTPRIVATE \
443 | OMP_CLAUSE_LASTPRIVATE | OMP_CLAUSE_REDUCTION \
444 | OMP_CLAUSE_SCHEDULE | OMP_CLAUSE_ORDERED | OMP_CLAUSE_COLLAPSE)
445 #define OMP_SECTIONS_CLAUSES \
446 (OMP_CLAUSE_PRIVATE | OMP_CLAUSE_FIRSTPRIVATE \
447 | OMP_CLAUSE_LASTPRIVATE | OMP_CLAUSE_REDUCTION)
448 #define OMP_TASK_CLAUSES \
449 (OMP_CLAUSE_PRIVATE | OMP_CLAUSE_FIRSTPRIVATE | OMP_CLAUSE_SHARED \
450 | OMP_CLAUSE_IF | OMP_CLAUSE_DEFAULT | OMP_CLAUSE_UNTIED \
451 | OMP_CLAUSE_FINAL | OMP_CLAUSE_MERGEABLE)
452
453 match
gfc_match_omp_parallel(void)454 gfc_match_omp_parallel (void)
455 {
456 gfc_omp_clauses *c;
457 if (gfc_match_omp_clauses (&c, OMP_PARALLEL_CLAUSES) != MATCH_YES)
458 return MATCH_ERROR;
459 new_st.op = EXEC_OMP_PARALLEL;
460 new_st.ext.omp_clauses = c;
461 return MATCH_YES;
462 }
463
464
465 match
gfc_match_omp_task(void)466 gfc_match_omp_task (void)
467 {
468 gfc_omp_clauses *c;
469 if (gfc_match_omp_clauses (&c, OMP_TASK_CLAUSES) != MATCH_YES)
470 return MATCH_ERROR;
471 new_st.op = EXEC_OMP_TASK;
472 new_st.ext.omp_clauses = c;
473 return MATCH_YES;
474 }
475
476
477 match
gfc_match_omp_taskwait(void)478 gfc_match_omp_taskwait (void)
479 {
480 if (gfc_match_omp_eos () != MATCH_YES)
481 {
482 gfc_error ("Unexpected junk after TASKWAIT clause at %C");
483 return MATCH_ERROR;
484 }
485 new_st.op = EXEC_OMP_TASKWAIT;
486 new_st.ext.omp_clauses = NULL;
487 return MATCH_YES;
488 }
489
490
491 match
gfc_match_omp_taskyield(void)492 gfc_match_omp_taskyield (void)
493 {
494 if (gfc_match_omp_eos () != MATCH_YES)
495 {
496 gfc_error ("Unexpected junk after TASKYIELD clause at %C");
497 return MATCH_ERROR;
498 }
499 new_st.op = EXEC_OMP_TASKYIELD;
500 new_st.ext.omp_clauses = NULL;
501 return MATCH_YES;
502 }
503
504
505 match
gfc_match_omp_critical(void)506 gfc_match_omp_critical (void)
507 {
508 char n[GFC_MAX_SYMBOL_LEN+1];
509
510 if (gfc_match (" ( %n )", n) != MATCH_YES)
511 n[0] = '\0';
512 if (gfc_match_omp_eos () != MATCH_YES)
513 {
514 gfc_error ("Unexpected junk after $OMP CRITICAL statement at %C");
515 return MATCH_ERROR;
516 }
517 new_st.op = EXEC_OMP_CRITICAL;
518 new_st.ext.omp_name = n[0] ? xstrdup (n) : NULL;
519 return MATCH_YES;
520 }
521
522
523 match
gfc_match_omp_do(void)524 gfc_match_omp_do (void)
525 {
526 gfc_omp_clauses *c;
527 if (gfc_match_omp_clauses (&c, OMP_DO_CLAUSES) != MATCH_YES)
528 return MATCH_ERROR;
529 new_st.op = EXEC_OMP_DO;
530 new_st.ext.omp_clauses = c;
531 return MATCH_YES;
532 }
533
534
535 match
gfc_match_omp_flush(void)536 gfc_match_omp_flush (void)
537 {
538 gfc_namelist *list = NULL;
539 gfc_match_omp_variable_list (" (", &list, true);
540 if (gfc_match_omp_eos () != MATCH_YES)
541 {
542 gfc_error ("Unexpected junk after $OMP FLUSH statement at %C");
543 gfc_free_namelist (list);
544 return MATCH_ERROR;
545 }
546 new_st.op = EXEC_OMP_FLUSH;
547 new_st.ext.omp_namelist = list;
548 return MATCH_YES;
549 }
550
551
552 match
gfc_match_omp_threadprivate(void)553 gfc_match_omp_threadprivate (void)
554 {
555 locus old_loc;
556 char n[GFC_MAX_SYMBOL_LEN+1];
557 gfc_symbol *sym;
558 match m;
559 gfc_symtree *st;
560
561 old_loc = gfc_current_locus;
562
563 m = gfc_match (" (");
564 if (m != MATCH_YES)
565 return m;
566
567 for (;;)
568 {
569 m = gfc_match_symbol (&sym, 0);
570 switch (m)
571 {
572 case MATCH_YES:
573 if (sym->attr.in_common)
574 gfc_error_now ("Threadprivate variable at %C is an element of "
575 "a COMMON block");
576 else if (gfc_add_threadprivate (&sym->attr, sym->name,
577 &sym->declared_at) == FAILURE)
578 goto cleanup;
579 goto next_item;
580 case MATCH_NO:
581 break;
582 case MATCH_ERROR:
583 goto cleanup;
584 }
585
586 m = gfc_match (" / %n /", n);
587 if (m == MATCH_ERROR)
588 goto cleanup;
589 if (m == MATCH_NO || n[0] == '\0')
590 goto syntax;
591
592 st = gfc_find_symtree (gfc_current_ns->common_root, n);
593 if (st == NULL)
594 {
595 gfc_error ("COMMON block /%s/ not found at %C", n);
596 goto cleanup;
597 }
598 st->n.common->threadprivate = 1;
599 for (sym = st->n.common->head; sym; sym = sym->common_next)
600 if (gfc_add_threadprivate (&sym->attr, sym->name,
601 &sym->declared_at) == FAILURE)
602 goto cleanup;
603
604 next_item:
605 if (gfc_match_char (')') == MATCH_YES)
606 break;
607 if (gfc_match_char (',') != MATCH_YES)
608 goto syntax;
609 }
610
611 return MATCH_YES;
612
613 syntax:
614 gfc_error ("Syntax error in !$OMP THREADPRIVATE list at %C");
615
616 cleanup:
617 gfc_current_locus = old_loc;
618 return MATCH_ERROR;
619 }
620
621
622 match
gfc_match_omp_parallel_do(void)623 gfc_match_omp_parallel_do (void)
624 {
625 gfc_omp_clauses *c;
626 if (gfc_match_omp_clauses (&c, OMP_PARALLEL_CLAUSES | OMP_DO_CLAUSES)
627 != MATCH_YES)
628 return MATCH_ERROR;
629 new_st.op = EXEC_OMP_PARALLEL_DO;
630 new_st.ext.omp_clauses = c;
631 return MATCH_YES;
632 }
633
634
635 match
gfc_match_omp_parallel_sections(void)636 gfc_match_omp_parallel_sections (void)
637 {
638 gfc_omp_clauses *c;
639 if (gfc_match_omp_clauses (&c, OMP_PARALLEL_CLAUSES | OMP_SECTIONS_CLAUSES)
640 != MATCH_YES)
641 return MATCH_ERROR;
642 new_st.op = EXEC_OMP_PARALLEL_SECTIONS;
643 new_st.ext.omp_clauses = c;
644 return MATCH_YES;
645 }
646
647
648 match
gfc_match_omp_parallel_workshare(void)649 gfc_match_omp_parallel_workshare (void)
650 {
651 gfc_omp_clauses *c;
652 if (gfc_match_omp_clauses (&c, OMP_PARALLEL_CLAUSES) != MATCH_YES)
653 return MATCH_ERROR;
654 new_st.op = EXEC_OMP_PARALLEL_WORKSHARE;
655 new_st.ext.omp_clauses = c;
656 return MATCH_YES;
657 }
658
659
660 match
gfc_match_omp_sections(void)661 gfc_match_omp_sections (void)
662 {
663 gfc_omp_clauses *c;
664 if (gfc_match_omp_clauses (&c, OMP_SECTIONS_CLAUSES) != MATCH_YES)
665 return MATCH_ERROR;
666 new_st.op = EXEC_OMP_SECTIONS;
667 new_st.ext.omp_clauses = c;
668 return MATCH_YES;
669 }
670
671
672 match
gfc_match_omp_single(void)673 gfc_match_omp_single (void)
674 {
675 gfc_omp_clauses *c;
676 if (gfc_match_omp_clauses (&c, OMP_CLAUSE_PRIVATE | OMP_CLAUSE_FIRSTPRIVATE)
677 != MATCH_YES)
678 return MATCH_ERROR;
679 new_st.op = EXEC_OMP_SINGLE;
680 new_st.ext.omp_clauses = c;
681 return MATCH_YES;
682 }
683
684
685 match
gfc_match_omp_workshare(void)686 gfc_match_omp_workshare (void)
687 {
688 if (gfc_match_omp_eos () != MATCH_YES)
689 {
690 gfc_error ("Unexpected junk after $OMP WORKSHARE statement at %C");
691 return MATCH_ERROR;
692 }
693 new_st.op = EXEC_OMP_WORKSHARE;
694 new_st.ext.omp_clauses = gfc_get_omp_clauses ();
695 return MATCH_YES;
696 }
697
698
699 match
gfc_match_omp_master(void)700 gfc_match_omp_master (void)
701 {
702 if (gfc_match_omp_eos () != MATCH_YES)
703 {
704 gfc_error ("Unexpected junk after $OMP MASTER statement at %C");
705 return MATCH_ERROR;
706 }
707 new_st.op = EXEC_OMP_MASTER;
708 new_st.ext.omp_clauses = NULL;
709 return MATCH_YES;
710 }
711
712
713 match
gfc_match_omp_ordered(void)714 gfc_match_omp_ordered (void)
715 {
716 if (gfc_match_omp_eos () != MATCH_YES)
717 {
718 gfc_error ("Unexpected junk after $OMP ORDERED statement at %C");
719 return MATCH_ERROR;
720 }
721 new_st.op = EXEC_OMP_ORDERED;
722 new_st.ext.omp_clauses = NULL;
723 return MATCH_YES;
724 }
725
726
727 match
gfc_match_omp_atomic(void)728 gfc_match_omp_atomic (void)
729 {
730 gfc_omp_atomic_op op = GFC_OMP_ATOMIC_UPDATE;
731 if (gfc_match ("% update") == MATCH_YES)
732 op = GFC_OMP_ATOMIC_UPDATE;
733 else if (gfc_match ("% read") == MATCH_YES)
734 op = GFC_OMP_ATOMIC_READ;
735 else if (gfc_match ("% write") == MATCH_YES)
736 op = GFC_OMP_ATOMIC_WRITE;
737 else if (gfc_match ("% capture") == MATCH_YES)
738 op = GFC_OMP_ATOMIC_CAPTURE;
739 if (gfc_match_omp_eos () != MATCH_YES)
740 {
741 gfc_error ("Unexpected junk after $OMP ATOMIC statement at %C");
742 return MATCH_ERROR;
743 }
744 new_st.op = EXEC_OMP_ATOMIC;
745 new_st.ext.omp_atomic = op;
746 return MATCH_YES;
747 }
748
749
750 match
gfc_match_omp_barrier(void)751 gfc_match_omp_barrier (void)
752 {
753 if (gfc_match_omp_eos () != MATCH_YES)
754 {
755 gfc_error ("Unexpected junk after $OMP BARRIER statement at %C");
756 return MATCH_ERROR;
757 }
758 new_st.op = EXEC_OMP_BARRIER;
759 new_st.ext.omp_clauses = NULL;
760 return MATCH_YES;
761 }
762
763
764 match
gfc_match_omp_end_nowait(void)765 gfc_match_omp_end_nowait (void)
766 {
767 bool nowait = false;
768 if (gfc_match ("% nowait") == MATCH_YES)
769 nowait = true;
770 if (gfc_match_omp_eos () != MATCH_YES)
771 {
772 gfc_error ("Unexpected junk after NOWAIT clause at %C");
773 return MATCH_ERROR;
774 }
775 new_st.op = EXEC_OMP_END_NOWAIT;
776 new_st.ext.omp_bool = nowait;
777 return MATCH_YES;
778 }
779
780
781 match
gfc_match_omp_end_single(void)782 gfc_match_omp_end_single (void)
783 {
784 gfc_omp_clauses *c;
785 if (gfc_match ("% nowait") == MATCH_YES)
786 {
787 new_st.op = EXEC_OMP_END_NOWAIT;
788 new_st.ext.omp_bool = true;
789 return MATCH_YES;
790 }
791 if (gfc_match_omp_clauses (&c, OMP_CLAUSE_COPYPRIVATE) != MATCH_YES)
792 return MATCH_ERROR;
793 new_st.op = EXEC_OMP_END_SINGLE;
794 new_st.ext.omp_clauses = c;
795 return MATCH_YES;
796 }
797
798
799 /* OpenMP directive resolving routines. */
800
801 static void
resolve_omp_clauses(gfc_code * code)802 resolve_omp_clauses (gfc_code *code)
803 {
804 gfc_omp_clauses *omp_clauses = code->ext.omp_clauses;
805 gfc_namelist *n;
806 int list;
807 static const char *clause_names[]
808 = { "PRIVATE", "FIRSTPRIVATE", "LASTPRIVATE", "COPYPRIVATE", "SHARED",
809 "COPYIN", "REDUCTION" };
810
811 if (omp_clauses == NULL)
812 return;
813
814 if (omp_clauses->if_expr)
815 {
816 gfc_expr *expr = omp_clauses->if_expr;
817 if (gfc_resolve_expr (expr) == FAILURE
818 || expr->ts.type != BT_LOGICAL || expr->rank != 0)
819 gfc_error ("IF clause at %L requires a scalar LOGICAL expression",
820 &expr->where);
821 }
822 if (omp_clauses->final_expr)
823 {
824 gfc_expr *expr = omp_clauses->final_expr;
825 if (gfc_resolve_expr (expr) == FAILURE
826 || expr->ts.type != BT_LOGICAL || expr->rank != 0)
827 gfc_error ("FINAL clause at %L requires a scalar LOGICAL expression",
828 &expr->where);
829 }
830 if (omp_clauses->num_threads)
831 {
832 gfc_expr *expr = omp_clauses->num_threads;
833 if (gfc_resolve_expr (expr) == FAILURE
834 || expr->ts.type != BT_INTEGER || expr->rank != 0)
835 gfc_error ("NUM_THREADS clause at %L requires a scalar "
836 "INTEGER expression", &expr->where);
837 }
838 if (omp_clauses->chunk_size)
839 {
840 gfc_expr *expr = omp_clauses->chunk_size;
841 if (gfc_resolve_expr (expr) == FAILURE
842 || expr->ts.type != BT_INTEGER || expr->rank != 0)
843 gfc_error ("SCHEDULE clause's chunk_size at %L requires "
844 "a scalar INTEGER expression", &expr->where);
845 }
846
847 /* Check that no symbol appears on multiple clauses, except that
848 a symbol can appear on both firstprivate and lastprivate. */
849 for (list = 0; list < OMP_LIST_NUM; list++)
850 for (n = omp_clauses->lists[list]; n; n = n->next)
851 {
852 n->sym->mark = 0;
853 if (n->sym->attr.flavor == FL_VARIABLE)
854 continue;
855 if (n->sym->attr.flavor == FL_PROCEDURE
856 && n->sym->result == n->sym
857 && n->sym->attr.function)
858 {
859 if (gfc_current_ns->proc_name == n->sym
860 || (gfc_current_ns->parent
861 && gfc_current_ns->parent->proc_name == n->sym))
862 continue;
863 if (gfc_current_ns->proc_name->attr.entry_master)
864 {
865 gfc_entry_list *el = gfc_current_ns->entries;
866 for (; el; el = el->next)
867 if (el->sym == n->sym)
868 break;
869 if (el)
870 continue;
871 }
872 if (gfc_current_ns->parent
873 && gfc_current_ns->parent->proc_name->attr.entry_master)
874 {
875 gfc_entry_list *el = gfc_current_ns->parent->entries;
876 for (; el; el = el->next)
877 if (el->sym == n->sym)
878 break;
879 if (el)
880 continue;
881 }
882 if (n->sym->attr.proc_pointer)
883 continue;
884 }
885 gfc_error ("Object '%s' is not a variable at %L", n->sym->name,
886 &code->loc);
887 }
888
889 for (list = 0; list < OMP_LIST_NUM; list++)
890 if (list != OMP_LIST_FIRSTPRIVATE && list != OMP_LIST_LASTPRIVATE)
891 for (n = omp_clauses->lists[list]; n; n = n->next)
892 {
893 if (n->sym->mark)
894 gfc_error ("Symbol '%s' present on multiple clauses at %L",
895 n->sym->name, &code->loc);
896 else
897 n->sym->mark = 1;
898 }
899
900 gcc_assert (OMP_LIST_LASTPRIVATE == OMP_LIST_FIRSTPRIVATE + 1);
901 for (list = OMP_LIST_FIRSTPRIVATE; list <= OMP_LIST_LASTPRIVATE; list++)
902 for (n = omp_clauses->lists[list]; n; n = n->next)
903 if (n->sym->mark)
904 {
905 gfc_error ("Symbol '%s' present on multiple clauses at %L",
906 n->sym->name, &code->loc);
907 n->sym->mark = 0;
908 }
909
910 for (n = omp_clauses->lists[OMP_LIST_FIRSTPRIVATE]; n; n = n->next)
911 {
912 if (n->sym->mark)
913 gfc_error ("Symbol '%s' present on multiple clauses at %L",
914 n->sym->name, &code->loc);
915 else
916 n->sym->mark = 1;
917 }
918 for (n = omp_clauses->lists[OMP_LIST_LASTPRIVATE]; n; n = n->next)
919 n->sym->mark = 0;
920
921 for (n = omp_clauses->lists[OMP_LIST_LASTPRIVATE]; n; n = n->next)
922 {
923 if (n->sym->mark)
924 gfc_error ("Symbol '%s' present on multiple clauses at %L",
925 n->sym->name, &code->loc);
926 else
927 n->sym->mark = 1;
928 }
929 for (list = 0; list < OMP_LIST_NUM; list++)
930 if ((n = omp_clauses->lists[list]) != NULL)
931 {
932 const char *name;
933
934 if (list < OMP_LIST_REDUCTION_FIRST)
935 name = clause_names[list];
936 else if (list <= OMP_LIST_REDUCTION_LAST)
937 name = clause_names[OMP_LIST_REDUCTION_FIRST];
938 else
939 gcc_unreachable ();
940
941 switch (list)
942 {
943 case OMP_LIST_COPYIN:
944 for (; n != NULL; n = n->next)
945 {
946 if (!n->sym->attr.threadprivate)
947 gfc_error ("Non-THREADPRIVATE object '%s' in COPYIN clause"
948 " at %L", n->sym->name, &code->loc);
949 if (n->sym->ts.type == BT_DERIVED && n->sym->ts.u.derived->attr.alloc_comp)
950 gfc_error ("COPYIN clause object '%s' at %L has ALLOCATABLE components",
951 n->sym->name, &code->loc);
952 }
953 break;
954 case OMP_LIST_COPYPRIVATE:
955 for (; n != NULL; n = n->next)
956 {
957 if (n->sym->as && n->sym->as->type == AS_ASSUMED_SIZE)
958 gfc_error ("Assumed size array '%s' in COPYPRIVATE clause "
959 "at %L", n->sym->name, &code->loc);
960 if (n->sym->ts.type == BT_DERIVED && n->sym->ts.u.derived->attr.alloc_comp)
961 gfc_error ("COPYPRIVATE clause object '%s' at %L has ALLOCATABLE components",
962 n->sym->name, &code->loc);
963 }
964 break;
965 case OMP_LIST_SHARED:
966 for (; n != NULL; n = n->next)
967 {
968 if (n->sym->attr.threadprivate)
969 gfc_error ("THREADPRIVATE object '%s' in SHARED clause at "
970 "%L", n->sym->name, &code->loc);
971 if (n->sym->attr.cray_pointee)
972 gfc_error ("Cray pointee '%s' in SHARED clause at %L",
973 n->sym->name, &code->loc);
974 }
975 break;
976 default:
977 for (; n != NULL; n = n->next)
978 {
979 if (n->sym->attr.threadprivate)
980 gfc_error ("THREADPRIVATE object '%s' in %s clause at %L",
981 n->sym->name, name, &code->loc);
982 if (n->sym->attr.cray_pointee)
983 gfc_error ("Cray pointee '%s' in %s clause at %L",
984 n->sym->name, name, &code->loc);
985 if (list != OMP_LIST_PRIVATE)
986 {
987 if (n->sym->attr.pointer
988 && list >= OMP_LIST_REDUCTION_FIRST
989 && list <= OMP_LIST_REDUCTION_LAST)
990 gfc_error ("POINTER object '%s' in %s clause at %L",
991 n->sym->name, name, &code->loc);
992 /* Variables in REDUCTION-clauses must be of intrinsic type (flagged below). */
993 if ((list < OMP_LIST_REDUCTION_FIRST || list > OMP_LIST_REDUCTION_LAST)
994 && n->sym->ts.type == BT_DERIVED
995 && n->sym->ts.u.derived->attr.alloc_comp)
996 gfc_error ("%s clause object '%s' has ALLOCATABLE components at %L",
997 name, n->sym->name, &code->loc);
998 if (n->sym->attr.cray_pointer
999 && list >= OMP_LIST_REDUCTION_FIRST
1000 && list <= OMP_LIST_REDUCTION_LAST)
1001 gfc_error ("Cray pointer '%s' in %s clause at %L",
1002 n->sym->name, name, &code->loc);
1003 }
1004 if (n->sym->as && n->sym->as->type == AS_ASSUMED_SIZE)
1005 gfc_error ("Assumed size array '%s' in %s clause at %L",
1006 n->sym->name, name, &code->loc);
1007 if (n->sym->attr.in_namelist
1008 && (list < OMP_LIST_REDUCTION_FIRST
1009 || list > OMP_LIST_REDUCTION_LAST))
1010 gfc_error ("Variable '%s' in %s clause is used in "
1011 "NAMELIST statement at %L",
1012 n->sym->name, name, &code->loc);
1013 switch (list)
1014 {
1015 case OMP_LIST_PLUS:
1016 case OMP_LIST_MULT:
1017 case OMP_LIST_SUB:
1018 if (!gfc_numeric_ts (&n->sym->ts))
1019 gfc_error ("%c REDUCTION variable '%s' at %L must be of numeric type, got %s",
1020 list == OMP_LIST_PLUS ? '+'
1021 : list == OMP_LIST_MULT ? '*' : '-',
1022 n->sym->name, &code->loc,
1023 gfc_typename (&n->sym->ts));
1024 break;
1025 case OMP_LIST_AND:
1026 case OMP_LIST_OR:
1027 case OMP_LIST_EQV:
1028 case OMP_LIST_NEQV:
1029 if (n->sym->ts.type != BT_LOGICAL)
1030 gfc_error ("%s REDUCTION variable '%s' must be LOGICAL "
1031 "at %L",
1032 list == OMP_LIST_AND ? ".AND."
1033 : list == OMP_LIST_OR ? ".OR."
1034 : list == OMP_LIST_EQV ? ".EQV." : ".NEQV.",
1035 n->sym->name, &code->loc);
1036 break;
1037 case OMP_LIST_MAX:
1038 case OMP_LIST_MIN:
1039 if (n->sym->ts.type != BT_INTEGER
1040 && n->sym->ts.type != BT_REAL)
1041 gfc_error ("%s REDUCTION variable '%s' must be "
1042 "INTEGER or REAL at %L",
1043 list == OMP_LIST_MAX ? "MAX" : "MIN",
1044 n->sym->name, &code->loc);
1045 break;
1046 case OMP_LIST_IAND:
1047 case OMP_LIST_IOR:
1048 case OMP_LIST_IEOR:
1049 if (n->sym->ts.type != BT_INTEGER)
1050 gfc_error ("%s REDUCTION variable '%s' must be INTEGER "
1051 "at %L",
1052 list == OMP_LIST_IAND ? "IAND"
1053 : list == OMP_LIST_MULT ? "IOR" : "IEOR",
1054 n->sym->name, &code->loc);
1055 break;
1056 /* Workaround for PR middle-end/26316, nothing really needs
1057 to be done here for OMP_LIST_PRIVATE. */
1058 case OMP_LIST_PRIVATE:
1059 gcc_assert (code->op != EXEC_NOP);
1060 default:
1061 break;
1062 }
1063 }
1064 break;
1065 }
1066 }
1067 }
1068
1069
1070 /* Return true if SYM is ever referenced in EXPR except in the SE node. */
1071
1072 static bool
expr_references_sym(gfc_expr * e,gfc_symbol * s,gfc_expr * se)1073 expr_references_sym (gfc_expr *e, gfc_symbol *s, gfc_expr *se)
1074 {
1075 gfc_actual_arglist *arg;
1076 if (e == NULL || e == se)
1077 return false;
1078 switch (e->expr_type)
1079 {
1080 case EXPR_CONSTANT:
1081 case EXPR_NULL:
1082 case EXPR_VARIABLE:
1083 case EXPR_STRUCTURE:
1084 case EXPR_ARRAY:
1085 if (e->symtree != NULL
1086 && e->symtree->n.sym == s)
1087 return true;
1088 return false;
1089 case EXPR_SUBSTRING:
1090 if (e->ref != NULL
1091 && (expr_references_sym (e->ref->u.ss.start, s, se)
1092 || expr_references_sym (e->ref->u.ss.end, s, se)))
1093 return true;
1094 return false;
1095 case EXPR_OP:
1096 if (expr_references_sym (e->value.op.op2, s, se))
1097 return true;
1098 return expr_references_sym (e->value.op.op1, s, se);
1099 case EXPR_FUNCTION:
1100 for (arg = e->value.function.actual; arg; arg = arg->next)
1101 if (expr_references_sym (arg->expr, s, se))
1102 return true;
1103 return false;
1104 default:
1105 gcc_unreachable ();
1106 }
1107 }
1108
1109
1110 /* If EXPR is a conversion function that widens the type
1111 if WIDENING is true or narrows the type if WIDENING is false,
1112 return the inner expression, otherwise return NULL. */
1113
1114 static gfc_expr *
is_conversion(gfc_expr * expr,bool widening)1115 is_conversion (gfc_expr *expr, bool widening)
1116 {
1117 gfc_typespec *ts1, *ts2;
1118
1119 if (expr->expr_type != EXPR_FUNCTION
1120 || expr->value.function.isym == NULL
1121 || expr->value.function.esym != NULL
1122 || expr->value.function.isym->id != GFC_ISYM_CONVERSION)
1123 return NULL;
1124
1125 if (widening)
1126 {
1127 ts1 = &expr->ts;
1128 ts2 = &expr->value.function.actual->expr->ts;
1129 }
1130 else
1131 {
1132 ts1 = &expr->value.function.actual->expr->ts;
1133 ts2 = &expr->ts;
1134 }
1135
1136 if (ts1->type > ts2->type
1137 || (ts1->type == ts2->type && ts1->kind > ts2->kind))
1138 return expr->value.function.actual->expr;
1139
1140 return NULL;
1141 }
1142
1143
1144 static void
resolve_omp_atomic(gfc_code * code)1145 resolve_omp_atomic (gfc_code *code)
1146 {
1147 gfc_code *atomic_code = code;
1148 gfc_symbol *var;
1149 gfc_expr *expr2, *expr2_tmp;
1150
1151 code = code->block->next;
1152 gcc_assert (code->op == EXEC_ASSIGN);
1153 gcc_assert ((atomic_code->ext.omp_atomic != GFC_OMP_ATOMIC_CAPTURE
1154 && code->next == NULL)
1155 || (atomic_code->ext.omp_atomic == GFC_OMP_ATOMIC_CAPTURE
1156 && code->next != NULL
1157 && code->next->op == EXEC_ASSIGN
1158 && code->next->next == NULL));
1159
1160 if (code->expr1->expr_type != EXPR_VARIABLE
1161 || code->expr1->symtree == NULL
1162 || code->expr1->rank != 0
1163 || (code->expr1->ts.type != BT_INTEGER
1164 && code->expr1->ts.type != BT_REAL
1165 && code->expr1->ts.type != BT_COMPLEX
1166 && code->expr1->ts.type != BT_LOGICAL))
1167 {
1168 gfc_error ("!$OMP ATOMIC statement must set a scalar variable of "
1169 "intrinsic type at %L", &code->loc);
1170 return;
1171 }
1172
1173 var = code->expr1->symtree->n.sym;
1174 expr2 = is_conversion (code->expr2, false);
1175 if (expr2 == NULL)
1176 {
1177 if (atomic_code->ext.omp_atomic == GFC_OMP_ATOMIC_READ
1178 || atomic_code->ext.omp_atomic == GFC_OMP_ATOMIC_WRITE)
1179 expr2 = is_conversion (code->expr2, true);
1180 if (expr2 == NULL)
1181 expr2 = code->expr2;
1182 }
1183
1184 switch (atomic_code->ext.omp_atomic)
1185 {
1186 case GFC_OMP_ATOMIC_READ:
1187 if (expr2->expr_type != EXPR_VARIABLE
1188 || expr2->symtree == NULL
1189 || expr2->rank != 0
1190 || (expr2->ts.type != BT_INTEGER
1191 && expr2->ts.type != BT_REAL
1192 && expr2->ts.type != BT_COMPLEX
1193 && expr2->ts.type != BT_LOGICAL))
1194 gfc_error ("!$OMP ATOMIC READ statement must read from a scalar "
1195 "variable of intrinsic type at %L", &expr2->where);
1196 return;
1197 case GFC_OMP_ATOMIC_WRITE:
1198 if (expr2->rank != 0 || expr_references_sym (code->expr2, var, NULL))
1199 gfc_error ("expr in !$OMP ATOMIC WRITE assignment var = expr "
1200 "must be scalar and cannot reference var at %L",
1201 &expr2->where);
1202 return;
1203 case GFC_OMP_ATOMIC_CAPTURE:
1204 expr2_tmp = expr2;
1205 if (expr2 == code->expr2)
1206 {
1207 expr2_tmp = is_conversion (code->expr2, true);
1208 if (expr2_tmp == NULL)
1209 expr2_tmp = expr2;
1210 }
1211 if (expr2_tmp->expr_type == EXPR_VARIABLE)
1212 {
1213 if (expr2_tmp->symtree == NULL
1214 || expr2_tmp->rank != 0
1215 || (expr2_tmp->ts.type != BT_INTEGER
1216 && expr2_tmp->ts.type != BT_REAL
1217 && expr2_tmp->ts.type != BT_COMPLEX
1218 && expr2_tmp->ts.type != BT_LOGICAL)
1219 || expr2_tmp->symtree->n.sym == var)
1220 {
1221 gfc_error ("!$OMP ATOMIC CAPTURE capture statement must read from "
1222 "a scalar variable of intrinsic type at %L",
1223 &expr2_tmp->where);
1224 return;
1225 }
1226 var = expr2_tmp->symtree->n.sym;
1227 code = code->next;
1228 if (code->expr1->expr_type != EXPR_VARIABLE
1229 || code->expr1->symtree == NULL
1230 || code->expr1->rank != 0
1231 || (code->expr1->ts.type != BT_INTEGER
1232 && code->expr1->ts.type != BT_REAL
1233 && code->expr1->ts.type != BT_COMPLEX
1234 && code->expr1->ts.type != BT_LOGICAL))
1235 {
1236 gfc_error ("!$OMP ATOMIC CAPTURE update statement must set "
1237 "a scalar variable of intrinsic type at %L",
1238 &code->expr1->where);
1239 return;
1240 }
1241 if (code->expr1->symtree->n.sym != var)
1242 {
1243 gfc_error ("!$OMP ATOMIC CAPTURE capture statement reads from "
1244 "different variable than update statement writes "
1245 "into at %L", &code->expr1->where);
1246 return;
1247 }
1248 expr2 = is_conversion (code->expr2, false);
1249 if (expr2 == NULL)
1250 expr2 = code->expr2;
1251 }
1252 break;
1253 default:
1254 break;
1255 }
1256
1257 if (expr2->expr_type == EXPR_OP)
1258 {
1259 gfc_expr *v = NULL, *e, *c;
1260 gfc_intrinsic_op op = expr2->value.op.op;
1261 gfc_intrinsic_op alt_op = INTRINSIC_NONE;
1262
1263 switch (op)
1264 {
1265 case INTRINSIC_PLUS:
1266 alt_op = INTRINSIC_MINUS;
1267 break;
1268 case INTRINSIC_TIMES:
1269 alt_op = INTRINSIC_DIVIDE;
1270 break;
1271 case INTRINSIC_MINUS:
1272 alt_op = INTRINSIC_PLUS;
1273 break;
1274 case INTRINSIC_DIVIDE:
1275 alt_op = INTRINSIC_TIMES;
1276 break;
1277 case INTRINSIC_AND:
1278 case INTRINSIC_OR:
1279 break;
1280 case INTRINSIC_EQV:
1281 alt_op = INTRINSIC_NEQV;
1282 break;
1283 case INTRINSIC_NEQV:
1284 alt_op = INTRINSIC_EQV;
1285 break;
1286 default:
1287 gfc_error ("!$OMP ATOMIC assignment operator must be "
1288 "+, *, -, /, .AND., .OR., .EQV. or .NEQV. at %L",
1289 &expr2->where);
1290 return;
1291 }
1292
1293 /* Check for var = var op expr resp. var = expr op var where
1294 expr doesn't reference var and var op expr is mathematically
1295 equivalent to var op (expr) resp. expr op var equivalent to
1296 (expr) op var. We rely here on the fact that the matcher
1297 for x op1 y op2 z where op1 and op2 have equal precedence
1298 returns (x op1 y) op2 z. */
1299 e = expr2->value.op.op2;
1300 if (e->expr_type == EXPR_VARIABLE
1301 && e->symtree != NULL
1302 && e->symtree->n.sym == var)
1303 v = e;
1304 else if ((c = is_conversion (e, true)) != NULL
1305 && c->expr_type == EXPR_VARIABLE
1306 && c->symtree != NULL
1307 && c->symtree->n.sym == var)
1308 v = c;
1309 else
1310 {
1311 gfc_expr **p = NULL, **q;
1312 for (q = &expr2->value.op.op1; (e = *q) != NULL; )
1313 if (e->expr_type == EXPR_VARIABLE
1314 && e->symtree != NULL
1315 && e->symtree->n.sym == var)
1316 {
1317 v = e;
1318 break;
1319 }
1320 else if ((c = is_conversion (e, true)) != NULL)
1321 q = &e->value.function.actual->expr;
1322 else if (e->expr_type != EXPR_OP
1323 || (e->value.op.op != op
1324 && e->value.op.op != alt_op)
1325 || e->rank != 0)
1326 break;
1327 else
1328 {
1329 p = q;
1330 q = &e->value.op.op1;
1331 }
1332
1333 if (v == NULL)
1334 {
1335 gfc_error ("!$OMP ATOMIC assignment must be var = var op expr "
1336 "or var = expr op var at %L", &expr2->where);
1337 return;
1338 }
1339
1340 if (p != NULL)
1341 {
1342 e = *p;
1343 switch (e->value.op.op)
1344 {
1345 case INTRINSIC_MINUS:
1346 case INTRINSIC_DIVIDE:
1347 case INTRINSIC_EQV:
1348 case INTRINSIC_NEQV:
1349 gfc_error ("!$OMP ATOMIC var = var op expr not "
1350 "mathematically equivalent to var = var op "
1351 "(expr) at %L", &expr2->where);
1352 break;
1353 default:
1354 break;
1355 }
1356
1357 /* Canonicalize into var = var op (expr). */
1358 *p = e->value.op.op2;
1359 e->value.op.op2 = expr2;
1360 e->ts = expr2->ts;
1361 if (code->expr2 == expr2)
1362 code->expr2 = expr2 = e;
1363 else
1364 code->expr2->value.function.actual->expr = expr2 = e;
1365
1366 if (!gfc_compare_types (&expr2->value.op.op1->ts, &expr2->ts))
1367 {
1368 for (p = &expr2->value.op.op1; *p != v;
1369 p = &(*p)->value.function.actual->expr)
1370 ;
1371 *p = NULL;
1372 gfc_free_expr (expr2->value.op.op1);
1373 expr2->value.op.op1 = v;
1374 gfc_convert_type (v, &expr2->ts, 2);
1375 }
1376 }
1377 }
1378
1379 if (e->rank != 0 || expr_references_sym (code->expr2, var, v))
1380 {
1381 gfc_error ("expr in !$OMP ATOMIC assignment var = var op expr "
1382 "must be scalar and cannot reference var at %L",
1383 &expr2->where);
1384 return;
1385 }
1386 }
1387 else if (expr2->expr_type == EXPR_FUNCTION
1388 && expr2->value.function.isym != NULL
1389 && expr2->value.function.esym == NULL
1390 && expr2->value.function.actual != NULL
1391 && expr2->value.function.actual->next != NULL)
1392 {
1393 gfc_actual_arglist *arg, *var_arg;
1394
1395 switch (expr2->value.function.isym->id)
1396 {
1397 case GFC_ISYM_MIN:
1398 case GFC_ISYM_MAX:
1399 break;
1400 case GFC_ISYM_IAND:
1401 case GFC_ISYM_IOR:
1402 case GFC_ISYM_IEOR:
1403 if (expr2->value.function.actual->next->next != NULL)
1404 {
1405 gfc_error ("!$OMP ATOMIC assignment intrinsic IAND, IOR "
1406 "or IEOR must have two arguments at %L",
1407 &expr2->where);
1408 return;
1409 }
1410 break;
1411 default:
1412 gfc_error ("!$OMP ATOMIC assignment intrinsic must be "
1413 "MIN, MAX, IAND, IOR or IEOR at %L",
1414 &expr2->where);
1415 return;
1416 }
1417
1418 var_arg = NULL;
1419 for (arg = expr2->value.function.actual; arg; arg = arg->next)
1420 {
1421 if ((arg == expr2->value.function.actual
1422 || (var_arg == NULL && arg->next == NULL))
1423 && arg->expr->expr_type == EXPR_VARIABLE
1424 && arg->expr->symtree != NULL
1425 && arg->expr->symtree->n.sym == var)
1426 var_arg = arg;
1427 else if (expr_references_sym (arg->expr, var, NULL))
1428 gfc_error ("!$OMP ATOMIC intrinsic arguments except one must not "
1429 "reference '%s' at %L", var->name, &arg->expr->where);
1430 if (arg->expr->rank != 0)
1431 gfc_error ("!$OMP ATOMIC intrinsic arguments must be scalar "
1432 "at %L", &arg->expr->where);
1433 }
1434
1435 if (var_arg == NULL)
1436 {
1437 gfc_error ("First or last !$OMP ATOMIC intrinsic argument must "
1438 "be '%s' at %L", var->name, &expr2->where);
1439 return;
1440 }
1441
1442 if (var_arg != expr2->value.function.actual)
1443 {
1444 /* Canonicalize, so that var comes first. */
1445 gcc_assert (var_arg->next == NULL);
1446 for (arg = expr2->value.function.actual;
1447 arg->next != var_arg; arg = arg->next)
1448 ;
1449 var_arg->next = expr2->value.function.actual;
1450 expr2->value.function.actual = var_arg;
1451 arg->next = NULL;
1452 }
1453 }
1454 else
1455 gfc_error ("!$OMP ATOMIC assignment must have an operator or intrinsic "
1456 "on right hand side at %L", &expr2->where);
1457
1458 if (atomic_code->ext.omp_atomic == GFC_OMP_ATOMIC_CAPTURE && code->next)
1459 {
1460 code = code->next;
1461 if (code->expr1->expr_type != EXPR_VARIABLE
1462 || code->expr1->symtree == NULL
1463 || code->expr1->rank != 0
1464 || (code->expr1->ts.type != BT_INTEGER
1465 && code->expr1->ts.type != BT_REAL
1466 && code->expr1->ts.type != BT_COMPLEX
1467 && code->expr1->ts.type != BT_LOGICAL))
1468 {
1469 gfc_error ("!$OMP ATOMIC CAPTURE capture statement must set "
1470 "a scalar variable of intrinsic type at %L",
1471 &code->expr1->where);
1472 return;
1473 }
1474
1475 expr2 = is_conversion (code->expr2, false);
1476 if (expr2 == NULL)
1477 {
1478 expr2 = is_conversion (code->expr2, true);
1479 if (expr2 == NULL)
1480 expr2 = code->expr2;
1481 }
1482
1483 if (expr2->expr_type != EXPR_VARIABLE
1484 || expr2->symtree == NULL
1485 || expr2->rank != 0
1486 || (expr2->ts.type != BT_INTEGER
1487 && expr2->ts.type != BT_REAL
1488 && expr2->ts.type != BT_COMPLEX
1489 && expr2->ts.type != BT_LOGICAL))
1490 {
1491 gfc_error ("!$OMP ATOMIC CAPTURE capture statement must read "
1492 "from a scalar variable of intrinsic type at %L",
1493 &expr2->where);
1494 return;
1495 }
1496 if (expr2->symtree->n.sym != var)
1497 {
1498 gfc_error ("!$OMP ATOMIC CAPTURE capture statement reads from "
1499 "different variable than update statement writes "
1500 "into at %L", &expr2->where);
1501 return;
1502 }
1503 }
1504 }
1505
1506
1507 struct omp_context
1508 {
1509 gfc_code *code;
1510 struct pointer_set_t *sharing_clauses;
1511 struct pointer_set_t *private_iterators;
1512 struct omp_context *previous;
1513 } *omp_current_ctx;
1514 static gfc_code *omp_current_do_code;
1515 static int omp_current_do_collapse;
1516
1517 void
gfc_resolve_omp_do_blocks(gfc_code * code,gfc_namespace * ns)1518 gfc_resolve_omp_do_blocks (gfc_code *code, gfc_namespace *ns)
1519 {
1520 if (code->block->next && code->block->next->op == EXEC_DO)
1521 {
1522 int i;
1523 gfc_code *c;
1524
1525 omp_current_do_code = code->block->next;
1526 omp_current_do_collapse = code->ext.omp_clauses->collapse;
1527 for (i = 1, c = omp_current_do_code; i < omp_current_do_collapse; i++)
1528 {
1529 c = c->block;
1530 if (c->op != EXEC_DO || c->next == NULL)
1531 break;
1532 c = c->next;
1533 if (c->op != EXEC_DO)
1534 break;
1535 }
1536 if (i < omp_current_do_collapse || omp_current_do_collapse <= 0)
1537 omp_current_do_collapse = 1;
1538 }
1539 gfc_resolve_blocks (code->block, ns);
1540 omp_current_do_collapse = 0;
1541 omp_current_do_code = NULL;
1542 }
1543
1544
1545 void
gfc_resolve_omp_parallel_blocks(gfc_code * code,gfc_namespace * ns)1546 gfc_resolve_omp_parallel_blocks (gfc_code *code, gfc_namespace *ns)
1547 {
1548 struct omp_context ctx;
1549 gfc_omp_clauses *omp_clauses = code->ext.omp_clauses;
1550 gfc_namelist *n;
1551 int list;
1552
1553 ctx.code = code;
1554 ctx.sharing_clauses = pointer_set_create ();
1555 ctx.private_iterators = pointer_set_create ();
1556 ctx.previous = omp_current_ctx;
1557 omp_current_ctx = &ctx;
1558
1559 for (list = 0; list < OMP_LIST_NUM; list++)
1560 for (n = omp_clauses->lists[list]; n; n = n->next)
1561 pointer_set_insert (ctx.sharing_clauses, n->sym);
1562
1563 if (code->op == EXEC_OMP_PARALLEL_DO)
1564 gfc_resolve_omp_do_blocks (code, ns);
1565 else
1566 gfc_resolve_blocks (code->block, ns);
1567
1568 omp_current_ctx = ctx.previous;
1569 pointer_set_destroy (ctx.sharing_clauses);
1570 pointer_set_destroy (ctx.private_iterators);
1571 }
1572
1573
1574 /* Save and clear openmp.c private state. */
1575
1576 void
gfc_omp_save_and_clear_state(struct gfc_omp_saved_state * state)1577 gfc_omp_save_and_clear_state (struct gfc_omp_saved_state *state)
1578 {
1579 state->ptrs[0] = omp_current_ctx;
1580 state->ptrs[1] = omp_current_do_code;
1581 state->ints[0] = omp_current_do_collapse;
1582 omp_current_ctx = NULL;
1583 omp_current_do_code = NULL;
1584 omp_current_do_collapse = 0;
1585 }
1586
1587
1588 /* Restore openmp.c private state from the saved state. */
1589
1590 void
gfc_omp_restore_state(struct gfc_omp_saved_state * state)1591 gfc_omp_restore_state (struct gfc_omp_saved_state *state)
1592 {
1593 omp_current_ctx = (struct omp_context *) state->ptrs[0];
1594 omp_current_do_code = (gfc_code *) state->ptrs[1];
1595 omp_current_do_collapse = state->ints[0];
1596 }
1597
1598
1599 /* Note a DO iterator variable. This is special in !$omp parallel
1600 construct, where they are predetermined private. */
1601
1602 void
gfc_resolve_do_iterator(gfc_code * code,gfc_symbol * sym)1603 gfc_resolve_do_iterator (gfc_code *code, gfc_symbol *sym)
1604 {
1605 int i = omp_current_do_collapse;
1606 gfc_code *c = omp_current_do_code;
1607
1608 if (sym->attr.threadprivate)
1609 return;
1610
1611 /* !$omp do and !$omp parallel do iteration variable is predetermined
1612 private just in the !$omp do resp. !$omp parallel do construct,
1613 with no implications for the outer parallel constructs. */
1614
1615 while (i-- >= 1)
1616 {
1617 if (code == c)
1618 return;
1619
1620 c = c->block->next;
1621 }
1622
1623 if (omp_current_ctx == NULL)
1624 return;
1625
1626 if (pointer_set_contains (omp_current_ctx->sharing_clauses, sym))
1627 return;
1628
1629 if (! pointer_set_insert (omp_current_ctx->private_iterators, sym))
1630 {
1631 gfc_omp_clauses *omp_clauses = omp_current_ctx->code->ext.omp_clauses;
1632 gfc_namelist *p;
1633
1634 p = gfc_get_namelist ();
1635 p->sym = sym;
1636 p->next = omp_clauses->lists[OMP_LIST_PRIVATE];
1637 omp_clauses->lists[OMP_LIST_PRIVATE] = p;
1638 }
1639 }
1640
1641
1642 static void
resolve_omp_do(gfc_code * code)1643 resolve_omp_do (gfc_code *code)
1644 {
1645 gfc_code *do_code, *c;
1646 int list, i, collapse;
1647 gfc_namelist *n;
1648 gfc_symbol *dovar;
1649
1650 if (code->ext.omp_clauses)
1651 resolve_omp_clauses (code);
1652
1653 do_code = code->block->next;
1654 collapse = code->ext.omp_clauses->collapse;
1655 if (collapse <= 0)
1656 collapse = 1;
1657 for (i = 1; i <= collapse; i++)
1658 {
1659 if (do_code->op == EXEC_DO_WHILE)
1660 {
1661 gfc_error ("!$OMP DO cannot be a DO WHILE or DO without loop control "
1662 "at %L", &do_code->loc);
1663 break;
1664 }
1665 gcc_assert (do_code->op == EXEC_DO);
1666 if (do_code->ext.iterator->var->ts.type != BT_INTEGER)
1667 gfc_error ("!$OMP DO iteration variable must be of type integer at %L",
1668 &do_code->loc);
1669 dovar = do_code->ext.iterator->var->symtree->n.sym;
1670 if (dovar->attr.threadprivate)
1671 gfc_error ("!$OMP DO iteration variable must not be THREADPRIVATE "
1672 "at %L", &do_code->loc);
1673 if (code->ext.omp_clauses)
1674 for (list = 0; list < OMP_LIST_NUM; list++)
1675 if (list != OMP_LIST_PRIVATE && list != OMP_LIST_LASTPRIVATE)
1676 for (n = code->ext.omp_clauses->lists[list]; n; n = n->next)
1677 if (dovar == n->sym)
1678 {
1679 gfc_error ("!$OMP DO iteration variable present on clause "
1680 "other than PRIVATE or LASTPRIVATE at %L",
1681 &do_code->loc);
1682 break;
1683 }
1684 if (i > 1)
1685 {
1686 gfc_code *do_code2 = code->block->next;
1687 int j;
1688
1689 for (j = 1; j < i; j++)
1690 {
1691 gfc_symbol *ivar = do_code2->ext.iterator->var->symtree->n.sym;
1692 if (dovar == ivar
1693 || gfc_find_sym_in_expr (ivar, do_code->ext.iterator->start)
1694 || gfc_find_sym_in_expr (ivar, do_code->ext.iterator->end)
1695 || gfc_find_sym_in_expr (ivar, do_code->ext.iterator->step))
1696 {
1697 gfc_error ("!$OMP DO collapsed loops don't form rectangular iteration space at %L",
1698 &do_code->loc);
1699 break;
1700 }
1701 if (j < i)
1702 break;
1703 do_code2 = do_code2->block->next;
1704 }
1705 }
1706 if (i == collapse)
1707 break;
1708 for (c = do_code->next; c; c = c->next)
1709 if (c->op != EXEC_NOP && c->op != EXEC_CONTINUE)
1710 {
1711 gfc_error ("collapsed !$OMP DO loops not perfectly nested at %L",
1712 &c->loc);
1713 break;
1714 }
1715 if (c)
1716 break;
1717 do_code = do_code->block;
1718 if (do_code->op != EXEC_DO && do_code->op != EXEC_DO_WHILE)
1719 {
1720 gfc_error ("not enough DO loops for collapsed !$OMP DO at %L",
1721 &code->loc);
1722 break;
1723 }
1724 do_code = do_code->next;
1725 if (do_code == NULL
1726 || (do_code->op != EXEC_DO && do_code->op != EXEC_DO_WHILE))
1727 {
1728 gfc_error ("not enough DO loops for collapsed !$OMP DO at %L",
1729 &code->loc);
1730 break;
1731 }
1732 }
1733 }
1734
1735
1736 /* Resolve OpenMP directive clauses and check various requirements
1737 of each directive. */
1738
1739 void
gfc_resolve_omp_directive(gfc_code * code,gfc_namespace * ns ATTRIBUTE_UNUSED)1740 gfc_resolve_omp_directive (gfc_code *code, gfc_namespace *ns ATTRIBUTE_UNUSED)
1741 {
1742 if (code->op != EXEC_OMP_ATOMIC)
1743 gfc_maybe_initialize_eh ();
1744
1745 switch (code->op)
1746 {
1747 case EXEC_OMP_DO:
1748 case EXEC_OMP_PARALLEL_DO:
1749 resolve_omp_do (code);
1750 break;
1751 case EXEC_OMP_WORKSHARE:
1752 case EXEC_OMP_PARALLEL_WORKSHARE:
1753 case EXEC_OMP_PARALLEL:
1754 case EXEC_OMP_PARALLEL_SECTIONS:
1755 case EXEC_OMP_SECTIONS:
1756 case EXEC_OMP_SINGLE:
1757 case EXEC_OMP_TASK:
1758 if (code->ext.omp_clauses)
1759 resolve_omp_clauses (code);
1760 break;
1761 case EXEC_OMP_ATOMIC:
1762 resolve_omp_atomic (code);
1763 break;
1764 default:
1765 break;
1766 }
1767 }
1768