1 /* OpenMP directive matching and resolving.
2 Copyright (C) 2005, 2006, 2007, 2008, 2010
3 Free Software Foundation, Inc.
4 Contributed by Jakub Jelinek
6 This file is part of GCC.
8 GCC is free software; you can redistribute it and/or modify it under
9 the terms of the GNU General Public License as published by the Free
10 Software Foundation; either version 3, or (at your option) any later
13 GCC is distributed in the hope that it will be useful, but WITHOUT ANY
14 WARRANTY; without even the implied warranty of MERCHANTABILITY or
15 FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License
18 You should have received a copy of the GNU General Public License
19 along with GCC; see the file COPYING3. If not see
20 <http://www.gnu.org/licenses/>. */
28 #include "pointer-set.h"
30 /* Match an end of OpenMP directive. End of OpenMP directive is optional
31 whitespace, followed by '\n' or comment '!'. */
34 gfc_match_omp_eos (void)
39 old_loc
= gfc_current_locus
;
40 gfc_gobble_whitespace ();
42 c
= gfc_next_ascii_char ();
47 c
= gfc_next_ascii_char ();
55 gfc_current_locus
= old_loc
;
59 /* Free an omp_clauses structure. */
62 gfc_free_omp_clauses (gfc_omp_clauses
*c
)
68 gfc_free_expr (c
->if_expr
);
69 gfc_free_expr (c
->num_threads
);
70 gfc_free_expr (c
->chunk_size
);
71 for (i
= 0; i
< OMP_LIST_NUM
; i
++)
72 gfc_free_namelist (c
->lists
[i
]);
76 /* Match a variable/common block list and construct a namelist from it. */
79 gfc_match_omp_variable_list (const char *str
, gfc_namelist
**list
,
82 gfc_namelist
*head
, *tail
, *p
;
84 char n
[GFC_MAX_SYMBOL_LEN
+1];
91 old_loc
= gfc_current_locus
;
99 m
= gfc_match_symbol (&sym
, 1);
103 gfc_set_sym_referenced (sym
);
104 p
= gfc_get_namelist ();
123 m
= gfc_match (" / %n /", n
);
124 if (m
== MATCH_ERROR
)
129 st
= gfc_find_symtree (gfc_current_ns
->common_root
, n
);
132 gfc_error ("COMMON block /%s/ not found at %C", n
);
135 for (sym
= st
->n
.common
->head
; sym
; sym
= sym
->common_next
)
137 gfc_set_sym_referenced (sym
);
138 p
= gfc_get_namelist ();
150 if (gfc_match_char (')') == MATCH_YES
)
152 if (gfc_match_char (',') != MATCH_YES
)
157 list
= &(*list
)->next
;
163 gfc_error ("Syntax error in OpenMP variable list at %C");
166 gfc_free_namelist (head
);
167 gfc_current_locus
= old_loc
;
171 #define OMP_CLAUSE_PRIVATE (1 << 0)
172 #define OMP_CLAUSE_FIRSTPRIVATE (1 << 1)
173 #define OMP_CLAUSE_LASTPRIVATE (1 << 2)
174 #define OMP_CLAUSE_COPYPRIVATE (1 << 3)
175 #define OMP_CLAUSE_SHARED (1 << 4)
176 #define OMP_CLAUSE_COPYIN (1 << 5)
177 #define OMP_CLAUSE_REDUCTION (1 << 6)
178 #define OMP_CLAUSE_IF (1 << 7)
179 #define OMP_CLAUSE_NUM_THREADS (1 << 8)
180 #define OMP_CLAUSE_SCHEDULE (1 << 9)
181 #define OMP_CLAUSE_DEFAULT (1 << 10)
182 #define OMP_CLAUSE_ORDERED (1 << 11)
183 #define OMP_CLAUSE_COLLAPSE (1 << 12)
184 #define OMP_CLAUSE_UNTIED (1 << 13)
186 /* Match OpenMP directive clauses. MASK is a bitmask of
187 clauses that are allowed for a particular directive. */
190 gfc_match_omp_clauses (gfc_omp_clauses
**cp
, int mask
)
192 gfc_omp_clauses
*c
= gfc_get_omp_clauses ();
194 bool needs_space
= true, first
= true;
199 if ((first
|| gfc_match_char (',') != MATCH_YES
)
200 && (needs_space
&& gfc_match_space () != MATCH_YES
))
204 gfc_gobble_whitespace ();
205 if ((mask
& OMP_CLAUSE_IF
) && c
->if_expr
== NULL
206 && gfc_match ("if ( %e )", &c
->if_expr
) == MATCH_YES
)
208 if ((mask
& OMP_CLAUSE_NUM_THREADS
) && c
->num_threads
== NULL
209 && gfc_match ("num_threads ( %e )", &c
->num_threads
) == MATCH_YES
)
211 if ((mask
& OMP_CLAUSE_PRIVATE
)
212 && gfc_match_omp_variable_list ("private (",
213 &c
->lists
[OMP_LIST_PRIVATE
], true)
216 if ((mask
& OMP_CLAUSE_FIRSTPRIVATE
)
217 && gfc_match_omp_variable_list ("firstprivate (",
218 &c
->lists
[OMP_LIST_FIRSTPRIVATE
],
222 if ((mask
& OMP_CLAUSE_LASTPRIVATE
)
223 && gfc_match_omp_variable_list ("lastprivate (",
224 &c
->lists
[OMP_LIST_LASTPRIVATE
],
228 if ((mask
& OMP_CLAUSE_COPYPRIVATE
)
229 && gfc_match_omp_variable_list ("copyprivate (",
230 &c
->lists
[OMP_LIST_COPYPRIVATE
],
234 if ((mask
& OMP_CLAUSE_SHARED
)
235 && gfc_match_omp_variable_list ("shared (",
236 &c
->lists
[OMP_LIST_SHARED
], true)
239 if ((mask
& OMP_CLAUSE_COPYIN
)
240 && gfc_match_omp_variable_list ("copyin (",
241 &c
->lists
[OMP_LIST_COPYIN
], true)
244 old_loc
= gfc_current_locus
;
245 if ((mask
& OMP_CLAUSE_REDUCTION
)
246 && gfc_match ("reduction ( ") == MATCH_YES
)
248 int reduction
= OMP_LIST_NUM
;
249 char buffer
[GFC_MAX_SYMBOL_LEN
+ 1];
250 if (gfc_match_char ('+') == MATCH_YES
)
251 reduction
= OMP_LIST_PLUS
;
252 else if (gfc_match_char ('*') == MATCH_YES
)
253 reduction
= OMP_LIST_MULT
;
254 else if (gfc_match_char ('-') == MATCH_YES
)
255 reduction
= OMP_LIST_SUB
;
256 else if (gfc_match (".and.") == MATCH_YES
)
257 reduction
= OMP_LIST_AND
;
258 else if (gfc_match (".or.") == MATCH_YES
)
259 reduction
= OMP_LIST_OR
;
260 else if (gfc_match (".eqv.") == MATCH_YES
)
261 reduction
= OMP_LIST_EQV
;
262 else if (gfc_match (".neqv.") == MATCH_YES
)
263 reduction
= OMP_LIST_NEQV
;
264 else if (gfc_match_name (buffer
) == MATCH_YES
)
267 const char *n
= buffer
;
269 gfc_find_symbol (buffer
, NULL
, 1, &sym
);
272 if (sym
->attr
.intrinsic
)
274 else if ((sym
->attr
.flavor
!= FL_UNKNOWN
275 && sym
->attr
.flavor
!= FL_PROCEDURE
)
276 || sym
->attr
.external
281 || sym
->attr
.subroutine
284 || sym
->attr
.cray_pointer
285 || sym
->attr
.cray_pointee
286 || (sym
->attr
.proc
!= PROC_UNKNOWN
287 && sym
->attr
.proc
!= PROC_INTRINSIC
)
288 || sym
->attr
.if_source
!= IFSRC_UNKNOWN
289 || sym
== sym
->ns
->proc_name
)
291 gfc_error_now ("%s is not INTRINSIC procedure name "
298 if (strcmp (n
, "max") == 0)
299 reduction
= OMP_LIST_MAX
;
300 else if (strcmp (n
, "min") == 0)
301 reduction
= OMP_LIST_MIN
;
302 else if (strcmp (n
, "iand") == 0)
303 reduction
= OMP_LIST_IAND
;
304 else if (strcmp (n
, "ior") == 0)
305 reduction
= OMP_LIST_IOR
;
306 else if (strcmp (n
, "ieor") == 0)
307 reduction
= OMP_LIST_IEOR
;
308 if (reduction
!= OMP_LIST_NUM
310 && ! sym
->attr
.intrinsic
311 && ! sym
->attr
.use_assoc
312 && ((sym
->attr
.flavor
== FL_UNKNOWN
313 && gfc_add_flavor (&sym
->attr
, FL_PROCEDURE
,
314 sym
->name
, NULL
) == FAILURE
)
315 || gfc_add_intrinsic (&sym
->attr
, NULL
) == FAILURE
))
317 gfc_free_omp_clauses (c
);
321 if (reduction
!= OMP_LIST_NUM
322 && gfc_match_omp_variable_list (" :", &c
->lists
[reduction
],
327 gfc_current_locus
= old_loc
;
329 if ((mask
& OMP_CLAUSE_DEFAULT
)
330 && c
->default_sharing
== OMP_DEFAULT_UNKNOWN
)
332 if (gfc_match ("default ( shared )") == MATCH_YES
)
333 c
->default_sharing
= OMP_DEFAULT_SHARED
;
334 else if (gfc_match ("default ( private )") == MATCH_YES
)
335 c
->default_sharing
= OMP_DEFAULT_PRIVATE
;
336 else if (gfc_match ("default ( none )") == MATCH_YES
)
337 c
->default_sharing
= OMP_DEFAULT_NONE
;
338 else if (gfc_match ("default ( firstprivate )") == MATCH_YES
)
339 c
->default_sharing
= OMP_DEFAULT_FIRSTPRIVATE
;
340 if (c
->default_sharing
!= OMP_DEFAULT_UNKNOWN
)
343 old_loc
= gfc_current_locus
;
344 if ((mask
& OMP_CLAUSE_SCHEDULE
)
345 && c
->sched_kind
== OMP_SCHED_NONE
346 && gfc_match ("schedule ( ") == MATCH_YES
)
348 if (gfc_match ("static") == MATCH_YES
)
349 c
->sched_kind
= OMP_SCHED_STATIC
;
350 else if (gfc_match ("dynamic") == MATCH_YES
)
351 c
->sched_kind
= OMP_SCHED_DYNAMIC
;
352 else if (gfc_match ("guided") == MATCH_YES
)
353 c
->sched_kind
= OMP_SCHED_GUIDED
;
354 else if (gfc_match ("runtime") == MATCH_YES
)
355 c
->sched_kind
= OMP_SCHED_RUNTIME
;
356 else if (gfc_match ("auto") == MATCH_YES
)
357 c
->sched_kind
= OMP_SCHED_AUTO
;
358 if (c
->sched_kind
!= OMP_SCHED_NONE
)
361 if (c
->sched_kind
!= OMP_SCHED_RUNTIME
362 && c
->sched_kind
!= OMP_SCHED_AUTO
)
363 m
= gfc_match (" , %e )", &c
->chunk_size
);
365 m
= gfc_match_char (')');
367 c
->sched_kind
= OMP_SCHED_NONE
;
369 if (c
->sched_kind
!= OMP_SCHED_NONE
)
372 gfc_current_locus
= old_loc
;
374 if ((mask
& OMP_CLAUSE_ORDERED
) && !c
->ordered
375 && gfc_match ("ordered") == MATCH_YES
)
377 c
->ordered
= needs_space
= true;
380 if ((mask
& OMP_CLAUSE_UNTIED
) && !c
->untied
381 && gfc_match ("untied") == MATCH_YES
)
383 c
->untied
= needs_space
= true;
386 if ((mask
& OMP_CLAUSE_COLLAPSE
) && !c
->collapse
)
388 gfc_expr
*cexpr
= NULL
;
389 match m
= gfc_match ("collapse ( %e )", &cexpr
);
394 const char *p
= gfc_extract_int (cexpr
, &collapse
);
400 else if (collapse
<= 0)
402 gfc_error_now ("COLLAPSE clause argument not"
403 " constant positive integer at %C");
406 c
->collapse
= collapse
;
407 gfc_free_expr (cexpr
);
415 if (gfc_match_omp_eos () != MATCH_YES
)
417 gfc_free_omp_clauses (c
);
425 #define OMP_PARALLEL_CLAUSES \
426 (OMP_CLAUSE_PRIVATE | OMP_CLAUSE_FIRSTPRIVATE | OMP_CLAUSE_SHARED \
427 | OMP_CLAUSE_COPYIN | OMP_CLAUSE_REDUCTION | OMP_CLAUSE_IF \
428 | OMP_CLAUSE_NUM_THREADS | OMP_CLAUSE_DEFAULT)
429 #define OMP_DO_CLAUSES \
430 (OMP_CLAUSE_PRIVATE | OMP_CLAUSE_FIRSTPRIVATE \
431 | OMP_CLAUSE_LASTPRIVATE | OMP_CLAUSE_REDUCTION \
432 | OMP_CLAUSE_SCHEDULE | OMP_CLAUSE_ORDERED | OMP_CLAUSE_COLLAPSE)
433 #define OMP_SECTIONS_CLAUSES \
434 (OMP_CLAUSE_PRIVATE | OMP_CLAUSE_FIRSTPRIVATE \
435 | OMP_CLAUSE_LASTPRIVATE | OMP_CLAUSE_REDUCTION)
436 #define OMP_TASK_CLAUSES \
437 (OMP_CLAUSE_PRIVATE | OMP_CLAUSE_FIRSTPRIVATE | OMP_CLAUSE_SHARED \
438 | OMP_CLAUSE_IF | OMP_CLAUSE_DEFAULT | OMP_CLAUSE_UNTIED)
441 gfc_match_omp_parallel (void)
444 if (gfc_match_omp_clauses (&c
, OMP_PARALLEL_CLAUSES
) != MATCH_YES
)
446 new_st
.op
= EXEC_OMP_PARALLEL
;
447 new_st
.ext
.omp_clauses
= c
;
453 gfc_match_omp_task (void)
456 if (gfc_match_omp_clauses (&c
, OMP_TASK_CLAUSES
) != MATCH_YES
)
458 new_st
.op
= EXEC_OMP_TASK
;
459 new_st
.ext
.omp_clauses
= c
;
465 gfc_match_omp_taskwait (void)
467 if (gfc_match_omp_eos () != MATCH_YES
)
469 gfc_error ("Unexpected junk after TASKWAIT clause at %C");
472 new_st
.op
= EXEC_OMP_TASKWAIT
;
473 new_st
.ext
.omp_clauses
= NULL
;
479 gfc_match_omp_critical (void)
481 char n
[GFC_MAX_SYMBOL_LEN
+1];
483 if (gfc_match (" ( %n )", n
) != MATCH_YES
)
485 if (gfc_match_omp_eos () != MATCH_YES
)
487 gfc_error ("Unexpected junk after $OMP CRITICAL statement at %C");
490 new_st
.op
= EXEC_OMP_CRITICAL
;
491 new_st
.ext
.omp_name
= n
[0] ? xstrdup (n
) : NULL
;
497 gfc_match_omp_do (void)
500 if (gfc_match_omp_clauses (&c
, OMP_DO_CLAUSES
) != MATCH_YES
)
502 new_st
.op
= EXEC_OMP_DO
;
503 new_st
.ext
.omp_clauses
= c
;
509 gfc_match_omp_flush (void)
511 gfc_namelist
*list
= NULL
;
512 gfc_match_omp_variable_list (" (", &list
, true);
513 if (gfc_match_omp_eos () != MATCH_YES
)
515 gfc_error ("Unexpected junk after $OMP FLUSH statement at %C");
516 gfc_free_namelist (list
);
519 new_st
.op
= EXEC_OMP_FLUSH
;
520 new_st
.ext
.omp_namelist
= list
;
526 gfc_match_omp_threadprivate (void)
529 char n
[GFC_MAX_SYMBOL_LEN
+1];
534 old_loc
= gfc_current_locus
;
536 m
= gfc_match (" (");
542 m
= gfc_match_symbol (&sym
, 0);
546 if (sym
->attr
.in_common
)
547 gfc_error_now ("Threadprivate variable at %C is an element of "
549 else if (gfc_add_threadprivate (&sym
->attr
, sym
->name
,
550 &sym
->declared_at
) == FAILURE
)
559 m
= gfc_match (" / %n /", n
);
560 if (m
== MATCH_ERROR
)
562 if (m
== MATCH_NO
|| n
[0] == '\0')
565 st
= gfc_find_symtree (gfc_current_ns
->common_root
, n
);
568 gfc_error ("COMMON block /%s/ not found at %C", n
);
571 st
->n
.common
->threadprivate
= 1;
572 for (sym
= st
->n
.common
->head
; sym
; sym
= sym
->common_next
)
573 if (gfc_add_threadprivate (&sym
->attr
, sym
->name
,
574 &sym
->declared_at
) == FAILURE
)
578 if (gfc_match_char (')') == MATCH_YES
)
580 if (gfc_match_char (',') != MATCH_YES
)
587 gfc_error ("Syntax error in !$OMP THREADPRIVATE list at %C");
590 gfc_current_locus
= old_loc
;
596 gfc_match_omp_parallel_do (void)
599 if (gfc_match_omp_clauses (&c
, OMP_PARALLEL_CLAUSES
| OMP_DO_CLAUSES
)
602 new_st
.op
= EXEC_OMP_PARALLEL_DO
;
603 new_st
.ext
.omp_clauses
= c
;
609 gfc_match_omp_parallel_sections (void)
612 if (gfc_match_omp_clauses (&c
, OMP_PARALLEL_CLAUSES
| OMP_SECTIONS_CLAUSES
)
615 new_st
.op
= EXEC_OMP_PARALLEL_SECTIONS
;
616 new_st
.ext
.omp_clauses
= c
;
622 gfc_match_omp_parallel_workshare (void)
625 if (gfc_match_omp_clauses (&c
, OMP_PARALLEL_CLAUSES
) != MATCH_YES
)
627 new_st
.op
= EXEC_OMP_PARALLEL_WORKSHARE
;
628 new_st
.ext
.omp_clauses
= c
;
634 gfc_match_omp_sections (void)
637 if (gfc_match_omp_clauses (&c
, OMP_SECTIONS_CLAUSES
) != MATCH_YES
)
639 new_st
.op
= EXEC_OMP_SECTIONS
;
640 new_st
.ext
.omp_clauses
= c
;
646 gfc_match_omp_single (void)
649 if (gfc_match_omp_clauses (&c
, OMP_CLAUSE_PRIVATE
| OMP_CLAUSE_FIRSTPRIVATE
)
652 new_st
.op
= EXEC_OMP_SINGLE
;
653 new_st
.ext
.omp_clauses
= c
;
659 gfc_match_omp_workshare (void)
661 if (gfc_match_omp_eos () != MATCH_YES
)
663 gfc_error ("Unexpected junk after $OMP WORKSHARE statement at %C");
666 new_st
.op
= EXEC_OMP_WORKSHARE
;
667 new_st
.ext
.omp_clauses
= gfc_get_omp_clauses ();
673 gfc_match_omp_master (void)
675 if (gfc_match_omp_eos () != MATCH_YES
)
677 gfc_error ("Unexpected junk after $OMP MASTER statement at %C");
680 new_st
.op
= EXEC_OMP_MASTER
;
681 new_st
.ext
.omp_clauses
= NULL
;
687 gfc_match_omp_ordered (void)
689 if (gfc_match_omp_eos () != MATCH_YES
)
691 gfc_error ("Unexpected junk after $OMP ORDERED statement at %C");
694 new_st
.op
= EXEC_OMP_ORDERED
;
695 new_st
.ext
.omp_clauses
= NULL
;
701 gfc_match_omp_atomic (void)
703 if (gfc_match_omp_eos () != MATCH_YES
)
705 gfc_error ("Unexpected junk after $OMP ATOMIC statement at %C");
708 new_st
.op
= EXEC_OMP_ATOMIC
;
709 new_st
.ext
.omp_clauses
= NULL
;
715 gfc_match_omp_barrier (void)
717 if (gfc_match_omp_eos () != MATCH_YES
)
719 gfc_error ("Unexpected junk after $OMP BARRIER statement at %C");
722 new_st
.op
= EXEC_OMP_BARRIER
;
723 new_st
.ext
.omp_clauses
= NULL
;
729 gfc_match_omp_end_nowait (void)
732 if (gfc_match ("% nowait") == MATCH_YES
)
734 if (gfc_match_omp_eos () != MATCH_YES
)
736 gfc_error ("Unexpected junk after NOWAIT clause at %C");
739 new_st
.op
= EXEC_OMP_END_NOWAIT
;
740 new_st
.ext
.omp_bool
= nowait
;
746 gfc_match_omp_end_single (void)
749 if (gfc_match ("% nowait") == MATCH_YES
)
751 new_st
.op
= EXEC_OMP_END_NOWAIT
;
752 new_st
.ext
.omp_bool
= true;
755 if (gfc_match_omp_clauses (&c
, OMP_CLAUSE_COPYPRIVATE
) != MATCH_YES
)
757 new_st
.op
= EXEC_OMP_END_SINGLE
;
758 new_st
.ext
.omp_clauses
= c
;
763 /* OpenMP directive resolving routines. */
766 resolve_omp_clauses (gfc_code
*code
)
768 gfc_omp_clauses
*omp_clauses
= code
->ext
.omp_clauses
;
771 static const char *clause_names
[]
772 = { "PRIVATE", "FIRSTPRIVATE", "LASTPRIVATE", "COPYPRIVATE", "SHARED",
773 "COPYIN", "REDUCTION" };
775 if (omp_clauses
== NULL
)
778 if (omp_clauses
->if_expr
)
780 gfc_expr
*expr
= omp_clauses
->if_expr
;
781 if (gfc_resolve_expr (expr
) == FAILURE
782 || expr
->ts
.type
!= BT_LOGICAL
|| expr
->rank
!= 0)
783 gfc_error ("IF clause at %L requires a scalar LOGICAL expression",
786 if (omp_clauses
->num_threads
)
788 gfc_expr
*expr
= omp_clauses
->num_threads
;
789 if (gfc_resolve_expr (expr
) == FAILURE
790 || expr
->ts
.type
!= BT_INTEGER
|| expr
->rank
!= 0)
791 gfc_error ("NUM_THREADS clause at %L requires a scalar "
792 "INTEGER expression", &expr
->where
);
794 if (omp_clauses
->chunk_size
)
796 gfc_expr
*expr
= omp_clauses
->chunk_size
;
797 if (gfc_resolve_expr (expr
) == FAILURE
798 || expr
->ts
.type
!= BT_INTEGER
|| expr
->rank
!= 0)
799 gfc_error ("SCHEDULE clause's chunk_size at %L requires "
800 "a scalar INTEGER expression", &expr
->where
);
803 /* Check that no symbol appears on multiple clauses, except that
804 a symbol can appear on both firstprivate and lastprivate. */
805 for (list
= 0; list
< OMP_LIST_NUM
; list
++)
806 for (n
= omp_clauses
->lists
[list
]; n
; n
= n
->next
)
809 if (n
->sym
->attr
.flavor
== FL_VARIABLE
)
811 if (n
->sym
->attr
.flavor
== FL_PROCEDURE
812 && n
->sym
->result
== n
->sym
813 && n
->sym
->attr
.function
)
815 if (gfc_current_ns
->proc_name
== n
->sym
816 || (gfc_current_ns
->parent
817 && gfc_current_ns
->parent
->proc_name
== n
->sym
))
819 if (gfc_current_ns
->proc_name
->attr
.entry_master
)
821 gfc_entry_list
*el
= gfc_current_ns
->entries
;
822 for (; el
; el
= el
->next
)
823 if (el
->sym
== n
->sym
)
828 if (gfc_current_ns
->parent
829 && gfc_current_ns
->parent
->proc_name
->attr
.entry_master
)
831 gfc_entry_list
*el
= gfc_current_ns
->parent
->entries
;
832 for (; el
; el
= el
->next
)
833 if (el
->sym
== n
->sym
)
838 if (n
->sym
->attr
.proc_pointer
)
841 gfc_error ("Object '%s' is not a variable at %L", n
->sym
->name
,
845 for (list
= 0; list
< OMP_LIST_NUM
; list
++)
846 if (list
!= OMP_LIST_FIRSTPRIVATE
&& list
!= OMP_LIST_LASTPRIVATE
)
847 for (n
= omp_clauses
->lists
[list
]; n
; n
= n
->next
)
849 gfc_error ("Symbol '%s' present on multiple clauses at %L",
850 n
->sym
->name
, &code
->loc
);
854 gcc_assert (OMP_LIST_LASTPRIVATE
== OMP_LIST_FIRSTPRIVATE
+ 1);
855 for (list
= OMP_LIST_FIRSTPRIVATE
; list
<= OMP_LIST_LASTPRIVATE
; list
++)
856 for (n
= omp_clauses
->lists
[list
]; n
; n
= n
->next
)
859 gfc_error ("Symbol '%s' present on multiple clauses at %L",
860 n
->sym
->name
, &code
->loc
);
864 for (n
= omp_clauses
->lists
[OMP_LIST_FIRSTPRIVATE
]; n
; n
= n
->next
)
866 gfc_error ("Symbol '%s' present on multiple clauses at %L",
867 n
->sym
->name
, &code
->loc
);
871 for (n
= omp_clauses
->lists
[OMP_LIST_LASTPRIVATE
]; n
; n
= n
->next
)
874 for (n
= omp_clauses
->lists
[OMP_LIST_LASTPRIVATE
]; n
; n
= n
->next
)
876 gfc_error ("Symbol '%s' present on multiple clauses at %L",
877 n
->sym
->name
, &code
->loc
);
881 for (list
= 0; list
< OMP_LIST_NUM
; list
++)
882 if ((n
= omp_clauses
->lists
[list
]) != NULL
)
886 if (list
< OMP_LIST_REDUCTION_FIRST
)
887 name
= clause_names
[list
];
888 else if (list
<= OMP_LIST_REDUCTION_LAST
)
889 name
= clause_names
[OMP_LIST_REDUCTION_FIRST
];
895 case OMP_LIST_COPYIN
:
896 for (; n
!= NULL
; n
= n
->next
)
898 if (!n
->sym
->attr
.threadprivate
)
899 gfc_error ("Non-THREADPRIVATE object '%s' in COPYIN clause"
900 " at %L", n
->sym
->name
, &code
->loc
);
901 if (n
->sym
->ts
.type
== BT_DERIVED
&& n
->sym
->ts
.u
.derived
->attr
.alloc_comp
)
902 gfc_error ("COPYIN clause object '%s' at %L has ALLOCATABLE components",
903 n
->sym
->name
, &code
->loc
);
906 case OMP_LIST_COPYPRIVATE
:
907 for (; n
!= NULL
; n
= n
->next
)
909 if (n
->sym
->as
&& n
->sym
->as
->type
== AS_ASSUMED_SIZE
)
910 gfc_error ("Assumed size array '%s' in COPYPRIVATE clause "
911 "at %L", n
->sym
->name
, &code
->loc
);
912 if (n
->sym
->ts
.type
== BT_DERIVED
&& n
->sym
->ts
.u
.derived
->attr
.alloc_comp
)
913 gfc_error ("COPYPRIVATE clause object '%s' at %L has ALLOCATABLE components",
914 n
->sym
->name
, &code
->loc
);
917 case OMP_LIST_SHARED
:
918 for (; n
!= NULL
; n
= n
->next
)
920 if (n
->sym
->attr
.threadprivate
)
921 gfc_error ("THREADPRIVATE object '%s' in SHARED clause at "
922 "%L", n
->sym
->name
, &code
->loc
);
923 if (n
->sym
->attr
.cray_pointee
)
924 gfc_error ("Cray pointee '%s' in SHARED clause at %L",
925 n
->sym
->name
, &code
->loc
);
929 for (; n
!= NULL
; n
= n
->next
)
931 if (n
->sym
->attr
.threadprivate
)
932 gfc_error ("THREADPRIVATE object '%s' in %s clause at %L",
933 n
->sym
->name
, name
, &code
->loc
);
934 if (n
->sym
->attr
.cray_pointee
)
935 gfc_error ("Cray pointee '%s' in %s clause at %L",
936 n
->sym
->name
, name
, &code
->loc
);
937 if (list
!= OMP_LIST_PRIVATE
)
939 if (n
->sym
->attr
.pointer
)
940 gfc_error ("POINTER object '%s' in %s clause at %L",
941 n
->sym
->name
, name
, &code
->loc
);
942 /* Variables in REDUCTION-clauses must be of intrinsic type (flagged below). */
943 if ((list
< OMP_LIST_REDUCTION_FIRST
|| list
> OMP_LIST_REDUCTION_LAST
) &&
944 n
->sym
->ts
.type
== BT_DERIVED
&& n
->sym
->ts
.u
.derived
->attr
.alloc_comp
)
945 gfc_error ("%s clause object '%s' has ALLOCATABLE components at %L",
946 name
, n
->sym
->name
, &code
->loc
);
947 if (n
->sym
->attr
.cray_pointer
)
948 gfc_error ("Cray pointer '%s' in %s clause at %L",
949 n
->sym
->name
, name
, &code
->loc
);
951 if (n
->sym
->as
&& n
->sym
->as
->type
== AS_ASSUMED_SIZE
)
952 gfc_error ("Assumed size array '%s' in %s clause at %L",
953 n
->sym
->name
, name
, &code
->loc
);
954 if (n
->sym
->attr
.in_namelist
955 && (list
< OMP_LIST_REDUCTION_FIRST
956 || list
> OMP_LIST_REDUCTION_LAST
))
957 gfc_error ("Variable '%s' in %s clause is used in "
958 "NAMELIST statement at %L",
959 n
->sym
->name
, name
, &code
->loc
);
965 if (!gfc_numeric_ts (&n
->sym
->ts
))
966 gfc_error ("%c REDUCTION variable '%s' at %L must be of numeric type, got %s",
967 list
== OMP_LIST_PLUS
? '+'
968 : list
== OMP_LIST_MULT
? '*' : '-',
969 n
->sym
->name
, &code
->loc
,
970 gfc_typename (&n
->sym
->ts
));
976 if (n
->sym
->ts
.type
!= BT_LOGICAL
)
977 gfc_error ("%s REDUCTION variable '%s' must be LOGICAL "
979 list
== OMP_LIST_AND
? ".AND."
980 : list
== OMP_LIST_OR
? ".OR."
981 : list
== OMP_LIST_EQV
? ".EQV." : ".NEQV.",
982 n
->sym
->name
, &code
->loc
);
986 if (n
->sym
->ts
.type
!= BT_INTEGER
987 && n
->sym
->ts
.type
!= BT_REAL
)
988 gfc_error ("%s REDUCTION variable '%s' must be "
989 "INTEGER or REAL at %L",
990 list
== OMP_LIST_MAX
? "MAX" : "MIN",
991 n
->sym
->name
, &code
->loc
);
996 if (n
->sym
->ts
.type
!= BT_INTEGER
)
997 gfc_error ("%s REDUCTION variable '%s' must be INTEGER "
999 list
== OMP_LIST_IAND
? "IAND"
1000 : list
== OMP_LIST_MULT
? "IOR" : "IEOR",
1001 n
->sym
->name
, &code
->loc
);
1003 /* Workaround for PR middle-end/26316, nothing really needs
1004 to be done here for OMP_LIST_PRIVATE. */
1005 case OMP_LIST_PRIVATE
:
1006 gcc_assert (code
->op
!= EXEC_NOP
);
1017 /* Return true if SYM is ever referenced in EXPR except in the SE node. */
1020 expr_references_sym (gfc_expr
*e
, gfc_symbol
*s
, gfc_expr
*se
)
1022 gfc_actual_arglist
*arg
;
1023 if (e
== NULL
|| e
== se
)
1025 switch (e
->expr_type
)
1030 case EXPR_STRUCTURE
:
1032 if (e
->symtree
!= NULL
1033 && e
->symtree
->n
.sym
== s
)
1036 case EXPR_SUBSTRING
:
1038 && (expr_references_sym (e
->ref
->u
.ss
.start
, s
, se
)
1039 || expr_references_sym (e
->ref
->u
.ss
.end
, s
, se
)))
1043 if (expr_references_sym (e
->value
.op
.op2
, s
, se
))
1045 return expr_references_sym (e
->value
.op
.op1
, s
, se
);
1047 for (arg
= e
->value
.function
.actual
; arg
; arg
= arg
->next
)
1048 if (expr_references_sym (arg
->expr
, s
, se
))
1057 /* If EXPR is a conversion function that widens the type
1058 if WIDENING is true or narrows the type if WIDENING is false,
1059 return the inner expression, otherwise return NULL. */
1062 is_conversion (gfc_expr
*expr
, bool widening
)
1064 gfc_typespec
*ts1
, *ts2
;
1066 if (expr
->expr_type
!= EXPR_FUNCTION
1067 || expr
->value
.function
.isym
== NULL
1068 || expr
->value
.function
.esym
!= NULL
1069 || expr
->value
.function
.isym
->id
!= GFC_ISYM_CONVERSION
)
1075 ts2
= &expr
->value
.function
.actual
->expr
->ts
;
1079 ts1
= &expr
->value
.function
.actual
->expr
->ts
;
1083 if (ts1
->type
> ts2
->type
1084 || (ts1
->type
== ts2
->type
&& ts1
->kind
> ts2
->kind
))
1085 return expr
->value
.function
.actual
->expr
;
1092 resolve_omp_atomic (gfc_code
*code
)
1097 code
= code
->block
->next
;
1098 gcc_assert (code
->op
== EXEC_ASSIGN
);
1099 gcc_assert (code
->next
== NULL
);
1101 if (code
->expr1
->expr_type
!= EXPR_VARIABLE
1102 || code
->expr1
->symtree
== NULL
1103 || code
->expr1
->rank
!= 0
1104 || (code
->expr1
->ts
.type
!= BT_INTEGER
1105 && code
->expr1
->ts
.type
!= BT_REAL
1106 && code
->expr1
->ts
.type
!= BT_COMPLEX
1107 && code
->expr1
->ts
.type
!= BT_LOGICAL
))
1109 gfc_error ("!$OMP ATOMIC statement must set a scalar variable of "
1110 "intrinsic type at %L", &code
->loc
);
1114 var
= code
->expr1
->symtree
->n
.sym
;
1115 expr2
= is_conversion (code
->expr2
, false);
1117 expr2
= code
->expr2
;
1119 if (expr2
->expr_type
== EXPR_OP
)
1121 gfc_expr
*v
= NULL
, *e
, *c
;
1122 gfc_intrinsic_op op
= expr2
->value
.op
.op
;
1123 gfc_intrinsic_op alt_op
= INTRINSIC_NONE
;
1127 case INTRINSIC_PLUS
:
1128 alt_op
= INTRINSIC_MINUS
;
1130 case INTRINSIC_TIMES
:
1131 alt_op
= INTRINSIC_DIVIDE
;
1133 case INTRINSIC_MINUS
:
1134 alt_op
= INTRINSIC_PLUS
;
1136 case INTRINSIC_DIVIDE
:
1137 alt_op
= INTRINSIC_TIMES
;
1143 alt_op
= INTRINSIC_NEQV
;
1145 case INTRINSIC_NEQV
:
1146 alt_op
= INTRINSIC_EQV
;
1149 gfc_error ("!$OMP ATOMIC assignment operator must be "
1150 "+, *, -, /, .AND., .OR., .EQV. or .NEQV. at %L",
1155 /* Check for var = var op expr resp. var = expr op var where
1156 expr doesn't reference var and var op expr is mathematically
1157 equivalent to var op (expr) resp. expr op var equivalent to
1158 (expr) op var. We rely here on the fact that the matcher
1159 for x op1 y op2 z where op1 and op2 have equal precedence
1160 returns (x op1 y) op2 z. */
1161 e
= expr2
->value
.op
.op2
;
1162 if (e
->expr_type
== EXPR_VARIABLE
1163 && e
->symtree
!= NULL
1164 && e
->symtree
->n
.sym
== var
)
1166 else if ((c
= is_conversion (e
, true)) != NULL
1167 && c
->expr_type
== EXPR_VARIABLE
1168 && c
->symtree
!= NULL
1169 && c
->symtree
->n
.sym
== var
)
1173 gfc_expr
**p
= NULL
, **q
;
1174 for (q
= &expr2
->value
.op
.op1
; (e
= *q
) != NULL
; )
1175 if (e
->expr_type
== EXPR_VARIABLE
1176 && e
->symtree
!= NULL
1177 && e
->symtree
->n
.sym
== var
)
1182 else if ((c
= is_conversion (e
, true)) != NULL
)
1183 q
= &e
->value
.function
.actual
->expr
;
1184 else if (e
->expr_type
!= EXPR_OP
1185 || (e
->value
.op
.op
!= op
1186 && e
->value
.op
.op
!= alt_op
)
1192 q
= &e
->value
.op
.op1
;
1197 gfc_error ("!$OMP ATOMIC assignment must be var = var op expr "
1198 "or var = expr op var at %L", &expr2
->where
);
1205 switch (e
->value
.op
.op
)
1207 case INTRINSIC_MINUS
:
1208 case INTRINSIC_DIVIDE
:
1210 case INTRINSIC_NEQV
:
1211 gfc_error ("!$OMP ATOMIC var = var op expr not "
1212 "mathematically equivalent to var = var op "
1213 "(expr) at %L", &expr2
->where
);
1219 /* Canonicalize into var = var op (expr). */
1220 *p
= e
->value
.op
.op2
;
1221 e
->value
.op
.op2
= expr2
;
1223 if (code
->expr2
== expr2
)
1224 code
->expr2
= expr2
= e
;
1226 code
->expr2
->value
.function
.actual
->expr
= expr2
= e
;
1228 if (!gfc_compare_types (&expr2
->value
.op
.op1
->ts
, &expr2
->ts
))
1230 for (p
= &expr2
->value
.op
.op1
; *p
!= v
;
1231 p
= &(*p
)->value
.function
.actual
->expr
)
1234 gfc_free_expr (expr2
->value
.op
.op1
);
1235 expr2
->value
.op
.op1
= v
;
1236 gfc_convert_type (v
, &expr2
->ts
, 2);
1241 if (e
->rank
!= 0 || expr_references_sym (code
->expr2
, var
, v
))
1243 gfc_error ("expr in !$OMP ATOMIC assignment var = var op expr "
1244 "must be scalar and cannot reference var at %L",
1249 else if (expr2
->expr_type
== EXPR_FUNCTION
1250 && expr2
->value
.function
.isym
!= NULL
1251 && expr2
->value
.function
.esym
== NULL
1252 && expr2
->value
.function
.actual
!= NULL
1253 && expr2
->value
.function
.actual
->next
!= NULL
)
1255 gfc_actual_arglist
*arg
, *var_arg
;
1257 switch (expr2
->value
.function
.isym
->id
)
1265 if (expr2
->value
.function
.actual
->next
->next
!= NULL
)
1267 gfc_error ("!$OMP ATOMIC assignment intrinsic IAND, IOR "
1268 "or IEOR must have two arguments at %L",
1274 gfc_error ("!$OMP ATOMIC assignment intrinsic must be "
1275 "MIN, MAX, IAND, IOR or IEOR at %L",
1281 for (arg
= expr2
->value
.function
.actual
; arg
; arg
= arg
->next
)
1283 if ((arg
== expr2
->value
.function
.actual
1284 || (var_arg
== NULL
&& arg
->next
== NULL
))
1285 && arg
->expr
->expr_type
== EXPR_VARIABLE
1286 && arg
->expr
->symtree
!= NULL
1287 && arg
->expr
->symtree
->n
.sym
== var
)
1289 else if (expr_references_sym (arg
->expr
, var
, NULL
))
1290 gfc_error ("!$OMP ATOMIC intrinsic arguments except one must not "
1291 "reference '%s' at %L", var
->name
, &arg
->expr
->where
);
1292 if (arg
->expr
->rank
!= 0)
1293 gfc_error ("!$OMP ATOMIC intrinsic arguments must be scalar "
1294 "at %L", &arg
->expr
->where
);
1297 if (var_arg
== NULL
)
1299 gfc_error ("First or last !$OMP ATOMIC intrinsic argument must "
1300 "be '%s' at %L", var
->name
, &expr2
->where
);
1304 if (var_arg
!= expr2
->value
.function
.actual
)
1306 /* Canonicalize, so that var comes first. */
1307 gcc_assert (var_arg
->next
== NULL
);
1308 for (arg
= expr2
->value
.function
.actual
;
1309 arg
->next
!= var_arg
; arg
= arg
->next
)
1311 var_arg
->next
= expr2
->value
.function
.actual
;
1312 expr2
->value
.function
.actual
= var_arg
;
1317 gfc_error ("!$OMP ATOMIC assignment must have an operator or intrinsic "
1318 "on right hand side at %L", &expr2
->where
);
1325 struct pointer_set_t
*sharing_clauses
;
1326 struct pointer_set_t
*private_iterators
;
1327 struct omp_context
*previous
;
1329 static gfc_code
*omp_current_do_code
;
1330 static int omp_current_do_collapse
;
1333 gfc_resolve_omp_do_blocks (gfc_code
*code
, gfc_namespace
*ns
)
1335 if (code
->block
->next
&& code
->block
->next
->op
== EXEC_DO
)
1340 omp_current_do_code
= code
->block
->next
;
1341 omp_current_do_collapse
= code
->ext
.omp_clauses
->collapse
;
1342 for (i
= 1, c
= omp_current_do_code
; i
< omp_current_do_collapse
; i
++)
1345 if (c
->op
!= EXEC_DO
|| c
->next
== NULL
)
1348 if (c
->op
!= EXEC_DO
)
1351 if (i
< omp_current_do_collapse
|| omp_current_do_collapse
<= 0)
1352 omp_current_do_collapse
= 1;
1354 gfc_resolve_blocks (code
->block
, ns
);
1355 omp_current_do_collapse
= 0;
1356 omp_current_do_code
= NULL
;
1361 gfc_resolve_omp_parallel_blocks (gfc_code
*code
, gfc_namespace
*ns
)
1363 struct omp_context ctx
;
1364 gfc_omp_clauses
*omp_clauses
= code
->ext
.omp_clauses
;
1369 ctx
.sharing_clauses
= pointer_set_create ();
1370 ctx
.private_iterators
= pointer_set_create ();
1371 ctx
.previous
= omp_current_ctx
;
1372 omp_current_ctx
= &ctx
;
1374 for (list
= 0; list
< OMP_LIST_NUM
; list
++)
1375 for (n
= omp_clauses
->lists
[list
]; n
; n
= n
->next
)
1376 pointer_set_insert (ctx
.sharing_clauses
, n
->sym
);
1378 if (code
->op
== EXEC_OMP_PARALLEL_DO
)
1379 gfc_resolve_omp_do_blocks (code
, ns
);
1381 gfc_resolve_blocks (code
->block
, ns
);
1383 omp_current_ctx
= ctx
.previous
;
1384 pointer_set_destroy (ctx
.sharing_clauses
);
1385 pointer_set_destroy (ctx
.private_iterators
);
1389 /* Note a DO iterator variable. This is special in !$omp parallel
1390 construct, where they are predetermined private. */
1393 gfc_resolve_do_iterator (gfc_code
*code
, gfc_symbol
*sym
)
1395 int i
= omp_current_do_collapse
;
1396 gfc_code
*c
= omp_current_do_code
;
1398 if (sym
->attr
.threadprivate
)
1401 /* !$omp do and !$omp parallel do iteration variable is predetermined
1402 private just in the !$omp do resp. !$omp parallel do construct,
1403 with no implications for the outer parallel constructs. */
1413 if (omp_current_ctx
== NULL
)
1416 if (pointer_set_contains (omp_current_ctx
->sharing_clauses
, sym
))
1419 if (! pointer_set_insert (omp_current_ctx
->private_iterators
, sym
))
1421 gfc_omp_clauses
*omp_clauses
= omp_current_ctx
->code
->ext
.omp_clauses
;
1424 p
= gfc_get_namelist ();
1426 p
->next
= omp_clauses
->lists
[OMP_LIST_PRIVATE
];
1427 omp_clauses
->lists
[OMP_LIST_PRIVATE
] = p
;
1433 resolve_omp_do (gfc_code
*code
)
1435 gfc_code
*do_code
, *c
;
1436 int list
, i
, collapse
;
1440 if (code
->ext
.omp_clauses
)
1441 resolve_omp_clauses (code
);
1443 do_code
= code
->block
->next
;
1444 collapse
= code
->ext
.omp_clauses
->collapse
;
1447 for (i
= 1; i
<= collapse
; i
++)
1449 if (do_code
->op
== EXEC_DO_WHILE
)
1451 gfc_error ("!$OMP DO cannot be a DO WHILE or DO without loop control "
1452 "at %L", &do_code
->loc
);
1455 gcc_assert (do_code
->op
== EXEC_DO
);
1456 if (do_code
->ext
.iterator
->var
->ts
.type
!= BT_INTEGER
)
1457 gfc_error ("!$OMP DO iteration variable must be of type integer at %L",
1459 dovar
= do_code
->ext
.iterator
->var
->symtree
->n
.sym
;
1460 if (dovar
->attr
.threadprivate
)
1461 gfc_error ("!$OMP DO iteration variable must not be THREADPRIVATE "
1462 "at %L", &do_code
->loc
);
1463 if (code
->ext
.omp_clauses
)
1464 for (list
= 0; list
< OMP_LIST_NUM
; list
++)
1465 if (list
!= OMP_LIST_PRIVATE
&& list
!= OMP_LIST_LASTPRIVATE
)
1466 for (n
= code
->ext
.omp_clauses
->lists
[list
]; n
; n
= n
->next
)
1467 if (dovar
== n
->sym
)
1469 gfc_error ("!$OMP DO iteration variable present on clause "
1470 "other than PRIVATE or LASTPRIVATE at %L",
1476 gfc_code
*do_code2
= code
->block
->next
;
1479 for (j
= 1; j
< i
; j
++)
1481 gfc_symbol
*ivar
= do_code2
->ext
.iterator
->var
->symtree
->n
.sym
;
1483 || gfc_find_sym_in_expr (ivar
, do_code
->ext
.iterator
->start
)
1484 || gfc_find_sym_in_expr (ivar
, do_code
->ext
.iterator
->end
)
1485 || gfc_find_sym_in_expr (ivar
, do_code
->ext
.iterator
->step
))
1487 gfc_error ("!$OMP DO collapsed loops don't form rectangular iteration space at %L",
1493 do_code2
= do_code2
->block
->next
;
1498 for (c
= do_code
->next
; c
; c
= c
->next
)
1499 if (c
->op
!= EXEC_NOP
&& c
->op
!= EXEC_CONTINUE
)
1501 gfc_error ("collapsed !$OMP DO loops not perfectly nested at %L",
1507 do_code
= do_code
->block
;
1508 if (do_code
->op
!= EXEC_DO
&& do_code
->op
!= EXEC_DO_WHILE
)
1510 gfc_error ("not enough DO loops for collapsed !$OMP DO at %L",
1514 do_code
= do_code
->next
;
1515 if (do_code
->op
!= EXEC_DO
&& do_code
->op
!= EXEC_DO_WHILE
)
1517 gfc_error ("not enough DO loops for collapsed !$OMP DO at %L",
1525 /* Resolve OpenMP directive clauses and check various requirements
1526 of each directive. */
1529 gfc_resolve_omp_directive (gfc_code
*code
, gfc_namespace
*ns ATTRIBUTE_UNUSED
)
1531 if (code
->op
!= EXEC_OMP_ATOMIC
)
1532 gfc_maybe_initialize_eh ();
1537 case EXEC_OMP_PARALLEL_DO
:
1538 resolve_omp_do (code
);
1540 case EXEC_OMP_WORKSHARE
:
1541 case EXEC_OMP_PARALLEL_WORKSHARE
:
1542 case EXEC_OMP_PARALLEL
:
1543 case EXEC_OMP_PARALLEL_SECTIONS
:
1544 case EXEC_OMP_SECTIONS
:
1545 case EXEC_OMP_SINGLE
:
1546 if (code
->ext
.omp_clauses
)
1547 resolve_omp_clauses (code
);
1549 case EXEC_OMP_ATOMIC
:
1550 resolve_omp_atomic (code
);