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